File Coverage

blib/lib/Data/ObjectDriver/SQL.pm

Criterion	Covered	Total	%
statement	233	267	87.2
branch	97	126	76.9
condition	44	75	58.6
subroutine	21	23	91.3
pod	15	15	100.0
total	410	506	81.0

# $Id$

package Data::ObjectDriver::SQL;
use strict;
use warnings;
use Scalar::Util 'blessed';

use base qw( Class::Accessor::Fast );

__PACKAGE__->mk_accessors(qw(
    select distinct select_map select_map_reverse
    from joins where bind limit offset group order
    having where_values column_mutator index_hint
    comment as
));

sub new {
    my $class = shift;
    my $stmt = $class->SUPER::new(@_);
    $stmt->select([]);
    $stmt->distinct(0);
    $stmt->select_map({});
    $stmt->select_map_reverse({});
    $stmt->bind([]);
    $stmt->from([]);
    $stmt->where([]);
    $stmt->where_values({});
    $stmt->having([]);
    $stmt->joins([]);
    $stmt->index_hint({});
    $stmt;
}

sub add_select {
    my $stmt = shift;
    my($term, $col) = @_;
    push @{ $stmt->select }, $term;
    if (blessed($term) && $term->isa('Data::ObjectDriver::SQL')) {
        my $alias = $col || $term->as || $term->as_sql;
        $stmt->select_map->{$term} = $alias;
        $stmt->select_map_reverse->{$alias} = $term;
    } else {
        $col ||= $term;
        $stmt->select_map->{$term} = $col;
        $stmt->select_map_reverse->{$col} = $term;
    }
}

sub add_join {
    my $stmt = shift;
    my($table, $joins) = @_;
    push @{ $stmt->joins }, {
        table => $table,
        joins => ref($joins) eq 'ARRAY' ? $joins : [ $joins ],
    };
}

sub add_index_hint {
    my $stmt = shift;
    my($table, $hint) = @_;
    $stmt->index_hint->{$table} = {
        type => $hint->{type} || 'USE',
        list => ref($hint->{list}) eq 'ARRAY' ? $hint->{list} : [ $hint->{list} ],
    };
}

sub as_sql {
    my $stmt = shift;
    my $sql = '';
    my @bind_for_select;

    if (@{ $stmt->select }) {
        $sql .= 'SELECT ';
        $sql .= 'DISTINCT ' if $stmt->distinct;
        my $select_map = $stmt->select_map;
        $sql .= join(', ',  map {
            my $col = $_;
            my $alias = $select_map->{$col};
            if (blessed($col) && $col->isa('Data::ObjectDriver::SQL')) {
                push @bind_for_select, @{ $col->{bind} };
                @{ $col->{bind} } = ();
                $col->as_subquery($alias);
            } else {
                if ($alias) {
                    /(?:^|\.)\Q$alias\E$/ ? $col : "$col $alias";
                } else {
                    $col;
                }
            }
        } @{ $stmt->select }) . "\n";
    }
    $sql .= 'FROM ';

    ## Add any explicit JOIN statements before the non-joined tables.
    my %joined;
    my @from = @{ $stmt->from || [] };
    if ($stmt->joins && @{ $stmt->joins }) {
        my $initial_table_written = 0;
        for my $j (@{ $stmt->joins }) {
            my($table, $joins) = map { $j->{$_} } qw( table joins );
            $table = $stmt->_add_index_hint($table); ## index hint handling
            $sql .= $table unless $initial_table_written++;
            $joined{$table}++;
            for my $join (@{ $j->{joins} }) {
                $joined{$join->{table}}++;
                $sql .= ' ' .
                        uc($join->{type}) . ' JOIN ' . $join->{table} . ' ON ' .
                        $join->{condition};
            }
        }
        @from = grep { ! $joined{ $_ } } @from;
        $sql .= ', ' if @from;
    }

    my @bind_for_from;

    if (@from) {
        $sql .= join ', ', map {
            my $from = $_;
            if (blessed($from) && $from->isa('Data::ObjectDriver::SQL')) {
                push @bind_for_from, @{$from->{bind}};
                @{$from->{bind}} = ();
                $from->as_subquery;
            } else {
                $stmt->_add_index_hint($from);
            }
        } @from;
    }

    $sql .= "\n";
    $sql .= $stmt->as_sql_where;

    $sql .= $stmt->as_aggregate('group');
    $sql .= $stmt->as_sql_having;
    $sql .= $stmt->as_aggregate('order');

    $sql .= $stmt->as_limit;
    my $comment = $stmt->comment;
    if ($comment && $comment =~ /([ 0-9a-zA-Z.:;()_#&,]+)/) {
        $sql .= "-- $1" if $1;
    }

    @{ $stmt->{bind} } = (@bind_for_select, @bind_for_from, @{ $stmt->{bind} });

    return $sql;
}

sub as_subquery {
    my ($stmt, $alias) = @_;
    my $subquery = '(' . $stmt->as_sql . ')';
    $alias ||= $stmt->as;
    if ($alias) {
        $subquery .= ' '. $alias;
    }
    $subquery;
}

sub as_limit {
    my $stmt = shift;
    my $n = $stmt->limit or
        return '';
    die "Non-numerics in limit clause ($n)" if $n =~ /\D/;
    return sprintf "LIMIT %d%s\n", $n,
           ($stmt->offset ? " OFFSET " . int($stmt->offset) : "");
}

sub as_aggregate {
    my $stmt = shift;
    my($set) = @_;

    if (my $attribute = $stmt->$set()) {
        my $elements = (ref($attribute) eq 'ARRAY') ? $attribute : [ $attribute ];
        return uc($set) . ' BY '
            . join(', ', map { $_->{column} . ($_->{desc} ? (' ' . $_->{desc}) : '') } @$elements)
                . "\n";
    }

    return '';
}

sub as_sql_where {
    my $stmt = shift;
    $stmt->where && @{ $stmt->where } ?
        'WHERE ' . join(' AND ', @{ $stmt->where }) . "\n" :
        '';
}

sub as_sql_having {
    my $stmt = shift;
    $stmt->having && @{ $stmt->having } ?
        'HAVING ' . join(' AND ', @{ $stmt->having }) . "\n" :
        '';
}

sub as_escape {
    my ($stmt, $escape_char) = @_;

    # escape_char can be ''(two quotes), or \\ for mysql and \ for others, but it doesn't accept any injections.
    die 'escape_char length must be up to two characters' if defined($escape_char) && length($escape_char) > 2;

    return " ESCAPE '$escape_char'";
}

sub add_where {
    my $stmt = shift;
    ## xxx Need to support old range and transform behaviors.
    my($col, $val) = @_;
    Carp::croak("Invalid/unsafe column name $col") unless $col =~ /^[\w\.]+$/;
    my($term, $bind, $tcol) = $stmt->_mk_term($col, $val);
    push @{ $stmt->{where} }, "($term)";
    push @{ $stmt->{bind} }, @$bind;
    $stmt->where_values->{$tcol} = $val;
}

sub add_complex_where {
    my $stmt = shift;
    my ($terms) = @_;
    my ($where, $bind) = $stmt->_parse_array_terms($terms);
    if ($where) {
        push @{ $stmt->{where} }, $where;
        push @{ $stmt->{bind} }, @$bind;
    }
}

sub _parse_array_terms {
    my $stmt = shift;
    my ($term_list) = @_;

    my @out;
    my $logic = 'AND';
    my @bind;
    foreach my $t ( @$term_list ) {
        if (! ref $t ) {
            $logic = $1 if uc($t) =~ m/^-?(OR|AND|OR_NOT|AND_NOT)$/;
            $logic =~ s/_/ /;
            next;
        }
        my $out;
        if (ref $t eq 'HASH') {
            # bag of terms to apply $logic with
            my @out;
            foreach my $t2 ( keys %$t ) {
                my ($term, $bind, $col) = $stmt->_mk_term($t2, $t->{$t2});
                $stmt->where_values->{$col} = $t->{$t2};
                if ($term) {
                    push @out, "($term)";
                    push @bind, @$bind;
                }
            }
            $out .= '(' . join(" AND ", @out) . ")" if @out;
        }
        elsif (ref $t eq 'ARRAY') {
            # another array of terms to process!
            my ($where, $bind) = $stmt->_parse_array_terms( $t );
            if ($where) {
                push @bind, @$bind;
                $out = '(' . $where . ')';
            }
        }
        push @out, (@out ? ' ' . $logic . ' ' : '') . $out if $out;
    }
    return (join("", @out), \@bind);
}

sub has_where {
    my $stmt = shift;
    my($col, $val) = @_;

    # TODO: should check if the value is same with $val?
    exists $stmt->where_values->{$col};
}

sub add_having {
    my $stmt = shift;
    my($col, $val) = @_;
#    Carp::croak("Invalid/unsafe column name $col") unless $col =~ /^[\w\.]+$/;

    if (my $orig = $stmt->select_map_reverse->{$col}) {
        if (blessed($orig) && $orig->isa('Data::ObjectDriver::SQL')) {
            # do nothins
        } else {
            $col = $orig;
        }
    }

    my($term, $bind) = $stmt->_mk_term($col, $val);
    push @{ $stmt->{having} }, "($term)";
    push @{ $stmt->{bind} }, @$bind;
}

sub _mk_term {
    my $stmt = shift;
    my($col, $val) = @_;
    my $term = '';
    my (@bind, $m);
    if (ref($val) eq 'ARRAY') {
        if (ref $val->[0] or (($val->[0] || '') eq '-and')) {
            my $logic = 'OR';
            my @values = @$val;
            if ($val->[0] eq '-and') {
                $logic = 'AND';
                shift @values;
            }

            my @terms;
            for my $v (@values) {
                my($term, $bind) = $stmt->_mk_term($col, $v);
                push @terms, "($term)";
                push @bind, @$bind;
            }
            $term = join " $logic ", @terms;
        } else {
            $col = $m->($col) if $m = $stmt->column_mutator;
            $term = $stmt->_mk_term_arrayref($col, 'IN', $val);
            @bind = @$val;
        }
    } elsif (ref($val) eq 'HASH') {
        my $c = $val->{column} || $col;
        $c = $m->($c) if $m = $stmt->column_mutator;
        my $op = uc $val->{op};
        if (($op eq 'IN' or $op eq 'NOT IN') and ref $val->{value} eq 'ARRAY') {
            $term = $stmt->_mk_term_arrayref($c, $op, $val->{value});
            push @bind, @{$val->{value}};
        } elsif (($op eq 'IN' or $op eq 'NOT IN') and ref $val->{value} eq 'REF') {
            my @values = @{${$val->{value}}};
            $term = "$c $op (" . (shift @values) . ")";
            push @bind, @values;
        } elsif ($op eq 'BETWEEN' and ref $val->{value} eq 'ARRAY') {
            Carp::croak "USAGE: foo => {op => 'BETWEEN', value => [\$a, \$b]}" if @{$val->{value}} != 2;
            $term = "$c $op ? AND ?";
            push @bind, @{$val->{value}};
        } else {
            my $value = $val->{value};
            if (ref $value eq 'SCALAR') {
                $term = "$c $val->{op} " . $$value;
            } elsif (blessed($value) && $value->isa('Data::ObjectDriver::SQL')) {
                local $value->{as} = undef;
                $term = "$c $val->{op} ". $value->as_subquery;
                push @bind, @{$value->{bind}};
            } else {
                $term = "$c $val->{op} ?";
                $term .= $stmt->as_escape($val->{escape}) if $val->{escape} && $op =~ /^(?:NOT\s+)?I?LIKE$/;
                push @bind, $value;
            }
        }
    } elsif (ref($val) eq 'SCALAR') {
        $col = $m->($col) if $m = $stmt->column_mutator;
        $term = "$col $$val";
    } elsif (ref($val) eq 'REF') {
        $col = $m->($col) if $m = $stmt->column_mutator;
        my @values = @{$$val};
        $term = "$col " . (shift @values);
        push @bind, @values;
    } else {
        $col = $m->($col) if $m = $stmt->column_mutator;
        if (defined $val) {
            $term = "$col = ?";
            push @bind, $val;
        } else {
            $term = "$col IS NULL";
        }
    }
    ($term, \@bind, $col);
}

sub _mk_term_arrayref {
    my ($stmt, $col, $op, $val) = @_;
    if (@$val) {
        return "$col $op (".join(',', ('?') x scalar @$val).')';
    } else {
        if ($op eq 'IN') {
            return '0 = 1';
        } elsif ($op eq 'NOT IN') {
            return '1 = 1';
        }
    }
}

sub _add_index_hint {
    my $stmt = shift;
    my ($tbl_name) = @_;
    my $hint = $stmt->index_hint->{$tbl_name};
    return $tbl_name unless $hint && ref($hint) eq 'HASH';
    if ($hint->{list} && @{ $hint->{list} }) {
        return $tbl_name . ' ' . uc($hint->{type} || 'USE') . ' INDEX (' .
                join (',', @{ $hint->{list} }) .
                ')';
    }
    return $tbl_name;
}

1;

__END__