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