Simplify guarded pass-through added to CDBI in ee333775
[dbsrgits/DBIx-Class.git] / lib / DBIx / Class / SQLMaker / Oracle.pm
1 package # Hide from PAUSE
2   DBIx::Class::SQLMaker::Oracle;
3
4 use warnings;
5 use strict;
6
7 BEGIN {
8   require DBIx::Class::Optional::Dependencies;
9   if (my $missing = DBIx::Class::Optional::Dependencies->req_missing_for ('id_shortener') ) {
10     die "The following extra modules are required for Oracle-based Storages: $missing\n";
11   }
12   require Digest::MD5;
13 }
14
15 use base 'DBIx::Class::SQLMaker';
16
17 sub new {
18   my $self = shift;
19   my %opts = (ref $_[0] eq 'HASH') ? %{$_[0]} : @_;
20   push @{$opts{special_ops}}, {
21     regex => qr/^prior$/i,
22     handler => '_where_field_PRIOR',
23   };
24
25   $self->next::method(\%opts);
26 }
27
28 sub _assemble_binds {
29   my $self = shift;
30   return map { @{ (delete $self->{"${_}_bind"}) || [] } } (qw/pre_select select from where oracle_connect_by group having order limit/);
31 }
32
33
34 sub _parse_rs_attrs {
35     my $self = shift;
36     my ($rs_attrs) = @_;
37
38     my ($cb_sql, @cb_bind) = $self->_connect_by($rs_attrs);
39     push @{$self->{oracle_connect_by_bind}}, @cb_bind;
40
41     my $sql = $self->next::method(@_);
42
43     return "$cb_sql $sql";
44 }
45
46 sub _connect_by {
47     my ($self, $attrs) = @_;
48
49     my $sql = '';
50     my @bind;
51
52     if ( ref($attrs) eq 'HASH' ) {
53         if ( $attrs->{'start_with'} ) {
54             my ($ws, @wb) = $self->_recurse_where( $attrs->{'start_with'} );
55             $sql .= $self->_sqlcase(' start with ') . $ws;
56             push @bind, @wb;
57         }
58         if ( my $connect_by = $attrs->{'connect_by'} || $attrs->{'connect_by_nocycle'} ) {
59             my ($connect_by_sql, @connect_by_sql_bind) = $self->_recurse_where( $connect_by );
60             $sql .= sprintf(" %s %s",
61                 ( $attrs->{'connect_by_nocycle'} ) ? $self->_sqlcase('connect by nocycle')
62                     : $self->_sqlcase('connect by'),
63                 $connect_by_sql,
64             );
65             push @bind, @connect_by_sql_bind;
66         }
67         if ( $attrs->{'order_siblings_by'} ) {
68             $sql .= $self->_order_siblings_by( $attrs->{'order_siblings_by'} );
69         }
70     }
71
72     return wantarray ? ($sql, @bind) : $sql;
73 }
74
75 sub _order_siblings_by {
76     my ( $self, $arg ) = @_;
77
78     my ( @sql, @bind );
79     for my $c ( $self->_order_by_chunks($arg) ) {
80         if (ref $c) {
81             push @sql, shift @$c;
82             push @bind, @$c;
83         }
84         else {
85             push @sql, $c;
86         }
87     }
88
89     my $sql =
90       @sql
91       ? sprintf( '%s %s', $self->_sqlcase(' order siblings by'), join( ', ', @sql ) )
92       : '';
93
94     return wantarray ? ( $sql, @bind ) : $sql;
95 }
96
97 # we need to add a '=' only when PRIOR is used against a column directly
98 # i.e. when it is invoked by a special_op callback
99 sub _where_field_PRIOR {
100   my ($self, $lhs, $op, $rhs) = @_;
101   my ($sql, @bind) = $self->_recurse_where ($rhs);
102
103   $sql = sprintf ('%s = %s %s ',
104     $self->_convert($self->_quote($lhs)),
105     $self->_sqlcase ($op),
106     $sql
107   );
108
109   return ($sql, @bind);
110 }
111
112 # use this codepath to hook all identifiers and mangle them if necessary
113 # this is invoked regardless of quoting being on or off
114 sub _quote {
115   my ($self, $label) = @_;
116
117   return '' unless defined $label;
118   return ${$label} if ref($label) eq 'SCALAR';
119
120   $label =~ s/ ( [^\.]{31,} ) /$self->_shorten_identifier($1)/gxe;
121
122   $self->next::method($label);
123 }
124
125 # this takes an identifier and shortens it if necessary
126 # optionally keywords can be passed as an arrayref to generate useful
127 # identifiers
128 sub _shorten_identifier {
129   my ($self, $to_shorten, $keywords) = @_;
130
131   # 30 characters is the identifier limit for Oracle
132   my $max_len = 30;
133   # we want at least 10 characters of the base36 md5
134   my $min_entropy = 10;
135
136   my $max_trunc = $max_len - $min_entropy - 1;
137
138   return $to_shorten
139     if length($to_shorten) <= $max_len;
140
141   $self->throw_exception("'keywords' needs to be an arrayref")
142     if defined $keywords && ref $keywords ne 'ARRAY';
143
144   # if no keywords are passed use the identifier as one
145   my @keywords = @{$keywords || []};
146   @keywords = $to_shorten unless @keywords;
147
148   # get a base36 md5 of the identifier
149   my $b36sum = Math::Base36::encode_base36(
150     Math::BigInt->from_hex (
151       '0x' . Digest::MD5::md5_hex ($to_shorten)
152     )
153   );
154
155   # switch from perl to java
156   # get run-length
157   my ($concat_len, @lengths);
158   for (@keywords) {
159     $_ = ucfirst (lc ($_));
160     $_ =~ s/\_+(\w)/uc ($1)/eg;
161
162     push @lengths, length ($_);
163     $concat_len += $lengths[-1];
164   }
165
166   # if we are still too long - try to disemvowel non-capitals (not keyword starts)
167   if ($concat_len > $max_trunc) {
168     $concat_len = 0;
169     @lengths = ();
170
171     for (@keywords) {
172       $_ =~ s/[aeiou]//g;
173
174       push @lengths, length ($_);
175       $concat_len += $lengths[-1];
176     }
177   }
178
179   # still too long - just start cutting proportionally
180   if ($concat_len > $max_trunc) {
181     my $trim_ratio = $max_trunc / $concat_len;
182
183     for my $i (0 .. $#keywords) {
184       $keywords[$i] = substr ($keywords[$i], 0, int ($trim_ratio * $lengths[$i] ) );
185     }
186   }
187
188   my $fin = join ('', @keywords);
189   my $fin_len = length $fin;
190
191   return sprintf ('%s_%s',
192     $fin,
193     substr ($b36sum, 0, $max_len - $fin_len - 1),
194   );
195 }
196
197 sub _unqualify_colname {
198   my ($self, $fqcn) = @_;
199
200   return $self->_shorten_identifier($self->next::method($fqcn));
201 }
202
203 #
204 # Oracle has a different INSERT...RETURNING syntax
205 #
206
207 sub _insert_returning {
208   my ($self, $options) = @_;
209
210   my $f = $options->{returning};
211
212   my ($f_list, @f_names) = do {
213     if (! ref $f) {
214       (
215         $self->_quote($f),
216         $f,
217       )
218     }
219     elsif (ref $f eq 'ARRAY') {
220       (
221         (join ', ', map { $self->_quote($_) } @$f),
222         @$f,
223       )
224     }
225     elsif (ref $f eq 'SCALAR') {
226       (
227         $$f,
228         $$f,
229       )
230     }
231     else {
232       $self->throw_exception("Unsupported INSERT RETURNING option $f");
233     }
234   };
235
236   my $rc_ref = $options->{returning_container}
237     or $self->throw_exception('No returning container supplied for IR values');
238
239   @$rc_ref = (undef) x @f_names;
240
241   return (
242     ( join (' ',
243       $self->_sqlcase(' returning'),
244       $f_list,
245       $self->_sqlcase('into'),
246       join (', ', ('?') x @f_names ),
247     )),
248     map {
249       $self->{bindtype} eq 'columns'
250         ? [ $f_names[$_] => \$rc_ref->[$_] ]
251         : \$rc_ref->[$_]
252     } (0 .. $#f_names),
253   );
254 }
255
256 1;