#!/usr/bin/env perl
use strict;
use warnings;
use DBIx::Perlish qw(:all);
use Getopt::Long;
use B::Terse;

my %opt = (
	flavor  => undef,
	help    => undef,
	deparse => undef,
	beautify => undef,
	strict   => undef,
	inline   => 0,
);

sub usage {
	print <<HELP;
$0 - dump perl code as sql

format:
    perlish-parse [options] [select|update|delete] [file|-]

options:
    --help
    --flavor   [pg|oracle]
    --deparse  -- print perl AST
    --beautify -- print nicer sql
    --strict   -- if set, no attempt to declare missing variables will be made
    --inline   -- if set, will try to dereference scalars and generate SQL accordingly
  
HELP
	exit 1;
}

GetOptions(\%opt,
	"help",
	"flavor=s",
	"deparse",
	"beautify",
	"strict",
	"inline",
) or usage;
$opt{help} and usage;

sub slurp($)
{
	my $f = shift;
	local $/;
	if ( $f eq '-') {
		return <STDIN>;
	} else {
		open F, '<', $f or die "Cannot open $f:$!\n";
		return <F>;
	}
}

my $null  = undef;
my $int  = 0;
my $out_int  = 1;
my $str  = 'x';
my $our_str  = 'x';
my $like = 'LIKE%';
my $rx   = '.*';
my @arr  = (1,2);
my %hash = ( x => 1);
my $arr_ref  = [1, 2];
my $hash_ref = {x => 1};
my $blessed = bless {x => 1}, __PACKAGE__;
our $our_int  = 0;
our @our_arr  = (1,2);
our $arr_our_ref  = [1, 2];
our $hash_our_ref = {x => 1};

my ( $mode, $text );
if ( 0 == @ARGV ) {
	($mode, $text) = ('select', slurp('-'));
} elsif ( 1 == @ARGV ) {
	if ( $ARGV[0] =~ /^(select|update|delete)$/i ) {
		($mode, $text) = (lc($ARGV[0]), slurp('-'));
	} elsif ( $ARGV[0] eq '-' || -e $ARGV[0]) {
		($mode, $text) = ('select', slurp($ARGV[0]));
	} else {
		($mode, $text) = ('select', $ARGV[0]);
	}
} elsif ( 2 == @ARGV ) {
	usage unless $ARGV[0] =~ /^(select|update|delete)$/i;
	($mode, $text) = (lc($ARGV[0]), ( $ARGV[1] eq '-' || -e $ARGV[1] ) ? slurp($ARGV[1]) : $ARGV[1]);
} else {
	usage;
}

my ($sub, $prevars, $last_eval_failure) = (undef, '', '');
while ( 1 ) {
	$sub = eval "$prevars sub { $text };";
	last unless $@;
	last if $opt{strict};
	last if $last_eval_failure eq $@;
	$last_eval_failure = $@;
	last unless $@ =~ /Global symbol "(.)(.*?)" requires explicit package name/;
	my ( $sigil, $var ) = ($1, "$1$2");
	if ( $sigil eq '$') {
		$prevars .= "my $var = '$var';\n";
	} else {
		$prevars .= "my $var;\n";
	}
}
die $@ if $@;

if ( $opt{deparse} ) {
	no warnings 'redefine';
	my $old = \&DBIx::Perlish::gen_sql;
	*DBIx::Perlish::gen_sql = sub {
		B::Terse::compile($_[0])->();
		$old->(@_);
	};
}

my ($sql, $bind_values, $nret, %flags) = DBIx::Perlish::gen_sql($sub, $mode,
	flavor => $opt{flavor},
	inline => $opt{inline},
);

if ( $opt{beautify}) {
	eval "require SQL::Beautify;";
	if ($@) {
		warn "SQL::Beautify is required\n";
	} else {
		my $b = SQL::Beautify->new;
		$b->query($sql);
		$sql = $b->beautify;
	}
}

print $sql, "\n";
