Commit | Line | Data |
dbd7896f |
1 | package DBIx::Class::CDBICompat::ImaDBI; |
2 | |
3 | use strict; |
4 | use warnings; |
5 | |
6 | use NEXT; |
ef29a097 |
7 | use base qw/Class::Data::Inheritable/; |
8 | |
12bbb339 |
9 | __PACKAGE__->mk_classdata('_transform_sql_handler_order' |
10 | => [ qw/TABLE ESSENTIAL JOIN/ ] ); |
11 | |
ef29a097 |
12 | __PACKAGE__->mk_classdata('_transform_sql_handlers' => |
13 | { |
12bbb339 |
14 | 'TABLE' => |
15 | sub { |
16 | my ($self, $class, $data) = @_; |
17 | return $class->_table_name unless $data; |
18 | my ($f_class, $alias) = split(/=/, $data); |
19 | $f_class ||= $class; |
d2ff6175 |
20 | $self->{_classes}{$alias} = $f_class; |
12bbb339 |
21 | return $f_class->_table_name." ${alias}"; |
22 | }, |
23 | 'ESSENTIAL' => |
24 | sub { |
25 | my ($self, $class, $data) = @_; |
26 | return join(' ', $class->columns('Essential')) unless $data; |
d2ff6175 |
27 | return join(' ', $self->{_classes}{$data}->columns('Essential')); |
12bbb339 |
28 | }, |
29 | 'JOIN' => |
30 | sub { |
31 | my ($self, $class, $data) = @_; |
32 | my ($from, $to) = split(/ /, $data); |
d2ff6175 |
33 | my ($from_class, $to_class) = @{$self->{_classes}}{$from, $to}; |
12bbb339 |
34 | my ($rel_obj) = grep { $_->{class} && $_->{class} eq $to_class } |
35 | values %{ $from_class->_relationships }; |
36 | unless ($rel_obj) { |
37 | ($from, $to) = ($to, $from); |
38 | ($from_class, $to_class) = ($to_class, $from_class); |
39 | ($rel_obj) = grep { $_->{class} && $_->{class} eq $to_class } |
40 | values %{ $from_class->_relationships }; |
41 | } |
78bab9ca |
42 | $self->throw( "No relationship to JOIN from ${from_class} to ${to_class}" ) |
12bbb339 |
43 | unless $rel_obj; |
44 | my $attrs = { |
d2ff6175 |
45 | %$self, |
12bbb339 |
46 | _aliases => { self => $from, foreign => $to }, |
47 | _action => 'join', |
48 | }; |
49 | my $join = $from_class->_cond_resolve($rel_obj->{cond}, $attrs); |
50 | return $join; |
51 | } |
52 | |
ef29a097 |
53 | } ); |
dbd7896f |
54 | |
55 | sub db_Main { |
56 | return $_[0]->_get_dbh; |
57 | } |
58 | |
59 | sub _dbi_connect { |
60 | my ($class, @info) = @_; |
61 | $info[3] = { %{ $info[3] || {}} }; |
62 | $info[3]->{RootClass} = 'DBIx::ContextualFetch'; |
63 | return $class->NEXT::_dbi_connect(@info); |
64 | } |
65 | |
66 | sub __driver { |
67 | return $_[0]->_get_dbh->{Driver}->{Name}; |
68 | } |
69 | |
a3018bd3 |
70 | sub set_sql { |
71 | my ($class, $name, $sql) = @_; |
72 | my $table = $class->_table_name; |
73 | #$sql =~ s/__TABLE__/$table/; |
74 | no strict 'refs'; |
75 | *{"${class}::sql_${name}"} = |
76 | sub { |
77 | my $sql = $sql; |
78 | my $class = shift; |
510ca912 |
79 | return $class->_sql_to_sth($class->transform_sql($sql, @_)); |
a3018bd3 |
80 | }; |
510ca912 |
81 | if ($sql =~ /select/i) { |
82 | my $meth = "sql_${name}"; |
83 | *{"${class}::search_${name}"} = |
84 | sub { |
85 | my ($class, @args) = @_; |
86 | $class->sth_to_objects($class->$meth, \@args); |
87 | }; |
88 | } |
89 | } |
90 | |
91 | sub transform_sql { |
92 | my ($class, $sql, @args) = @_; |
93 | my $table = $class->_table_name; |
12bbb339 |
94 | my $attrs = { }; |
95 | foreach my $key (@{$class->_transform_sql_handler_order}) { |
ef29a097 |
96 | my $h = $class->_transform_sql_handlers->{$key}; |
12bbb339 |
97 | $sql =~ s/__$key(?:\(([^\)]+)\))?__/$h->($attrs, $class, $1)/eg; |
ef29a097 |
98 | } |
510ca912 |
99 | return sprintf($sql, @args); |
a3018bd3 |
100 | } |
101 | |
dbd7896f |
102 | 1; |