File Coverage

lib/DBIx/Oro.pm
Criterion Covered Total %
statement 566 737 76.8
branch 317 504 62.9
condition 89 191 46.6
subroutine 37 47 78.7
pod 19 21 90.4
total 1028 1500 68.5


line stmt bran cond sub pod time code
1             package DBIx::Oro;
2 23     23   26011 use strict;
  23         41  
  23         737  
3 23     23   101 use warnings;
  23         52  
  23         1401  
4              
5             our $VERSION = '0.31_9';
6              
7             # See the bottom of this file for the POD documentation.
8              
9             # Todo: Fix treatments in joined tables!
10              
11             # Todo: Are combined indices necessarily in the same order?
12             # In that case update and select etc. need ordered
13             # keys!
14              
15             # Todo: Improve documentation
16             # - =head1 ADVANCED CONCEPTS
17             # - Joined tables
18             # - Treatments
19             # - Caching
20             # - Injected SQL
21             # - explain
22             # - on_connect
23              
24             # Todo: -prefix is not documented!
25             # Todo: Put 'created' in SQLite driver
26             # implement ->errstr
27             # implement "-with" (?)
28             # Debug: $lemma_oro->insert({
29             # wcl => $_,
30             # lemma => $inter
31             # },{
32             # token => $search_for
33             # });
34             # (Should raise error)
35             # Todo: Support left outer join (Maybe with id => 1, maybe => 1 in join hash)
36             # Todo: Create all Queries in DBIx::Oro::Query
37             # Todo: To change queries from different drivers,
38             # use events.
39             # Todo: Return key -column_order => [] with fetchall_arrayref.
40             # Todo: my $value = $oro->value(Table => 'Field') # Ähnlich wie count
41             # Todo: Oder my ($value) = $oro->value(Table => Field => { -limit => 1 }) # und es gibt ein Array zurück
42             # Todo: Check for BDB-support:
43             # http://charlesleifer.com/blog/sqlite-small-fast-reliable-choose-any-three-/
44              
45 23     23   300 use v5.10.1;
  23         64  
46              
47 23     23   107 use Scalar::Util qw/blessed/;
  23         46  
  23         2225  
48 23     23   114 use Carp qw/carp croak/;
  23         33  
  23         1571  
49             our @CARP_NOT;
50              
51             # Database connection
52 23     23   36591 use DBI;
  23         372807  
  23         227198  
53              
54             our $AS_REGEX = qr/(?::~?`?[-_a-zA-Z0-9]+`?)/;
55              
56             our $OP_REGEX = qr/^(?i:
57             (?:[\<\>\!=]?\=?)|<>|
58             (?:!|not[_ ])?
59             (?:match|like|glob|regex|between)|
60             (?:eq|ne|[gl][te]|not)
61             )$/x;
62              
63             our $KEY_REGEX = qr/`?[_\.0-9a-zA-Z]+`?/;
64              
65             our $KEY_REGEX_NOPREF = qr/`?[_0-9a-zA-Z]+`?/;
66              
67             our $NUM_RE = qr/^\s*(\d+)\s*$/;
68              
69             our $SFIELD_REGEX =
70             qr/(?:$KEY_REGEX|(?:$KEY_REGEX\.)?\*|"[^"]*"|'[^']*')/;
71              
72             our $FIELD_OP_REGEX = qr/[-\+\/\%\*,]/;
73              
74             our $FUNCTION_REGEX =
75             qr/([_a-zA-Z0-9]*
76             \(\s*(?:$SFIELD_REGEX|(?-1))
77             (?:\s*$FIELD_OP_REGEX\s*(?:$SFIELD_REGEX|(?-1)))*\s*\))/x;
78              
79             our $VALID_FIELD_REGEX =
80             qr/^(?:$SFIELD_REGEX|$FUNCTION_REGEX)$AS_REGEX?$/;
81              
82             our $VALID_GROUPORDER_REGEX =
83             qr/^[-\+]?(?:$KEY_REGEX|$FUNCTION_REGEX)$/;
84              
85             our $FIELD_REST_RE = qr/^(.+?)(:~?)([^:"~][^:"]*?)$/;
86              
87             our $CACHE_COMMENT = 'From Cache';
88              
89             our $ITEMS_PER_PAGE = 25;
90              
91             our @EXTENSIONS = ();
92              
93             # Import extension
94             sub import {
95 46     46   339 my $class = shift;
96              
97             # Load extensions
98 46         1495 foreach (@_) {
99              
100             # Load extensions
101 0         0 my $module = qq{DBIx::Oro::Extension::$_};
102 0 0       0 unless (eval "require $module; 1;") {
103 0 0       0 croak qq{Unable to load extension "$_"} and return;
104             };
105              
106             # Push to extension array
107 0         0 push(@EXTENSIONS, $_);
108              
109             # Start import for extensions
110 0         0 $module->import;
111             };
112             };
113              
114              
115             # Constructor
116             sub new {
117 27     27 1 29415 my $class = shift;
118 27         55 my ($self, %param);
119              
120             # SQLite - one parameter
121 27 100 66     346 if (@_ == 1) {
    100 66        
122 1         6 @param{qw/driver file/} = ('SQLite', shift);
123             }
124              
125             # SQLite - two parameter
126             elsif (@_ == 2 && ref $_[1] && ref $_[1] eq 'CODE') {
127 6         33 @param{qw/driver file init/} = ('SQLite', @_);
128             }
129              
130             # Hash
131             else {
132 20         92 %param = @_;
133             };
134              
135             # Init by default
136 27         48 ${$param{in_txn}} = 0;
  27         91  
137 27         73 $param{last_sql} = '';
138              
139 27         57 my $pwd = delete $param{password};
140              
141             # Set default to SQLite
142 27   100     154 $param{driver} //= 'SQLite';
143              
144             # Load driver
145 27         86 my $package = 'DBIx::Oro::Driver::' . $param{driver};
146 27 50       1842 unless (eval 'require ' . $package . '; 1;') {
147 0         0 croak 'Unable to load ' . $package;
148 0         0 return;
149             };
150              
151             # On_connect event
152 27         121 my $on_connect = delete $param{on_connect};
153              
154             # Get driver specific handle
155 27         247 $self = $package->new( %param );
156              
157             # No database created
158 27 50       97 return unless $self;
159              
160             # Connection identifier (for _password)
161 27         94 $self->{_id} = "$self";
162              
163             # Set password securely
164 27 50       86 $self->_password($pwd) if $pwd;
165              
166             # On connect events
167 27         59 $self->{on_connect} = {};
168 27         72 $self->{_connect_cb} = 1;
169              
170 27 50       87 if ($on_connect) {
171 0 0       0 $self->on_connect(
    0          
172             ref $on_connect eq 'HASH' ?
173             %$on_connect : $on_connect
174             ) or return;
175             };
176              
177             # Connect to database
178 27 50       169 $self->_connect or croak 'Unable to connect to database';
179              
180             # Savepoint array
181             # First element is a counter
182 27         107 $self->{savepoint} = [1];
183              
184             # Initialize database and return Oro instance
185 27 50       180 return $self if $self->_init;
186              
187             # Fail
188 0         0 return;
189             };
190              
191              
192             # New table object
193             sub table {
194 26     26 1 31 my $self = shift;
195              
196             # Joined table
197             my %param = (
198 26         35 table => do {
199 26 100       67 if (ref($_[0])) {
200 3         13 [ _join_tables( shift(@_) ) ];
201             }
202              
203             # Table name
204             else {
205 23         81 shift;
206             };
207             }
208             );
209              
210             # Clone parameters
211 26         71 foreach (qw/dbh created in_txn savepoint pid tid
212             dsn _connect_cb on_connect/) {
213 234         408 $param{$_} = $self->{$_};
214             };
215              
216             # Connection identifier (for _password)
217 26         81 $param{_id} = "$self";
218              
219             # Bless object with hash
220 26         98 bless \%param, ref $self;
221             };
222              
223              
224             # Database handle
225             # Based on DBIx::Connector
226             sub dbh {
227 1430     1430 1 4672 my $self = shift;
228              
229             # Store new database handle
230 1430 50       2160 return ($self->{dbh} = shift) if $_[0];
231              
232 1430 100       1082 return $self->{dbh} if ${$self->{in_txn}};
  1430         3471  
233              
234 509         537 state $c = 'Unable to connect to database';
235              
236             # Check for thread id
237 509 50 33     7493 if (defined $self->{tid} && $self->{tid} != threads->tid) {
    50          
    100          
238 0   0     0 return $self->_connect || croak $c;
239             }
240              
241             # Check for process id
242             elsif ($self->{pid} != $$) {
243 0   0     0 return $self->_connect || croak $c;
244             }
245              
246             elsif ($self->{dbh}->{Active}) {
247 506         1498 return $self->{dbh};
248             };
249              
250             # Return handle if active
251 3   33     22 return $self->_connect || croak $c;
252             };
253              
254              
255             # Last executed SQL
256             sub last_sql {
257 29     29 1 1025 my $self = shift;
258 29         57 my $last_sql = $self->{last_sql};
259              
260             # Check for recurrent placeholders
261 29 50       483 if ($last_sql =~ m/(?:UNION|\?(?:, \?){3,}|(?:\(\?(?:, \?)*\), ){3,})/) {
262              
263 0         0 our $c;
264              
265             # Count Union selects
266             state $UNION_RE =
267 0         0 qr/(?{$c=1})(SELECT \?(?:, \?)*)(?: UNION \1(?{$c++})){3,}/;
  0         0  
  0         0  
268              
269             # Count Union selects
270             state $BRACKET_RE =
271 0         0 qr/(?{$c=1})(\(\?(?:, \?)*\))(?:, \1(?{$c++})){3,}/;
  0         0  
  0         0  
272              
273             # Count recurring placeholders
274             state $PLACEHOLDER_RE =
275 0         0 qr/(?{$c=1})\?(?:, \?(?{$c++})){3,}/;
  0         0  
  0         0  
276              
277             # Rewrite placeholders with count
278 0         0 for ($last_sql) {
279 0         0 s/$UNION_RE/WITH $c x UNION $1/og;
280 0         0 s/$BRACKET_RE/$c x $1/og;
281 0         0 s/$PLACEHOLDER_RE/$c x ?/og;
282             };
283             };
284              
285 29 100 50     156 return $last_sql || '' unless wantarray;
286              
287             # Return as array
288 17 100       36 return ('', 0) unless $last_sql;
289              
290             # Check if database request
291 16         23 state $offset = -1 * length $CACHE_COMMENT;
292              
293             return (
294 16         67 $last_sql,
295             substr($last_sql, $offset) eq $CACHE_COMMENT
296             );
297             };
298              
299              
300             # Database driver
301 0     0 1 0 sub driver { '' };
302              
303              
304             # Extensions
305             sub extension {
306 0     0 0 0 return @EXTENSIONS;
307             };
308              
309              
310             # Insert values to database
311             # This is the MySQL way
312             sub insert {
313 0     0 1 0 my $self = shift;
314              
315             # Get table name
316 0 0       0 my $table = _table_name($self, \@_) or return;
317              
318             # No parameters
319 0 0       0 return unless $_[0];
320              
321             # Properties
322 0 0 0     0 my $prop = shift if ref $_[0] eq 'HASH' && ref $_[1];
323              
324             # Single insert
325 0 0       0 if (ref $_[0] eq 'HASH') {
    0          
326              
327             # Param
328 0         0 my %param = %{ shift(@_) };
  0         0  
329              
330             # Create insert arrays
331 0         0 my (@keys, @values);
332              
333 0         0 while (my ($key, $value) = each %param) {
334             # Insert pairs
335 0 0 0     0 next if !ref $key && $key !~ $DBIx::Oro::KEY_REGEX;
336 0         0 push @keys, $key;
337 0         0 push @values, _stringify($value);
338             };
339              
340             # Nothing to insert
341 0 0       0 return unless @keys;
342              
343             # Create insert string
344 0         0 my $sql = 'INSERT ';
345              
346 0 0 0     0 if ($prop && (my $oc = $prop->{-on_conflict})) {
347 0 0       0 if ($oc eq 'replace') {
    0          
348 0         0 $sql = 'REPLACE '
349             }
350             elsif ($oc eq 'ignore') {
351 0         0 $sql .= 'IGNORE '
352             };
353             };
354              
355             $sql .= 'INTO ' . $table .
356 0         0 ' (' . join(', ', map { "`$_`" } @keys) . ') VALUES (' . _q(\@values) . ')';
  0         0  
357              
358             # Prepare and execute
359 0         0 return scalar $self->prep_and_exec( $sql, \@values );
360             }
361              
362             # Multiple inserts
363             elsif (ref($_[0]) eq 'ARRAY') {
364              
365 0 0       0 return unless $_[1];
366              
367 0         0 my @keys = @{ shift(@_) };
  0         0  
368              
369             # Default values
370 0         0 my @default = ();
371              
372             # Check if keys are defaults
373 0         0 my $i = 0;
374 0         0 my @default_keys;
375 0         0 while ($keys[$i]) {
376              
377             # No default - next
378 0 0       0 $i++, next unless ref $keys[$i];
379              
380             # Has default value
381 0         0 my ($key, $value) = @{ splice( @keys, $i, 1) };
  0         0  
382 0         0 push(@default_keys, $key);
383 0         0 push(@default, _stringify($value));
384             };
385              
386             # Unshift default keys to front
387 0         0 unshift(@keys, @default_keys);
388              
389             my $sql .= 'INSERT INTO ' . $table .
390 0         0 ' (' . join(', ', map { "`$_`" } @keys) . ') ' .
  0         0  
391             'VALUES ';
392              
393             # Add data in brackets
394 0         0 $sql .= join(', ', ('(' ._q(\@keys) . ')') x scalar @_ );
395              
396             # Prepare and execute with prepended defaults
397             return $self->prep_and_exec(
398             $sql,
399 0         0 [ map { (@default, @$_); } @_ ]
  0         0  
400             );
401             };
402              
403             # Unknown query
404 0         0 return;
405             };
406              
407              
408             # Update existing values in the database
409             sub update {
410 25     25 1 74 my $self = shift;
411              
412             # Get table name
413 25 50       62 my $table = _table_name($self, \@_) or return;
414              
415             # No parameters
416 25 50       60 return unless $_[0];
417              
418             # Get pairs
419 25         55 my ($pairs, $values) = _get_pairs( shift(@_) );
420              
421             # Nothing to update
422 25 50       60 return unless @$pairs;
423              
424             # No arrays or operators allowed
425 25         55 foreach (@$pairs) {
426 26 100       427 return unless $_ =~ /^$KEY_REGEX\s+(?:=|IS\s)/o;
427             };
428              
429             # Set undef to pairs
430 24         44 my @pairs = map { $_ =~ s{ IS NULL$}{ = NULL}io; $_ } @$pairs;
  24         80  
  24         69  
431              
432             # Generate sql
433 24         71 my $sql = 'UPDATE ' . $table . ' SET ' . join(', ', @pairs);
434              
435             # Condition
436 24 50       58 if ($_[0]) {
437 24         57 my ($cond_pairs, $cond_values) = _get_pairs( shift(@_) );
438              
439             # No conditions given
440 24 50       64 if (@$cond_pairs) {
441              
442             # Append condition
443 24         63 $sql .= ' WHERE ' . join(' AND ', @$cond_pairs);
444              
445             # Append values
446 24         56 push(@$values, @$cond_values);
447             };
448             };
449              
450             # Prepare and execute
451 24         57 my $rv = $self->prep_and_exec($sql, $values);
452              
453             # Return value
454 24 100 100     225 return (!$rv || $rv eq '0E0') ? 0 : $rv;
455             };
456              
457              
458             # Select from table
459             sub select {
460 124     124 1 26074 my $self = shift;
461              
462             # Get table object
463 124         376 my ($tables,
464             $fields,
465             $join_pairs,
466             $treatment,
467             $field_alias) = _table_obj($self, \@_);
468              
469 124         419 my @pairs = @$join_pairs;
470              
471             # Fields to select
472 124 100 100     691 if ($_[0] && ref($_[0]) eq 'ARRAY') {
473              
474             # Not allowed for join selects
475 37 50       107 return if $fields->[0];
476              
477 37         124 ($fields, $treatment) = _fields($tables->[0], shift(@_) );
478              
479 37         109 $fields = [ $fields ];
480             };
481              
482             # Default
483 124   100     453 $fields->[0] ||= '*';
484              
485             # Create sql query
486 124         407 my $sql = join(', ', @$fields) . ' FROM ' . join(', ', @$tables);
487              
488             # Append condition
489 124         132 my @values;
490              
491 124         118 my ($cond, $prep);
492 124 100 66     730 if (($_[0] && ref($_[0]) eq 'HASH') || @$join_pairs) {
      66        
493              
494             # Condition
495 103         98 my ($pairs, $values);
496 103 50 33     468 if ($_[0] && ref($_[0]) eq 'HASH') {
497 103         276 ($pairs, $values, $prep) = _get_pairs( shift(@_), $field_alias);
498              
499 103         179 push(@values, @$values);
500              
501             # Add to pairs
502 103 100       288 push(@pairs, @$pairs) if $pairs->[0];
503             };
504              
505             # Add where clause
506 103 100       353 $sql .= ' WHERE ' . join(' AND ', @pairs) if @pairs;
507              
508             # Add distinct information
509 103 100       236 if ($prep) {
510 62 100       180 $sql = 'DISTINCT ' . $sql if delete $prep->{'distinct'};
511              
512             # Apply restrictions
513 62         209 $sql .= _restrictions($prep, \@values);
514             };
515             };
516              
517 124         139 my $result;
518              
519             # Check cache
520 124         206 my ($chi, $key, $chi_param);
521 124 50 66     394 if ($prep && $prep->{cache}) {
522              
523             # Cache parameters
524 0         0 ($chi, $key, $chi_param) = @{delete $prep->{cache}};
  0         0  
525              
526             # Generate key
527 0 0       0 $key = 'SELECT ' . $sql . '-' . join('-', @values) unless $key;
528              
529             # Get cache result
530 0         0 $result = $chi->get($key);
531             };
532              
533             # Unknown restrictions
534 124 100       302 if (scalar keys %$prep) {
535 1         155 carp 'Unknown restriction option: ' . join(', ', keys %$prep);
536             };
537              
538 124         128 my ($rv, $sth);
539              
540             # Result was not cached
541 124 50       231 unless ($result) {
542              
543             # Prepare and execute
544 124         503 ($rv, $sth) = $self->prep_and_exec('SELECT ' . $sql, \@values);
545              
546             # No statement created
547 124 100       374 return unless $sth;
548             }
549              
550             else {
551             # Last sql command
552 0         0 $self->{last_sql} = 'SELECT ' . $sql . ' -- ' . $CACHE_COMMENT;
553             };
554              
555             # Prepare treatments
556 122         140 my (@treatment, %treatsub);
557 122 100       236 if ($treatment) {
558 7         28 @treatment = keys %$treatment;
559 7         17 foreach (@treatment) {
560 7         8 $treatsub{$_} = shift(@{$treatment->{$_}});
  7         30  
561             };
562             };
563              
564             # Release callback
565 122 0 33     316 if ($_[0] && ref $_[0] && ref $_[0] eq 'CODE' ) {
      33        
566 0         0 my $cb = shift;
567              
568 0         0 carp 'Calling select with an iteration callback is deprecated since v0.31';
569              
570             # Iterate through dbi result
571 0         0 my ($i, $row) = (0);
572 0 0       0 while ($row = $sth ? $sth->fetchrow_hashref : $result->[$i]) {
573              
574             # Iterate for cache result
575 0 0 0     0 push(@$result, $row) if $chi && $sth;
576              
577             # Increment for cached results
578 0         0 $i++;
579              
580             # Treat result
581 0 0       0 if ($treatment) {
582              
583             # Treat each treatable row value
584 0         0 foreach ( grep { exists $row->{$_} } @treatment) {
  0         0  
585             $row->{$_} = $treatsub{$_}->(
586 0         0 $row->{$_}, @{ $treatment->{$_} }
  0         0  
587             );
588             };
589             };
590              
591             # Finish if callback returns -1
592 0         0 local $_ = $row;
593 0         0 my $rv = $cb->($row);
594 0 0 0     0 if ($rv && $rv eq '-1') {
595 0         0 $result = undef;
596 0         0 last;
597             };
598             };
599              
600             # Save to cache
601 0 0 0     0 if ($sth && $chi && $result) {
      0        
602 0         0 $chi->set($key => $result, $chi_param);
603             };
604              
605             # Came from cache
606 0 0 0     0 return if !$sth && $chi;
607              
608             # Finish statement
609 0         0 $sth->finish;
610 0         0 return;
611             };
612              
613             # Create array ref
614 122 50       242 unless ($result) {
615 122         1080 $result = $sth->fetchall_arrayref({});
616              
617             # Save to stash
618 122 50 33     21047 if ($chi && $result) {
619 0         0 $chi->set($key => $result, $chi_param);
620             };
621             };
622              
623             # Return array ref
624 122 100       2076 return $result unless $treatment;
625              
626             # Treat each row
627 7         19 foreach my $row (@$result) {
628              
629             # Treat each treatable row value
630 11         18 foreach (@treatment) {
631             $row->{$_} = $treatsub{$_}->(
632 11         47 $row->{$_}, @{$treatment->{$_}}
633 11 50       34 ) if $row->{$_};
634             };
635             };
636              
637             # Return result
638 7         180 $result;
639             };
640              
641              
642             # List elements
643             sub list {
644 21     21 1 86239 my $self = shift;
645              
646             # Get callback
647 21 100 66     167 my $cb = pop if ref $_[-1] && ref $_[-1] eq 'CODE';
648              
649             # Get param hash reference
650 21 50 33     108 my $param = pop if ref $_[-1] && ref $_[-1] eq 'HASH';
651              
652             # Get table object
653 21 100       90 $self = $self->table( @_ ) if $_[0];
654              
655 21         24 my (%condition, %pagination);
656              
657             # Check numerical values
658 21   100     51 my $start_index = _check_param($param, 'startIndex', 'num') // 0;
659 21         33 my $count = _check_param($param, 'count', 'num');
660 21   100     38 my $start_page = _check_param($param, 'startPage', 'num') // 1;
661              
662             # Set caching condition
663 21 50       62 $condition{-cache} = delete $param->{-cache} if $param->{-cache};
664              
665             ### Sorting parameters
666 21         24 my %sort;
667              
668             # Check, if parameter is a field
669 21         30 my $sort_by = _check_param($param, 'sortBy');
670 21 50 33     355 if ($sort_by && $sort_by =~ s/^\s*($KEY_REGEX)\s*$/$1/) {
671              
672 21   100     82 $param->{sortOrder} //= 'ascending';
673 21 100       82 my $sort_order = index(lc($param->{sortOrder}), 'desc') == 0 ? 'descending' : undef;
674              
675             # Set SQL limitation
676 21 100       86 $pagination{-order} = $sort_order ? "-$sort_by" : $sort_by;
677              
678             # Set sort information
679 21         37 $sort{sortBy} = $sort_by;
680 21 100       63 $sort{sortOrder} = $sort_order if $sort_order;
681             };
682              
683             # Set SQL limitations
684 21         66 $pagination{-offset} = $start_index;
685 21   66     66 $pagination{-limit} = $count || $ITEMS_PER_PAGE;
686              
687             # Not first page
688 21 100       52 if ($start_page > 1) {
689              
690             # Set SQL limitations
691 2   50     7 $pagination{-offset} //= 0;
692 2         6 $pagination{-offset} += (($start_page - 1) * $pagination{-limit});
693             };
694              
695              
696             ### Filter parameters
697 21         51 my %filter;
698              
699             # Filter parameter is set
700 21         39 my $filter_by = _check_param($param, 'filterBy');
701 21 50       48 if ($filter_by) {
702              
703             # Filter operation is set
704 21         35 my $filter_op = _check_param($param, 'filterOp');
705 21 50       42 if ($filter_op) {
706 21         29 $filter_op = lc $filter_op;
707              
708             # Set parameters for response
709 21         35 $filter{filterBy} = $filter_by;
710 21         27 $filter{filterOp} = $filter_op;
711              
712             # Check for presence
713 21 100       53 if ($filter_op eq 'present') {
    100          
714              
715             # Create SQL condition
716 4         20 $condition{$filter_by} = { not => undef };
717             }
718              
719             # Check for absence
720             elsif ($filter_op eq 'absent') {
721              
722             # Create SQL condition
723 1         4 $condition{$filter_by} = undef;
724             }
725              
726             # Check with filterValue
727             else {
728              
729             # Get filterValue
730 16 50       30 if (my $fv = _check_param($param, 'filterValue')) {
731              
732             # Set filter value for response
733 16         26 $filter{filterValue} = $fv;
734              
735             # Check for equality
736 16 100       45 if ($filter_op eq 'equals') {
    100          
737              
738             # Equals the value
739 1         4 $condition{$filter_by} = $fv;
740             }
741              
742             # Check for disparaty
743             elsif ($filter_op eq 'disparate') {
744              
745             # Equals the value
746 1         5 $condition{$filter_by} = { ne => $fv };
747             }
748              
749             # Check with SQL like
750             else {
751 14         28 $fv =~ s/([\%_])/\\$1/g;
752              
753             # Check for containing
754 14 100       41 if ($filter_op eq 'contains') {
    50          
755 1         6 $condition{$filter_by} = { like => "%${fv}%" };
756             }
757              
758             # Check for beginning
759             elsif ($filter_op eq 'startswith') {
760              
761             # Set response operation
762 13         18 $filter{filterOp} = 'startsWith';
763 13         85 $condition{$filter_by} = { like => "${fv}%" };
764             };
765             };
766             }
767              
768             # No filterValue - reset
769             else {
770 0         0 %filter = ();
771             };
772             };
773             };
774             };
775              
776             # Get count
777 21         79 my $total_results = $self->count(\%condition);
778              
779             # Something went wrong
780 21 100       65 return unless defined $total_results;
781              
782             # Check fields
783 20         21 my @fields;
784 20 100       48 if ($param->{fields}) {
785              
786             # Fields is a reference
787 5 100       16 if (ref $param->{fields}) {
788 1         2 @fields = @{ $param->{fields} };
  1         4  
789             }
790              
791             # Fields is a string
792             else {
793             @fields =
794 9         68 grep { /^$KEY_REGEX$/ }
795 9         15 map { s/\s//g; $_ }
  9         65  
796 4         33 split /\s*,\s*/, $param->{fields};
797             };
798             };
799              
800 20         19 my $entry;
801              
802             # More than one result
803 20 50       36 if ($total_results) {
804              
805             # Table is joined and there are fields existing
806 20 100 66     95 if (ref $self->{table} && @fields) {
    100          
807              
808             # Is a joined table, filter fields afterwards
809 2         14 my $select = $self->select({ %condition, %pagination });
810              
811             # Iterate for filtering
812 2         7 foreach my $row (@$select) {
813              
814             # Filter
815 12         10 my %new;
816 12         13 foreach (@fields) {
817 36 50       77 $new{$_} = $row->{$_} if exists $row->{$_};
818             };
819 12         18 push(@$entry, \%new);
820             };
821              
822             # Define fields
823 2         15 $filter{fields} = \@fields;
824             }
825              
826             # Fields in simple table
827             elsif (@fields) {
828             # Just prepend field to select
829 3         4 $filter{fields} = \@fields;
830 3         18 $entry = $self->select(\@fields, { %condition, %pagination });
831             }
832              
833             # No fields
834             else {
835 15         109 $entry = $self->select({ %condition, %pagination });
836             };
837              
838             # Use callback for each entry
839 20 100 66     76 if ($cb && @$entry) {
840 1         2 my @entry_cb;
841 1         8 push( @entry_cb, $cb->($_) ) foreach @$entry;
842 1         47 $entry = \@entry_cb;
843             };
844             };
845              
846             # Return response
847             {
848             totalResults => $total_results,
849             startIndex => $start_index,
850             itemsPerPage => $pagination{-limit},
851 20   50     308 startPage => $start_page,
852             entry => $entry || [],
853             %filter,
854             %sort
855             };
856             };
857              
858              
859             # Load one line
860             sub load {
861 29     29 1 84 my $self = shift;
862 29         75 my @param = @_;
863              
864             # Has a condition
865 29 50 33     208 if ($param[-1] && ref($param[-1])) {
866              
867             # Add limitation to the condition
868 29 100       109 if (ref($param[-1]) eq 'HASH') {
    50          
869 24         90 $param[-1]->{-limit} = 1;
870             }
871              
872             # Load is malformed
873             elsif (ref($param[-1]) ne 'ARRAY') {
874 0         0 carp 'Load is malformed';
875 0         0 return;
876             };
877             }
878              
879             # Has no condition yet
880             else {
881 0         0 push(@param, { -limit => 1 });
882             };
883              
884             # Select with limit
885 29         110 my $row = $self->select(@param);
886              
887             # Error or not found
888 29 100       79 return unless $row;
889              
890             # Return row
891 28         174 $row->[0];
892             };
893              
894              
895             # Delete entry
896             sub delete {
897 11     11 1 18 my $self = shift;
898              
899             # Get table name
900 11 50       37 my $table = _table_name($self, \@_) or return;
901              
902             # Build sql
903 11         32 my $sql = 'DELETE FROM ' . $table;
904              
905             # Condition
906 11         25 my ($pairs, $values, $prep, $secure);
907 11 100       28 if ($_[0]) {
908              
909             # Add condition
910 5         13 ($pairs, $values, $prep) = _get_pairs( shift(@_) );
911              
912             # Add where clause to sql
913 5 50 33     32 $sql .= ' WHERE ' . join(' AND ', @$pairs) if @$pairs || $prep;
914              
915             # Apply restrictions
916 5 50       14 $sql .= _restrictions($prep, $values) if $prep;
917             };
918              
919             # Prepare and execute deletion
920 11         29 my $rv = $self->prep_and_exec($sql, $values);
921              
922             # Return value
923 11 100 66     107 return (!$rv || $rv eq '0E0') ? 0 : $rv;
924             };
925              
926              
927             # Update or insert a value
928             sub merge {
929 10     10 1 12 my $self = shift;
930              
931             # Get table name
932 10 50       25 my $table = _table_name($self, \@_) or return;
933              
934 10         15 my %param = %{ shift( @_ ) };
  10         35  
935 10 50       25 my %cond = $_[0] ? %{ shift( @_ ) } : ();
  10         26  
936              
937             # Prefix with table if necessary
938 10         20 my @param = ( \%param, \%cond );
939 10 100       42 unshift(@param, $table) unless $self->{table};
940              
941 10         14 my $rv;
942 10         9 my $job = 'update';
943             $self->txn(
944             sub {
945              
946             # Update
947 10     10   32 $rv = $self->update( @param );
948              
949 10 100       31 return 1 if $rv;
950              
951             # Delete all element conditions
952 5         16 delete $cond{$_} foreach grep {
953 6 100       36 ref($cond{$_}) && !blessed($cond{$_})
954             } keys %cond;
955              
956             # Insert
957 5         20 @param = ( { %param, %cond } );
958 5 50       25 unshift(@param, $table) unless $self->{table};
959              
960 5 100       18 $rv = $self->insert(@param) or return -1;
961              
962 4         9 $job = 'insert';
963              
964 4         6 return;
965 10 100       76 }) or return;
966              
967             # Return value is bigger than 0
968 9 50 33     97 if ($rv && $rv > 0) {
969 9 50       55 return wantarray ? ($rv, $job) : $rv;
970             };
971              
972 0         0 return;
973             };
974              
975              
976             # Count results
977             sub count {
978 52     52 1 888 my $self = shift;
979              
980             # Init arrays
981 52         154 my ($tables, $fields, $join_pairs, $treatment, $field_alias) =
982             _table_obj($self, \@_);
983              
984 52         103 my @pairs = @$join_pairs;
985              
986             # Build sql
987 52         183 my $sql =
988             'SELECT ' . join(', ', 'count(1)', @$fields) .
989             ' FROM ' . join(', ', @$tables);
990              
991             # Ignore fields
992 52 100 100     220 shift if $_[0] && ref $_[0] eq 'ARRAY';
993              
994             # Get conditions
995 52         57 my ($pairs, $values, $prep);
996 52 100 66     215 if ($_[0] && ref $_[0] eq 'HASH') {
997 30         99 ($pairs, $values, $prep) = _get_pairs( shift(@_), $field_alias );
998 30 50       106 push(@pairs, @$pairs) if $pairs->[0];
999             };
1000              
1001             # Add where clause
1002 52 100       177 $sql .= ' WHERE ' . join(' AND ', @pairs) if @pairs;
1003 52         144 $sql .= ' LIMIT 1';
1004              
1005 52         52 my $result;
1006              
1007             # Check cache
1008 52         52 my ($chi, $key, $chi_param);
1009 52 0 33     97 if ($prep && $prep->{cache}) {
1010              
1011             # Cache parameters
1012 0         0 ($chi, $key, $chi_param) = @{$prep->{cache}};
  0         0  
1013              
1014             # Generate key
1015 0 0       0 $key = $sql . '-' . join('-', @$values) unless $key;
1016              
1017             # Get cache result
1018 0 0       0 if ($result = $chi->get($key)) {
1019              
1020             # Last sql command
1021 0         0 $self->{last_sql} = $sql . ' -- ' . $CACHE_COMMENT;
1022              
1023             # Return cache result
1024 0         0 return $result;
1025             };
1026             };
1027              
1028             # Prepare and execute
1029 52   100     255 my ($rv, $sth) = $self->prep_and_exec($sql, $values || []);
1030              
1031             # Return value is empty
1032 52 100       142 return undef if !$rv;
1033              
1034             # Return count
1035 49   100     489 $result = $sth->fetchrow_arrayref->[0] || 0;
1036 49         167 $sth->finish;
1037              
1038             # Save to cache
1039 49 50 33     116 $chi->set($key => $result, $chi_param) if $chi && $result;
1040              
1041             # Return result
1042 49         674 $result;
1043             };
1044              
1045              
1046             # Prepare and execute
1047             sub prep_and_exec {
1048 1188     1188 1 1476 my ($self, $sql, $values, $cached) = @_;
1049 1188         1821 my $dbh = $self->dbh;
1050              
1051             # Last sql command
1052 1188         1744 $self->{last_sql} = $sql;
1053              
1054             # Prepare
1055 1188 50       5398 my $sth =
1056             $cached ? $dbh->prepare_cached( $sql ) :
1057             $dbh->prepare( $sql );
1058              
1059             # Check for errors
1060 1188 100       82537 if ($dbh->err) {
1061              
1062 11 50       78 if (index($dbh->errstr, 'database') <= 0) {
1063 11         57 carp $dbh->errstr . ' in "' . _trim_last_sql($self->last_sql) . '"';
1064 11         493 return;
1065             };
1066              
1067             # Retry with reconnect
1068 0         0 $dbh = $self->_connect;
1069              
1070 0 0       0 $sth =
1071             $cached ? $dbh->prepare_cached( $sql ) :
1072             $dbh->prepare( $sql );
1073              
1074 0 0       0 if ($dbh->err) {
1075 0         0 carp $dbh->errstr . ' in "' . _trim_last_sql($self->last_sql) . '"';
1076 0         0 return;
1077             };
1078             };
1079              
1080             # No statement handle established
1081 1177 50       2142 return unless $sth;
1082              
1083             # Execute
1084 1177         3255626 my $rv = $sth->execute( @$values );
1085              
1086             # Check for errors
1087 1177 100       5403 if ($dbh->err) {
1088 4         52 carp $dbh->errstr . ' in "' . _trim_last_sql($self->last_sql) . '"';
1089 4         182 return;
1090             };
1091              
1092             # Return value and statement
1093 1173 100       2502 return ($rv, $sth) if wantarray;
1094              
1095             # Finish statement
1096 971         1807 $sth->finish;
1097              
1098             # Return value
1099 971         10313 $rv;
1100             };
1101              
1102              
1103             # Wrapper for DBI do
1104             sub do {
1105 126     126 1 13978 $_[0]->{last_sql} = $_[1];
1106              
1107             # Database connection
1108 126         261 my $dbh = shift->dbh;
1109              
1110 126         644 my $rv = $dbh->do( @_ );
1111              
1112             # Error
1113 126 50 33     23634 carp $dbh->errstr . ' in "' . $_[0] . '"' if !$rv && $dbh->err;
1114 126         325 return $rv;
1115             };
1116              
1117              
1118             # Explain query plan
1119             sub explain {
1120 0     0 1 0 'Not implemented for ' . $_[0]->driver;
1121             };
1122              
1123              
1124             # Wrap a transaction
1125             sub txn {
1126 69     69 1 18934 my $self = shift;
1127              
1128             # No callback defined
1129 69 50 33     507 return unless $_[0] && ref($_[0]) eq 'CODE';
1130              
1131 69         230 my $dbh = $self->dbh;
1132              
1133             # Outside transaction
1134 69 100       507 if ($dbh->{AutoCommit}) {
1135              
1136             # Start new transaction
1137 67         452 $dbh->begin_work;
1138              
1139 67         1209 ${$self->{in_txn}} = 1;
  67         159  
1140              
1141             # start
1142 67         106 local $_ = $self;
1143 67         172 my $rv = $_[0]->($self);
1144 67 100 100     1801 if (!$rv || $rv ne '-1') {
1145 65         90 ${$self->{in_txn}} = 0;
  65         145  
1146 65         28106338 $dbh->commit;
1147 65         257 return 1;
1148             };
1149              
1150             # Rollback
1151 2         5 ${$self->{in_txn}} = 0;
  2         6  
1152 2         32 $dbh->rollback;
1153 2         10 return;
1154             }
1155              
1156             # Inside transaction
1157             else {
1158 2         3 ${$self->{in_txn}} = 1;
  2         5  
1159              
1160             # Push savepoint on stack
1161 2         4 my $sp_array = $self->{savepoint};
1162              
1163             # Use PID for concurrent accesses
1164 2         8 my $sp = "orosp_${$}_";
1165              
1166             # Use TID for concurrent accesses
1167 2 50       7 $sp .= threads->tid . '_' if $self->{tid};
1168              
1169 2         5 $sp .= $sp_array->[0]++;
1170              
1171             # Push new savepoint to array
1172 2         4 push(@$sp_array, $sp);
1173              
1174             # Start transaction
1175 2         8 $self->do("SAVEPOINT $sp");
1176              
1177             # Run wrap actions
1178 2         7 my $rv = $_[0]->($self);
1179              
1180             # Pop savepoint from stack
1181 2         12 my $last_sp = pop(@$sp_array);
1182 2 50       7 if ($last_sp eq $sp) {
1183 2         5 $sp_array->[0]--;
1184             }
1185              
1186             # Last savepoint does not match
1187             else {
1188 0         0 carp "Savepoint $sp is not the last savepoint on stack";
1189             };
1190              
1191             # Commit savepoint
1192 2 100 66     15 if (!$rv || $rv ne '-1') {
1193 1         5 $self->do("RELEASE SAVEPOINT $sp");
1194 1         6 return 1;
1195             };
1196              
1197             # Rollback
1198 1         7 $self->do("ROLLBACK TO SAVEPOINT $sp");
1199 1         9 return;
1200             };
1201             };
1202              
1203              
1204             # Add connect event
1205             sub on_connect {
1206 3     3 1 6 my $self = shift;
1207 3         5 my $cb = pop;
1208              
1209             # Parameter is no subroutine
1210 3 50 33     23 return unless ref $cb && ref $cb eq 'CODE';
1211              
1212 3   66     14 my $name = shift || '_cb_' . $self->{_connect_cb}++;
1213              
1214             # Push subroutines on_connect
1215 3 100       12 unless (exists $self->{on_connect}->{$name}) {
1216 2         4 $self->{on_connect}->{$name} = $cb;
1217 2         9 return 1;
1218             };
1219              
1220             # Event was not newly established
1221 1         4 return;
1222             };
1223              
1224              
1225             # Wrapper for DBI last_insert_id
1226             sub last_insert_id {
1227 0     0 1 0 my $dbh = shift->dbh;
1228 0 0       0 @_ = (undef) x 4 unless @_;
1229 0         0 $dbh->last_insert_id(@_);
1230             };
1231              
1232              
1233             # Import files
1234             sub import_sql {
1235 0     0 0 0 my $self = shift;
1236              
1237 0         0 carp 'import_sql is deprecated and will be deleted in further versions';
1238              
1239             # Get callback
1240 0 0 0     0 my $cb = pop @_ if ref $_[-1] && ref $_[-1] eq 'CODE';
1241              
1242 0 0       0 my $files = @_ > 1 ? \@_ : shift;
1243              
1244 0 0       0 return unless $files;
1245              
1246             # Import subroutine
1247             my $import = sub {
1248 0     0   0 my $file = shift;
1249              
1250             # No file given
1251 0 0       0 return unless $file;
1252              
1253 0 0       0 if (open(SQL, '<:utf8', $file)) {
1254 0         0 my @sql = split(/^--\s-.*?$/m, join('', ));
1255 0         0 close(SQL);
1256              
1257             # Start transaction
1258             return $self->txn(
1259             sub {
1260 0         0 my ($sql, @sql_seq);;
1261 0         0 foreach $sql (@sql) {
1262 0         0 $sql =~ s/^(?:--.*?|\s*)?$//mg;
1263 0         0 $sql =~ s/\n\n+/\n/sg;
1264              
1265             # Use callback
1266 0 0 0     0 @sql_seq = $cb->($sql) if $cb && $sql;
1267              
1268 0 0       0 next unless $sql;
1269              
1270             # Start import
1271 0         0 foreach (@sql_seq) {
1272 0 0       0 $self->do($_) or return -1;
1273             };
1274             };
1275             }
1276 0         0 );
1277             }
1278              
1279             # Unable to read SQL file
1280             else {
1281 0         0 carp "Unable to import file '$file'";
1282 0         0 return;
1283             };
1284 0         0 };
1285              
1286             # Multiple file import
1287 0 0       0 if (ref $files) {
1288             return $self->txn(
1289             sub {
1290 0     0   0 foreach (@$files) {
1291 0 0       0 $import->($_) or return -1;
1292             };
1293 0         0 });
1294             };
1295              
1296             # Single file import
1297 0         0 return $import->($files);
1298             };
1299              
1300              
1301             # Disconnect on destroy
1302             sub DESTROY {
1303 36     36   9233 my $self = shift;
1304              
1305             # Check if table is parent
1306 36 100       123 unless (exists $self->{table}) {
1307              
1308             # No database connection
1309 10 50       102 return $self unless $self->{dbh};
1310              
1311             # Delete password
1312 10         46 $self->_password(0);
1313              
1314             # Delete cached kids
1315 10 50       79 if (blessed $self->{dbh}) {
1316 10         54 local $SIG{__WARN__} = \&_no_warn;
1317 10         104 my $kids = $self->{dbh}->{CachedKids};
1318 10 50       54 %$kids = () if $kids;
1319             };
1320              
1321             # Disconnect
1322             # $self->{dbh}->disconnect unless $self->{dbh}->{Kids};
1323 10         607 $self->{dbh}->disconnect;
1324              
1325             # Delete parameters
1326 10         498 delete $self->{$_} foreach qw/dbh on_connect _connect_cb/;
1327             };
1328              
1329             # Return object
1330 36         535 $self;
1331             };
1332              
1333              
1334             # Initialize database
1335 0     0   0 sub _init { 1 };
1336              
1337              
1338             # Connect with database
1339             sub _connect {
1340 30     30   52 my $self = shift;
1341              
1342 30 50       110 croak 'No database given' unless $self->{dsn};
1343              
1344             # DBI Connect
1345             my $dbh = DBI->connect(
1346             $self->{dsn},
1347             $self->{user} // undef,
1348 30   50     288 $self->_password,
1349             {
1350             PrintError => 0,
1351             RaiseError => 0,
1352             AutoCommit => 1,
1353             @_
1354             });
1355              
1356             # Unable to connect to database
1357 30 50 0     260833 carp $DBI::errstr and return unless $dbh;
1358              
1359             # Store database handle
1360 30         97 $self->{dbh} = $dbh;
1361              
1362             # Save process id
1363 30         230 $self->{pid} = $$;
1364              
1365             # Save thread id
1366 30 50       131 $self->{tid} = threads->tid if $INC{'threads.pm'};
1367              
1368             # Emit all on_connect events
1369 30         58 foreach (values %{ $self->{on_connect} }) {
  30         193  
1370 2         444 $_->( $self, $dbh );
1371             };
1372              
1373             # Return handle
1374 30         550 $dbh;
1375             };
1376              
1377              
1378             # Password closure should prevent accidentally overt passwords
1379             {
1380             # Password hash
1381             my %pwd;
1382              
1383             # Password method
1384             sub _password {
1385 40     40   90 my $id = shift->{_id};
1386 40         55 my $pwd_set = shift;
1387              
1388 40         316 my ($this) = caller(0);
1389              
1390             # Request only allowed in this namespace
1391 40 50       193 return if index(__PACKAGE__, $this) != 0;
1392              
1393             # Return password
1394 40 100       119 unless (defined $pwd_set) {
1395 30         391 return $pwd{$id};
1396             }
1397              
1398             # Delete password
1399 10 50       38 unless ($pwd_set) {
1400 10         27 delete $pwd{$id};
1401             }
1402              
1403             # Set password
1404             else {
1405              
1406             # Password can only be set on construction
1407 0         0 for ((caller(1))[3]) {
1408 0 0       0 m/::new$/o or return;
1409 0 0       0 index($_, __PACKAGE__) == 0 or return;
1410 0 0       0 !$pwd{$id} or return;
1411 0         0 $pwd{$id} = $pwd_set;
1412             };
1413             };
1414             };
1415             };
1416              
1417              
1418             # Get table name
1419             sub _table_name {
1420 984     984   797 my $self = shift;
1421              
1422             # Table name
1423 984         743 my $table;
1424 984 100       1693 unless (exists $self->{table}) {
1425 966 50       1847 return shift(@{ $_[0] }) unless ref $_[0]->[0];
  966         3001  
1426             }
1427              
1428             # Table object
1429             else {
1430              
1431             # Join table object not allowed
1432 18 50       118 return $self->{table} unless ref $self->{table};
1433             };
1434              
1435 0         0 return;
1436             };
1437              
1438              
1439             # Get table object
1440             sub _table_obj {
1441 176     176   187 my $self = shift;
1442              
1443 176         168 my $tables;
1444 176         287 my ($fields, $pairs) = ([], []);
1445              
1446             # Not a table object
1447 176 100       418 unless (exists $self->{table}) {
1448              
1449 123         121 my $table = shift( @{ shift @_ } );
  123         249  
1450              
1451             # Table name as a string
1452 123 100       255 unless (ref $table) {
1453 113         214 $tables = [ $table ];
1454             }
1455              
1456             # Joined tables
1457             else {
1458 10         29 return _join_tables( $table );
1459             };
1460             }
1461              
1462             # A table object
1463             else {
1464              
1465             # joined table
1466 53 100       83 if (ref $self->{table}) {
1467 8         9 return @{ $self->{table} };
  8         24  
1468             }
1469              
1470             # Table name
1471             else {
1472 45         82 $tables = [ $self->{table} ];
1473             };
1474             };
1475              
1476 158         340 return ($tables, $fields, $pairs);
1477             };
1478              
1479              
1480             # Join tables
1481             sub _join_tables {
1482 13     13   15 my @join = @{ shift @_ };
  13         47  
1483              
1484 13         20 my (@tables, @fields, @pairs, $treatment);
1485 0         0 my %field_alias;
1486 0         0 my %marker;
1487              
1488             # Parse table array
1489 13         40 while (@join) {
1490              
1491             # Table name
1492 26         35 my $table = shift @join;
1493              
1494             # Check table name
1495 26 100       91 my $t_alias = $2 if $table =~ s/^([^:]+?):([^:]+?)$/$1 $2/o;
1496              
1497             # Push table
1498 26         42 push(@tables, $table);
1499              
1500             # Set prefix
1501 26 100       51 my $prefix = $t_alias ? $t_alias : $table;
1502              
1503 26 50       67 if (my $ref = ref $join[0]) {
1504              
1505             # Remember aliases
1506 26         29 my %alias;
1507              
1508             # Field array
1509 26 100       57 if ($ref eq 'ARRAY') {
1510              
1511 22         26 my $field_array = shift @join;
1512              
1513 22         28 my $f_prefix = '';
1514              
1515             # Has a hash next to it
1516 22 50 33     110 if (ref $join[0] && ref $join[0] eq 'HASH') {
1517              
1518             # Set Prefix if given
1519             # Todo: Is this documented?
1520 22 100       71 if (exists $join[0]->{-prefix}) {
1521 1         5 $f_prefix = delete $join[0]->{-prefix};
1522 1 50       7 $f_prefix = _clean_alias($prefix) . '_' if $f_prefix eq '*';
1523             };
1524             };
1525              
1526             # Reformat field values
1527             my $reformat = [
1528             map {
1529              
1530             # Is a reference
1531 22 50       39 unless (ref $_) {
  33         60  
1532              
1533             # Set alias semi explicitely
1534 33 100       173 if (index($_, ':') == -1) {
1535 24         63 $_ .= ':~' . $f_prefix . _clean_alias($_);
1536             };
1537              
1538             # Field is not a function
1539 33 100       70 if (index($_, '(') == -1) {
1540 32 100       95 $_ = "$prefix.$_" if index($_, '.') == -1;
1541             }
1542              
1543             # Field is a function
1544             else {
1545 1         72 s/((?:\(|$FIELD_OP_REGEX)\s*)($KEY_REGEX_NOPREF)
1546             (\s*(?:$FIELD_OP_REGEX|\)))/$1$prefix\.$2$3/ogx;
1547             };
1548              
1549             };
1550              
1551 33         67 $_;
1552             } @$field_array
1553             ];
1554              
1555             # Automatically prepend table and, if not given, alias
1556 22         56 (my $fields, $treatment, my $alias) = _fields($t_alias, $reformat);
1557              
1558             # Set alias for markers
1559             # $alias{$_} = 1 foreach keys %$alias;
1560 22         95 while (my ($key, $val) = each %$alias) {
1561 33         116 $field_alias{$key} = $alias{$key} = $val ;
1562             };
1563              
1564             # TODO: only use alias if necessary, as they can't be used in WHERE!
1565              
1566 22 100       83 push(@fields, $fields) if $fields;
1567             }
1568              
1569             # Add prepended *
1570             else {
1571 4         11 push(@fields, "$prefix.*");
1572             };
1573              
1574             # Marker hash reference
1575 26 50 33     138 if (ref $join[0] && ref $join[0] eq 'HASH') {
1576 26         90 my $hash = shift @join;
1577              
1578             # Add database fields to marker hash
1579 26         98 while (my ($key, $value) = each %$hash) {
1580              
1581             # TODO: Does this work?
1582 26 50       52 unless ($alias{$key}) {
1583 26 50       172 $key = "$prefix.$key" if $key =~ $KEY_REGEX_NOPREF;
1584             }
1585             else {
1586 0         0 $key = $alias{$key};
1587             };
1588              
1589             # Prefix, if not an explicite alias
1590 26 100       63 foreach (ref $value ? @$value : $value) {
1591              
1592 28   100     114 my $array = ($marker{$_} //= []);
1593 28         145 push(@$array, $key);
1594             };
1595             };
1596             };
1597             };
1598             };
1599              
1600             # Create condition pairs based on markers
1601 13         20 my ($ind, $fields);
1602 13         57 while (($ind, $fields) = each %marker) {
1603 14         23 my $field = shift(@$fields);
1604 14         26 foreach (@$fields) {
1605 14 100       92 push(
1606             @pairs,
1607             "$field " . ($ind < 0 ? '!' : '') . "= $_"
1608             );
1609             };
1610             };
1611              
1612             # Return join initialised values
1613 13         70 return (\@tables, \@fields, \@pairs, $treatment, \%field_alias);
1614             };
1615              
1616              
1617             # Get pairs and values
1618             sub _get_pairs {
1619 196     196   187 my (@pairs, @values, %prep);
1620              
1621             # Get alias for fields
1622 196 100       415 my $alias = @_ == 2 ? pop @_ : {};
1623              
1624 196         205 while (my ($key, $value) = each %{ $_[0] }) {
  501         1749  
1625              
1626             # Not a valid key
1627 305 50       1964 unless ($key =~ m/^-?$KEY_REGEX$/o) {
1628 0 0       0 carp "$key is not a valid Oro key" and next;
1629             };
1630              
1631             # Normal key
1632 305 100       647 if (substr($key, 0, 1) ne '-') {
1633              
1634             # Get alias
1635 194 100       767 $key = exists $alias->{$key} ? $alias->{$key} : (index($key, '.') >= 0 ? $key : '`' . $key . '`');
    100          
1636              
1637             # Equality
1638 194 100       523 unless (ref $value) {
    100          
    100          
    100          
    50          
1639              
1640             # NULL value
1641 100 100       161 unless (defined $value) {
1642 3         12 push(@pairs, "$key IS NULL");
1643             }
1644              
1645             # Simple value
1646             else {
1647              
1648 97         365 push(@pairs, "$key = ?"),
1649             push(@values, $value);
1650             }
1651             }
1652              
1653             # Element of or SQL
1654             elsif (ref $value eq 'ARRAY') {
1655              
1656             # Escaped SQL
1657 7 100 66     38 if (ref $value->[0] && ref $value->[0] eq 'SCALAR') {
1658 1         8 push(@pairs, "$key = (" . ${$value->[0]} . ')'),
1659 1         4 push(@values, map { _stringify($_) } @{$value}[ 1 .. $#$value ]);
  1         4  
  1         3  
1660 1         4 next;
1661             };
1662              
1663             # Undefined values in the array are not specified
1664             # as ' IN (NULL, ...)' does not work
1665             push (@pairs, "$key IN (" . _q($value) . ')' ),
1666 6         21 push(@values, map { _stringify($_) } @$value);
  13         27  
1667             }
1668              
1669             # Operators
1670             elsif (ref $value eq 'HASH') {
1671 83         276 while (my ($op, $val) = each %$value) {
1672 85 50       672 if ($op =~ $OP_REGEX) {
1673 85         159 for ($op) {
1674              
1675             # Uppercase
1676 85         137 $_ = uc;
1677              
1678             # Translate negation
1679 85         167 s{^(?:NOT_|!(?=[MLGRB]))}{NOT };
1680              
1681             # Translate literal compare operators
1682 85 100       285 tr/GLENTQ/><=!/d if $_ =~ m/^(?:[GL][TE]|NE|EQ)$/o;
1683 85         168 s/==/=/o;
1684             };
1685              
1686             # Array operators
1687 85 100 66     248 if (ref $val && ref $val eq 'ARRAY') {
1688              
1689             # Between operator
1690 3 100       11 if (index($op, 'BETWEEN') >= 0) {
    50          
1691             push(@pairs, "$key $op ? AND ?"),
1692 2         8 push(@values, map { _stringify($_) } @{$val}[0, 1]);
  4         8  
  2         4  
1693             }
1694              
1695             # Not element of
1696             elsif ($op =~ /^NOT( IN)?$/) {
1697             # Undefined values in the array are not specified
1698             # as ' NOT IN (NULL, ...)' does not work
1699              
1700             push(@pairs, "$key NOT IN (" . _q($val) . ')' ),
1701 1         5 push(@values, map { _stringify($_) } @$val);
  2         3  
1702             };
1703             }
1704              
1705             # Simple operator
1706             else {
1707 82         178 my $p = "$key $op ";
1708              
1709             # Value is an object
1710 82 50       309 if (blessed $val) {
1711 0 0 0     0 $val = _stringify($val) or
1712             carp "Unknown Oro value $key $op $val" and next;
1713             };
1714              
1715             # Defined value
1716 82 100       135 if (defined $val) {
1717 74         95 $p .= '?';
1718 74         118 push(@values, $val);
1719             }
1720              
1721             # Null value
1722             else {
1723 8         14 $p .= 'NULL';
1724             };
1725              
1726             # Add LIKE escape sequence
1727 82 100       178 if ($op eq 'LIKE') {
1728 29         45 $p .= q! ESCAPE '\'!;
1729             };
1730              
1731 82         354 push(@pairs, $p);
1732             };
1733              
1734             }
1735              
1736             # Unknown operator
1737             else {
1738 0   0     0 $val //= '?';
1739 0 0       0 carp "Unknown Oro operator $key $op $val" and next;
1740             }
1741             }
1742             }
1743              
1744             # Escaped SQL
1745             elsif (ref $value eq 'SCALAR') {
1746 1         6 push(@pairs, "$key = ($$value)"),
1747             }
1748              
1749             # Stringifiable object
1750             elsif ($value = _stringify($value)) {
1751             # Simple object
1752 3         8 push(@pairs, "$key = ?"),
1753             push(@values, $value);
1754             }
1755              
1756             # Unknown pair
1757             else {
1758 0 0       0 carp "Unknown Oro pair $key, " . ($value ? $value : '[undef]' ) and next;
    0          
1759             };
1760             }
1761              
1762             # Restriction of the result set
1763             else {
1764 111         208 $key = lc $key;
1765              
1766             # No value existing
1767 111 50       412 next unless defined $value;
1768              
1769             # Limit and Offset restriction
1770 111 100       615 if ($key =~ m/^-(?:limit|offset|distinct)$/) {
    100          
    50          
    0          
1771 70 50       408 $prep{substr($key, 1)} = $value if $value =~ m/^\d+$/o;
1772             }
1773              
1774             # Order restriction
1775             elsif ($key =~ s/^-(order|group)(?:[-_]by)?$/$1/) {
1776              
1777             # Already array and group
1778 37 100 100     126 if ($key eq 'group' && ref $value) {
1779 2 100 66     13 if (ref $value->[-1] && ref $value->[-1] eq 'HASH') {
1780 1         3 $prep{having} = pop @$value;
1781              
1782 1 50       5 unless (@$value) {
1783 0 0       0 carp '"Having" without "Group" is not allowed' and next;
1784             };
1785             };
1786             };
1787              
1788 37         44 my @field_array;
1789              
1790             # Check group values
1791 37 100       111 foreach (ref $value ? @$value : $value) {
1792              
1793             # Valid order/group_by value
1794 38 100       251 if ($_ =~ $VALID_GROUPORDER_REGEX) {
1795 37         78 s/^([\-\+])//o;
1796 37 100 66     231 push(@field_array, $1 && $1 eq '-' ? "$_ DESC" : $_ );
1797             }
1798              
1799             # Invalid order/group_by value
1800             else {
1801 1         163 carp "$_ is not a valid Oro $key restriction";
1802             };
1803             };
1804              
1805 37 100       748 $prep{$key} = join(', ', @field_array) if scalar @field_array;
1806             }
1807              
1808             # And or or
1809             elsif ($key =~ m/^-(or|and)$/) {
1810 4         13 my $op = uc $1;
1811 4         14 my @array = @$value;
1812              
1813 4         7 my (@or_pairs, @or_values);
1814 4         14 while (@array) {
1815              
1816             # Not a hash
1817 8 100       21 if (!ref $array[0]) {
1818 4         10 unshift(@array, {
1819             shift @array => shift @array
1820             });
1821             };
1822              
1823             # Ignore prep
1824 8         35 my ($or_pairs, $or_values) = _get_pairs(shift(@array), $alias);
1825              
1826             # Push values
1827 8         15 push(@values, @$or_values);
1828              
1829             # Push local pairs
1830 8 100       16 if (@$or_pairs > 1) {
1831 2         12 push(@or_pairs, '(' . join (' AND ', @$or_pairs) . ')');
1832             }
1833              
1834             # Push single local pair
1835             else {
1836 6         19 push(@or_pairs, $or_pairs->[0]);
1837             };
1838             };
1839              
1840             # Join with chosen operator
1841 4         23 push(@pairs, '(' . join(" $op ", @or_pairs) . ')');
1842             }
1843              
1844             # Cache
1845             elsif ($key eq '-cache') {
1846 0         0 my $chi = $value->{chi};
1847              
1848             # Check chi existence
1849 0 0       0 if ($chi) {
1850 0   0     0 $prep{cache} = [ $chi, $value->{key} // '', $value ];
1851             }
1852              
1853             # No chi given
1854             else {
1855 0         0 carp 'No CHI driver given for cache';
1856             };
1857             }
1858             else {
1859 0         0 carp "$key is an unknown restriction";
1860             };
1861             };
1862             };
1863              
1864 196 100       832 return (\@pairs, \@values, (keys %prep ? \%prep : undef));
1865             };
1866              
1867              
1868             # Get fields
1869             sub _fields {
1870 59     59   74 my $table = shift;
1871              
1872 59         62 my (%treatment, %alias, @fields);
1873              
1874 59         70 foreach ( @{$_[0]} ) {
  59         157  
1875              
1876             # Ordinary String
1877 82 100       188 unless (ref $_) {
    50          
1878              
1879             # Valid field
1880 71 100       547 if ($_ =~ $VALID_FIELD_REGEX) {
1881 70         152 push(@fields, $_);
1882             }
1883              
1884             # Invalid field
1885             else {
1886 1         227 carp "$_ is not a valid Oro field value"
1887             };
1888             }
1889              
1890             # Treatment
1891             elsif (ref $_ eq 'ARRAY') {
1892 11         28 my ($sub, $alias) = @$_;
1893 11         145 my ($sql, $inner_sub) = $sub->($table);
1894 11 100       77 ($sql, $inner_sub, my @param) = $sql->($table) if ref $sql;
1895              
1896 11 100       52 $treatment{ $alias } = [$inner_sub, @param ] if $inner_sub;
1897 11         50 push(@fields, "$sql:$alias");
1898             };
1899             };
1900              
1901 59         774 my $fields = join(', ', @fields);
1902              
1903             # Return if no alias fields exist
1904 59 100       274 return $fields unless $fields =~ m/[\.:=]/o;
1905              
1906             # Join with alias fields
1907             return (
1908             join(
1909             ', ',
1910             map {
1911             # Explicite field alias
1912 40 100       64 if ($_ =~ $FIELD_REST_RE) {
  59 50       356  
    100          
1913              
1914             # ~ indicates rather not explicite alias
1915             # Will only be set in case of agregate functions
1916             # TODO: if ($2 eq ':' && index($1,'(') >= 0);
1917 52         188 $alias{$3} = $1;
1918 52         352 qq{$1 AS `$3`};
1919             }
1920              
1921             # Implicite field alias
1922             elsif (m/^(?:.+?)\.(?:[^\.]+?)$/) {
1923 0         0 my $cl = _clean_alias $_;
1924 0         0 $alias{$cl} = qq{$_ AS `$cl`};
1925             }
1926              
1927             # Field value
1928             else {
1929 7         18 $_
1930             };
1931             } @fields
1932             ),
1933             (%treatment ? \%treatment : undef),
1934             \%alias
1935             );
1936             };
1937              
1938              
1939             # Restrictions
1940             sub _restrictions {
1941 62     62   76 my ($prep, $values) = @_;
1942 62         92 my $sql = '';
1943              
1944             # Group restriction
1945 62 100       153 if ($prep->{group}) {
1946 3         8 $sql .= ' GROUP BY ' . delete $prep->{group};
1947              
1948             # Having restriction
1949 3 100       9 if ($prep->{having}) {
1950              
1951             # Get conditions
1952             my ($cond_pairs, $cond_values) = _get_pairs(
1953             delete $prep->{having}
1954 1         4 );
1955              
1956             # Conditions given
1957 1 50       2 if (@$cond_pairs) {
1958              
1959             # Append having condition
1960 1         3 $sql .= ' HAVING ' . join(' AND ', @$cond_pairs);
1961              
1962             # Append values
1963 1         2 push(@$values, @$cond_values);
1964             };
1965             };
1966             };
1967              
1968             # Order restriction
1969 62 100       142 if (exists $prep->{order}) {
1970 33         86 $sql .= ' ORDER BY ' . delete $prep->{order};
1971             };
1972              
1973             # Limit restriction
1974 62 100       155 if ($prep->{limit}) {
1975 47         73 $sql .= ' LIMIT ?';
1976 47         92 push(@$values, delete $prep->{limit});
1977              
1978             # Offset restriction
1979 47 100       111 if (defined $prep->{offset}) {
1980 21         20 $sql .= ' OFFSET ?';
1981 21         32 push(@$values, delete $prep->{offset});
1982             };
1983             };
1984              
1985 62         201 $sql;
1986             };
1987              
1988              
1989             # Check for stringification of blessed values
1990             sub _stringify {
1991 23 100   23   147 my $ref = blessed $_[0] or return $_[0];
1992 3 50       12 if (index(($_ = "$_[0]"), $ref) != 0) {
1993 3         27 return $_;
1994             };
1995 0         0 undef;
1996             }
1997              
1998              
1999             # Clean alias string
2000             sub _clean_alias {
2001 25     25   50 for (my $x = shift) {
2002 25         44 tr/ ()[]"$@#./_/s;
2003 25         62 s/[_\s]+$//;
2004 25         68 return $x;
2005             };
2006             };
2007              
2008              
2009             # Check list param
2010             sub _check_param {
2011 142 100 66 142   518 if ($_[0]->{$_[1]} && !ref $_[0]->{ $_[1] }) {
2012              
2013             # Check for numerical value
2014 98 100       143 if ($_[2]) {
2015 19 50       202 return $_[0]->{$_[1]} =~ $NUM_RE ? $1 : undef;
2016             };
2017              
2018             # Return value
2019 79         149 return $_[0]->{$_[1]};
2020             };
2021              
2022             # Fail
2023 44         141 return;
2024             };
2025              
2026              
2027             # Questionmark string
2028             sub _q {
2029 944     944   754 my ($s, $i, $r);
2030              
2031             # Loop over all values
2032 944         1060 for ($i = 0; $i < scalar(@{$_[0]});) {
  2397         4042  
2033 1453         1539 $r = $_[0]->[$i];
2034              
2035             # Append key
2036 1453 100       2002 unless (ref $r) {
2037 1448         1216 $s .= '?,';
2038 1448         948 $i++;
2039 1448         1287 next;
2040             };
2041              
2042             # Scalar for direct SQL input
2043 5 100       25 if (ref $r eq 'SCALAR') {
    100          
2044 1         5 $s .= "($$r),";
2045 1         2 splice(@{$_[0]}, $i, 1, ());
  1         5  
2046             }
2047              
2048             # Array for direct SQL input
2049             elsif (ref $r eq 'ARRAY') {
2050              
2051             # Check for scalar reference
2052 1 50       4 unless (ref $r->[0]) {
2053 0         0 carp 'First element of array insertion needs to be a scalar reference';
2054 0         0 splice(@{$_[0]}, $i++, 1);
  0         0  
2055 0         0 next;
2056             };
2057              
2058             # Embed SQL statement directly
2059 1         3 $s .= '(' . ${ shift @$r } . '),';
  1         4  
2060 1         2 splice(@{$_[0]}, $i++, scalar @$r, @$r);
  1         6  
2061             }
2062              
2063             # Stringifyable objects
2064             else {
2065 3         5 $i++;
2066 3 50       10 $s .= '?,' and next;
2067             };
2068             };
2069              
2070             # Delete final ','
2071 944         1276 chop $s;
2072              
2073             # Return value
2074 944         1882 $s;
2075             };
2076              
2077              
2078             # Trim last_sql message for reporting
2079             sub _trim_last_sql {
2080 15     15   16 my $last_sql = shift;
2081              
2082 15 50       2110 return $last_sql if length($last_sql) <= 500;
2083 0           return substr($last_sql, 0, 497) . ' ...';
2084             };
2085              
2086              
2087             # Empty code ref
2088       0     sub _no_warn {};
2089              
2090              
2091             1;
2092              
2093              
2094             __END__