Corrected columns_info_for indent level - 2 space indent everyone please, you may...
[dbsrgits/DBIx-Class.git] / lib / DBIx / Class / CDBICompat / ImaDBI.pm
1 package # hide from PAUSE
2     DBIx::Class::CDBICompat::ImaDBI;
3
4 use strict;
5 use warnings;
6 use DBIx::ContextualFetch;
7
8 use base qw/DBIx::Class/;
9
10 __PACKAGE__->mk_classdata('_transform_sql_handler_order'
11                             => [ qw/TABLE ESSENTIAL JOIN/ ] );
12
13 __PACKAGE__->mk_classdata('_transform_sql_handlers' =>
14   {
15     'TABLE' =>
16       sub {
17         my ($self, $class, $data) = @_;
18         return $class->result_source_instance->name unless $data;
19         my ($f_class, $alias) = split(/=/, $data);
20         $f_class ||= $class;
21         $self->{_classes}{$alias} = $f_class;
22         return $f_class->result_source_instance->name." ${alias}";
23       },
24     'ESSENTIAL' =>
25       sub {
26         my ($self, $class, $data) = @_;
27         return join(' ', $class->columns('Essential')) unless $data;
28         return join(' ', $self->{_classes}{$data}->columns('Essential'));
29       },
30     'JOIN' =>
31       sub {
32         my ($self, $class, $data) = @_;
33         my ($from, $to) = split(/ /, $data);
34         my ($from_class, $to_class) = @{$self->{_classes}}{$from, $to};
35         my ($rel_obj) = grep { $_->{class} && $_->{class} eq $to_class }
36                           map { $from_class->relationship_info($_) }
37                             $from_class->relationships;
38         unless ($rel_obj) {
39           ($from, $to) = ($to, $from);
40           ($from_class, $to_class) = ($to_class, $from_class);
41           ($rel_obj) = grep { $_->{class} && $_->{class} eq $to_class }
42                           map { $from_class->relationship_info($_) }
43                             $from_class->relationships;
44         }
45         $self->throw_exception( "No relationship to JOIN from ${from_class} to ${to_class}" )
46           unless $rel_obj;
47         my $join = $from_class->storage->sql_maker->_join_condition(
48           $from_class->result_source_instance->resolve_condition(
49             $rel_obj->{cond}, $to, $from) );
50         return $join;
51       }
52         
53   } );
54
55 sub db_Main {
56   return $_[0]->storage->dbh;
57 }
58
59 sub connection {
60   my ($class, @info) = @_;
61   $info[3] = { %{ $info[3] || {}} };
62   $info[3]->{RootClass} = 'DBIx::ContextualFetch';
63   return $class->next::method(@info);
64 }
65
66 sub __driver {
67   return $_[0]->storage->dbh->{Driver}->{Name};
68 }
69
70 sub set_sql {
71   my ($class, $name, $sql) = @_;
72   no strict 'refs';
73   *{"${class}::sql_${name}"} =
74     sub {
75       my $sql = $sql;
76       my $class = shift;
77       return $class->storage->sth($class->transform_sql($sql, @_));
78     };
79   if ($sql =~ /select/i) {
80     my $meth = "sql_${name}";
81     *{"${class}::search_${name}"} =
82       sub {
83         my ($class, @args) = @_;
84         my $sth = $class->$meth;
85         $sth->execute(@args);
86         return $class->sth_to_objects($sth);
87       };
88   }
89 }
90
91 sub sth_to_objects {
92   my ($class, $sth) = @_;
93   my @ret;
94   while (my $row = $sth->fetchrow_hashref) {
95     push(@ret, $class->inflate_result($class->result_source_instance, $row));
96   }
97   return @ret;
98 }
99
100 sub transform_sql {
101   my ($class, $sql, @args) = @_;
102   my $attrs = { };
103   foreach my $key (@{$class->_transform_sql_handler_order}) {
104     my $h = $class->_transform_sql_handlers->{$key};
105     $sql =~ s/__$key(?:\(([^\)]+)\))?__/$h->($attrs, $class, $1)/eg;
106   }
107   #warn $sql;
108   return sprintf($sql, @args);
109 }
110
111 package DBIx::ContextualFetch::st;
112
113 no warnings 'redefine';
114
115 sub _untaint_execute {
116   my $sth = shift;
117   my $old_value = $sth->{Taint};
118   $sth->{Taint} = 0;
119   my $ret;
120   {
121     no warnings 'uninitialized';
122     $ret = $sth->SUPER::execute(@_);
123   }
124   $sth->{Taint} = $old_value;
125   return $ret;
126 }
127
128 1;