File Coverage

lib/DB/Object/Tables.pm
Criterion Covered Total %
statement 40 343 11.6
branch 1 128 0.7
condition 0 79 0.0
subroutine 14 74 18.9
pod 61 61 100.0
total 116 685 16.9


line stmt bran cond sub pod time code
1             # -*- perl -*-
2             ##----------------------------------------------------------------------------
3             ## Database Object Interface - ~/lib/DB/Object/Tables.pm
4             ## Version v0.6.0
5             ## Copyright(c) 2022 DEGUEST Pte. Ltd.
6             ## Author: Jacques Deguest <jack@deguest.jp>
7             ## Created 2017/07/19
8             ## Modified 2023/03/16
9             ## All rights reserved
10             ##
11             ## This program is free software; you can redistribute it and/or modify it
12             ## under the same terms as Perl itself.
13             ##----------------------------------------------------------------------------
14             # This package's purpose is to separate the object of the tables from the main
15             # DB::Object package so that when they get DESTROY'ed, it does not interrupt
16             # the SQL connection
17             ##----------------------------------------------------------------------------
18             package DB::Object::Tables;
19             BEGIN
20 0         0 {
21 2     2   2639 use strict;
  2         4  
  2         67  
22 2     2   8 use warnings;
  2         4  
  2         59  
23 2     2   10 use parent qw( DB::Object );
  2         4  
  2         12  
24 2     2   129 use vars qw( $VERSION $VERBOSE $DEBUG );
  2         3  
  2         118  
25 2     2   443 use DB::Object::Fields;
  2         4  
  2         17  
26 2     2   6 $VERSION = 'v0.6.0';
27 2         3 $VERBOSE = 0;
28 2         52 $DEBUG = 0;
29 2     2   683 use Devel::Confess;
  2         5  
  2         13  
30 2     2   137 use Want;
  2         5  
  2         100  
31             };
32              
33 2     2   10 use strict;
  2         5  
  2         40  
34 2     2   8 use warnings;
  2         3  
  2         8267  
35              
36             sub init
37             {
38 0     0 1 0 my $self = shift( @_ );
39 0         0 my $table = '';
40 0 0 0     0 $table = shift( @_ ) if( @_ && @_ % 2 );
41 0         0 my %arg = ( @_ );
42             # Prioritise this, so we get debugging messages
43 0         0 $self->{debug} = CORE::delete( $arg{delete} );
44 0 0 0     0 return( $self->error( "You must provide a table name to create a table object." ) ) if( !$table && !$arg{table} );
45 0   0     0 $table ||= CORE::delete( $arg{table} );
46 0         0 $self->{avoid} = [];
47 0         0 $self->{alias} = {};
48             # $self->{bind} = '';
49             # $self->{cache} = '';
50 0         0 $self->{dbo} = '';
51 0         0 $self->{default} = {};
52 0         0 $self->{enhance} = '';
53 0         0 $self->{fields} = {};
54             # DB::Object::Fields
55 0         0 $self->{fields_object} = '';
56 0         0 $self->{null} = {};
57 0         0 $self->{prefixed} = 0;
58 0         0 $self->{primary} = [];
59 0         0 $self->{query_object} = '';
60 0         0 $self->{query_reset} = 0;
61 0         0 $self->{reverse} = 0;
62             # The schema name, if any
63 0         0 $self->{schema} = '';
64 0         0 $self->{structure} = {};
65 0 0       0 $self->{table} = $table if( $table );
66 0         0 $self->{types} = {};
67             # An hash to contain table field to an hash of constant value and constant name:
68             # field => { constant => 12, name => PG_JSONB, type => 'jsonb' };
69 0         0 $self->{types_const} = {};
70             # The table type. It could be table or view
71 0         0 $self->{type} = '';
72 0         0 my $keys = [keys( %arg )];
73 0         0 @$self{ @$keys } = @arg{ @$keys };
74             # foreach my $k ( keys( %arg ) )
75             # {
76             # $self->{ $k } = $arg{ $k };
77             # }
78             # Load table default, fields, structure informations
79             # my $db = $self->database();
80 0         0 my $ref = $self->structure();
81 0 0 0     0 return( $self->error( "There is no table by the name of $table" ) ) if( !defined( $ref ) || !%$ref );
82 0         0 return( $self );
83             }
84              
85             # Get/set alias
86             sub alias
87             {
88 0     0 1 0 my $self = shift( @_ );
89 0         0 my $q = $self->_reset_query;
90 0         0 return( $q->alias( @_ ) );
91             }
92              
93             sub alter
94             {
95 0     0 1 0 my $self = shift( @_ );
96             # Expecting a reference to an array
97 0         0 my $spec = '';
98 0 0 0     0 $spec = shift( @_ ) if( @_ == 1 && ref( $_[ 0 ] ) );
99 0 0 0     0 $spec = [ @_ ] if( @_ && !$spec );
100             my $table = $self->{table} ||
101 0   0     0 return( $self->error( "No table was provided." ) );
102 0 0 0     0 return( $self->error( "No proper ALTER specification was provided." ) ) if( !$spec || !ref( $spec ) || !@$spec );
      0        
103 0         0 my $query = "ALTER TABLE $table " . CORE::join( ', ', @$spec );
104 0   0     0 my $sth = $self->prepare( $query ) ||
105             return( $self->error( "Error while preparing ALTER query to modify table '$table':\n", $self->errstr() ) );
106 0 0       0 if( !defined( wantarray() ) )
107             {
108 0 0       0 $sth->execute() ||
109             return( $self->error( "Error while executing query to ALTER table '$table':\n", $self->as_string(), $sth->errstr() ) );
110             }
111 0         0 return( $sth );
112             }
113              
114             sub as
115             {
116 0     0 1 0 my $self = shift( @_ );
117 0         0 my $q = $self->_reset_query;
118 0 0       0 if( @_ )
119             {
120             # my( $p, $f, $l ) = caller;
121 0 0       0 $self->prefixed( length( $_[0] ) > 0 ? 1 : 0 );
122             }
123 0         0 return( $q->table_alias( @_ ) );
124             }
125              
126             sub avoid
127             {
128 0     0 1 0 my $self = shift( @_ );
129 0         0 my $q = $self->_reset_query;
130 0         0 return( $q->avoid( @_ ) );
131             }
132              
133             sub columns
134             {
135 0     0 1 0 my $self = shift( @_ );
136 0         0 my $fields = $self->fields;
137 0         0 my $cols = [sort{ $fields->{ $a } <=> $fields->{ $b } } keys( %$fields )];
  0         0  
138 0         0 return( $self->new_array( $cols ) );
139             }
140              
141             sub constant
142             {
143 0     0 1 0 my $self = shift( @_ );
144 0         0 my( $pack, $file, $line ) = caller;
145 0         0 my $base_class = $self->database_object->base_class;
146             # This does not work for calls made internally
147 0 0       0 return( $self ) if( $pack =~ /^${base_class}\b/ );
148 0         0 my $sth = $self->database_object->constant_queries_cache_get({
149             pack => $pack,
150             file => $file,
151             line => $line,
152             });
153             # $sth returned may be void if no cache was found or if the caller's file mod time has changed
154 0         0 my $q;
155 0 0       0 if( $sth )
156             {
157 0         0 $q = $sth->query_object;
158 0         0 $self->query_object( $q );
159             }
160             else
161             {
162 0         0 $q = $self->_reset_query;
163             }
164 0         0 $q->constant({
165             sth => $sth,
166             pack => $pack,
167             file => $file,
168             line => $line,
169             });
170 0         0 return( $self );
171             }
172              
173             # sub create must be superseded by sub classes
174             sub create
175             {
176 0     0 1 0 my $self = shift( @_ );
177 0         0 my $class = ref( $self );
178 0         0 return( $self->error( "create() is not implemented by $class." ) );
179             }
180              
181             sub create_info
182             {
183 0     0 1 0 my $self = shift( @_ );
184 0         0 my $class = ref( $self );
185 0         0 return( $self->error( "create_info() is not implemented by $class." ) );
186             }
187              
188 0     0 1 0 sub database { return( shift->database_object->database ); }
189              
190 73     73 1 1550 sub database_object { return( shift->{dbo} ); }
191              
192 0     0 1 0 sub dbh { return( shift->_set_get( 'dbh', @_ ) ); }
193              
194             sub default
195             {
196 0     0 1 0 my $self = shift( @_ );
197 0         0 $self->structure();
198 0         0 my $default = $self->{default};
199 0 0       0 return( wantarray() ? () : undef() ) if( !%$default );
    0          
200 0 0       0 return( wantarray() ? %$default : \%$default );
201             }
202              
203             sub delete
204             {
205 0     0 1 0 my $self = shift( @_ );
206 0         0 my $q = $self->_reset_query;
207             # If the user wants to execute this, then we reset the query,
208             # but if the user wants to call other methods chained like as_string we don't do anything
209             # CORE::delete( $self->{query_reset} ) if( !defined( wantarray() ) );
210 0 0 0     0 if( Want::want('VOID') || Want::want('OBJECT') )
211             {
212 0 0       0 CORE::delete( $self->{query_reset} ) if( Want::want('VOID') );
213             # return( $q->select( @_ ) );
214             # return( $q->select( @_ ) ) if( !defined( wantarray() ) );
215 0         0 return( $q->delete( @_ ) );
216             }
217             # CORE::delete( $self->{query_reset} ) if( !defined( wantarray() ) );
218             # return( $q->delete( @_ ) );
219             # return( $q->delete( @_ ) ) if( !defined( wantarray() ) );
220 0 0       0 if( wantarray() )
221             {
222 0   0     0 my( @val ) = $q->delete( @_ ) || return( $self->pass_error( $q->error ) );
223 0         0 $self->reset;
224 0         0 return( @val );
225             }
226             else
227             {
228 0   0     0 my $val = $q->delete( @_ ) || return( $self->pass_error( $q->error ) );
229 0         0 $self->reset;
230 0         0 return( $val );
231             }
232             }
233              
234             sub drop
235             {
236 0     0 1 0 my $self = shift( @_ );
237             my $table = $self->{table} ||
238 0   0     0 return( $self->error( "No table was provided to drop." ) );
239 0         0 my $query = "DROP TABLE $table";
240 0   0     0 my $sth = $self->prepare( $query ) ||
241             return( $self->error( "Error while preparing query to drop table '$table':\n$query", $self->errstr() ) );
242 0 0       0 if( !defined( wantarray() ) )
243             {
244 0 0       0 $sth->execute() ||
245             return( $self->error( "Error while executing query to drop table '$table':\n$query", $sth->errstr() ) );
246             }
247 0         0 return( $sth );
248             }
249              
250             sub exists
251             {
252 0     0 1 0 my $self = shift( @_ );
253 0         0 my $class = ref( $self );
254 0         0 return( $self->error( "exists() is not implemented by $class." ) );
255             }
256              
257             sub fields
258             {
259 0     0 1 0 my $self = shift( @_ );
260 0         0 $self->structure();
261 0         0 my $fields = $self->{fields};
262 0 0       0 return( wantarray() ? () : undef() ) if( !%$fields );
    0          
263 0 0       0 return( wantarray() ? %$fields : \%$fields );
264             }
265              
266             sub fields_object
267             {
268 0     0 1 0 my $self = shift( @_ );
269 0         0 my $o = $self->{fields_object};
270             # This will make sure we have a query object which DB::Object::Fields and DB::Object::Field need
271 0         0 $self->_reset_query;
272 0 0 0     0 if( $o && $self->_is_object( $o ) )
273             {
274 0         0 $o->prefixed( $self->{prefixed} );
275 0         0 $o->query_object( $self->query_object );
276 0         0 return( $o );
277             }
278 0         0 my $db_name = $self->database_object->database;
279 0         0 $db_name =~ tr/-/_/;
280 0         0 $db_name =~ s/\_{2,}/_/g;
281 0         0 $db_name = join( '', map( ucfirst( lc( $_ ) ), split( /\_/, $db_name ) ) );
282 0         0 my $name = $self->name;
283 0         0 my $new_class = $name;
284 0         0 $new_class =~ tr/-/_/;
285 0         0 $new_class =~ s/\_{2,}/_/g;
286 0         0 $new_class = join( '', map( ucfirst( lc( $_ ) ), split( /\_/, $new_class ) ) );
287 0         0 my $class = ref( $self ) . "\::${db_name}\::${new_class}";
288 0 0       0 if( !$self->_is_class_loaded( $class ) )
289             {
290 0         0 my $perl = <<EOT;
291             package $class;
292             BEGIN
293             {
294             use strict;
295             use parent qw( DB::Object::Fields );
296             };
297              
298             1;
299              
300             EOT
301             # print( STDERR __PACKAGE__, "::_set_get_hash_as_object(): Evaluating\n$perl\n" );
302 0         0 my $rc = eval( $perl );
303             # print( STDERR __PACKAGE__, "::_set_get_hash_as_object(): Returned $rc\n" );
304 0 0       0 die( "Unable to dynamically create module $class: $@" ) if( $@ );
305             }
306             else
307             {
308             }
309             $o = $class->new(
310             prefixed => $self->{prefixed},
311             # For table alias
312 0         0 query_object => $self->query_object,
313             table_object => $self,
314             debug => $self->debug,
315             );
316 0         0 $o->prefixed( $self->{prefixed} );
317 0         0 $self->{fields_object} = $o;
318 0         0 return( $o );
319             }
320              
321 0     0 1 0 sub fo { return( shift->fields_object( @_ ) ); }
322              
323             sub format_statement($;\%\%@)
324             {
325 0     0 1 0 my $self = shift( @_ );
326 0         0 my $q = $self->_reset_query;
327 0         0 return( $q->format_statement( @_ ) );
328             }
329              
330             sub format_update($;%)
331             {
332 0     0 1 0 my $self = shift( @_ );
333 0         0 my $q = $self->_reset_query;
334 0         0 return( $q->format_update( @_ ) );
335             }
336              
337             sub from_unixtime
338             {
339 0     0 1 0 my $self = shift( @_ );
340 0         0 my $q = $self->_reset_query;
341 0         0 return( $q->from_unixtime( @_ ) );
342             }
343              
344             sub group
345             {
346 0     0 1 0 my $self = shift( @_ );
347 0         0 my $q = $self->_reset_query;
348 0         0 return( $q->group( @_ ) );
349             }
350              
351             sub insert
352             {
353 0     0 1 0 my $self = shift( @_ );
354 0         0 my $q = $self->_reset_query;
355             # If the user wants to execute this, then we reset the query,
356             # but if the user wants to call other methods chained like as_string we don't do anything
357             # CORE::delete( $self->{query_reset} ) if( !defined( wantarray() ) );
358 0 0 0     0 if( Want::want('VOID') || Want::want('OBJECT') )
359             {
360 0 0       0 CORE::delete( $self->{query_reset} ) if( Want::want('VOID') );
361             # return( $q->select( @_ ) );
362             # return( $q->select( @_ ) ) if( !defined( wantarray() ) );
363 0         0 return( $q->insert( @_ ) );
364             }
365             # CORE::delete( $self->{query_reset} ) if( !defined( wantarray() ) );
366             # return( $q->insert( @_ ) ) if( !defined( wantarray() ) );
367 0 0       0 if( wantarray() )
368             {
369 0   0     0 my( @val ) = $q->insert( @_ ) || return( $self->pass_error( $q->error ) );
370 0         0 $self->reset;
371 0         0 return( @val );
372             }
373             else
374             {
375 0   0     0 my $val = $q->insert( @_ ) || return( $self->pass_error( $q->error ) );
376 0         0 $self->reset;
377 0         0 return( $val );
378             }
379             }
380              
381             sub limit
382             {
383 0     0 1 0 my $self = shift( @_ );
384 0         0 my $q = $self->_reset_query;
385 0         0 return( $q->limit( @_ ) );
386             }
387              
388             sub local
389             {
390 0     0 1 0 my $self = shift( @_ );
391 0         0 my $q = $self->_reset_query;
392 0         0 return( $q->local( @_ ) );
393             }
394              
395             sub lock
396             {
397 0     0 1 0 my $self = shift( @_ );
398 0         0 my $class = ref( $self );
399 0         0 return( $self->error( "lock() is not implemented by $class." ) );
400             }
401              
402             sub name
403             {
404             # Read-only
405 0     0 1 0 return( shift->{table} );
406             }
407              
408             sub null
409             {
410 0     0 1 0 my $self = shift( @_ );
411 0         0 $self->structure();
412 0         0 my $null = $self->{null};
413 0 0       0 return( wantarray() ? () : undef() ) if( !%$null );
    0          
414 0 0       0 return( wantarray() ? %$null : $null );
415             }
416              
417 0     0 1 0 sub on_conflict { return( shift->error( "The on conflict clause is not supported by this driver." ) ); }
418              
419             sub optimize
420             {
421 0     0 1 0 my $self = shift( @_ );
422 0         0 my $class = ref( $self );
423 0         0 return( $self->error( "optimize() is not implemented by $class." ) );
424             }
425              
426             sub order
427             {
428 0     0 1 0 my $self = shift( @_ );
429 0         0 my $q = $self->_reset_query;
430 0         0 return( $q->order( @_ ) );
431             }
432              
433             sub prefix
434             {
435 0     0 1 0 my $self = shift( @_ );
436 0         0 my @val = ();
437 0         0 my $alias = $self->query_object->table_alias;
438             #my $q = $self->query_object || die( "No query object could be created or gotten: ", $self->error );
439             #my $alias = $q->table_alias;
440 0 0 0     0 return( $alias ) if( $alias && $self->{prefixed} > 0 );
441 0 0       0 CORE::push( @val, $self->database_object->database ) if( $self->{prefixed} > 2 );
442 0 0 0     0 CORE::push( @val, $self->schema ) if( $self->{prefixed} > 1 && $self->schema );
443 0 0       0 CORE::push( @val, $self->name ) if( $self->{prefixed} > 0 );
444 0 0       0 return( '' ) if( !scalar( @val ) );
445 0         0 return( CORE::join( '.', @val ) );
446             }
447              
448 0     0 1 0 sub prefix_database { return( shift->{prefixed} > 2 ); }
449              
450 0     0 1 0 sub prefix_schema { return( shift->{prefixed} > 1 ); }
451              
452 0     0 1 0 sub prefix_table { return( shift->{prefixed} > 0 ); }
453              
454             # This the prefix intended for field in query
455             sub prefixed
456             {
457 0     0 1 0 my $self = shift( @_ );
458 0 0       0 if( @_ )
459             {
460 0 0       0 $self->{prefixed} = ( $_[0] =~ /^\d+$/ ? $_[0] : ( $_[0] ? 1 : 0 ) );
    0          
461             }
462             else
463             {
464 0         0 $self->{prefixed} = 1;
465             }
466 0         0 my $fo = $self->{fields_object};
467 0 0       0 $fo->prefixed( $self->{prefixed} ) if( $fo );
468             # return( want( 'OBJECT' ) ? $self : $self->{prefixed} );
469 0         0 return( $self->{prefixed} );
470             }
471              
472             sub primary
473             {
474 0     0 1 0 my $self = shift( @_ );
475 0         0 $self->structure();
476 0         0 my $primary = $self->{primary};
477 0 0 0     0 return( wantarray() ? () : undef() ) if( !$primary || !@$primary );
    0          
478 0 0       0 return( wantarray() ? @$primary : \@$primary );
479             }
480              
481             # In PostgreSQL, Oracle, SQL server this would be schema_name.table_name
482 0     0 1 0 sub qualified_name { return( shift->name ); }
483              
484 4     4 1 54 sub query_object { return( shift->_set_get_object_without_init( 'query_object', 'DB::Object::Query', @_ ) ); }
485              
486 0     0 1 0 sub query_reset { return( shift->_set_get_scalar( 'query_reset', @_ ) ); }
487              
488             sub rename
489             {
490 0     0 1 0 my $self = shift( @_ );
491 0         0 my $class = ref( $self );
492 0         0 return( $self->error( "rename() is not implemented by $class." ) );
493             }
494              
495             sub repair
496             {
497 0     0 1 0 my $self = shift( @_ );
498 0         0 my $class = ref( $self );
499 0         0 return( $self->error( "repair() is not implemented by $class." ) );
500             }
501              
502             sub replace
503             {
504 0     0 1 0 my $self = shift( @_ );
505 0         0 my $q = $self->_reset_query;
506             # If the user wants to execute this, then we reset the query,
507             # but if the user wants to call other methods chained like as_string we don't do anything
508             # CORE::delete( $self->{query_reset} ) if( !defined( wantarray() ) );
509 0 0 0     0 if( Want::want('VOID') || Want::want('OBJECT') )
510             {
511 0 0       0 CORE::delete( $self->{query_reset} ) if( Want::want('VOID') );
512             # return( $q->select( @_ ) );
513             # return( $q->select( @_ ) ) if( !defined( wantarray() ) );
514 0         0 return( $q->replace( @_ ) );
515             }
516             # CORE::delete( $self->{query_reset} ) if( !defined( wantarray() ) );
517             # return( $q->replace( @_ ) );
518             # return( $q->replace( @_ ) ) if( !defined( wantarray() ) );
519 0 0       0 if( wantarray() )
520             {
521 0   0     0 my( @val ) = $q->replace( @_ ) || return( $self->pass_error( $q->error ) );
522 0         0 return( @val );
523             }
524             else
525             {
526 0   0     0 my $val = $q->replace( @_ ) || return( $self->pass_error( $q->error ) );
527 0         0 return( $val );
528             }
529             }
530              
531             sub reset
532             {
533 1     1 1 50 my $self = shift( @_ );
534 1         164 CORE::delete( $self->{query_reset} );
535 1 50       21 $self->_reset_query( @_ ) || return( $self->pass_error );
536 1         8 CORE::delete( $self->{fields_object} );
537             ## To allow chaining of commands
538 1         24 return( $self );
539             }
540              
541             # Modelled after PostgreSQL and available since 3.35.0 released 2021-03-12
542             # <https://www.sqlite.org/lang_returning.html>
543             sub returning
544             {
545 0     0 1   my $self = shift( @_ );
546 0           my $q = $self->_reset_query;
547 0           return( $q->returning( @_ ) );
548             }
549              
550             sub reverse
551             {
552 0     0 1   my $self = shift( @_ );
553 0 0         if( @_ )
554             {
555 0           my $q = $self->_reset_query;
556 0           $self->{reverse}++;
557 0           $q->reverse( $self->{reverse} );
558             }
559 0           return( $self->{reverse} );
560             }
561              
562 0     0 1   sub schema { return( shift->_set_get_scalar( 'schema', @_ ) ); }
563              
564             sub select
565             {
566 0     0 1   my $self = shift( @_ );
567 0           my $q = $self->_reset_query;
568             # If the user wants to execute this, then we reset the query,
569             # but if the user wants to call other methods chained like as_string we don't do anything
570             # CORE::delete( $self->{query_reset} ) if( !defined( wantarray() ) );
571 0 0 0       if( Want::want('VOID') || Want::want('OBJECT') )
572             {
573 0 0         CORE::delete( $self->{query_reset} ) if( Want::want('VOID') );
574             # return( $q->select( @_ ) );
575             # return( $q->select( @_ ) ) if( !defined( wantarray() ) );
576 0           return( $q->select( @_ ) );
577             }
578            
579 0 0         if( wantarray() )
580             {
581 0   0       my( @val ) = $q->select( @_ ) || return( $self->pass_error( $q->error ) );
582             # a statement handler is returned and we reset the query so that other calls would not use the previous DB::Object::Query object
583 0           $self->reset;
584 0           return( @val );
585             }
586             else
587             {
588 0   0       my $val = $q->select( @_ ) || return( $self->pass_error( $q->error ) );
589 0           $self->reset;
590 0           return( $val );
591             }
592             }
593              
594             sub sort
595             {
596 0     0 1   my $self = shift( @_ );
597 0 0         if( @_ )
598             {
599 0           my $q = $self->_reset_query;
600 0           $self->{reverse} = 0;
601 0           $q->sort( $self->{reverse} );
602             }
603 0           return( $self->{reverse} );
604             }
605              
606             sub stat
607             {
608 0     0 1   my $self = shift( @_ );
609 0           my $class = ref( $self );
610 0           return( $self->error( "stat() is not implemented by $class." ) );
611             }
612              
613             # sub structure must be superseded by sub classes
614             sub structure
615             {
616 0     0 1   my $self = shift( @_ );
617 0           my $class = ref( $self );
618 0           return( $self->error( "structure() is not implemented by $class." ) );
619             }
620              
621 0     0 1   sub table { return( shift->{table} ); }
622              
623             sub tie
624             {
625 0     0 1   my $self = shift( @_ );
626 0           my $q = $self->_reset_query;
627 0           return( $q->tie( @_ ) );
628             }
629              
630 0     0 1   sub type { return( shift->_set_get_scalar( 'type', @_ ) ); }
631              
632             sub types
633             {
634 0     0 1   my $self = shift( @_ );
635 0           $self->structure();
636 0           my $types = $self->{types};
637 0 0         return( wantarray() ? () : undef() ) if( !%$types );
    0          
638 0 0         return( wantarray() ? %$types : $types );
639             }
640              
641             sub types_const
642             {
643 0     0 1   my $self = shift( @_ );
644 0           $self->structure();
645 0           my $types = $self->{types_const};
646 0 0         return( wantarray() ? () : undef() ) if( !%$types );
    0          
647 0 0         return( wantarray() ? %$types : $types );
648             }
649              
650             sub unlock
651             {
652 0     0 1   my $self = shift( @_ );
653 0           my $class = ref( $self );
654 0           return( $self->error( "unlock() is not implemented by $class." ) );
655             }
656              
657             sub unix_timestamp
658             {
659 0     0 1   my $self = shift( @_ );
660 0           my $q = $self->_reset_query;
661 0           return( $q->unix_timestamp( @_ ) );
662             }
663              
664             sub update
665             {
666 0     0 1   my $self = shift( @_ );
667 0           my $q = $self->_reset_query;
668             # If the user wants to execute this, then we reset the query,
669             # but if the user wants to call other methods chained like as_string we don't do anything
670             # CORE::delete( $self->{query_reset} ) if( !defined( wantarray() ) );
671 0 0 0       if( Want::want('VOID') || Want::want('OBJECT') )
672             {
673 0 0         CORE::delete( $self->{query_reset} ) if( Want::want('VOID') );
674             # return( $q->select( @_ ) );
675             # return( $q->select( @_ ) ) if( !defined( wantarray() ) );
676 0           return( $q->update( @_ ) );
677             }
678             # CORE::delete( $self->{query_reset} ) if( !defined( wantarray() ) );
679             # return( $q->update( @_ ) );
680             # return( $q->update( @_ ) ) if( !defined( wantarray() ) );
681 0 0         if( wantarray() )
682             {
683 0   0       my( @val ) = $q->update( @_ ) || return( $self->pass_error( $q->error ) );
684 0           $self->reset;
685 0           return( @val );
686             }
687             else
688             {
689 0   0       my $val = $q->update( @_ ) || return( $self->pass_error( $q->error ) );
690 0           $self->reset;
691 0           return( $val );
692             }
693             }
694              
695             sub where
696             {
697 0     0 1   my $self = shift( @_ );
698 0           my $q = $self->_reset_query;
699 0           return( $q->where( @_ ) );
700             }
701              
702             AUTOLOAD
703             {
704 0     0     my( $method ) = our $AUTOLOAD =~ /([^:]+)$/;
705 2     2   19 no overloading;
  2         4  
  2         366  
706 0           my $self = shift( @_ );
707 0           my $fields = $self->fields;
708             # User called a field on a table object, instead of using the method fields_object or its shortcut 'fo'
709 0 0         if( CORE::exists( $fields->{ $method } ) )
710             {
711 0           warn( "You have called a field name '$method' using a table object. This practice is discouraged, although it works for now. Best to use something like: \$tbl->fo->$method rather than just \$tbl->$method\n" );
712 0           return( $self->fields_object->_initiate_field_object( $method ) );
713             }
714             else
715             {
716 0           warn( "You called table '", $self->name, "' object \$tbl->$method, but no such method exist.\n" );
717 0           return( $self->error( "You called table '", $self->name, "' object \$tbl->$method, but no such method exist." ) );
718             }
719             };
720              
721             DESTROY
722       0     {
723             # Do nothing
724             # DB::Object::Tables are never destroyed.
725             # They are just gateway to tables, and they are cached by DB::Object::table()
726             # print( STDERR "DESTROY'ing table $self ($self->{ 'table' })\n" );
727             };
728              
729             1;
730              
731             # NOTE: POD
732             __END__
733              
734             =encoding utf8
735              
736             =head1 NAME
737              
738             DB::Object::Tables - Database Table Object
739              
740             =head1 SYNOPSIS
741              
742             =head1 VERSION
743              
744             v0.6.0
745              
746             =head1 DESCRIPTION
747              
748             This is the table object package used to represent and manipulate table objects.
749              
750             =head1 CONSTRUCTOR
751              
752             =head2 new
753              
754             my $tbl = DB::Object::Tables->new( 'my_table' ) || die( DB::Object::Tables->error );
755              
756             Creates a new L<DB::Object::Tables> object.
757              
758             A table name may be provided as first argument.
759              
760             It may also take an hash of arguments, that also are method of the same name.
761              
762             It will call L</structure> to get the table structure from database and returns an error if it fails.
763              
764             Possible arguments are:
765              
766             =over 4
767              
768             =item I<debug>
769              
770             Toggles debug mode on/off
771              
772             =back
773              
774             =head1 METHODS
775              
776             =head2 alias
777              
778             This is a convenient wrapper around L<DB::Object::Query/alias>
779              
780             It takes a column name to alias hash and sets those aliases for the following query.
781              
782             Get/set alias for table fields in SELECT queries. The hash provided thus contain a list of field => alias pairs.
783              
784             =head2 alter
785              
786             Provided with an array or array reference of specification for the alter and this will prepare the proper query.
787              
788             The specification array or array reference will be joined with a comma
789              
790             If called in void context, the resulting statement handler will be executed immediately.
791              
792             This returns the resulting statement handler.
793              
794             =head2 as
795              
796             Provided with a table alias and this will call L<DB::Object::Query/table_alias> passing it whatever arguments were provided.
797              
798             =head2 avoid
799              
800             Takes a list of array reference of column to avoid in the next query.
801              
802             This is a convenient wrapper around L<DB::Object::Query/avoid>
803              
804             =head2 columns
805              
806             Returns an L<array object|Module::Generic::Array> of the table columns.
807              
808             This information is provided by L</fields>, which is in turn provided by L</structure>
809              
810             =head2 constant
811              
812             Sets the query object constant for statement caching and return our current object.
813              
814             =head2 create
815              
816             This must be implemented by the driver package, so check L<DB::Object::Mysql::Tables/create>, L<DB::Object::Postgres::Tables/create> or L<DB::Object::SQLite::Tables/create>
817              
818             =head2 create_info
819              
820             This must be implemented by the driver package, so check L<DB::Object::Mysql::Tables/create_info>, L<DB::Object::Postgres::Tables/create_info> or L<DB::Object::SQLite::Tables/create_info>
821              
822             =head2 database
823              
824             Returns the name of the current database by calling L<DB::Object/database>
825              
826             =head2 database_object
827              
828             Returns the database object (L<DB::Object>)
829              
830             =head2 dbh
831              
832             Returns the database handler (L<DBI>)
833              
834             =head2 default
835              
836             This calls L</structure> which may return cached data.
837              
838             Returns an hash in list context and an hash reference in scalar representing column to its default values pairs.
839              
840             If nothing is found, it returns an empty list in list context and L<perlfunc/undef> in scalar context.
841              
842             =head2 delete
843              
844             L</delete> will format a delete query based on previously set parameters, such as L</where>.
845              
846             L</delete> will refuse to execute a query without a where condition. To achieve this, one must prepare the delete query on his/her own by using the L</do> method and passing the sql query directly.
847              
848             $tbl->where( login => 'jack' );
849             $tbl->limit(1);
850             my $rows_affected = $tbl->delete();
851             # or passing the where condition directly to delete
852             my $sth = $tbl->delete( login => 'jack' );
853              
854             =head2 drop
855              
856             This will prepare the query to drop the current table.
857              
858             In void context, this will execute the resulting statement handler.
859              
860             It returns the resulting statement handler
861              
862             =head2 exists
863              
864             This must be implemented by the driver package, so check L<DB::Object::Mysql::Tables/exists>, L<DB::Object::Postgres::Tables/exists> or L<DB::Object::SQLite::Tables/exists>
865              
866             =head2 fields
867              
868             This calls L</structure> which may return cached data.
869              
870             Returns an hash in list context and an hash reference in scalar representing column to its order (integer) in the table pairs.
871              
872             If nothing is found, it returns an empty list in list context and L<perlfunc/undef> in scalar context.
873              
874             =head2 fields_object
875              
876             my $tbl = $dbh->user || die( "No table \"user\" found in database\n" );
877             # get the field object for "name"
878             my $name = $tbl->fields_object->name
879             # Do something with it
880             my $expr = $name == 'joe';
881             # Resulting in an DB::Object::Fields::Field::Overloaded object
882              
883             This returns the cached object if there is one.
884              
885             This will dynamically create a package based on the database and table name. For example a database C<Foo> and a table C<Bar> would result in the following dynamically created package: C<DB::Object::Tables::Foo::Bar>
886              
887             This new package will inherit from L<DB::Object::Fields>, which enable the dynamic loading of column object using C<AUTOLOAD>
888              
889             This will instantiate an object from this newly created package, cache it and return it.
890              
891             =head2 fo
892              
893             This is a convenient shortcut for L</fields_object>
894              
895             my $tbl = $dbh->user || die( "No table \"user\" found in database\n" );
896             # get the field object for "name"
897             my $name = $tbl->fo->name
898              
899             =head2 format_statement
900              
901             This is a convenient wrapper around L<DB::Object::Query/format_statement>
902              
903             Format the sql statement for queries of types C<select>, C<delete> and C<insert>
904              
905             In list context, it returns 2 strings: one comma-separated list of fields and one comma-separated list of values. In scalar context, it only returns a comma-separated string of fields.
906              
907             =head2 format_update
908              
909             This is a convenient wrapper around L<DB::Object::Query/format_update>
910              
911             Formats update query based on the following arguments provided:
912              
913             =over 4
914              
915             =item I<data>
916              
917             An array of key-value pairs to be used in the update query. This array can be provided as the prime argument as a reference to an array, an array, or as the I<data> element of a hash or a reference to a hash provided.
918              
919             Why an array if eventually we build a list of key-value pair? Because the order of the fields may be important, and if the key-value pair list is provided, L</format_update> honors the order in which the fields are provided.
920              
921             =back
922              
923             L</format_update> will then iterate through each field-value pair, and perform some work:
924              
925             If the field being reviewed was provided to B<from_unixtime>, then L</format_update> will enclose it in the function FROM_UNIXTIME() as in:
926              
927             FROM_UNIXTIME(field_name)
928            
929             If the the given value is a reference to a scalar, it will be used as-is, ie. it will not be enclosed in quotes or anything. This is useful if you want to control which function to use around that field.
930              
931             If the given value is another field or looks like a function having parenthesis, or if the value is a question mark, the value will be used as-is.
932              
933             If L<DB::Object/bind> is off, the value will be escaped and the pair field='value' created.
934              
935             If the field is a SET data type and the value is a number, the value will be used as-is without surrounding single quote.
936              
937             If L<DB::Object/bind> is enabled, a question mark will be used as the value and the original value will be saved as value to bind upon executing the query.
938              
939             Finally, otherwise the value is escaped and surrounded by single quotes.
940              
941             L</format_update> returns a string representing the comma-separated list of fields that will be used.
942              
943             =head2 from_unixtime
944              
945             Provided with an array or array reference of table columns and this will set the list of fields that are to be treated as unix time and converted accordingly after the sql query is executed.
946              
947             It returns the list of fields in list context or a reference to an array in scalar context.
948              
949             =head2 group
950              
951             This is a convenient wrapper around L<DB::Object::Query/group>
952              
953             =head2 insert
954              
955             This is a convenient wrapper around L<DB::Object::Query/insert>
956              
957             =head2 limit
958              
959             This is a convenient wrapper around L<DB::Object::Query/limit>
960              
961             =head2 local
962              
963             This is a convenient wrapper around L<DB::Object::Query/local>
964              
965             =head2 lock
966              
967             This must be implemented by the driver package, so check L<DB::Object::Mysql::Tables/lock>, L<DB::Object::Postgres::Tables/lock> or L<DB::Object::SQLite::Tables/lock>
968              
969             =head2 name
970              
971             Returns the table name. This is read-only.
972              
973             =head2 null
974              
975             This calls L</structure> which may return cached data.
976              
977             Returns an hash in list context and an hash reference in scalar representing column to its default null values pairs.
978              
979             If nothing is found, it returns an empty list in list context and L<perlfunc/undef> in scalar context.
980              
981             =head2 on_conflict
982              
983             The SQL C<ON CONFLICT> clause needs to be implemented by the driver and is currently supported only by L<DB::Object::Postgres> and L<DB::Object::SQLite>.
984              
985             =head2 optimize
986              
987             This must be implemented by the driver package, so check L<DB::Object::Mysql::Tables/optimize>, L<DB::Object::Postgres::Tables/optimize> or L<DB::Object::SQLite::Tables/optimize>
988              
989             =head2 order
990              
991             This is a convenient wrapper around L<DB::Object::Query/order>
992              
993             Prepares the C<ORDER BY> clause and returns the value of the clause in list context or the C<ORDER BY> clause in full in scalar context, ie. "ORDER BY $clause"
994              
995             =head2 prefix
996              
997             Based on the prefix level, this will return a string with the database name if prefix is higher than 2, with the schema if the prefix level is higher than 1 and with the table name if the prefix level is higher than 0.
998              
999             The resulting string is used as prefix to table columns when preparing queries.
1000              
1001             =head2 prefix_database
1002              
1003             Returns true if L</prefixed> is higher than 2.
1004              
1005             =head2 prefix_schema
1006              
1007             Returns true if L</prefixed> is higher than 1.
1008              
1009             =head2 prefix_table
1010              
1011             Returns true if L</prefixed> is higher than 0.
1012              
1013             =head2 prefixed
1014              
1015             Sets or gets the prefix level. 0 being no prefix and 2 implying the use of the database name in prefix.
1016              
1017             =head2 primary
1018              
1019             This calls L</structure> which may return cached data.
1020              
1021             Returns an hash in list context and an hash reference in scalar representing column to primary keys pairs. If a column has no primary keys, its value would be empty.
1022              
1023             If nothing is found, it returns an empty list in list context and L<perlfunc/undef> in scalar context.
1024              
1025             =head2 qualified_name
1026              
1027             Returns the table name. This is read-only.
1028              
1029             =head2 query_object
1030              
1031             Returns the query object (L<DB::Object::Query>)
1032              
1033             =head2 query_reset
1034              
1035             Reset the query object (L<DB::Object::Query>)
1036              
1037             =head2 rename
1038              
1039             This must be implemented by the driver package, so check L<DB::Object::Mysql::Tables/rename>, L<DB::Object::Postgres::Tables/rename> or L<DB::Object::SQLite::Tables/rename>
1040              
1041             =head2 repair
1042              
1043             This must be implemented by the driver package, so check L<DB::Object::Mysql::Tables/repair>, L<DB::Object::Postgres::Tables/repair> or L<DB::Object::SQLite::Tables/repair>
1044              
1045             =head2 replace
1046              
1047             Just like for the C<INSERT> query, L</replace> takes one optional argument representing a L<DB::Object::Statement> C<SELECT> object or a list of field-value pairs.
1048              
1049             If a C<SELECT> statement is provided, it will be used to construct a query of the type of C<REPLACE INTO mytable SELECT FROM other_table>
1050              
1051             Otherwise the query will be C<REPLACE INTO mytable (fields) VALUES(values)>
1052              
1053             In scalar context, it execute the query and in list context it simply returns the statement handler.
1054              
1055             =head2 reset
1056              
1057             This is used to reset a prepared query to its default values. If a field is a date/time type, its default value will be set to NOW()
1058              
1059             It execute an update with the reseted value and return the number of affected rows.
1060              
1061             =head2 returning
1062              
1063             The SQL C<RETURNING> clause needs to be implemented by the driver and is currently supported only by and L<DB::Object::Postgres> (see L<DB::Object::Postgres::Query/returning>) and L<DB::Object::SQLite> (see L<DB::Object::SQLite::Query/returning>).
1064              
1065             =head2 reverse
1066              
1067             Get or set the reverse mode.
1068              
1069             =head2 schema
1070              
1071             Returns the schema name, if any. For example, with PostgreSQL, the default schema name would be C<public>.
1072              
1073             =head2 select
1074              
1075             Given an optional list of fields to fetch, L</select> prepares a C<SELECT> query.
1076              
1077             If no field was provided, L</select> will use default value where appropriate like the C<NOW()> for date/time fields.
1078              
1079             L<DB::Object::Query/select> calls upon L<DB::Object::Query/tie>, L<DB::Object::Query/where>, L<DB::Object::Query/group>, L<DB::Object::Query/order>, L<DB::Object::Query/limit>, L<DB::Object::Query/local>, and possibly more depending on the driver implementation, to build the query.
1080              
1081             In scalar context, it execute the query and return it. In list context, it just returns the statement handler.
1082              
1083             =head2 sort
1084              
1085             It toggles sort mode on and consequently disable reverse mode.
1086              
1087             =head2 stat
1088              
1089             This must be implemented by the driver package, so check L<DB::Object::Mysql::Tables/stat>, L<DB::Object::Postgres::Tables/stat> or L<DB::Object::SQLite::Tables/stat>
1090              
1091             =head2 structure
1092              
1093             The implementation is driver specific.
1094              
1095             This must be implemented by the driver package, so check L<DB::Object::Mysql::Tables/structure>, L<DB::Object::Postgres::Tables/structure> or L<DB::Object::SQLite::Tables/structure>
1096              
1097             =head2 table
1098              
1099             Returns the table name. This is read-only.
1100              
1101             =head2 tie
1102              
1103             This is a convenient wrapper around L<DB::Object::Query/tie>
1104              
1105             =head2 type
1106              
1107             The table type
1108              
1109             =head2 types
1110              
1111             This calls L</structure> which may return cached data.
1112              
1113             Returns an hash in list context and an hash reference in scalar representing column to data type.
1114              
1115             If nothing is found, it returns an empty list in list context and L<perlfunc/undef> in scalar context.
1116              
1117             =head2 types_const
1118              
1119             This calls L</structure> which may return cached data.
1120              
1121             Returns an hash in list context and an hash reference in scalar representing column to hash that defines the driver constant for this data type:
1122              
1123             some_column => { constant => 17, name => 'PG_JSONB', type => 'jsonb' }
1124              
1125             This is used to help manage binded value with the right type, or helps when converting an hash into json.
1126              
1127             If nothing is found, it returns an empty list in list context and L<perlfunc/undef> in scalar context.
1128              
1129             =head2 unix_timestamp
1130              
1131             This is a convenient wrapper around L<DB::Object::Query/unix_timestamp>
1132              
1133             =head2 unlock
1134              
1135             This must be implemented by the driver package, so check L<DB::Object::Mysql::Tables/unlock>, L<DB::Object::Postgres::Tables/unlock> or L<DB::Object::SQLite::Tables/unlock>
1136              
1137             =head2 update
1138              
1139             Given a list of field-value pairs, L</update> prepares a sql update query.
1140              
1141             It calls upon L<DB::Object::Query/where> and L<DB::Object::Query/limit> as previously set.
1142              
1143             It returns undef and sets an error if it failed to prepare the update statement. In scalar context, it execute the query. In list context, it simply return the statement handler.
1144              
1145             =head2 where
1146              
1147             This is a convenient wrapper around L<DB::Object::Query/where>
1148              
1149             =head1 AUTHOR
1150              
1151             Jacques Deguest E<lt>F<jack@deguest.jp>E<gt>
1152              
1153             =head1 SEE ALSO
1154              
1155             L<DB::Object::Mysql::Tables>, L<DB::Object::Postgres::Tables> or L<DB::Object::SQLite::Tables>
1156              
1157             =head1 AUTHOR
1158              
1159             Jacques Deguest E<lt>F<jack@deguest.jp>E<gt>
1160              
1161             =head1 COPYRIGHT & LICENSE
1162              
1163             Copyright (c) 2019-2021 DEGUEST Pte. Ltd.
1164              
1165             You can use, copy, modify and redistribute this package and associated
1166             files under the same terms as Perl itself.
1167              
1168             =cut