Commit | Line | Data |
dbd7896f |
1 | package DBIx::Class::CDBICompat::ImaDBI; |
2 | |
3 | use strict; |
4 | use warnings; |
aea8af71 |
5 | use DBIx::ContextualFetch; |
dbd7896f |
6 | |
7 | use NEXT; |
ef29a097 |
8 | use base qw/Class::Data::Inheritable/; |
9 | |
12bbb339 |
10 | __PACKAGE__->mk_classdata('_transform_sql_handler_order' |
11 | => [ qw/TABLE ESSENTIAL JOIN/ ] ); |
12 | |
ef29a097 |
13 | __PACKAGE__->mk_classdata('_transform_sql_handlers' => |
14 | { |
12bbb339 |
15 | 'TABLE' => |
16 | sub { |
17 | my ($self, $class, $data) = @_; |
18 | return $class->_table_name unless $data; |
19 | my ($f_class, $alias) = split(/=/, $data); |
20 | $f_class ||= $class; |
d2ff6175 |
21 | $self->{_classes}{$alias} = $f_class; |
12bbb339 |
22 | return $f_class->_table_name." ${alias}"; |
23 | }, |
24 | 'ESSENTIAL' => |
25 | sub { |
26 | my ($self, $class, $data) = @_; |
27 | return join(' ', $class->columns('Essential')) unless $data; |
d2ff6175 |
28 | return join(' ', $self->{_classes}{$data}->columns('Essential')); |
12bbb339 |
29 | }, |
30 | 'JOIN' => |
31 | sub { |
32 | my ($self, $class, $data) = @_; |
33 | my ($from, $to) = split(/ /, $data); |
d2ff6175 |
34 | my ($from_class, $to_class) = @{$self->{_classes}}{$from, $to}; |
12bbb339 |
35 | my ($rel_obj) = grep { $_->{class} && $_->{class} eq $to_class } |
36 | values %{ $from_class->_relationships }; |
37 | unless ($rel_obj) { |
38 | ($from, $to) = ($to, $from); |
39 | ($from_class, $to_class) = ($to_class, $from_class); |
40 | ($rel_obj) = grep { $_->{class} && $_->{class} eq $to_class } |
41 | values %{ $from_class->_relationships }; |
42 | } |
78bab9ca |
43 | $self->throw( "No relationship to JOIN from ${from_class} to ${to_class}" ) |
12bbb339 |
44 | unless $rel_obj; |
45 | my $attrs = { |
d2ff6175 |
46 | %$self, |
12bbb339 |
47 | _aliases => { self => $from, foreign => $to }, |
48 | _action => 'join', |
49 | }; |
438adc0e |
50 | my $join = $from_class->storage->sql_maker->where( |
51 | $from_class->resolve_condition($rel_obj->{cond}, $attrs) ); |
52 | $join =~ s/^\s*WHERE//i; |
12bbb339 |
53 | return $join; |
54 | } |
55 | |
ef29a097 |
56 | } ); |
dbd7896f |
57 | |
58 | sub db_Main { |
8b445e33 |
59 | return $_[0]->storage->dbh; |
dbd7896f |
60 | } |
61 | |
8b445e33 |
62 | sub connection { |
dbd7896f |
63 | my ($class, @info) = @_; |
64 | $info[3] = { %{ $info[3] || {}} }; |
65 | $info[3]->{RootClass} = 'DBIx::ContextualFetch'; |
8b445e33 |
66 | return $class->NEXT::connection(@info); |
dbd7896f |
67 | } |
68 | |
69 | sub __driver { |
8b445e33 |
70 | return $_[0]->storage->dbh->{Driver}->{Name}; |
dbd7896f |
71 | } |
72 | |
a3018bd3 |
73 | sub set_sql { |
74 | my ($class, $name, $sql) = @_; |
75 | my $table = $class->_table_name; |
76 | #$sql =~ s/__TABLE__/$table/; |
77 | no strict 'refs'; |
78 | *{"${class}::sql_${name}"} = |
79 | sub { |
80 | my $sql = $sql; |
81 | my $class = shift; |
8b445e33 |
82 | return $class->storage->sth($class->transform_sql($sql, @_)); |
a3018bd3 |
83 | }; |
510ca912 |
84 | if ($sql =~ /select/i) { |
85 | my $meth = "sql_${name}"; |
86 | *{"${class}::search_${name}"} = |
87 | sub { |
88 | my ($class, @args) = @_; |
223b8fe3 |
89 | my $sth = $class->$meth; |
90 | $sth->execute(@args); |
91 | return $class->sth_to_objects($sth); |
510ca912 |
92 | }; |
93 | } |
94 | } |
95 | |
223b8fe3 |
96 | sub sth_to_objects { |
97 | my ($class, $sth) = @_; |
98 | my @cols = $class->_select_columns; |
99 | my @ret; |
100 | while (my @row = $sth->fetchrow_array) { |
101 | push(@ret, $class->_row_to_object(\@cols,\@row)); |
102 | } |
103 | return @ret; |
104 | } |
105 | |
510ca912 |
106 | sub transform_sql { |
107 | my ($class, $sql, @args) = @_; |
108 | my $table = $class->_table_name; |
12bbb339 |
109 | my $attrs = { }; |
110 | foreach my $key (@{$class->_transform_sql_handler_order}) { |
ef29a097 |
111 | my $h = $class->_transform_sql_handlers->{$key}; |
12bbb339 |
112 | $sql =~ s/__$key(?:\(([^\)]+)\))?__/$h->($attrs, $class, $1)/eg; |
ef29a097 |
113 | } |
438adc0e |
114 | #warn $sql; |
510ca912 |
115 | return sprintf($sql, @args); |
a3018bd3 |
116 | } |
117 | |
aea8af71 |
118 | package DBIx::ContextualFetch::st; |
119 | |
120 | no warnings 'redefine'; |
121 | |
122 | sub _untaint_execute { |
123 | my $sth = shift; |
124 | my $old_value = $sth->{Taint}; |
125 | $sth->{Taint} = 0; |
126 | my $ret; |
127 | { |
128 | no warnings 'uninitialized'; |
129 | $ret = $sth->SUPER::execute(@_); |
130 | } |
131 | $sth->{Taint} = $old_value; |
132 | return $ret; |
133 | } |
134 | |
dbd7896f |
135 | 1; |