Move code having to do with adding columns out of ColumnCase.
[dbsrgits/DBIx-Class.git] / lib / DBIx / Class / CDBICompat / ImaDBI.pm
CommitLineData
c0e7b4e5 1package # hide from PAUSE
2 DBIx::Class::CDBICompat::ImaDBI;
dbd7896f 3
4use strict;
5use warnings;
aea8af71 6use DBIx::ContextualFetch;
dbd7896f 7
75a23b3e 8use base qw/DBIx::Class/;
ef29a097 9
902133a3 10__PACKAGE__->mk_classdata('sql_transformer_class' =>
11 'DBIx::Class::CDBICompat::SQLTransformer');
12
12bbb339 13__PACKAGE__->mk_classdata('_transform_sql_handler_order'
e60dc79f 14 => [ qw/TABLE ESSENTIAL JOIN IDENTIFIER/ ] );
12bbb339 15
ef29a097 16__PACKAGE__->mk_classdata('_transform_sql_handlers' =>
17 {
12bbb339 18 'TABLE' =>
19 sub {
20 my ($self, $class, $data) = @_;
b98e75f6 21 return $class->result_source_instance->name unless $data;
12bbb339 22 my ($f_class, $alias) = split(/=/, $data);
23 $f_class ||= $class;
d2ff6175 24 $self->{_classes}{$alias} = $f_class;
b98e75f6 25 return $f_class->result_source_instance->name." ${alias}";
12bbb339 26 },
27 'ESSENTIAL' =>
28 sub {
29 my ($self, $class, $data) = @_;
e60dc79f 30 $class = $data ? $self->{_classes}{$data} : $class;
31 return join(', ', $class->columns('Essential'));
32 },
33 'IDENTIFIER' =>
34 sub {
35 my ($self, $class, $data) = @_;
36 $class = $data ? $self->{_classes}{$data} : $class;
37 return join ' AND ', map "$_ = ?", $class->primary_columns;
12bbb339 38 },
39 'JOIN' =>
40 sub {
41 my ($self, $class, $data) = @_;
42 my ($from, $to) = split(/ /, $data);
d2ff6175 43 my ($from_class, $to_class) = @{$self->{_classes}}{$from, $to};
12bbb339 44 my ($rel_obj) = grep { $_->{class} && $_->{class} eq $to_class }
4685e006 45 map { $from_class->relationship_info($_) }
46 $from_class->relationships;
12bbb339 47 unless ($rel_obj) {
48 ($from, $to) = ($to, $from);
49 ($from_class, $to_class) = ($to_class, $from_class);
50 ($rel_obj) = grep { $_->{class} && $_->{class} eq $to_class }
4685e006 51 map { $from_class->relationship_info($_) }
52 $from_class->relationships;
12bbb339 53 }
701da8c4 54 $self->throw_exception( "No relationship to JOIN from ${from_class} to ${to_class}" )
12bbb339 55 unless $rel_obj;
fef5d100 56 my $join = $from_class->storage->sql_maker->_join_condition(
8c49f629 57 $from_class->result_source_instance->resolve_condition(
3842b955 58 $rel_obj->{cond}, $to, $from) );
12bbb339 59 return $join;
60 }
61
ef29a097 62 } );
dbd7896f 63
64sub db_Main {
8b445e33 65 return $_[0]->storage->dbh;
dbd7896f 66}
67
8b445e33 68sub connection {
dbd7896f 69 my ($class, @info) = @_;
70 $info[3] = { %{ $info[3] || {}} };
71 $info[3]->{RootClass} = 'DBIx::ContextualFetch';
147dd158 72 return $class->next::method(@info);
dbd7896f 73}
74
75sub __driver {
8b445e33 76 return $_[0]->storage->dbh->{Driver}->{Name};
dbd7896f 77}
78
a3018bd3 79sub set_sql {
80 my ($class, $name, $sql) = @_;
a3018bd3 81 no strict 'refs';
82 *{"${class}::sql_${name}"} =
83 sub {
84 my $sql = $sql;
85 my $class = shift;
8b445e33 86 return $class->storage->sth($class->transform_sql($sql, @_));
a3018bd3 87 };
510ca912 88 if ($sql =~ /select/i) {
89 my $meth = "sql_${name}";
90 *{"${class}::search_${name}"} =
91 sub {
92 my ($class, @args) = @_;
223b8fe3 93 my $sth = $class->$meth;
902133a3 94 return $class->sth_to_objects($sth, \@args);
510ca912 95 };
96 }
97}
98
223b8fe3 99sub sth_to_objects {
902133a3 100 my ($class, $sth, $execute_args) = @_;
101
102 $sth->execute(@$execute_args);
103
223b8fe3 104 my @ret;
b52e9bf8 105 while (my $row = $sth->fetchrow_hashref) {
8c49f629 106 push(@ret, $class->inflate_result($class->result_source_instance, $row));
223b8fe3 107 }
902133a3 108
223b8fe3 109 return @ret;
110}
111
510ca912 112sub transform_sql {
113 my ($class, $sql, @args) = @_;
902133a3 114
115 my $tclass = $class->sql_transformer_class;
116 $class->ensure_class_loaded($tclass);
117 my $t = $tclass->new($class, $sql, @args);
118
119 return sprintf($t->sql, $t->args);
a3018bd3 120}
121
a2800991 122package
123 DBIx::ContextualFetch::st; # HIDE FROM PAUSE THIS IS NOT OUR CLASS
aea8af71 124
125no warnings 'redefine';
126
127sub _untaint_execute {
128 my $sth = shift;
129 my $old_value = $sth->{Taint};
130 $sth->{Taint} = 0;
131 my $ret;
132 {
133 no warnings 'uninitialized';
134 $ret = $sth->SUPER::execute(@_);
135 }
136 $sth->{Taint} = $old_value;
137 return $ret;
138}
139
dbd7896f 1401;