File Coverage

blib/lib/DBIx/DBSchema.pm
Criterion Covered Total %
statement 21 125 16.8
branch 0 34 0.0
condition 0 6 0.0
subroutine 7 21 33.3
pod 13 13 100.0
total 41 199 20.6


line stmt bran cond sub pod time code
1             package DBIx::DBSchema;
2              
3 1     1   595 use strict;
  1         6  
  1         29  
4 1     1   549 use Storable;
  1         2977  
  1         81  
5 1     1   490 use DBIx::DBSchema::_util qw(_load_driver _dbh _parse_opt);
  1         3  
  1         79  
6 1     1   583 use DBIx::DBSchema::Table 0.12;
  1         21  
  1         33  
7 1     1   7 use DBIx::DBSchema::Index;
  1         1  
  1         18  
8 1     1   4 use DBIx::DBSchema::Column;
  1         2  
  1         66  
9 1     1   6 use DBIx::DBSchema::ForeignKey;
  1         1  
  1         1587  
10              
11             our $VERSION = '0.47';
12             $VERSION = eval $VERSION; # modperlstyle: convert the string into a number
13              
14             our $DEBUG = 0;
15              
16             our $errstr;
17              
18             =head1 NAME
19              
20             DBIx::DBSchema - Database-independent schema objects
21              
22             =head1 SYNOPSIS
23              
24             use DBIx::DBSchema;
25              
26             $schema = new DBIx::DBSchema @dbix_dbschema_table_objects;
27             $schema = new_odbc DBIx::DBSchema $dbh;
28             $schema = new_odbc DBIx::DBSchema $dsn, $user, $pass;
29             $schema = new_native DBIx::DBSchema $dbh;
30             $schema = new_native DBIx::DBSchema $dsn, $user, $pass;
31              
32             $schema->save("filename");
33             $schema = load DBIx::DBSchema "filename" or die $DBIx::DBSchema::errstr;
34              
35             $schema->addtable($dbix_dbschema_table_object);
36              
37             @table_names = $schema->tables;
38              
39             $DBIx_DBSchema_table_object = $schema->table("table_name");
40              
41             @sql = $schema->sql($dbh);
42             @sql = $schema->sql($dsn, $username, $password);
43             @sql = $schema->sql($dsn); #doesn't connect to database - less reliable
44              
45             $perl_code = $schema->pretty_print;
46             %hash = eval $perl_code;
47             use DBI qw(:sql_types); $schema = pretty_read DBIx::DBSchema \%hash;
48              
49             =head1 DESCRIPTION
50              
51             DBIx::DBSchema objects are collections of DBIx::DBSchema::Table objects and
52             represent a database schema.
53              
54             This module implements an OO-interface to database schemas. Using this module,
55             you can create a database schema with an OO Perl interface. You can read the
56             schema from an existing database. You can save the schema to disk and restore
57             it in a different process. You can write SQL CREATE statements statements for
58             different databases from a single source. You can transform one schema to
59             another, adding any necessary new columns, tables, indices and foreign keys.
60              
61             Currently supported databases are MySQL, PostgreSQL and SQLite. Sybase and
62             Oracle drivers are partially implemented. DBIx::DBSchema will attempt to use
63             generic SQL syntax for other databases. Assistance adding support for other
64             databases is welcomed. See L, "Driver Writer's Guide and
65             Base Class".
66              
67             =head1 METHODS
68              
69             =over 4
70              
71             =item new TABLE_OBJECT, TABLE_OBJECT, ...
72              
73             Creates a new DBIx::DBSchema object.
74              
75             =cut
76              
77             sub new {
78 0     0 1   my($proto, @tables) = @_;
79 0           my %tables = map { $_->name, $_ } @tables; #check for duplicates?
  0            
80              
81 0   0       my $class = ref($proto) || $proto;
82 0           my $self = {
83             'tables' => \%tables,
84             };
85              
86 0           bless ($self, $class);
87              
88             }
89              
90             =item new_odbc DATABASE_HANDLE | DATA_SOURCE USERNAME PASSWORD [ ATTR ]
91              
92             Creates a new DBIx::DBSchema object from an existing data source, which can be
93             specified by passing an open DBI database handle, or by passing the DBI data
94             source name, username, and password. This uses the experimental DBI type_info
95             method to create a schema with standard (ODBC) SQL column types that most
96             closely correspond to any non-portable column types. Use this to import a
97             schema that you wish to use with many different database engines. Although
98             primary key and (unique) index information will only be read from databases
99             with DBIx::DBSchema::DBD drivers (currently MySQL and PostgreSQL), import of
100             column names and attributes *should* work for any database. Note that this
101             method only uses "ODBC" column types; it does not require or use an ODBC
102             driver.
103              
104             =cut
105              
106             sub new_odbc {
107 0     0 1   my($proto, $dbh) = ( shift, _dbh(@_) );
108             $proto->new(
109 0           map { new_odbc DBIx::DBSchema::Table $dbh, $_ } _tables_from_dbh($dbh)
  0            
110             );
111             }
112              
113             =item new_native DATABASE_HANDLE | DATA_SOURCE USERNAME PASSWORD [ ATTR ]
114              
115             Creates a new DBIx::DBSchema object from an existing data source, which can be
116             specified by passing an open DBI database handle, or by passing the DBI data
117             source name, username and password. This uses database-native methods to read
118             the schema, and will preserve any non-portable column types. The method is
119             only available if there is a DBIx::DBSchema::DBD for the corresponding database engine (currently, MySQL and PostgreSQL).
120              
121             =cut
122              
123             sub new_native {
124 0     0 1   my($proto, $dbh) = (shift, _dbh(@_) );
125             $proto->new(
126 0           map { new_native DBIx::DBSchema::Table ( $dbh, $_ ) } _tables_from_dbh($dbh)
  0            
127             );
128             }
129              
130             =item load FILENAME
131              
132             Loads a DBIx::DBSchema object from a file. If there is an error, returns
133             false and puts an error message in $DBIx::DBSchema::errstr;
134              
135             =cut
136              
137             sub load {
138 0     0 1   my($proto,$file)=@_; #use $proto ?
139              
140 0           my $self;
141              
142             #first try Storable
143 0           eval { $self = Storable::retrieve($file); };
  0            
144              
145 0 0 0       if ( $@ && $@ =~ /not.*storable/i ) { #then try FreezeThaw
146 0           my $olderror = $@;
147              
148 0           eval "use FreezeThaw;";
149 0 0         if ( $@ ) {
150 0           $@ = $olderror;
151             } else {
152             open(FILE,"<$file")
153 0 0         or do { $errstr = "Can't open $file: $!"; return ''; };
  0            
  0            
154 0           my $string = join('',);
155             close FILE
156 0 0         or do { $errstr = "Can't close $file: $!"; return ''; };
  0            
  0            
157 0           ($self) = FreezeThaw::thaw($string);
158             }
159             }
160              
161 0 0         unless ( $self ) {
162 0           $errstr = $@;
163             }
164              
165 0           $self;
166              
167             }
168              
169             =item save FILENAME
170              
171             Saves a DBIx::DBSchema object to a file.
172              
173             =cut
174              
175             sub save {
176             #my($self, $file) = @_;
177 0     0 1   Storable::nstore(@_);
178             }
179              
180             =item addtable TABLE_OBJECT
181              
182             Adds the given DBIx::DBSchema::Table object to this DBIx::DBSchema.
183              
184             =cut
185              
186             sub addtable {
187 0     0 1   my($self,$table)=@_;
188 0           $self->{'tables'}->{$table->name} = $table; #check for dupliates?
189             }
190              
191             =item tables
192              
193             Returns a list of the names of all tables.
194              
195             =cut
196              
197             sub tables {
198 0     0 1   my($self)=@_;
199 0           keys %{$self->{'tables'}};
  0            
200             }
201              
202             =item table TABLENAME
203              
204             Returns the specified DBIx::DBSchema::Table object.
205              
206             =cut
207              
208             sub table {
209 0     0 1   my($self,$table)=@_;
210 0           $self->{'tables'}->{$table};
211             }
212              
213             =item sql [ DATABASE_HANDLE | DATA_SOURCE [ USERNAME PASSWORD [ ATTR ] ] ]
214              
215             Returns a list of SQL `CREATE' statements for this schema.
216              
217             The data source can be specified by passing an open DBI database handle, or by
218             passing the DBI data source name, username and password.
219              
220             Although the username and password are optional, it is best to call this method
221             with a database handle or data source including a valid username and password -
222             a DBI connection will be opened and used to check the database version as well
223             as for more reliable quoting and type mapping. Note that the database
224             connection will be used passively, B to actually run the CREATE
225             statements.
226              
227             If passed a DBI data source (or handle) such as `DBI:mysql:database' or
228             `DBI:Pg:dbname=database', will use syntax specific to that database engine.
229             Currently supported databases are MySQL and PostgreSQL.
230              
231             If not passed a data source (or handle), or if there is no driver for the
232             specified database, will attempt to use generic SQL syntax.
233              
234             =cut
235              
236             sub sql {
237 0     0 1   my($self, $dbh) = ( shift, _dbh(@_) );
238             (
239 0           ( map { $self->table($_)->sql_create_table($dbh); } $self->tables ),
240 0           ( map { $self->table($_)->sql_add_constraints($dbh); } $self->tables ),
  0            
241             );
242             }
243              
244             =item sql_update_schema [ OPTIONS_HASHREF, ] PROTOTYPE_SCHEMA [ DATABASE_HANDLE | DATA_SOURCE [ USERNAME PASSWORD [ ATTR ] ] ]
245              
246             Returns a list of SQL statements to update this schema so that it is idential
247             to the provided prototype schema, also a DBIx::DBSchema object.
248              
249             Right now this method knows how to add new tables and alter existing tables,
250             including indices. If specifically requested by passing an options hashref
251             with B set true before all other arguments, it will also drop
252             tables.
253              
254             See L,
255             L and
256             L for additional specifics and
257             limitations.
258              
259             The data source can be specified by passing an open DBI database handle, or by
260             passing the DBI data source name, username and password.
261              
262             Although the username and password are optional, it is best to call this method
263             with a database handle or data source including a valid username and password -
264             a DBI connection will be opened and used to check the database version as well
265             as for more reliable quoting and type mapping. Note that the database
266             connection will be used passively, B to actually run the CREATE
267             statements.
268              
269             If passed a DBI data source (or handle) such as `DBI:mysql:database' or
270             `DBI:Pg:dbname=database', will use syntax specific to that database engine.
271             Currently supported databases are MySQL and PostgreSQL.
272              
273             If not passed a data source (or handle), or if there is no driver for the
274             specified database, will attempt to use generic SQL syntax.
275              
276             =cut
277              
278             #gosh, false laziness w/DBSchema::Table::sql_alter_schema
279              
280             sub sql_update_schema {
281 0     0 1   my($self, $opt, $new, $dbh) = ( shift, _parse_opt(\@_), shift, _dbh(@_) );
282              
283 0           my @r = ();
284 0           my @later = ();
285              
286 0           foreach my $table ( $new->tables ) {
287            
288 0 0         if ( $self->table($table) ) {
289            
290 0 0         warn "$table exists\n" if $DEBUG > 1;
291              
292 0           push @r,
293             $self->table($table)->sql_alter_table( $new->table($table),
294             $dbh, $opt );
295 0           push @later,
296             $self->table($table)->sql_alter_constraints( $new->table($table),
297             $dbh, $opt );
298              
299             } else {
300            
301 0 0         warn "table $table does not exist.\n" if $DEBUG;
302              
303 0           push @r, $new->table($table)->sql_create_table( $dbh );
304 0           push @later, $new->table($table)->sql_add_constraints( $dbh );
305            
306             }
307            
308             }
309              
310 0 0         if ( $opt->{'drop_tables'} ) {
311              
312 0 0         warn "drop_tables enabled\n" if $DEBUG;
313              
314             # drop tables not in $new
315 0           foreach my $table ( grep !$new->table($_), $self->tables ) {
316              
317 0 0         warn "table $table should be dropped.\n" if $DEBUG;
318              
319 0           push @r, $self->table($table)->sql_drop_table( $dbh );
320              
321             }
322              
323             }
324              
325 0           push @r, @later;
326              
327 0 0         warn join("\n", @r). "\n"
328             if $DEBUG > 1;
329              
330 0           @r;
331            
332             }
333              
334             =item update_schema [ OPTIONS_HASHREF, ] PROTOTYPE_SCHEMA, DATABASE_HANDLE | DATA_SOURCE [ USERNAME PASSWORD [ ATTR ] ]
335              
336             Same as sql_update_schema, except actually runs the SQL commands to update
337             the schema. Throws a fatal error if any statement fails.
338              
339             =cut
340              
341             sub update_schema {
342             #my($self, $new, $dbh) = ( shift, shift, _dbh(@_) );
343 0     0 1   my($self, $opt, $new, $dbh) = ( shift, _parse_opt(\@_), shift, _dbh(@_) );
344              
345 0           foreach my $statement ( $self->sql_update_schema( $opt, $new, $dbh ) ) {
346 0 0         $dbh->do( $statement )
347             or die "Error: ". $dbh->errstr. "\n executing: $statement";
348             }
349              
350             }
351              
352             =item pretty_print
353              
354             Returns the data in this schema as Perl source, suitable for assigning to a
355             hash.
356              
357             =cut
358              
359             sub pretty_print {
360 0     0 1   my($self) = @_;
361              
362             join("},\n\n",
363             map {
364 0           my $tablename = $_;
  0            
365 0           my $table = $self->table($tablename);
366 0           my %indices = $table->indices;
367              
368             "'$tablename' => {\n".
369             " 'columns' => [\n".
370             join("", map {
371             #cant because -w complains about , in qw()
372             # (also biiiig problems with empty lengths)
373             #" qw( $_ ".
374             #$table->column($_)->type. " ".
375             #( $table->column($_)->null ? 'NULL' : 0 ). " ".
376             #$table->column($_)->length. " ),\n"
377             " '$_', ".
378             "'". $table->column($_)->type. "', ".
379             "'". $table->column($_)->null. "', ".
380             "'". $table->column($_)->length. "', ".
381              
382             ( ref($table->column($_)->default)
383 0 0         ? "\\'". ${ $table->column($_)->default }. "'"
  0            
384             : "'". $table->column($_)->default. "'"
385             ).', '.
386              
387             "'". $table->column($_)->local. "',\n"
388             } $table->columns
389             ).
390             " ],\n".
391             " 'primary_key' => '". $table->primary_key. "',\n".
392              
393             #old style index representation..
394              
395             (
396             $table->{'unique'} # $table->_unique
397             ? " 'unique' => [ ". join(', ',
398 0           map { "[ '". join("', '", @{$_}). "' ]" }
  0            
399 0           @{$table->_unique->lol_ref}
400             ). " ],\n"
401             : ''
402             ).
403              
404             ( $table->{'index'} # $table->_index
405             ? " 'index' => [ ". join(', ',
406 0           map { "[ '". join("', '", @{$_}). "' ]" }
  0            
407 0           @{$table->_index->lol_ref}
408             ). " ],\n"
409             : ''
410             ).
411              
412             #new style indices
413             " 'indices' => { ". join( ",\n ",
414              
415 0           map { my $iname = $_;
416 0           my $index = $indices{$iname};
417             "'$iname' => { \n".
418             ( $index->using
419             ? " 'using' => '". $index->using ."',\n"
420             : ''
421             ).
422             " 'unique' => ". $index->unique .",\n".
423             " 'columns' => [ '".
424 0 0         join("', '", @{$index->columns} ).
  0            
425             "' ],\n".
426             " },\n";
427             }
428             keys %indices
429              
430             ). "\n }, \n".
431              
432             #foreign_keys
433             " 'foreign_keys' => [ ". join( ",\n ",
434              
435 0 0         map { my $name = $_->constraint;
  0 0          
436 0           "'$name' => { \n".
437             " },\n";
438             }
439             $table->foreign_keys
440              
441             ). "\n ], \n"
442              
443             ;
444              
445             } $self->tables
446             ). "}\n";
447             }
448              
449             =item pretty_read HASHREF
450              
451             This method is B recommended. If you need to load and save your schema
452             to a file, see the L and L methods.
453              
454             Creates a schema as specified by a data structure such as that created by
455             B method.
456              
457             =cut
458              
459             sub pretty_read {
460 0     0 1   my($proto, $href) = @_;
461              
462             my $schema = $proto->new( map {
463              
464 0           my $tablename = $_;
465 0           my $info = $href->{$tablename};
466              
467 0           my @columns;
468 0           while ( @{$info->{'columns'}} ) {
  0            
469             push @columns, DBIx::DBSchema::Column->new(
470 0           splice @{$info->{'columns'}}, 0, 6
  0            
471             );
472             }
473              
474             DBIx::DBSchema::Table->new({
475             'name' => $tablename,
476             'primary_key' => $info->{'primary_key'},
477             'columns' => \@columns,
478              
479             #indices
480 0           'indices' => [ map { my $idx_info = $info->{'indices'}{$_};
481             DBIx::DBSchema::Index->new({
482             'name' => $_,
483             #'using' =>
484             'unique' => $idx_info->{'unique'},
485 0           'columns' => $idx_info->{'columns'},
486             });
487             }
488 0           keys %{ $info->{'indices'} }
  0            
489             ],
490             } );
491              
492 0           } (keys %{$href}) );
  0            
493              
494             }
495              
496             # private subroutines
497              
498             sub _tables_from_dbh {
499 0     0     my($dbh) = @_;
500 0           my $driver = _load_driver($dbh);
501 0           my $driver_class = "DBIx::DBSchema::DBD::$driver";
502 0           $driver_class->tables($dbh);
503             }
504              
505             =back
506              
507             =head1 AUTHORS
508              
509             Ivan Kohler
510              
511             Charles Shapiro and Mitchell Friedman
512             contributed the start of a Sybase driver.
513              
514             Daniel Hanks contributed the Oracle driver.
515              
516             Jesse Vincent contributed the SQLite driver and fixes to quiet down
517             internal usage of the old API.
518              
519             Slaven Rezic contributed column and table dropping, Pg
520             bugfixes and more.
521              
522             Nathan Anderson contribued updates to the
523             SQLite and Sybase drivers.
524              
525             =head1 CONTRIBUTIONS
526              
527             Contributions are welcome! I'm especially keen on any interest in the top
528             items/projects below under BUGS.
529              
530             =head1 REPOSITORY
531              
532             The code is available from our public git repository:
533              
534             git clone git://git.freeside.biz/DBIx-DBSchema.git
535              
536             Or on the web:
537              
538             http://freeside.biz/gitweb/?p=DBIx-DBSchema.git
539             Or:
540             http://freeside.biz/gitlist/DBIx-DBSchema.git
541              
542             =head1 COPYRIGHT
543              
544             Copyright (c) 2000-2007 Ivan Kohler
545             Copyright (c) 2000 Mail Abuse Prevention System LLC
546             Copyright (c) 2007-2017 Freeside Internet Services, Inc.
547             All rights reserved.
548             This program is free software; you can redistribute it and/or modify it under
549             the same terms as Perl itself.
550              
551             =head1 BUGS AND TODO
552              
553             Multiple primary keys are not yet supported.
554              
555             Foreign keys: need to support dropping, NOT VALID, reverse engineering w/mysql
556              
557             Need to port and test with additional databases
558              
559             Each DBIx::DBSchema object should have a name which corresponds to its name
560             within the SQL database engine (DBI data source).
561              
562             Need to support "using" index attribute in pretty_read and in reverse
563             engineering
564              
565             sql CREATE TABLE output should convert integers
566             (i.e. use DBI qw(:sql_types);) to local types using DBI->type_info plus a hash
567             to fudge things
568              
569             =head2 PRETTY_ BUGS
570              
571             pretty_print is actually pretty ugly.
572              
573             pretty_print isn't so good about quoting values... save/load is a much better
574             alternative to using pretty_print/pretty_read
575              
576             pretty_read is pretty ugly too.
577              
578             pretty_read should *not* create and pass in old-style unique/index indices
579             when nothing is given in the read.
580              
581             Perhaps pretty_read should eval column types so that we can use DBI
582             qw(:sql_types) here instead of externally.
583              
584             perhaps we should just get rid of pretty_read entirely. pretty_print is useful
585             for debugging, but pretty_read is pretty bunk.
586              
587             =head1 SEE ALSO
588              
589             L, L,
590             L, L,
591             L, L, L,
592             L
593              
594             =cut
595              
596             1;
597