File Coverage

blib/lib/DBIx/Simple/Class/Schema.pm
Criterion Covered Total %
statement 144 146 98.6
branch 54 60 90.0
condition 37 47 78.7
subroutine 15 15 100.0
pod 2 2 100.0
total 252 270 93.3


line stmt bran cond sub pod time code
1             package DBIx::Simple::Class::Schema;
2 1     1   152689 use strict;
  1         3  
  1         51  
3 1     1   5 use warnings;
  1         2  
  1         31  
4 1     1   32 use 5.010001;
  1         2  
  1         34  
5 1     1   5 use Carp;
  1         9  
  1         76  
6 1     1   6 use Data::Dumper;
  1         1  
  1         405  
7 1     1   1821 use parent 'DBIx::Simple::Class';
  1         608  
  1         7  
8              
9             our $VERSION = '0.006';
10              
11              
12             *_get_obj_args = \&DBIx::Simple::Class::_get_obj_args;
13              
14             #struct to keep schemas while building
15             my $schemas = {};
16              
17             #for accessing schema structures during tests
18             sub _schemas {
19 6 50   6   30 $_[2] && ($schemas->{$_[1]} = $_[2]);
20 6 100 66     62 return $_[1] && exists $schemas->{$_[1]} ? $schemas->{$_[1]} : $schemas;
21             }
22              
23             sub _get_table_info {
24 4     4   12 my ($class, $args) = _get_obj_args(@_);
25              
26 4 50       16 $args->{namespace} || Carp::croak('Please pass "namespace" argument');
27              
28             #get tables from the current database
29             #see https://metacpan.org/module/DBI#table_info
30 4   100     15 return $schemas->{$args->{namespace}}{tables} = $class->dbh->table_info(
      100        
31             undef, undef,
32             $args->{table} || '%',
33             $args->{type} || "'TABLE','VIEW'"
34             )->fetchall_arrayref({});
35              
36             }
37              
38             sub _get_column_info {
39 4     4   11 my ($class, $tables) = @_;
40 4         17 my $dbh = $class->dbh;
41 4         23 foreach my $t (@$tables) {
42 8         931 $t->{column_info} =
43             $dbh->column_info(undef, undef, $t->{TABLE_NAME}, '%')->fetchall_arrayref({});
44              
45             #TODO support multi_column primary keys.see DSC::find()
46 8   100     19693 $t->{PRIMARY_KEY} =
47             $dbh->primary_key_info(undef, undef, $t->{TABLE_NAME})->fetchall_arrayref({})
48             ->[0]->{COLUMN_NAME} || '';
49              
50             #as child table
51 8         12127 my $sth =
52             $dbh->foreign_key_info(undef, undef, undef, undef, undef, $t->{TABLE_NAME});
53 8 50       9833 $t->{FOREIGN_KEYS} = $sth->fetchall_arrayref({}) if $sth;
54              
55             }
56 4         580 return $tables;
57             }
58              
59             #generates COLUMNS and PRIMARY_KEY
60             sub _generate_COLUMNS_ALIASES_CHECKS {
61 4     4   11 my ($class, $tables) = @_;
62              
63 4         12 foreach my $t (@$tables) {
64 8         29 $t->{COLUMNS} = [];
65 8         22 $t->{ALIASES} = {};
66 8         26 $t->{CHECKS} = {};
67 8         20 $t->{QUOTE_IDENTIFIERS} = 0;
68 8         14 foreach my $col (sort { $a->{ORDINAL_POSITION} <=> $b->{ORDINAL_POSITION} }
  86         142  
  8         48  
69             @{$t->{column_info}})
70             {
71 52         79 push @{$t->{COLUMNS}}, $col->{COLUMN_NAME};
  52         137  
72              
73             #generate ALIASES
74 52 100       546 if ($col->{COLUMN_NAME} =~ /\W/) { #not A-z0-9_
    100          
75 2   50     19 $t->{QUOTE_IDENTIFIERS} ||= 1;
76 2         7 $t->{ALIASES}{$col->{COLUMN_NAME}} = $col->{COLUMN_NAME};
77 2         15 $t->{ALIASES}{$col->{COLUMN_NAME}} =~ s/\W/_/g; #foo-bar=>foo_bar
78             }
79             elsif ($class->SUPER::can($col->{COLUMN_NAME})) {
80 2         10 $t->{ALIASES}{$col->{COLUMN_NAME}} = 'column_' . $col->{COLUMN_NAME};
81             }
82              
83             # generate CHECKS
84 52 100       238 if ($col->{IS_NULLABLE} eq 'NO') {
85 32         112 $t->{CHECKS}{$col->{COLUMN_NAME}}{required} = 1;
86 32         80 $t->{CHECKS}{$col->{COLUMN_NAME}}{defined} = 1;
87             }
88 52 100 100     7755 if ($col->{COLUMN_DEF} && $col->{COLUMN_DEF} !~ /NULL/i) {
89 20         34 my $default = $col->{COLUMN_DEF};
90 20         71 $default =~ s|\'||g;
91 20         71 $t->{CHECKS}{$col->{COLUMN_NAME}}{default} = $default;
92             }
93 52   100     264 my $size = $col->{COLUMN_SIZE} // 0;
94 52 100 66     646 if ($size >= 65535 || $size == 0) {
95 18         34 $size = '';
96             }
97 52 100       391 if ($col->{TYPE_NAME} =~ /INT/i) {
    100          
    100          
98 16         494 $t->{CHECKS}{$col->{COLUMN_NAME}}{allow} = qr/^-?\d{1,$size}$/x;
99             }
100             elsif ($col->{TYPE_NAME} =~ /FLOAT|DOUBLE|DECIMAL/i) {
101 8   100     33 my $scale = $col->{DECIMAL_DIGITS} || 0;
102 8         15 my $precision = $size - $scale;
103 8         340 $t->{CHECKS}{$col->{COLUMN_NAME}}{allow} =
104             qr/^-?\d{1,$precision}(?:\.\d{0,$scale})?$/x;
105             }
106             elsif ($col->{TYPE_NAME} =~ /CHAR|TEXT|CLOB/i) {
107             $t->{CHECKS}{$col->{COLUMN_NAME}}{allow} =
108 5 100   5   1664 sub { ($_[0] =~ /^.{1,$size}$/x) || ($_[0] eq '') }
109 24         704 }
110             } #end foreach @{$t->{column_info}
111             } #end foreach $tables
112 4         10 return $tables;
113             }
114              
115             my $_MAKE_SCHEMA;
116              
117             sub _MAKE_SCHEMA {
118 33 100   33   5346 $_MAKE_SCHEMA = $_[1] if defined $_[1];
119 33         181 return $_MAKE_SCHEMA;
120             }
121              
122             sub _generate_CODE {
123 4     4   161 my ($class, $args) = @_;
124 4         9 my $code = '';
125 4         12 my $namespace = $args->{namespace};
126 4         14 my $tables = $schemas->{$namespace}{tables};
127 4         14 $schemas->{$namespace}{code} = [];
128 4 100       18 if ($class->_MAKE_SCHEMA) {
129 2         3 push @{$schemas->{$namespace}{code}}, <<"BASE_CLASS";
  2         26  
130             package $namespace; #The schema/base class
131             use 5.010001;
132             use strict;
133             use warnings;
134             use utf8;
135             use parent qw(DBIx::Simple::Class);
136              
137             our \$VERSION = '0.01';
138             sub is_base_class{return 1}
139             sub dbix {
140              
141             # Singleton DBIx::Simple instance
142             state \$DBIx;
143             return (\$_[1] ? (\$DBIx = \$_[1]) : \$DBIx)
144             || Carp::croak('DBIx::Simple is not instantiated. Please first do '
145             . \$_[0]
146             . '->dbix(DBIx::Simple->connect(\$DSN,\$u,\$p,{...})');
147             }
148              
149             1;
150             $/$/=pod$/$/=encoding utf8$/$/=head1 NAME$/$/$namespace - the base schema class.
151             $/=head1 DESCRIPTION
152              
153             This is the base class for using table records as plain Perl objects.
154             The subclassses are:$/$/=over
155             BASE_CLASS
156             }
157 4         13 foreach my $t (@$tables) {
158 10         46 my $package =
159 8         2975 $namespace . '::' . (join '', map { ucfirst lc } split /_/, $t->{TABLE_NAME});
160 8         79 my $COLUMNS = Data::Dumper->Dump([$t->{COLUMNS}], ['$COLUMNS']);
161 8         863 my $ALIASES = Data::Dumper->Dump([$t->{ALIASES}], ['$ALIASES']);
162 8         610 my $CHECKS = Data::Dumper->Dump([$t->{CHECKS}], ['$CHECKS']);
163 8         2351 my $TABLE = Data::Dumper->Dump([$t->{TABLE_NAME}], ['$TABLE_NAME']);
164 8         350 my $name_description =
165             "A class for $t->{TABLE_TYPE} $t->{TABLE_NAME} in schema $t->{TABLE_SCHEM}";
166 8 100       23 $schemas->{$namespace}{code}[0] .= qq|$/=item L<$package> - $name_description$/|
167             if $class->_MAKE_SCHEMA;
168 8         310 push @{$schemas->{$namespace}{code}}, qq|package $package; #A table/row class
  52         302  
169             use 5.010001;
170             use strict;
171             use warnings;
172             use utf8;
173             use parent qw($namespace);
174             | . qq|
175             sub is_base_class{return 0}
176             my $TABLE
177             sub TABLE {return \$TABLE_NAME}| . qq|
178             sub PRIMARY_KEY{return '$t->{PRIMARY_KEY}'}
179             my $COLUMNS
180             sub COLUMNS {return \$COLUMNS}
181             my $ALIASES
182             sub ALIASES {return \$ALIASES}
183             my $CHECKS
184             sub CHECKS {return \$CHECKS}
185              
186             __PACKAGE__->QUOTE_IDENTIFIERS($t->{QUOTE_IDENTIFIERS});
187             #__PACKAGE__->BUILD;#build accessors during load
188              
189             1;
190             | . qq|$/=pod$/$/=encoding utf8$/$/=head1 NAME$/$/$name_description
191              
192             | . qq|=head1 SYNOPSIS$/$/=head1 DESCRIPTION$/$/=head1 COLUMNS$/
193             Each column from table C<$t->{TABLE_NAME}> has an accessor method in this class.
194             |
195 8         14 . (join '', map { $/ . '=head2 ' . $_ . $/ } @{$t->{COLUMNS}})
  8         22  
196             . qq|$/=head1 ALIASES$/$/=head1 GENERATOR$/$/L<$class>$/$/=head1 SEE ALSO$/|
197             . qq|L<$namespace>, L, L<$class>
198             $/=head1 AUTHOR$/$/$ENV{USER}$/$/=cut
199             |;
200             } # end foreach my $t (@$tables)
201              
202 4 100       2907 $schemas->{$namespace}{code}[0] .= qq|$/=back$/$/=head1 GENERATOR$/$/L<$class>
203             $/$/=head1 SEE ALSO$/$/
204             L<$class>, L, L, L
205             $/=head1 AUTHOR$/$/$ENV{USER}$/$/=cut
206             | if $class->_MAKE_SCHEMA;
207 4 100       2072 if (defined wantarray) {
208 3 100       15 if (wantarray) {
209 1         2 return @{$schemas->{$namespace}{code}};
  1         10  
210             }
211             else {
212 2         5 return join '', @{$schemas->{$namespace}{code}};
  2         51  
213             }
214             }
215 1         6 return;
216             }
217              
218             sub load_schema {
219 4     4 1 38 my ($class, $args) = _get_obj_args(@_);
220 4 100       18 unless ($args->{namespace}) {
221 2         14 $args->{namespace} = $class->dbh->{Name};
222 2 50       53 if ($args->{namespace} =~ /(database|dbname|db)=([^;]+);?/x) {
223 2         7 $args->{namespace} = $2;
224             }
225 2         14 $args->{namespace} =~ s/\W//xg;
226 2         13 $args->{namespace} =
227 2         8 'DSCS::' . (join '', map { ucfirst lc } split /_/, $args->{namespace});
228             }
229              
230 4         18 my $tables = $class->_get_table_info($args);
231              
232             #get table columns, PRIMARY_KEY, foreign keys
233 4         3308 $class->_get_column_info($tables);
234              
235             #generate COLUMNS, ALIASES, CHECKS
236 4         32 $class->_generate_COLUMNS_ALIASES_CHECKS($tables);
237 4   66     58 $class->_MAKE_SCHEMA(($args->{table} eq '%') or (not $args->{table}));
238              
239             #generate code
240 4 100       15 if (wantarray) {
241 1         5 return ($class->_generate_CODE($args));
242             }
243 3         55 return $class->_generate_CODE($args);
244             }
245              
246              
247             sub dump_schema_at {
248 8     8 1 3522 my ($class, $args) = _get_obj_args(@_);
249 8   66     54 $args->{lib_root} ||= $INC[0];
250 8         13 my ($namespace, @namespace, @base_path, $schema_path);
251              
252             #_generate_CODE() should be called by now
253             #we always have only one key
254 8   66     450 $namespace = (keys %$schemas)[0]
255             || Carp::croak('Please first call ' . __PACKAGE__ . '->load_schema()!');
256              
257 7         68 require File::Path;
258 7         81 require File::Spec;
259 7         939 require IO::File;
260 7         10979 @namespace = split /::/, $namespace;
261 7         84 @base_path = File::Spec->splitdir($args->{lib_root});
262              
263 7         81 $schema_path = File::Spec->catdir(@base_path, @namespace);
264              
265 7 100 100     564 if (eval "require $namespace" && $class->_MAKE_SCHEMA) {
266 4         709 carp( "Module $namespace is already installed at "
267             . $INC{join('/', @namespace) . '.pm'}
268             . ". Please avoid namespace collisions...");
269             }
270 7         3241 say('Will dump classes at ' . $args->{lib_root});
271              
272             #We should be able to continue safely now...
273 7         33 my $tables = $schemas->{$namespace}{tables};
274 7         19 my $code = $schemas->{$namespace}{code};
275 7 100       232 if (!-d $schema_path) {
276 2 50 0     6 eval { File::Path::make_path($schema_path); }
  2         554  
277             || carp("Can not make path $schema_path.$/$!. Quitting...") && return;
278             }
279              
280 7 100       30 if ($class->_MAKE_SCHEMA) {
281 5 100 100     27 carp("Overwriting $schema_path.pm...") if $args->{overwrite} && $class->DEBUG;
282 5   33     578 my $base_fh = IO::File->new("> $schema_path.pm")
283             || Carp::croak("Could not open $schema_path.pm for writing" . $!);
284 5         774 print $base_fh $code->[0];
285 5         23 $base_fh->close;
286             }
287              
288 7         282 foreach my $i (0 .. @$tables - 1) {
289 28         97 my $filename =
290 21         462 (join '', map { ucfirst lc } split /_/, $tables->[$i]{TABLE_NAME}) . '.pm';
291 21 100 100     655 next if (-f "$schema_path/$filename" && !$args->{overwrite});
292 12 100 100     73 carp("Overwriting $schema_path/$filename...")
293             if $args->{overwrite} && $class->DEBUG;
294 12         1470 my $fh = IO::File->new("> $schema_path/$filename");
295 12 50       1371 if (defined $fh) {
296 12         86 print $fh $code->[$i + 1];
297 12         37 $fh->close;
298             }
299             else {
300 0         0 carp("$schema_path/$filename: $!. Quitting!");
301 0         0 return;
302             }
303             }
304 7         224 return 1;
305             }
306              
307             1;
308              
309              
310             =encoding utf8
311              
312             =head1 NAME
313              
314             DBIx::Simple::Class::Schema - Create and use classes representing tables from a database
315              
316             =head1 SYNOPSIS
317              
318             #Somewhere in a utility script or startup() of your application.
319             DBIx::Simple::Class::Schema->dbix(DBIx::Simple->connect(...));
320             my $perl_code = DBIx::Simple::Class::Schema->load_schema(
321             namespace =>'My::Model',
322             table => '%', #all tables from the current database
323             type => "'TABLE','VIEW'", # make classes for tables and views
324             );
325              
326             #Now eval() to use your classes.
327             eval $perl_code || Carp::croak($@);
328              
329              
330             #Or load and save it for more customisations and later usage.
331             DBIx::Simple::Class::Schema->load_schema(
332             namespace =>'My::Model',
333             table => '%', #all tables from the current database
334             type => "'TABLE','VIEW'", # make classes for tables and views
335             );
336             DBIx::Simple::Class::Schema->dump_schema_at(
337             lib_root => "$ENV{PERL_LOCAL_LIB_ROOT}/lib"
338             overwrite =>1 #overwrite existing files
339             ) || Carp::croak 'Something went wrong! See above...';
340              
341              
342             =head1 DESCRIPTION
343              
344             DBIx::Simple::Class::Schema automates the creation of classes from
345             database tables. You can use it when you want to prototype quickly
346             your application. It is also very convenient as an initial generator and dumper of
347             your classes representing your database tables.
348              
349             =head1 METHODS
350              
351             =head2 load_schema
352              
353             Class method.
354              
355             Params:
356             namespace - String. The class name for your base class,
357             default: 'DSCS::'.(join '', map { ucfirst lc } split /_/, $database)
358             table - SQL string for a LIKE clause,
359             default: '%'
360             type - SQL String for an IN clause.
361             default: "'TABLE','VIEW'"
362              
363             Extracts tables' information from the current connection and generates
364             Perl classes representing those tables or/and views.
365             If called in list context returns an array with perl code for each package.
366             The first package is the base class. The base class is generated only the argument C is '%' or empty.
367             If called in scalar context returns all the generated code as a string.
368              
369             The generated classes are saved internally and are available for use by
370             L.
371             This makes it very convenient for quickly prototyping applications
372             by just modifying tables in your database.
373              
374             my $perl_code = DBIx::Simple::Class::Schema->load_schema();
375             #concatenaded code as one string
376             eval $perl_code || Carp::croak($@);
377             #...
378             my $user = Dbname::User->find(2345);
379            
380             #or My::Schema, My::Schema::Table1, My::Schema::Table2,...
381             my @perl_code = DBIx::Simple::Class::Schema->load_schema();
382            
383             #or just prepare code before dumping it to disk.
384             DBIx::Simple::Class::Schema->load_schema();
385              
386             =head2 dump_schema_at
387              
388             Class method.
389              
390             Params:
391             lib_root: String - Where classes will be dumped.
392             default: $INC[0]
393             overwrite: boolean -1/0 Should it overwrite existing classes with the same name?
394             default: 0
395              
396             Uses the generated code by L and saves each class on the disk.
397             Does several checks:
398              
399             =over
400              
401             =item *
402              
403             Checks if a file with the name of your base class exists and exits
404             if the flag C is not set.
405              
406             =item *
407              
408             The base class is dumped to disk only if the argument C is '%' or empty.
409             It was not generated in L.
410             In other words base/schema class is generated when no specific table class is
411             required to be generated. This is convinient if you want to generate only specific table-classes and use them on-the-fly without dumping them to disk.
412              
413             =item *
414              
415             Checks if there is a module with the same name as your base class installed
416             and warns if there is such module. This is done to avoid namespace collisions.
417              
418             =item *
419              
420             Checks if the files can be written to disk and exit immediately if there is a problem.
421              
422             =back
423              
424             For every check above issues a warning so you, the developer, can decide what to do.
425             Returns true on success.
426              
427             =head1 SUPPORTED DATABASE DRIVERS
428              
429             DBIx::Simple::Class::Schema strives to be DBD agnostic and
430             uses only functionality specified by L.
431             This means that if a driver implements the methods specifyed in L it is supported.
432             However currently only tests for L and L are written.
433             Feel free to contribute with tests for your prefered driver.
434             The following methods are used to retreive information form the database:
435              
436             =over
437              
438             =item * L
439              
440             =item * L
441              
442             =item * L
443              
444             =back
445              
446             =head1 SUPPORTED SQL TYPES
447              
448             Currently some minimal L are automatically generated for TYPE_NAMEs
449             matching C,C, C.
450             You are supposed to write your own business-specific checks.
451              
452              
453             =head1 SEE ALSO
454              
455             L, L, L,
456             L
457              
458             =head1 LICENSE AND COPYRIGHT
459              
460             Copyright 2012-2013 Красимир Беров (Krasimir Berov).
461              
462             This program is free software, you can redistribute it and/or modify it under
463             the terms of the Artistic License version 2.0.
464              
465             See http://www.opensource.org/licenses/artistic-license-2.0 for more information.
466              
467             =cut
468