File Coverage

blib/lib/Data/Model/SQL.pm

Criterion	Covered	Total	%
statement	222	240	92.5
branch	76	96	79.1
condition	29	38	76.3
subroutine	23	23	100.0
pod	0	13	0.0
total	350	410	85.3

package Data::Model::SQL;
use strict;
use warnings;
use base qw(Data::Model::Accessor);

use Carp ();
$Carp::Internal{(__PACKAGE__)}++;

__PACKAGE__->mk_accessors(qw/ select where having bind bind_column limit offset select_map select_map_reverse column_mutator where_values /);


for my $name (qw/ from joins /) {
    no strict 'refs';
    *{$name} = sub {
        return $_[0]->{$name} unless @_ > 1;
        my $self = shift;
        $self->{$name} = ((@_ == 1 && ref($_[0]) eq 'ARRAY') ? $_[0] : [@_]);
    };
}

for my $name (qw/ group order /) {
    no strict 'refs';
    *{$name} = sub {
        return $_[0]->{$name} unless @_ > 1;
        my $self = shift;
        $self->{$name} = ((@_ == 1 && ref($_[0]) eq 'ARRAY') ? $_[0] : [@_]);
    };
}

sub new {
    my($class, %args) = @_;
    my $self = bless { %args }, $class;
    for my $name (qw/ select from joins bind bind_column group order where /) {
        unless ($self->$name && ref $self->$name eq 'ARRAY') {
            $self->$name ? $self->$name([ $self->$name ]) : $self->$name([]);;
        }
    }
    for my $name (qw/ select_map select_map_reverse where_values /) {
        $self->$name( {} ) unless $self->$name && ref $self->$name eq 'HASH';
    }

    # ここで select, join, where クエリ 等を%args から構築する

    # where
    if (exists $args{where}) {
        my @wheres;
        if (ref($args{where}) eq 'ARRAY') {
            while (my($column, $value) = splice @{ $args{where} }, 0, 2) {
                push @wheres, +[ $column, $value ];
            }
        } elsif (ref($args{where}) eq 'HASH') {
            while (my($column, $value) = each %{ $args{where} }) {
                push @wheres, +[ $column, $value ];
            }
        } else {
            Carp::croak('where requires the type of ARRAY or HASH reference');
        }

        for my $where (@wheres) {
            $self->add_where(@{ $where });
        }
    }

    # where_sql
    if (exists $args{where_sql}) {
        my @wheres;
        if (ref($args{where_sql}) eq 'ARRAY') {
            while (my($sql, $values) = splice @{ $args{where_sql} }, 0, 2) {
                push @wheres, +[ $sql, $values ];
            }
        } elsif (ref($args{where_sql}) eq 'HASH') {
            while (my($sql, $values) = each %{ $args{where} }) {
                push @wheres, +[ $sql, $values ];
            }
        } else {
            Carp::croak('where_sql requires the type of ARRAY or HASH reference');
        }

        for my $where (@wheres) {
            my($sql, $values) = @{ $where };
            $self->add_where_sql( $sql => @{ $values });
        }
    }


=pod

  Data::Model::SQL->new(
      where => +[
          foo => [ -and => 'foo', 'bar', 'baz'],
          bar => 'baz',
          baz => +{ '!=' => 2 },
      ],
      order => [
          +{ foo => 'ASC' },
      ],
      joins => [
          foo => [
              { inner => { 'baz b1' => 'foo.baz_id = b1.baz_id AND b1.quux_id = 1' }}
          ],
      ],
      group => [qw/ foo bar /],
  );

=cut

    $self;
}

sub add_select {
    my($self, $term, $col) = @_;
    push @{ $self->{select} }, $term;
    return unless $col;
    $self->select_map->{$term}        = $col;
    $self->select_map_reverse->{$col} = $term;
}

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

sub _add_where {
    my($self, $col, $val) = @_;
    if (lc($col) eq '-and' || lc($col) eq '-or') {
        my $op = lc($col) eq '-and' ? 'AND' : 'OR';
        my(@terms, @binds, @bind_columns, @tcols);
        while (my($ccol, $cval) = splice @{ $val }, 0, 2) {
            my($term, $bind, $bind_column, $tcol) = $self->_add_where( $ccol => $cval );
            push @terms, "($term)";
            push @binds, @{ $bind };
            push @bind_columns, @{ $bind_column };
            push @tcols, @{ $tcol };
        }
        my $term = join " $op ", @terms;
        return $term, \@binds, \@bind_columns, \@tcols;
    } else {
        ## xxx Need to support old range and transform behaviors.
        Carp::croak("Invalid/unsafe column name $col") unless $col =~ /^[\w\.]+$/ || ref($col) eq 'SCALAR';
        my($term, $bind, $tcol) = $self->_mk_term($col, $val);
        my @bind_column = (($tcol) x scalar(@$bind));
        return $term, $bind, \@bind_column, [ $tcol => $val ];
    }
}

sub add_where {
    my $self = shift;
    my($term, $binds, $bind_columns, $tcols) = $self->_add_where(@_);

    push @{ $self->{where} }, "($term)";
    push @{ $self->{bind} }, @{ $binds };
    push @{ $self->{bind_column} }, @{ $bind_columns };
    my @tcols = @{ $tcols };
    while (my($tcol, $tval) = splice @tcols, 0, 2) {
        $self->where_values->{$tcol} = $tval if defined $tcol;
    }
}

sub add_where_sql {
    my($self, $term, @bind) = @_;

    my(@columns, @values);
    while (my($column, $value) = splice @bind, 0, 2) {
        $self->where_values->{$column} = $value;
        push @columns, $column;
        push @values,  $value;
    }

    push @{ $self->{where} }, sprintf("($term)", @columns);
    push @{ $self->{bind_column} }, @columns;
    push @{ $self->{bind} }, @values;
}

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

    if (my $orig = $stmt->select_map_reverse->{$col}) {
        $col = $orig;
    }

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

sub as_select {
    my $self = shift;
    my $sql = '';
    if (@{ $self->select }) {
        $sql .= 'SELECT ';
        $sql .= join(', ',  map {
            my $alias = $self->select_map->{$_};
            $alias ? /(?:^|\.)\Q$alias\E$/ ? $_ : "$_ $alias" : $_;
        } @{ $self->select });
        $sql .= "\n";
    }
    $sql;
}

sub as_join {
    my $self = shift;
    my $sql = '';
    if ($self->joins && @{ $self->joins }) {
        my $initial_table_written = 0;
        for my $data (@{ $self->joins }) {
            my($table, $joins) = map { $data->{$_} } qw( table joins );
            $sql .= $table unless $initial_table_written++;
            for my $join (@{ $joins }) {
                my($type, $target) = (%{ $join });
                my $condition = '';
                if (ref $target eq 'HASH') {
                    my($key, $val) = (%{ $target });
                    $target    = $key;
                    $condition = $val;
                }
                $sql .= ' ' . uc($type) . ' JOIN ' . $target;
                $sql .= ' ON ' . $condition if $condition;
            }
        }
        $sql .= ', ' if @{ $self->from };
    }
    $sql;
}

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

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

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

sub as_aggregate {
    my($self, $set) = @_;
    return '' unless my $attribute = $self->$set;

    my @sqls;
    for my $element (@{ $attribute }) {
        my $ref = ref $element;
        if (!$ref) {
            push @sqls, $element;
        } elsif ($ref eq 'HASH') {
            while (my($column, $desc) = each %{ $element }) {
                push @sqls, $column . ' ' . uc($desc);
            }
        }
    }
    return '' unless @sqls;
    return uc($set) . ' BY ' . join(', ', @sqls) . "\n";
}

sub as_sql {
    my $self = shift;

    my $sql = '';
    $sql .= $self->as_select;

    $sql .= 'FROM ';
    ## Add any explicit JOIN statements before the non-joined tables.
    $sql .= $self->as_join;
    $sql .= join(', ', @{ $self->from }) . "\n";

    $sql .= $self->as_sql_where;

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

    $sql .= $self->as_limit;
    $sql;
}

sub _mk_term {
    my($self, $col, $val) = @_;
    my $term = '';
    my (@bind, $m);
    if (ref($col) eq 'SCALAR') {
        $term = ${ $col };
        $col  = undef;
    } elsif (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) = $self->_mk_term($col, $v);
                push @terms, "($term)";
                push @bind, @$bind;
            }
            $term = join " $logic ", @terms;
        } else {
            $col = $m->($col) if $m = $self->column_mutator;
            $term = "$col IN (".join(',', ('?') x scalar @$val).')';
            @bind = @$val;
        }
    } elsif (ref($val) eq 'HASH') {
        $col = $m->($col) if $m = $self->column_mutator;
        my($op, $v) = (%{ $val });
        if ((uc($op) eq 'IN' || uc($op) eq 'NOT IN') && ref($v) eq 'ARRAY') {
            $term = "$col $op (".join(',', ('?') x scalar @$v).')';
            @bind = @$v;
        } else {
            $term = "$col $op ?";
            push @bind, $v;
        }
    } elsif (ref($val) eq 'SCALAR') {
        $col = $m->($col) if $m = $self->column_mutator;
        $term = "$col $$val";
    } else {
        $col = $m->($col) if $m = $self->column_mutator;
        $term = "$col = ?";
        push @bind, $val;
    }
    ($term, \@bind, $col);
}

1;

__END__