Commit | Line | Data |
c0024355 |
1 | package # Hide from PAUSE |
2 | DBIx::Class::SQLAHacks::Oracle; |
3 | |
4 | use base qw( DBIx::Class::SQLAHacks ); |
5 | use Carp::Clan qw/^DBIx::Class|^SQL::Abstract/; |
6 | |
43426175 |
7 | # |
8 | # TODO: |
9 | # - Problems with such statements: parentid != PRIOR artistid |
10 | # - Check the parameter syntax of connect_by |
11 | # - Review review by experienced DBIC/SQL:A developers :-) |
12 | # |
13 | |
14 | sub new { |
15 | my $self = shift->SUPER::new(@_); |
16 | |
17 | push @{ $self->{unary_ops} },{ |
18 | regex => qr/^prior$/, |
19 | handler => '_prior_as_unary_op', |
20 | }; |
21 | |
22 | push @{ $self->{special_ops} },{ |
23 | regex => qr/^prior$/, |
24 | handler => '_prior_as_special_op', |
25 | }; |
26 | |
27 | return $self; |
28 | } |
29 | |
30 | |
c0024355 |
31 | sub select { |
32 | my ($self, $table, $fields, $where, $order, @rest) = @_; |
33 | |
34 | $self->{_db_specific_attrs} = pop @rest; |
35 | |
36 | my ($sql, @bind) = $self->SUPER::select($table, $fields, $where, $order, @rest); |
37 | push @bind, @{$self->{_oracle_connect_by_binds}}; |
38 | |
39 | return wantarray ? ($sql, @bind) : $sql; |
40 | } |
41 | |
42 | sub _emulate_limit { |
43 | my ( $self, $syntax, $sql, $order, $rows, $offset ) = @_; |
44 | |
45 | my ($cb_sql, @cb_bind) = $self->_connect_by(); |
46 | $sql .= $cb_sql; |
47 | $self->{_oracle_connect_by_binds} = \@cb_bind; |
48 | |
49 | return $self->SUPER::_emulate_limit($syntax, $sql, $order, $rows, $offset); |
50 | } |
51 | |
52 | sub _connect_by { |
53 | my ($self) = @_; |
54 | my $attrs = $self->{_db_specific_attrs}; |
55 | my $sql = ''; |
56 | my @bind; |
57 | |
58 | if ( ref($attrs) eq 'HASH' ) { |
59 | if ( $attrs->{'start_with'} ) { |
60 | my ($ws, @wb) = $self->_recurse_where( $attrs->{'start_with'} ); |
61 | $sql .= $self->_sqlcase(' start with ') . $ws; |
62 | push @bind, @wb; |
63 | } |
64 | if ( my $connect_by = $attrs->{'connect_by'}) { |
43426175 |
65 | my ($connect_by_sql, @connect_by_sql_bind) = $self->_recurse_where( $attrs->{'connect_by'} ); |
66 | $sql .= sprintf(" %s %s", |
67 | $self->_sqlcase('connect by'), |
68 | $connect_by_sql, |
69 | ); |
70 | push @bind, @connect_by_sql_bind; |
71 | # $sql .= $self->_sqlcase(' connect by'); |
72 | # foreach my $key ( keys %$connect_by ) { |
73 | # $sql .= " $key = " . $connect_by->{$key}; |
74 | # } |
c0024355 |
75 | } |
76 | if ( $attrs->{'order_siblings_by'} ) { |
77 | $sql .= $self->_order_siblings_by( $attrs->{'order_siblings_by'} ); |
78 | } |
79 | } |
80 | |
81 | return wantarray ? ($sql, @bind) : $sql; |
82 | } |
83 | |
84 | sub _order_siblings_by { |
85 | my $self = shift; |
86 | my $ref = ref $_[0]; |
87 | |
88 | my @vals = $ref eq 'ARRAY' ? @{$_[0]} : |
89 | $ref eq 'SCALAR' ? ${$_[0]} : |
90 | $ref eq '' ? $_[0] : |
91 | puke( "Unsupported data struct $ref for ORDER SIBILINGS BY" ); |
92 | |
93 | my $val = join ', ', map { $self->_quote($_) } @vals; |
94 | return $val ? $self->_sqlcase(' order siblings by')." $val" : ''; |
95 | } |
96 | |
43426175 |
97 | sub _prior_as_special_op { |
98 | my ( $self, $field, $op, $arg ) = @_; |
99 | |
100 | my ( $label, $and, $placeholder ); |
101 | $label = $self->_convert( $self->_quote($field) ); |
102 | $and = ' ' . $self->_sqlcase('and') . ' '; |
103 | $placeholder = $self->_convert('?'); |
104 | |
105 | # TODO: $op is prior, and not the operator |
106 | $op = $self->_sqlcase('='); |
107 | |
108 | my ( $sql, @bind ) = $self->_SWITCH_refkind( |
109 | $arg, |
110 | { |
111 | SCALARREF => sub { |
112 | my $sql = sprintf( "%s %s PRIOR %s", $label, $op, $$arg ); |
113 | return $sql; |
114 | }, |
115 | SCALAR => sub { |
116 | my $sql = sprintf( "%s %s PRIOR %s", $label, $op, $placeholder ); |
117 | return ( $sql, $arg ); |
118 | }, |
119 | HASHREF => sub { # case { '-prior' => { '=<' => 'nwiger'} } |
120 | # no _convert and _quote from SCALARREF |
121 | my ( $sql, @bind ) = $self->_where_hashpair_HASHREF( $field, $arg, $op ); |
122 | $sql = sprintf( " PRIOR %s", $sql ); |
123 | return ( $sql, @bind ); |
124 | }, |
125 | FALLBACK => sub { |
126 | # TODO |
127 | $self->puke(" wrong way... :/"); |
128 | }, |
129 | } |
130 | ); |
131 | return ( $sql, @bind ); |
132 | } |
133 | |
134 | sub _prior_as_unary_op { |
135 | my ( $self, $op, $arg ) = @_; |
136 | |
137 | my $placeholder = $self->_convert('?'); |
138 | my $and = ' ' . $self->_sqlcase('and') . ' '; |
139 | |
140 | my ( $sql, @bind ) = $self->_SWITCH_refkind( |
141 | $arg, |
142 | { |
143 | ARRAYREF => sub { |
144 | $self->puke("special op 'prior' accepts an arrayref with exactly two values") |
145 | if @$arg != 2; |
146 | |
147 | my ( @all_sql, @all_bind ); |
148 | |
149 | foreach my $val ( @{$arg} ) { |
150 | my ( $sql, @bind ) = $self->_SWITCH_refkind($val, |
151 | { |
152 | SCALAR => sub { |
153 | return ( $placeholder, ($val) ); |
154 | }, |
155 | SCALARREF => sub { |
156 | return ( $$val, () ); |
157 | }, |
158 | } |
159 | ); |
160 | push @all_sql, $sql; |
161 | push @all_bind, @bind; |
162 | } |
163 | my $sql = sprintf("PRIOR %s ",join $self->_sqlcase('='), @all_sql); |
164 | return ($sql,@all_bind); |
165 | }, |
166 | FALLBACK => sub { |
167 | |
168 | # TODO |
169 | $self->puke(" wrong way... :/ "); |
170 | }, |
171 | } |
172 | ); |
173 | return ( $sql, @bind ); |
174 | }; |
175 | |
c0024355 |
176 | 1; |
177 | |
178 | __END__ |
179 | |
180 | =pod |
181 | |
182 | =head1 NAME |
183 | |
184 | DBIx::Class::SQLAHacks::Oracle - adds hierarchical query support for Oracle to SQL::Abstract |
185 | |
186 | =head1 DESCRIPTION |
187 | |
188 | See L<DBIx::Class::Storage::DBI::Oracle::Generic> for more informations about |
189 | how to use hierarchical queries with DBIx::Class. |
190 | |
191 | =cut |