File Coverage

lib/DBIx/DR.pm
Criterion Covered Total %
statement 104 115 90.4
branch 24 44 54.5
condition 10 20 50.0
subroutine 22 26 84.6
pod 1 1 100.0
total 161 206 78.1


line stmt bran cond sub pod time code
1 1     1   23252 use utf8;
  1         2  
  1         4  
2 1     1   23 use strict;
  1         2  
  1         14  
3 1     1   3 use warnings;
  1         1  
  1         17  
4              
5 1     1   257 use DBIx::DR::Iterator;
  1         1  
  1         20  
6 1     1   4 use DBIx::DR::Util ();
  1         1  
  1         11  
7 1     1   239 use DBIx::DR::PlPlaceHolders;
  1         2  
  1         47  
8              
9             package DBIx::DR;
10             our $VERSION = '0.31';
11 1     1   4 use base 'DBI';
  1         1  
  1         1416  
12 1     1   11536 use Carp;
  1         2  
  1         179  
13             $Carp::Internal{ (__PACKAGE__) } = 1;
14              
15             sub connect {
16 1     1 1 947 my ($class, $dsn, $user, $auth, $attr) = @_;
17              
18 1         9 my $dbh = $class->SUPER::connect($dsn, $user, $auth, $attr);
19              
20 1 50       1385 $attr = {} unless ref $attr;
21              
22             $dbh->{"private_DBIx::DR_iterator"} =
23 1   50     14 $attr->{dr_iterator} || 'dbix-dr-iterator#new';
24              
25             $dbh->{"private_DBIx::DR_item"} =
26 1   50     11 $attr->{dr_item} || 'dbix-dr-iterator-item#new';
27              
28 1         5 $dbh->{"private_DBIx::DR_sql_dir"} = $attr->{dr_sql_dir};
29              
30             $dbh->{"private_DBIx::DR_template"} = DBIx::DR::PlPlaceHolders->new(
31             sql_dir => $attr->{dr_sql_dir},
32 1   50     33 sql_utf8 => $attr->{dr_sql_utf8} // 1
33             );
34              
35 1         6 $dbh->{"private_DBIx::DR_dr_decode_errors"} = $attr->{dr_decode_errors};
36              
37 1         3 return $dbh;
38             }
39              
40             package DBIx::DR::st;
41 1     1   4 use base 'DBI::st';
  1         1  
  1         367  
42 1     1   5 use Carp;
  1         1  
  1         56  
43             $Carp::Internal{ (__PACKAGE__) } = 1;
44              
45             package DBIx::DR::db;
46 1     1   4 use Encode qw(decode encode);
  1         2  
  1         42  
47 1     1   4 use base 'DBI::db';
  1         1  
  1         220  
48 1     1   4 use DBIx::DR::Util;
  1         1  
  1         85  
49 1     1   445 use File::Spec::Functions qw(catfile);
  1         521  
  1         50  
50 1     1   8 use Carp;
  1         1  
  1         746  
51             $Carp::Internal{ (__PACKAGE__) } = 1;
52              
53              
54             sub set_helper {
55 1     1   301 my ($self, %opts) = @_;
56 1         9 $self->{"private_DBIx::DR_template"}->set_helper(%opts);
57             }
58              
59             sub _dr_extract_args_ep {
60 18     18   35 my $self = shift;
61              
62 18         22 my (@sql, %args);
63              
64 18 100       64 if (@_ % 2) {
65 14         56 ($sql[0], %args) = @_;
66 14         50 delete $args{-f};
67             } else {
68 4         15 %args = @_;
69             }
70              
71 18 50 66     64 croak "SQL wasn't defined" unless @sql or $args{-f};
72              
73 18         25 my ($iterator, $item);
74              
75 18 50       57 unless ($args{-noiterator}) {
76 18   66     164 $iterator = $args{-iterator} || $self->{'private_DBIx::DR_iterator'};
77 18 50       39 croak "Iterator class was not defined" unless $iterator;
78              
79 18 50       47 unless($args{-noitem}) {
80 18   66     71 $item = $args{-item} || $self->{'private_DBIx::DR_item'};
81 18 50       40 croak "Item class was not definded" unless $item;
82             }
83             }
84              
85             return (
86 18         48 $self,
87             \@sql,
88             \%args,
89             $item,
90             $iterator,
91             );
92             }
93              
94              
95              
96             sub _user_sql($@) {
97 2     2   4 my ($sql, @bv) = @_;
98 2         18 $sql =~ s/\?/'$_'/ for @bv;
99 2         284 return $sql;
100             }
101              
102              
103             sub select {
104 4     4   1926 my ($self, $sql, $args, $item, $iterator) = &_dr_extract_args_ep;
105              
106 4         37 my $req = $self->{"private_DBIx::DR_template"}->sql_transform(
107             @$sql,
108             %$args
109             );
110              
111 4 100       17 carp _user_sql($req->sql, $req->bind_values) if $args->{'-warn'};
112 4 100       103 croak _user_sql($req->sql, $req->bind_values) if $args->{'-die'};
113              
114 3         2 my $res;
115              
116 3     0   18 local $SIG{__DIE__} = sub { croak $self->_dr_decode_err(@_) };
  0         0  
117              
118 3 100       8 if (exists $args->{-hash}) {
119             $res = $self->selectall_hashref(
120             $req->sql,
121             $args->{-hash},
122             $args->{-dbi},
123 2         11 $req->bind_values
124             );
125              
126             } else {
127 1   50     7 my $dbi = $args->{-dbi} // {};
128 1 50       4 croak "argument '-dbi' must be HASHREF or undef"
129             unless 'HASH' eq ref $dbi;
130 1         8 $res = $self->selectall_arrayref(
131             $req->sql,
132             { %$dbi, Slice => {} },
133             $req->bind_values
134             );
135             }
136              
137              
138 3 50       1333 return $res unless $iterator;
139              
140 3         10 my ($class, $method) = camelize $iterator;
141              
142             return $class->$method(
143 3 50       35 $res, -item => $item, -noitem_iter => $args->{-noitem_iter}) if $method;
144 0         0 return bless $res => $class;
145             }
146              
147             sub single {
148 4     4   9 my ($self, $sql, $args, $item) = &_dr_extract_args_ep;
149 4         22 my $req = $self->{"private_DBIx::DR_template"}->sql_transform(
150             @$sql,
151             %$args
152             );
153            
154 4 50       10 carp _user_sql($req->sql, $req->bind_values) if $args->{'-warn'};
155 4 50       8 croak _user_sql($req->sql, $req->bind_values) if $args->{'-die'};
156              
157 4     0   17 local $SIG{__DIE__} = sub { croak $self->_dr_decode_err(@_) };
  0         0  
158             my $res = $self->selectrow_hashref(
159             $req->sql,
160             $args->{-dbi},
161 4         15 $req->bind_values
162             );
163              
164 4 100       748 return unless $res;
165              
166 3         7 my ($class, $method) = camelize $item;
167 3 50       13 return $class->$method($res) if $method;
168 0         0 return bless $res => $class;
169             }
170              
171             sub perform {
172 10     10   5673 my ($self, $sql, $args) = &_dr_extract_args_ep;
173 10         91 my $req = $self->{"private_DBIx::DR_template"}->sql_transform(
174             @$sql,
175             %$args
176             );
177            
178 9 50       35 carp _user_sql($req->sql, $req->bind_values) if $args->{'-warn'};
179 9 50       16 croak _user_sql($req->sql, $req->bind_values) if $args->{'-die'};
180              
181 9     0   51 local $SIG{__DIE__} = sub { croak $self->_dr_decode_err(@_) };
  0         0  
182             my $res = $self->do(
183             $req->sql,
184             $args->{-dbi},
185 9         75 $req->bind_values
186             );
187 9         662734 return $res;
188             }
189              
190              
191             sub _dr_decode_err {
192 0     0     my ($self, @arg) = @_;
193 0 0         if ($self->{"private_DBIx::DR_dr_decode_errors"}) {
194 0           for (@arg) {
195 0 0 0       $_ = eval { decode utf8 => $_ } || $_ unless utf8::is_utf8 $_;
196             }
197             }
198 0 0         return @arg if wantarray;
199 0           return join ' ' => @arg;
200             }
201              
202              
203             1;
204              
205             __END__