moved Oracle datetime bind param transformation to private function
[dbsrgits/DBIx-Class.git] / lib / DBIx / Class / SQLMaker / Oracle.pm
CommitLineData
c0024355 1package # Hide from PAUSE
d5dedbd6 2 DBIx::Class::SQLMaker::Oracle;
c0024355 3
9ab1e5f0 4use warnings;
5use strict;
6
d5dedbd6 7use base qw( DBIx::Class::SQLMaker );
c0024355 8
c7d50a7d 9BEGIN {
c7d50a7d 10 use DBIx::Class::Optional::Dependencies;
70c28808 11 die('The following extra modules are required for Oracle-based Storages ' . DBIx::Class::Optional::Dependencies->req_missing_for ('id_shortener') . "\n" )
c7d50a7d 12 unless DBIx::Class::Optional::Dependencies->req_ok_for ('id_shortener');
13}
14
9ab1e5f0 15sub new {
16 my $self = shift;
17 my %opts = (ref $_[0] eq 'HASH') ? %{$_[0]} : @_;
18 push @{$opts{special_ops}}, {
19 regex => qr/^prior$/i,
20 handler => '_where_field_PRIOR',
21 };
22
70551c3d 23 $self->next::method(\%opts);
9ab1e5f0 24}
25
583a0c65 26sub _assemble_binds {
27 my $self = shift;
fcb7fcbb 28 return map { @{ (delete $self->{"${_}_bind"}) || [] } } (qw/select from where oracle_connect_by group having order limit/);
c0024355 29}
30
583a0c65 31
49afd714 32sub _parse_rs_attrs {
33 my $self = shift;
34 my ($rs_attrs) = @_;
c0024355 35
2e4dd241 36 my ($cb_sql, @cb_bind) = $self->_connect_by($rs_attrs);
49afd714 37 push @{$self->{oracle_connect_by_bind}}, @cb_bind;
38
70551c3d 39 my $sql = $self->next::method(@_);
c0024355 40
49afd714 41 return "$cb_sql $sql";
c0024355 42}
43
44sub _connect_by {
2e4dd241 45 my ($self, $attrs) = @_;
46
c0024355 47 my $sql = '';
48 my @bind;
49
50 if ( ref($attrs) eq 'HASH' ) {
51 if ( $attrs->{'start_with'} ) {
52 my ($ws, @wb) = $self->_recurse_where( $attrs->{'start_with'} );
53 $sql .= $self->_sqlcase(' start with ') . $ws;
54 push @bind, @wb;
55 }
6b2fbbf0 56 if ( my $connect_by = $attrs->{'connect_by'} || $attrs->{'connect_by_nocycle'} ) {
57 my ($connect_by_sql, @connect_by_sql_bind) = $self->_recurse_where( $connect_by );
43426175 58 $sql .= sprintf(" %s %s",
ef5db928 59 ( $attrs->{'connect_by_nocycle'} ) ? $self->_sqlcase('connect by nocycle')
2ba03b16 60 : $self->_sqlcase('connect by'),
43426175 61 $connect_by_sql,
62 );
63 push @bind, @connect_by_sql_bind;
c0024355 64 }
65 if ( $attrs->{'order_siblings_by'} ) {
66 $sql .= $self->_order_siblings_by( $attrs->{'order_siblings_by'} );
67 }
68 }
69
70 return wantarray ? ($sql, @bind) : $sql;
71}
72
73sub _order_siblings_by {
2a770efe 74 my ( $self, $arg ) = @_;
75
76 my ( @sql, @bind );
77 for my $c ( $self->_order_by_chunks($arg) ) {
78 $self->_SWITCH_refkind(
79 $c,
80 {
81 SCALAR => sub { push @sql, $c },
82 ARRAYREF => sub { push @sql, shift @$c; push @bind, @$c },
83 }
84 );
85 }
c0024355 86
2a770efe 87 my $sql =
88 @sql
89 ? sprintf( '%s %s', $self->_sqlcase(' order siblings by'), join( ', ', @sql ) )
90 : '';
c0024355 91
2a770efe 92 return wantarray ? ( $sql, @bind ) : $sql;
c0024355 93}
94
9ab1e5f0 95# we need to add a '=' only when PRIOR is used against a column diretly
96# i.e. when it is invoked by a special_op callback
97sub _where_field_PRIOR {
98 my ($self, $lhs, $op, $rhs) = @_;
99 my ($sql, @bind) = $self->_recurse_where ($rhs);
100
101 $sql = sprintf ('%s = %s %s ',
102 $self->_convert($self->_quote($lhs)),
103 $self->_sqlcase ($op),
104 $sql
105 );
106
107 return ($sql, @bind);
108}
109
19c4cc62 110# use this codepath to hook all identifiers and mangle them if necessary
111# this is invoked regardless of quoting being on or off
112sub _quote {
113 my ($self, $label) = @_;
114
115 return '' unless defined $label;
116 return ${$label} if ref($label) eq 'SCALAR';
117
118 $label =~ s/ ( [^\.]{31,} ) /$self->_shorten_identifier($1)/gxe;
119
120 $self->next::method($label);
121}
122
63ca94e1 123# this takes an identifier and shortens it if necessary
124# optionally keywords can be passed as an arrayref to generate useful
125# identifiers
126sub _shorten_identifier {
127 my ($self, $to_shorten, $keywords) = @_;
128
129 # 30 characters is the identifier limit for Oracle
130 my $max_len = 30;
131 # we want at least 10 characters of the base36 md5
132 my $min_entropy = 10;
133
134 my $max_trunc = $max_len - $min_entropy - 1;
135
136 return $to_shorten
137 if length($to_shorten) <= $max_len;
138
70c28808 139 $self->throw_exception("'keywords' needs to be an arrayref")
63ca94e1 140 if defined $keywords && ref $keywords ne 'ARRAY';
141
142 # if no keywords are passed use the identifier as one
143 my @keywords = @{$keywords || []};
144 @keywords = $to_shorten unless @keywords;
145
146 # get a base36 md5 of the identifier
147 require Digest::MD5;
148 require Math::BigInt;
149 require Math::Base36;
150 my $b36sum = Math::Base36::encode_base36(
151 Math::BigInt->from_hex (
152 '0x' . Digest::MD5::md5_hex ($to_shorten)
153 )
154 );
155
156 # switch from perl to java
157 # get run-length
158 my ($concat_len, @lengths);
159 for (@keywords) {
160 $_ = ucfirst (lc ($_));
161 $_ =~ s/\_+(\w)/uc ($1)/eg;
162
163 push @lengths, length ($_);
164 $concat_len += $lengths[-1];
165 }
166
167 # if we are still too long - try to disemvowel non-capitals (not keyword starts)
168 if ($concat_len > $max_trunc) {
169 $concat_len = 0;
170 @lengths = ();
171
172 for (@keywords) {
173 $_ =~ s/[aeiou]//g;
174
175 push @lengths, length ($_);
176 $concat_len += $lengths[-1];
177 }
178 }
179
180 # still too long - just start cuting proportionally
181 if ($concat_len > $max_trunc) {
182 my $trim_ratio = $max_trunc / $concat_len;
183
184 for my $i (0 .. $#keywords) {
185 $keywords[$i] = substr ($keywords[$i], 0, int ($trim_ratio * $lengths[$i] ) );
186 }
187 }
188
189 my $fin = join ('', @keywords);
190 my $fin_len = length $fin;
191
192 return sprintf ('%s_%s',
193 $fin,
194 substr ($b36sum, 0, $max_len - $fin_len - 1),
195 );
196}
197
198sub _unqualify_colname {
199 my ($self, $fqcn) = @_;
200
201 return $self->_shorten_identifier($self->next::method($fqcn));
202}
203
bf51641f 204#
205# Oracle has a different INSERT...RETURNING syntax
206#
207
208sub _insert_returning {
209 my ($self, $options) = @_;
210
211 my $f = $options->{returning};
212
213 my ($f_list, @f_names) = $self->_SWITCH_refkind($f, {
214 ARRAYREF => sub {
215 (join ', ', map { $self->_quote($_) } @$f),
216 @$f
217 },
218 SCALAR => sub {
219 $self->_quote($f),
220 $f,
221 },
222 SCALARREF => sub {
223 $$f,
224 $$f,
225 },
226 });
227
228 my $rc_ref = $options->{returning_container}
70c28808 229 or $self->throw_exception('No returning container supplied for IR values');
bf51641f 230
231 @$rc_ref = (undef) x @f_names;
232
233 return (
234 ( join (' ',
235 $self->_sqlcase(' returning'),
236 $f_list,
237 $self->_sqlcase('into'),
238 join (', ', ('?') x @f_names ),
239 )),
240 map {
241 $self->{bindtype} eq 'columns'
242 ? [ $f_names[$_] => \$rc_ref->[$_] ]
243 : \$rc_ref->[$_]
244 } (0 .. $#f_names),
245 );
246}
247
7729a3b5 248# this is needed because DBD::Oracle doesn't support specifying
249# the data type of a bind var as ORA_DATE
250sub _modify_datetime_for_bind {
251 my $date = shift;
252
253 # from the Oracle extract function docs:
254 # EXTRACT interprets expr as an ANSI datetime datatype.
255 # For example, EXTRACT treats DATE not as legacy Oracle DATE but as
256 # ANSI DATE, without time elements.
257 # Therefore, you can extract only YEAR, MONTH, and DAY from a DATE value.
258
259 return $date eq '?' ? "TO_TIMESTAMP($date)" : $date;
260}
1ca22a2a 261
262{
263 my %part_map = (
08c123d2 264 second => 'SECOND',
265 minute => 'MINUTE',
266 hour => 'HOUR',
267 day_of_month => 'DAY',
268 month => 'MONTH',
269 year => 'YEAR',
1ca22a2a 270 );
271
c33937bf 272 sub _datetime_sql {
3aa074bf 273 my ($self, $part, $date) = @_;
274
275 die $self->_unsupported_date_extraction($part, 'Oracle')
276 unless exists $part_map{$part};
277
7729a3b5 278 my $rhs = _modify_datetime_for_bind($date);
3aa074bf 279
280 return "EXTRACT($part_map{$_[1]} FROM $rhs)";
c33937bf 281 }
1ca22a2a 282}
283
284{
285 my %part_map = (
08c123d2 286 second => '* 31 * 24 * 60 * 60',
287 minute => '* 31 * 24 * 60',
288 hour => '* 31 * 24',
289 day => '* 31',
290 month => undef,
291 year => '/ 12',
1ca22a2a 292 );
293
c33937bf 294 sub _datetime_diff_sql {
295 die $_[0]->_unsupported_date_diff($_[1], 'Oracle')
296 unless exists $part_map{$_[1]};
08c123d2 297 my $sql = "MONTHS_BETWEEN($_[2], $_[3])";
298 $sql .= " $part_map{$_[1]}"
299 if defined $part_map{$_[1]};
300 $sql = "TRUNC($sql)";
301 return $sql;
c33937bf 302 }
1ca22a2a 303}
dff53b7e 304
08c123d2 305{
306 my %part_map = (
307 second => 'NUMTODSINTERVAL',
308 minute => 'NUMTODSINTERVAL',
309 hour => 'NUMTODSINTERVAL',
310 day => 'NUMTODSINTERVAL',
311 month => 'NUMTOYMINTERVAL',
312 year => 'NUMTOYMINTERVAL',
313 );
314
315 sub _datetime_add_sql {
316 my ($self, $part, $date, $amount) = @_;
317
318 die $self->_unsupported_date_adding($part, 'Oracle')
319 unless exists $part_map{$part};
320
7729a3b5 321 my $rhs = _modify_datetime_for_bind($date);
3aa074bf 322
323 return "($rhs + $part_map{$part}($amount, '$part'))";
08c123d2 324 }
325}
326
327sub _reorder_add_datetime_vars {
328 my ($self, $amount, $date) = @_;
329
330 return ($date, $amount);
331}
332
dff53b7e 333=head1 DATE FUNCTION IMPLEMENTATION
334
08c123d2 335The function used to extract date information is C<EXTRACT>, which supports
dff53b7e 336
08c123d2 337 second
338 minute
339 hour
dff53b7e 340 day_of_month
08c123d2 341 month
dff53b7e 342 year
dff53b7e 343
08c123d2 344The function used to diff dates is C<MONTHS_BETWEEN> with
345multiplication/division to the requested format.
346The valid formats are:
dff53b7e 347
348 second
349 minute
350 hour
08c123d2 351 day
dff53b7e 352 month
dff53b7e 353 year
354
355=cut
356
c0024355 3571;