File Coverage

blib/lib/Class/DBI/SQL/Transformer.pm
Criterion Covered Total %
statement 63 63 100.0
branch 7 10 70.0
condition 14 19 73.7
subroutine 9 9 100.0
pod 3 3 100.0
total 96 104 92.3


line stmt bran cond sub pod time code
1             package Class::DBI::SQL::Transformer;
2              
3 19     19   272 use strict;
  19         177  
  19         285  
4 19     19   2317 use warnings;
  19         178  
  19         320  
5              
6             =head1 NAME
7            
8             Class::DBI::SQL::Transformer - Transform SQL
9            
10             =head1 SYNOPSIS
11            
12             my $trans = $tclass->new($self, $sql, @args);
13             return $self->SUPER::transform_sql($trans->sql => $trans->args);
14            
15             =head1 DESCRIPTION
16            
17             Class::DBI hooks into the transform_sql() method in Ima::DBI to provide
18             its own SQL extensions. Class::DBI::SQL::Transformer does the heavy
19             lifting of these transformations.
20            
21             =head1 CONSTRUCTOR
22            
23             =head2 new
24            
25             my $trans = $tclass->new($self, $sql, @args);
26            
27             Create a new transformer for the SQL and arguments that will be used
28             with the given object (or class).
29            
30             =cut
31              
32             sub new {
33 443     443 1 7313 my ($me, $caller, $sql, @args) = @_;
34 443         15539 bless {
35             _caller      => $caller,
36             _sql         => $sql,
37             _args        => [@args],
38             _transformed => 0,
39             } => $me;
40             }
41              
42             =head2 sql / args
43            
44             my $sql = $trans->sql;
45             my @args = $trans->args;
46            
47             The transformed SQL and args.
48            
49             =cut
50              
51             # TODO Document what the different transformations are
52             # and factor out how they're called so that people can pick and mix the
53             # ones they want and add new ones.
54              
55             sub sql {
56 443     443 1 9463 my $self = shift;
57 443 50       10286 $self->_do_transformation if !$self->{_transformed};
58 443         7996 return $self->{_transformed_sql};
59             }
60              
61             sub args {
62 443     443 1 4333 my $self = shift;
63 443 50       4927 $self->_do_transformation if !$self->{_transformed};
64 443         12757 return @{ $self->{_transformed_args} };
  443         18295  
65             }
66              
67             sub _expand_table {
68 439     439   5478 my $self = shift;
69 439         17565 my ($class, $alias) = split /=/, shift, 2;
70 439         4437 my $caller = $self->{_caller};
71 439 100       13036 my $table = $class ? $class->table : $caller->table;
72 439   66     25761 $self->{cmap}{ $alias || $table } = $class || ref $caller || $caller;
      100        
      66        
73 439   100     10694 ($alias ||= "") &&= " $alias";
      100        
74 439         12375 return $table . $alias;
75             }
76              
77             sub _expand_join {
78 2     2   54 my $self = shift;
79 2         24 my $joins = shift;
80 2         32 my @table = split /\s+/, $joins;
81              
82 2         21 my $caller = $self->{_caller};
83 2         29 my %tojoin = map { $table[$_] => $table[ $_ + 1 ] } 0 .. $#table - 1;
  2         73  
84 2         19 my @sql;
85 2         30 while (my ($t1, $t2) = each %tojoin) {
86 2   33     36 my ($c1, $c2) = map $self->{cmap}{$_}
87             || $caller->_croak("Don't understand table '$_' in JOIN"), ($t1, $t2);
88              
89             my $join_col = sub {
90 3     3   53 my ($c1, $c2) = @_;
91 3         60 my $meta = $c1->meta_info('has_a');
92 3         50 my ($col) = grep $meta->{$_}->foreign_class eq $c2, keys %$meta;
93 3         118 $col;
94 2         20 };
95              
96 2   66     43 my $col = $join_col->($c1 => $c2) || do {
97 1         11 ($c1, $c2) = ($c2, $c1);
98 1         12 ($t1, $t2) = ($t2, $t1);
99 1         63 $join_col->($c1 => $c2);
100             };
101              
102 2 50       42 $caller->_croak("Don't know how to join $c1 to $c2") unless $col;
103 2         87 push @sql, sprintf " %s.%s = %s.%s ", $t1, $col, $t2, $c2->primary_column;
104             }
105 2         120 return join " AND ", @sql;
106             }
107              
108             sub _do_transformation {
109 443     443   5190 my $me = shift;
110 443         6670 my $sql = $me->{_sql};
111 443         6438 my @args = @{ $me->{_args} };
  443         8536  
112 443         10985 my $caller = $me->{_caller};
113              
114 443         13873 $sql =~ s/__TABLE\(?(.*?)\)?__/$me->_expand_table($1)/eg;
  439         7064  
115 443         5690 $sql =~ s/__JOIN\((.*?)\)__/$me->_expand_join($1)/eg;
  2         26  
116 443         7116 $sql =~ s/__ESSENTIAL__/join ", ", $caller->_essential/eg;
  127         5430  
117             $sql =~
118 443         18483 s/__ESSENTIAL\((.*?)\)__/join ", ", map "$1.$_", $caller->_essential/eg;
  2         87  
119 443 100       6304 if ($sql =~ /__IDENTIFIER__/) {
120 155         2305 my $key_sql = join " AND ", map "$_=?", $caller->primary_columns;
121 155         8308 $sql =~ s/__IDENTIFIER__/$key_sql/g;
122             }
123              
124 443         7178 $me->{_transformed_sql}  = $sql;
125 443         6485 $me->{_transformed_args} = [@args];
126 443         10211 $me->{_transformed}      = 1;
127 443         7953 return 1;
128             }
129              
130             1;
131              
132