File Coverage

blib/lib/SQL/Interpolate/Macro.pm

Criterion	Covered	Total	%
statement	232	251	92.4
branch	68	84	80.9
condition	23	45	51.1
subroutine	42	49	85.7
pod	8	10	80.0
total	373	439	84.9

package SQL::Interpolate::Macro;
use strict;
use warnings;
use base qw(Exporter);
use SQL::Interpolate;

BEGIN {
    SQL::Interpolate::_enable_macros();
}

our $VERSION = '0.32';
our @EXPORT;
our %EXPORT_TAGS = (all => [qw(
    sql_and
    sql_flatten
    sql_if
    sql_link
    sql_or
    sql_paren
    sql_rel
    sql_rel_filter

    relations
    sql_fragment
)]);  # note: relations and sql_fragment depreciated
our @EXPORT_OK = @{$EXPORT_TAGS{'all'}};

sub sql_flatten;

sub sql_flatten {
    my (@items) = @_;

    # extract optional state parameter
    my $state;
    my $interp;
    if (ref $items[0] eq 'DBI::db') {
        $state = shift @items;
    }
    elsif (UNIVERSAL::isa($items[0], 'SQL::Interpolate')) {
        $state = $interp = shift @items;
    }

    # flatten items
    @items = map {
        my $e = $_;
        if (UNIVERSAL::isa($e, 'SQL::Interpolate::Macro')) {
            my @out = $e->expand($state);
            sql_flatten $state || (), @out;
        }
        elsif (ref $e eq 'SQL::Interpolate::SQL') {
            sql_flatten $state || (), @$e;
        }
        elsif (ref $e eq 'ARRAY') {
            my $complex = 0;
            for my $o (@$e) { ref $o ne '' and do { $complex = 1; last }; }
            if ($complex) {
                my @newarray;
                for my $o (@$e) {
                    if (UNIVERSAL::isa($o, 'SQL::Interpolate::Macro')) {
                        push @newarray, $o->expand($state);
                    }
                    elsif (ref $o eq 'SQL::Interpolate::SQL') {
                        push @newarray,
                            SQL::Interpolate::SQL->new(
                                sql_flatten $state || (), @$o);
                    }
                    elsif (ref $o eq '' or
                           ref $o eq 'SQL::Interpolate::Variable')
                    {
                        push @newarray, $o;
                    }
                    else {
                        my $type = ref $o;
                        _error(qq(reference type "$type" not allowed in array.));
                    }
                }
                \@newarray;
            }
            else {
                $e;
            }
        }
        elsif (ref $e eq '') { # SQL string
            # apply any filters to string and expand any new macros
            if ($interp && @{$interp->{text_fragment_filters}} != 0) {
                my @out = ($e);
                for my $filter (@{$interp->{text_fragment_filters}}) {
                    @out = $filter->filter_text_fragment($e);
                    my $same = @out == 1 && ref $out[0] eq '' && $out[0] eq $e;
                    unless($same) {
                        @out = sql_flatten($state || (), @out);
                        last;
                    }
                }
                @out
            }
            else { $e }
        }
        else { $e }
    } @items;

    return @items;
}

sub sql_and {
    return SQL::Interpolate::And->new(@_);
}

sub sql_or {
    return SQL::Interpolate::Or->new(@_);
}

sub sql_if {
    return SQL::Interpolate::If->new(@_);
}

sub sql_rel {
    return SQL::Interpolate::Rel->new(@_);
}

sub sql_link {
    return SQL::Interpolate::Link->new(@_);
}

sub sql_paren {
    return SQL::Interpolate::Paren->new(@_);
}

sub sql_rel_filter {
    return SQL::Interpolate::RelProcessor->new(@_);
}

# depreciated
sub relations {
    print STDERR
        "SQL::Interpolate::Macro - WARNING: "
        . "relations() is depreciated. use sql_rel_filter() instead.\n";
    return sql_rel_filter(@_);
}

# [private]
# Given instances of two relations, generate the SQL to link them.
# For example,
#   ['Sp', ['S', 'p'], $sales_ord_line] and
#   ['p', ['p'], $part]
# gives "Sp.part_nbr = p.part_nbr".
# params:
#   $e1 - entity 1
#   $e2 - entity 2
# where each instance is a arrayref of an entity relation name, a arrayref of
#   names of contained entities, and a relation
#   specification (as passed into C).
sub _single_link_sql {
    my ($e1, $e2) = @_;

    my ($left_idx, $right_idx);
    if   ($e1->[1]->[0] eq  $e2->[1]->[0])
        { $left_idx=0; $right_idx=0; }
    elsif (defined($e2->[1]->[1]) && $e1->[1]->[0] eq  $e2->[1]->[1])
        { $left_idx=0; $right_idx=1; }
    elsif (defined($e1->[1]->[1]) && $e1->[1]->[1] eq  $e2->[1]->[0])
        { $left_idx=1; $right_idx=0; }
    elsif (defined($e1->[1]->[1]) && defined($e2->[1]->[1]) &&
              $e1->[1]->[1] eq  $e2->[1]->[1])
        { $left_idx=1; $right_idx=1; }
    else {
        die "Invalid SQL link [$e1->[0] to $e2->[0]]";
    }

    my $sql = "$e1->[0].$e1->[2]->{key}->[$left_idx ]" . " = " .
              "$e2->[0].$e2->[2]->{key}->[$right_idx]";

    return $sql;
}

# depreciated
sub sql_fragment {
    print STDERR
        "SQL::Interpolate::Macro - WARNING: " .
        "sql_fragment() is depreciated. use sql() instead.\n";
    return SQL::Interpolate::SQL->new(@_);
}

1;

package SQL::Interpolate::SQLFilter;
use strict;
use warnings;
#IMPROVE: package name?

1;

package SQL::Interpolate::RelProcessor;
use base 'SQL::Interpolate::SQLFilter';
use strict;
use warnings;

sub new {
    my ($class, $relations) = @_;
    return bless {
        relations => $relations,
        keys => {}
    }, $class;
}

sub init {
    my $self = shift;
    $self->{keys} = {};
    return;
}

sub filter_text {
    my ($self, $sql) = @_;
    while (my ($name, $key) = each %{$self->{keys}}) {
        $sql =~ s{ (?
    }
    return $sql;
}

sub filter_text_fragment {
    my ($self, $sql) = @_;
    my @out;
    pos($sql) = 0;
    my $pos0 = pos($sql);
    until ($sql =~ /\G$/gc) {
        my $pos1 = pos($sql);
        if ($sql =~ m{\G \b REL \( (.*?) \)}xsgc) {
            push @out, substr($sql, $pos0, $pos1 - $pos0) if $pos1 != $pos0;
            $pos0 = pos($sql);
            push @out, SQL::Interpolate::Rel->new($1);
        }
        elsif ($sql =~ m{\G \b LINK \( (.*?) \)}xsgc) {
            push @out, substr($sql, $pos0, $pos1 - $pos0) if $pos1 != $pos0;
            $pos0 = pos($sql);
            my $params = $1;
            my @params = split /,/, $params;
            s{^\s*|\s*$}{}gs for @params;
            push @out, SQL::Interpolate::Link->new(@params);
        }
        else {
            $sql =~ m{\G.[^RL]*}xsgc;
        }
    }
    my $pos1 = pos($sql);
    push @out, substr($sql, $pos0, $pos1 - $pos0) if $pos1 != $pos0;
    return @out;
}

1;

package SQL::Interpolate::Rel;
use strict;
use base 'SQL::Interpolate::Macro';

sub new {
    my ($class, $name) = @_;

    my $self = bless [
        $name
    ], $class;
    return $self;
}

sub expand {
    my ($self, $interp) = @_;

    # improve-method call?
    my $filters = $interp->{filters_hash}->{'SQL::Interpolate::RelProcessor'};
    die "No sql_rel_filter defined" if ! defined $filters;
    die "Multiple relation filters currently not supported" if @$filters > 1;
    my $filter = $filters->[0];

    my $keys = $filter->{keys};
    my $name = $self->[0];
    my $sql;

    for my $relation_name (keys %{$filter->{relations}}) {
        my $relation = $filter->{relations}->{$relation_name};
        my $name_re = $relation->{name};

        if ($name =~ /($name_re)/s) {
            my ($name, $name1, $name2) = ($1, $2, $3);

            $keys->{$name1} = "$name.$relation->{key}->[0]";
            $keys->{$name2} = "$name.$relation->{key}->[1]"
                if defined $relation->{key}->[1];
            $sql = "$relation_name as $name";
            last;
        }
    }
    if (! defined $sql) {
        die "Unrecognized relation REL($name).";
    }
    return $sql;
}

1;

package SQL::Interpolate::Link;
use strict;
use base 'SQL::Interpolate::Macro';

sub new {
    my ($class, @rels) = @_;

    my $self = bless [
        @rels
    ], $class;
    return $self;
}

sub expand {
    my ($self, $interp) = @_;

    # improve-method call?
    my $filters = $interp->{filters_hash}->{'SQL::Interpolate::RelProcessor'};
    die "No sql_rel_filter filter defined" if ! defined $filters;
    die "Multiple relation filters currently not supported" if @$filters > 1;
    my $filter = $filters->[0];

    my @params = @$self;

    my $good = 1;
    my $last;
    for my $param (@params) {
        my $match = 0;
        done_param:
        for my $relation (values %{$filter->{relations}}) {
            my $name_re = $relation->{name};
            if ($param =~ /($name_re)/gs) {
                my ($name, $name1, $name2) = ($1, $2, $3);
                $param = [$name, [$name1, defined($name2) ? $name2 : ()],
                          $relation];
                $match = 1;
                last done_param;
            }
        }
        if (!$match) {
            die "Invalid param [$param] in LINK macro in SQL template.";
        }
    }

    # relations touching entities.
    my %links;
    my @sql_snips;
    for my $param (@params) {
        for my $entity (@{$param->[1]}) {
            if (defined $links{$entity}) {
                #print Dumper($entity, $links{$entity}, $param), "\n";
                push @sql_snips,
                    SQL::Interpolate::Macro::_single_link_sql(
                        $links{$entity}, $param);
            }
        }
        $links{$param->[1]->[0]} = $param;
        $links{$param->[1]->[1]} = $param if defined $param->[1]->[1];
    }

    my $sql = join ' AND ', @sql_snips;

    $sql = "($sql)" if @sql_snips > 1;

    return $sql;
}

1;

package SQL::Interpolate::Paren;
use strict;
use base 'SQL::Interpolate::Macro';

sub new {
    my ($class, @elements) = @_;

    my $self = bless [
        @elements
    ], $class;
    return $self;
}

sub expand {
    my ($self, $interp) = @_;
    return ('(', SQL::Interpolate::Macro::sql_flatten(
                     $interp || (), @$self), ')');
}

1;

package SQL::Interpolate::And;
use strict;
use base 'SQL::Interpolate::Macro';

sub new {
    my ($class, @elements) = @_;

    my $self = bless [@elements], $class;
    return $self;
}

sub expand {
    my ($self, $interp) = @_;
    my @out = map {
        my @expand = SQL::Interpolate::Macro::sql_flatten $interp || (), $_;
        (@expand == 0) ? () : ('AND', '(', @expand, ')')
    } @$self;
    shift @out;
    return '1=1' if @out == 0;  # trivial case
    @out = ('(', @out, ')') if @out != 0;
    return @out;
}

1;

package SQL::Interpolate::Or;
use strict;
use base 'SQL::Interpolate::Macro';

sub new {
    my ($class, @elements) = @_;

    my $self = bless [
        @elements
    ], $class;
    return $self;
}

sub expand {
    my ($self, $interp) = @_;
    my @out = map {
        my @expand = SQL::Interpolate::Macro::sql_flatten $interp || (), $_;
        (@expand == 0) ? () : ('OR', '(', @expand, ')')
    } @$self;
    shift @out;
    return '1=0' if @out == 0;  # trivial case
    @out = ('(', @out, ')') if @out != 0;
    return @out;
}

1;

package SQL::Interpolate::If;
use strict;
use base 'SQL::Interpolate::Macro';

sub new {
    my ($class, $condition, $value_if_true) = @_;

    my $self = bless [
        $condition, $value_if_true
    ], $class;
    return $self;
}

sub expand {
    my ($self, $interp) = @_;
    return $self->[0]
        ? SQL::Interpolate::Macro::sql_flatten($interp || (), $self->[1])
        : ();
}

1;

__END__