# Source: https://perlmonks.org/?node_id=1210536
# Author: LanX
# ... plus explanation

use strict;
use warnings;

use B::Deparse;
use PadWalker qw/closed_over peek_sub set_closed_over/;
use Data::Dump qw/pp/;

# ========= Tests

use Test::More;

# lexicals for placeholders
my $a = 'A';
my @list = qw/L I S T/;
my $x = 'X';

# no placeholders for underscore vars
my @_table = "any_table";

my $sql = sub { "SELECT * FROM @_table WHERE a = $a AND b IN (@list) AND c = $x" };

my @stm = holderplace($sql);

is_deeply( \@stm,
           [
             "SELECT * FROM any_table WHERE a = ? AND b IN (?, ?, ?, ?) AND c = ?",
            [\"A", ["L", "I", "S", "T"], \"X"]
           ],
           "statement with placeholders plus bind variables"
         );


# change bind variables
$a = 'AA';
@list = qw/LL II SS TT/;
$x = 'XX';

is_deeply( \@stm,
           [
             "SELECT * FROM any_table WHERE a = ? AND b IN (?, ?, ?, ?) AND c = ?",
            [\"AA", ["LL", "II", "SS", "TT"], \"XX"]
           ],
           "statement with placeholders plus changed variables"
         );



done_testing();


# ========== Code

sub holderplace {
   my ($lambda)=@_;

   my $h_vars = closed_over($lambda);
   #  $h_vars is a hash with all closed_over lexicals
   #  key = '$name' value= reference
   #  allowed sigils are '$@%'

   my %new_vars;
   my @value_refs;


   for my $key ( keys %$h_vars) {

      my $sigil = substr $key,0,1;

      # exclude variables starting with underscore
      next if $key =~ m/^\Q${sigil}\E_/;


      if ( '$' eq $sigil ) {
         $new_vars{$key} = \'?';
      } elsif ( '@' eq $sigil ) {
         $new_vars{$key} = [ join ", ", ("?") x @{$h_vars->{$key} } ];
      } else {
         next;                          # TODO Error?
      }
   }


   # Create Statement with placeholders
   set_closed_over( $lambda, \%new_vars );
   my $newstr = $lambda->();

   # Variable refs in order of placeholders
   my @var_refs =
     map { $h_vars->{$_} }
       grep { $new_vars{$_} }
         @{ get_vars($lambda) };

   return ("$newstr", \@var_refs );
}




# scans output of B::Deparse to get interpolated vars in correct order
sub get_vars {
   # scans output of B::Deparse to get interpolated vars in correct order
   my ($lambda)=@_;

   # deparse sub body
   my $source = B::Deparse->new('-q')->coderef2text($lambda);
   # returns something like:
   # {
   #  use warnings;
   #  use strict;
   #  'SELECT * FROM ' . join($", @_table) . ' WHERE x = ' . $a . ' AND b IN (' . join($", @list) . ') ' . $x;
   # }

   # truncate {block} and use statements
   $source =~ s/^{\s*(use.*?;\s*)*//s;
   $source =~ s/;\s*}$//s;
   #warn $source;

   my %quotes = qw"[ ] ( ) < > { } / /";
   $quotes{'#'}='#';

   # single quotes like q(...)
   my $re_q = join "|", map { "q\\$_.*?\\$quotes{$_}" } keys %quotes;

   #warn pp
     my @parts = split /\s* (?: '(?:\\'|[^'])*?' | $re_q )\s*/msx, $source;

   for my $part (@parts) {
      next unless $part =~ /^\..*\.?$/;

      if ( $part =~ /^\. join\(.*? (\@\w+)\)( \.)?$/) {
         $part = $1;                    # array
      }
      elsif ( $part =~ /^\. (\$\w+)( \.)?$/) {
         $part = $1;                    # scalar
      }
   }

   return \@parts;
}




