File Coverage

blib/lib/DBIx/PreQL.pm

Criterion	Covered	Total	%
statement	146	166	87.9
branch	66	94	70.2
condition	24	45	53.3
subroutine	19	23	82.6
pod	1	1	100.0
total	256	329	77.8

package DBIx::PreQL;
use strict;
use warnings;
use Carp qw< croak carp >;
require overload;   # Just for Overloaded()

use constant TAG_ALWAYS         => '*';
use constant TAG_NEVER          => '#';
use constant TAG_IF_ALL_EXIST   => '&';
use constant TAG_IF_ANY_EXIST   => '|';
use constant TAG_IF_PREFIXED    => qr/^([&|])(?![&|])(\S*)$/;

# Substitution types:
#   !ifset!,        !~ifnotset!
#   ?param?,        ?@array_ref?
#   ?=same_as?,     ?!distinct?
#   ?"literal_sql?


sub _parse_data {
    my( $data ) = @_;

    croak "data must be a hash reference"
        unless  ! defined($data)
            ||  ref($data) eq 'HASH';

    return $data || {};
}


sub _parse_wanted {
    my( $w ) = @_;

    return if ! defined $w;

    return $w if ref $w eq 'CODE';

    if( ref $w eq 'ARRAY' ) {
        my %w; @w{@$w} = (1) x @$w;

        return sub { return $w{$_[0]} };
    }

    croak "wanted must be an array ref or code ref";
}


sub _split_query {
    my( $q ) = @_;

    croak "No query specified"
        if  ! defined($q)  ||  ! length($q);

    my @lines = grep /\S/,  # Remove blank lines
        map {
            # Split into lines, removing trailing whitespace:
            split /[^\S\n]*\n/, $_
        } ref $q eq 'ARRAY' ?  @$q : ($q);
    my $indent;
    for(  @lines  ) {
        next    # Lines with nothing after the tag have no indentation
            if  ! /^(\s*\S+\s+)/;
        my $l = length( $1 );   # Measure how much the SQL is indented
        $indent = $l            # Track the least amount of indentation
            if  ! $indent  ||  $l < $indent;
    }
    return( $indent, @lines );
}


sub _parse_line {
    my( $line, $indent ) = @_;

    my( $pre, $tag, $post, $sql ) = $line =~ /^(\s*)(\S+)(\s*)(.*)$/
        or  die "Impossible: SQL template line w/o tag:\n$line\nfound";

    my $context = ":\n    $tag $sql\n";     # Used for error messages.
    # Preserve indentation (using minimal spaces):
    $indent = ' ' x( length("$pre$tag$post") - $indent );


    my $prefix = '';
    if(  $tag =~ TAG_IF_PREFIXED  ) {   # '&', '|', '&FOO', or '|BAR' tag:
        ( $prefix, $tag ) = ( $1, $2 );

        # Note that '&*' and '|*' act like '&' and '|' (respectively)
        $tag = TAG_ALWAYS
            if  '' eq $tag;
    }

    return $prefix, $tag, $indent, $sql, $context;
}

sub _find_named_placeholders {
    my( $sql, $data ) = @_;

    my( @pholders, @found, @missing );
    while(  $sql =~ /\?[\@=!"]?(\w+)\?/g  ) {
        my $name = $1;
        push @pholders, $name;

        if( defined $data->{$name} ) {
            push @found, $name;
        }
        else {
            push @missing, $name
        }
    }

    return {
        all     => \@pholders,
        found   => \@found,
        missing => \@missing,
    };
}

sub _find_dependencies {
    my( $sql, $data ) = @_;

    my( @deps, @found, @lost );
    while(  $sql =~ /!(~?)(\w+)!/g  ) {
        my( $negated, $name ) = ( $1, $2 );

        push @deps, $name;

        my $found = defined $data->{$name};
        $found = ! $found
            if  $negated;

        if( $found ) {
            push @found, $name;
        } else {
            push @lost, $name;
        }
    }

    return {
        all     => \@deps,
        found   => \@found,
        missing => \@lost,
    };
}

sub _select_line {
    my( $line, $base_indent, $data, $want, $known_tags ) = @_;

    my( $prefix, $tag, $indent, $sql, $context ) = _parse_line( $line, $base_indent );

    return
        if TAG_NEVER eq $tag;

    my $nph  = _find_named_placeholders( $sql, $data );
    my $deps = _find_dependencies( $sql, $data );

    return
        if  @{$nph->{missing}}
        &&  $prefix;  # $tag starts with '&' or '|'

    croak "Missing tag?$context"    # Catch "* SELECT\n  *\n* FROM\n"
        if  $sql !~ /\S/;           #                  ^ missing tag

#TAG_IF_ALL_EXIST,     {
#    die_msg     => "No parameters nor dependency markers specified",
#    die_unless  => [ $nph->{all}, $deps->{all} ],
#    skip_if     => [ $deps->{missing} ],
#},
#
#TAG_IF_ANY_EXIST, {
#    die_msg => "No dependency markers specified",
#    die_unless  => [ $deps->{all} ],
#    skip_unless => [ $deps->{found} ],
#},
#TAG_ALWAYS, {
#    die_msg => "Dependency markers ({$deps->{all}}) used with wrong tag type"
#    die_if  => [ $deps->{all} ],
#}




    if( TAG_IF_ALL_EXIST eq $prefix ) {
        croak "No parameters nor dependency markers specified$context"
            if  ! @{$nph->{all}}
            &&  ! @{$deps->{all}};
        return
            if  @{$deps->{missing}};
    } elsif( TAG_IF_ANY_EXIST eq $prefix ) {
        croak "No dependency markers specified$context"
            if  ! @{$deps->{all}};
        return
            if  ! @{$deps->{found}};
    } else {
        croak "Dependency markers (@{$deps->{all}}) used with wrong tag type$context"
            if  @{$deps->{all}};

        if( TAG_ALWAYS ne $tag ) {  # Handle custom tags:
            if(  $known_tags  ) {
                croak "Unknown tag found$context"
                    if  ! $known_tags->{$tag}++;
            } else {
                croak "Missing tag?$context"
                    if  $tag =~ /,$/
                    ||  grep( $_ eq uc $tag, qw<
                            SELECT FROM LEFT RIGHT INNER OUTER JOIN USING ON
                            WHERE AND OR
                            ORDER GROUP BY LIMIT OFFSET HAVING
                            UNION ALL DISTINCT
                            INSERT UPDATE ALTER CREATE DROP
                            WITH OVER BETWEEN
                        > );
            }
            croak "No wanted function provided when using custom tag$context"
                if  ! $want;
            return
                if  ! $want->( $tag, $data );
        }
    }

    croak "Missing named place-holders (@{$nph->{missing}})$context"
        if  @{$nph->{missing}};

    return( $indent . $sql, $context );
}


sub _bad_type {
    my( $sigil, $name, $val, $context ) = @_;

    my $type = ref($val);
    croak "Invalid type ($type) for ?$sigil$name?$context";
}

{
    #SIGIL => { VALTYPE => sub { param => ?, repl => ? } }
    # sub takes args $name, $value.
    # returns kvp list of param and repl to override defaults.
    my %NPH_HANDLER = (
        ''  => { ''     => sub { param => [$_[0]]   },
                 SCALAR => sub { repl  => ${$_[1]}  },
               },
        '@' => { ARRAY  => sub { param => [$_[0]]   } },
        '"' => { ''     => sub { repl  => $_[1]     },
                 SCALAR => sub { repl  => ${$_[1]}  },
               },
        '=' => { ''     => sub { param => [$_[0]], repl => '= ?' },
                 SCALAR => sub { repl  => "= ${$_[1]}"  },
                 NULL   => sub { repl  => 'IS NULL'  },
               },
        '!' => { ''     => sub { param => [$_[0]], repl => '<> ?' },
                 SCALAR => sub { repl  => "<> ${$_[1]}"  },
                 NULL   => sub { repl  => 'IS NOT NULL'  },
               },
    );

    sub _process_named_placeholder {
        my ($sigil, $name, $value) = @_;

        my $type = ref $value || '';
        $type = 'NULL'
            if $type && _is_null( $type );

        return
            unless exists( $NPH_HANDLER{$sigil} )
                && exists( $NPH_HANDLER{$sigil}{$type} );

        my $handler = $NPH_HANDLER{$sigil}{$type};

        return { repl => '?', param => [], $handler->($name, $value) };
    }

}

sub _substitute_line {
    my( $sql, $context, $data ) = @_;

    # Remove dependency markers and extra whitespace:
    #   "a   !b! !c!"           => "a"
    #   "a!b!c"                 => "ac"
    #   "a !b! c" or "a !b!c"   => "a c"
    $sql =~ s/(\s*)!~?\w+!(?=(\s*)(\S?))/
        $1 && !$2 && length $3 ? ' ' : '';
    /ge;

    # Replace named parameters with computed text
    # Fill param array.
    my @params;
    $sql =~ s{\?([\@=!"]?)(\w+)\?}{
        my( $sigil, $name ) = ( $1, $2 );
        my $value = $data->{$name};

        my $np = _process_named_placeholder( $sigil, $name, $value )
            or _bad_type( $sigil, $name, $value, $context );

        push @params, @{$np->{param}};

        $np->{repl};
    }ge;

    return( $sql, @params );
}


sub build_query {
    my( $class, %a ) = @_;
    croak "You must call build_query() as a class method"
        if  $class ne __PACKAGE__;

    my $data        = _parse_data( delete $a{data} );
    my $want        = _parse_wanted( delete $a{wanted} );
    my @query_lines = _split_query( delete $a{query} );
    my $indent      = shift @query_lines;
    my $keep_keys   = delete $a{keep_keys};
    my $known_tags  = delete $a{known_tags};
    $known_tags &&= { map { $_ => 1 } @$known_tags };

    my @unexpected_keys = sort keys %a;
    croak "Unexpected arguments given to build_query(): @unexpected_keys"
        if @unexpected_keys;

    my @query;      # Accumulate lines in loop
    my @binds;      # Build list in loop

    for ( @query_lines ) {
        # Determine if we should include this line:
        my( $line, $context ) = _select_line(
            $_, $indent, $data, $want, $known_tags,
        )
            or  next;

        ( $line, my @params ) = _substitute_line( $line, $context, $data );

        # Remove trailing comma if in front of 'FROM':
        $query[-1] =~ s/,\s*$//
            if  @query  &&  $line =~ /^\s*FROM\b/i;

        # Remove leading 'AND' if behind 'WHERE':
        $line =~ s/^(\s*)AND\b/$1   /
            if  @query  &&  $query[-1] =~ /\bWHERE\s*$/i;

        push @query, $line;
        push @binds, @params;
    }

    my $query = join "\n", @query;

    if( ! $keep_keys ) {
        $_ = $data->{$_}
            for  @binds;
    }

    if(  $known_tags  ) {
        my @unused = grep 1==$known_tags->{$_}, sort keys %$known_tags;
        carp "Some known tags never used (@unused)"
            if  @unused;
    }

    return $query, @binds;
}


sub _is_ref {
    my( $val ) = @_;
    return 0
        if  ! ref $val
        ||  overload::Method( $val, '""' );
    return 1;
}


sub _is_a {
    my( $val, $type ) = @_;
    return 0
        if  ! _is_ref( $val );
    my $isa = eval { $val->isa($type) };
    $isa = UNIVERSAL::isa( $val, $type )
        if  ! defined $isa;
    return $isa;
}


sub _is_null {
    my( $val ) = @_;
    return 1
        if  _is_a( $val, 'SCALAR' )
        &&  $$val =~ /^\s*NULL\s*$/i;
    return 0;
}


1;

__END__