File Coverage

blib/lib/SQL/Concrete.pm
Criterion Covered Total %
statement 112 113 99.1
branch 53 60 88.3
condition 12 15 80.0
subroutine 23 23 100.0
pod 2 5 40.0
total 202 216 93.5


line stmt bran cond sub pod time code
1 1     1   73488 use 5.006; use strict; use warnings;
  1     1   4  
  1     1   4  
  1         2  
  1         16  
  1         4  
  1         2  
  1         63  
2              
3             package SQL::Concrete;
4              
5             our $VERSION = '1.004';
6              
7             use Exporter::Tidy
8 1         8 core => [ qw( sql_render ) ],
9             util => [ qw( sql ) ],
10             clauses => [ qw( sql_values sql_set sql_select ) ],
11             CLAUSES => [ qw( VALUES SET SELECT ) ],
12             all => [ qw( :core :util :CLAUSES ) ],
13             _map => { VALUES => 'sql_values', SET => 'sql_set', SELECT => 'sql_select' },
14 1     1   892 noncore => [ qw( :util :clauses :CLAUSES ) ]; # used internally by SQL::Concrete::Dollars
  1         14  
15              
16 56     56 1 10889 sub sql_render { SQL::Concrete::Renderer->new->render( @_ ) }
17 25     25 1 55 sub sql { my @stuff = @_; bless sub { $_[0]->render_sql( @stuff ) }, __PACKAGE__ }
  25     25   17092  
  25         129  
18 2     2 0 6 sub sql_set { my @stuff = @_; bless sub { $_[0]->render_set( @stuff ) }, __PACKAGE__ }
  2     2   909  
  2         9  
19 7     7 0 22 sub sql_values { my @stuff = @_; bless sub { $_[0]->render_values( @stuff ) }, __PACKAGE__ }
  7     7   3487  
  7         31  
20 24     24 0 57 sub sql_select { my @stuff = @_; bless sub { $_[0]->render_select( @stuff ) }, __PACKAGE__ }
  24     24   14754  
  24         111  
21              
22             package SQL::Concrete::Renderer;
23              
24             our $VERSION = '1.004';
25              
26 1     1   620 use Object::Tiny::Lvalue qw( alias_id prev_item bind );
  1         290  
  1         4  
27              
28             # our code references are blessed into this package
29             # so that we can distinguish them from other code references
30             sub _CODE_() { 'SQL::Concrete' }
31              
32 59     59   84 sub new { my $class = shift; bless { @_ }, $class }
  59         164  
33              
34             sub render {
35 59     59   72 my $self = shift;
36 59         121 local $self->{'bind'} = [];
37 59         93 local $self->{'alias_id'} = 0;
38 59         109 my $sql = $self->render_sql( @_ );
39 54         63 return ( $sql, @{ $self->bind } );
  54         823  
40             }
41              
42             sub render_sql {
43 84     84   88 my $self = shift;
44              
45 84         102 my $sql = '';
46 84         1307 my $bind = $self->bind;
47 84         323 local $self->{'prev_item'};
48              
49 84         158 for my $item ( @_ ) {
50 96         133 my $type = ref $item;
51              
52 96 100       608 my $append
    100          
    50          
    100          
    100          
    100          
    100          
53             = ( not $type ) ? $self->prev_item = $item
54             : ( 'SCALAR' eq $type ) ? $self->render_bind( $$item )
55             : ( 'ARRAY' eq $type ) ? ( @$item ? join ', ', $self->bind_or_render_values( @$item ) : $self->error( 'empty array' ) )
56             : ( _CODE_ eq $type ) ? $item->( $self )
57             : ( 'HASH' eq $type ) ? ( keys %$item ? undef : '1=1' ) # further handled below
58             : $self->error( "unrecognized $type value in interpolation" );
59              
60 92 100       212 if ( not defined $append ) { # 'twas a non-empty hash
61             $append = join ' AND ', map {
62 10         29 my $lft = $_;
  14         20  
63 14         15 my $rgt = $item->{ $lft };
64 14         18 my $type = ref $rgt;
65             my $term
66             = ( not defined $rgt ) ? $lft . ' IS NULL'
67             : ( not $type ) ? join( '=', $lft, $self->bind_or_render_values( $rgt ) )
68             : ( _CODE_ eq $type ) ? $lft . '=' . $rgt->( $self )
69 14 100       42 : ( 'ARRAY' eq $type ) ? do {
    100          
    100          
    100          
70 6   66     15 my $list = @$rgt && join ', ', $self->bind_or_render_values( @$rgt );
71 6 100       17 @$rgt ? "$lft IN ($list)" : '1 IN (0)';
72             }
73             : $self->error( "unrecognized $type value for key '$lft' in hash" );
74 13         29 $term;
75             } sort keys %$item;
76 9 100       25 $append = "($append)" if keys %$item > 1;
77             }
78              
79 91 100 100     179 $sql .= '1 IN (1)', next if '1 IN (0)' eq $append and $sql =~ s/\bNOT\s*\z//i;
80 90 100 66     194 $sql .= ' ' if $sql =~ /\S/ and $append !~ /\A\s/ and $sql !~ /=\z/;
      100        
81 90         164 $sql .= $append;
82             }
83              
84 79         192 return $sql;
85             }
86              
87             sub bind_or_render_values {
88 47     47   62 my $self = shift;
89             map {
90 47         61 my $type = ref;
  74         92  
91 74 50 66     147 $self->error( "unrecognized $type value in aggregate" ) if $type and _CODE_ ne $type;
92 74 100       121 $type ? $_->( $self ) : $self->render_bind( $_ );
93             } @_;
94             }
95              
96 67     67   68 sub render_bind { push @{ $_[0]{'bind'} }, $_[1]; '?' }
  67         125  
  67         158  
97              
98             sub render_set {
99 2     2   3 my $self = shift;
100 2 50       5 $self->error( 'empty SET' ) if not @_;
101 2         5 my %h = @_;
102 2         10 my @k = sort keys %h;
103 2         6 my @v = $self->bind_or_render_values( @h{ @k } );
104 2         5 my $list = join ', ', map { "$k[$_]=$v[$_]" } 0 .. $#k;
  4         11  
105 2         7 "SET $list";
106             }
107              
108             sub render_values {
109 7     7   9 my $self = shift;
110 7         12 my ( $item ) = @_;
111 7         8 my $type = ref $item;
112 7         9 my $columns = '';
113             my @value
114             = 'ARRAY' eq $type ? $self->bind_or_render_values( @$item )
115 7 50       16 : 'HASH' eq $type ? do {
    100          
116 3         13 my @key = sort keys %$item;
117 3         7 $columns = join ', ', @key;
118 3         5 $columns = "($columns) ";
119 3         7 $self->bind_or_render_values( @$item{ @key } );
120             }
121             : $self->error( "unrecognized $type value in VALUES" );
122 7         13 my $list = join ', ', @value;
123 7         17 "${columns}VALUES($list)";
124             }
125              
126             sub render_select {
127 24     24   33 my $self = shift;
128 24 100       49 my @alias = ref $_[0] ? () : shift @_;
129              
130 24 100       47 $self->error( 'empty SELECT' ) if not @_;
131              
132 23         29 my $row0 = shift @_;
133 23         29 my $type0 = ref $row0;
134              
135 23         29 my @select;
136              
137 23 100       47 if ( 'ARRAY' eq $type0 ) {
    50          
138 14 100       26 $self->error( 'empty first row in SELECT' ) if not @$row0; # improve?
139 13         17 @select = map { join ', ', $self->bind_or_render_values( @$_ ) } $row0, @_;
  15         28  
140             }
141             elsif ( 'HASH' eq $type0 ) {
142 9 100       24 $self->error( 'empty first row in SELECT' ) if not keys %$row0; # improve?
143 8         25 my @k = sort keys %$row0;
144 8         20 my @v = $self->bind_or_render_values( @$row0{ @k } );
145             @select = (
146 12         40 ( join ', ', map { "$v[$_] AS $k[$_]" } 0 .. $#k ),
147 8         15 map { join ', ', $self->bind_or_render_values( @$_{ @k } ) } @_,
  2         5  
148             );
149             }
150 0         0 else { $self->error( "unrecognized first row '$row0' in SELECT" ) }
151              
152 21         66 my $sql = join ' UNION ALL ', map "SELECT $_", @select;
153 21         43 $sql = "($sql)";
154              
155 21 100       41 if ( @alias ) {
156 14         18 $sql .= ' AS ';
157 14 50       229 $sql .= defined $alias[0] ? $alias[0] : 'tbl'.$self->alias_id++;
158             }
159              
160 21         86 $sql;
161             }
162              
163             sub error {
164 5     5   7 my $self = shift;
165 5         75 my $prev = $self->prev_item;
166 5 50       21 push @_, " (somewhere past '$prev')" if defined $prev;
167 5         20 require Carp;
168 5         8 local $Carp::Internal{ (_CODE_) } = 1;
169 5         9 local $Carp::Internal{ (__PACKAGE__) } = 1;
170 5         436 Carp::croak( 'SQL::Concrete: ', @_ );
171             }
172              
173             1;
174              
175             __END__