DBSchema.pm

   1 package DBIx::DBSchema;
   2
   3 use strict;
   4 use Storable;
   5 use DBIx::DBSchema::_util qw(_load_driver _dbh _parse_opt);
   6 use DBIx::DBSchema::Table 0.08;
   7 use DBIx::DBSchema::Index;
   8 use DBIx::DBSchema::Column;
   9 use DBIx::DBSchema::ForeignKey;
  10
  11 our $VERSION = '0.43_01';
  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<DBIx::DBSchema::DBD>, "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   my($proto, @tables) = @_;
  79   my %tables = map  { $_->name, $_ } @tables; #check for duplicates?
  80
  81   my $class = ref($proto) || $proto;
  82   my $self = {
  83     'tables' => \%tables,
  84   };
  85
  86   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   my($proto, $dbh) = ( shift, _dbh(@_) );
 108   $proto->new(
 109     map { new_odbc DBIx::DBSchema::Table $dbh, $_ } _tables_from_dbh($dbh)
 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   my($proto, $dbh) = (shift, _dbh(@_) );
 125   $proto->new(
 126     map { new_native DBIx::DBSchema::Table ( $dbh, $_ ) } _tables_from_dbh($dbh)
 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   my($proto,$file)=@_; #use $proto ?
 139
 140   my $self;
 141
 142   #first try Storable
 143   eval { $self = Storable::retrieve($file); };
 144
 145   if ( $@ && $@ =~ /not.*storable/i ) { #then try FreezeThaw
 146     my $olderror = $@;
 147
 148     eval "use FreezeThaw;";
 149     if ( $@ ) {
 150       $@ = $olderror;
 151     } else {
 152       open(FILE,"<$file")
 153         or do { $errstr = "Can't open $file: $!"; return ''; };
 154       my $string = join('',<FILE>);
 155       close FILE
 156         or do { $errstr = "Can't close $file: $!"; return ''; };
 157       ($self) = FreezeThaw::thaw($string);
 158     }
 159   }
 160
 161   unless ( $self ) {
 162     $errstr = $@;
 163   }
 164
 165   $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   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   my($self,$table)=@_;
 188   $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   my($self)=@_;
 199   keys %{$self->{'tables'}};
 200 }
 201
 202 =item table TABLENAME
 203
 204 Returns the specified DBIx::DBSchema::Table object.
 205
 206 =cut
 207
 208 sub table {
 209   my($self,$table)=@_;
 210   $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<not> 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   my($self, $dbh) = ( shift, _dbh(@_) );
 238   map { $self->table($_)->sql_create_table($dbh); } $self->tables;
 239 }
 240
 241 =item sql_update_schema [ OPTIONS_HASHREF, ] PROTOTYPE_SCHEMA [ DATABASE_HANDLE | DATA_SOURCE [ USERNAME PASSWORD [ ATTR ] ] ]
 242
 243 Returns a list of SQL statements to update this schema so that it is idential
 244 to the provided prototype schema, also a DBIx::DBSchema object.
 245
 246 Right now this method knows how to add new tables and alter existing tables,
 247 including indices.  If specifically requested by passing an options hashref
 248 with B<drop_tables> set true before all other arguments, it will also drop
 249 tables.
 250
 251 See L<DBIx::DBSchema::Table/sql_alter_table>,
 252 L<DBIx::DBSchema::Column/sql_add_column> and
 253 L<DBIx::DBSchema::Column/sql_alter_column> for additional specifics and
 254 limitations.
 255
 256 The data source can be specified by passing an open DBI database handle, or by
 257 passing the DBI data source name, username and password.
 258
 259 Although the username and password are optional, it is best to call this method
 260 with a database handle or data source including a valid username and password -
 261 a DBI connection will be opened and used to check the database version as well
 262 as for more reliable quoting and type mapping.  Note that the database
 263 connection will be used passively, B<not> to actually run the CREATE
 264 statements.
 265
 266 If passed a DBI data source (or handle) such as `DBI:mysql:database' or
 267 `DBI:Pg:dbname=database', will use syntax specific to that database engine.
 268 Currently supported databases are MySQL and PostgreSQL.
 269
 270 If not passed a data source (or handle), or if there is no driver for the
 271 specified database, will attempt to use generic SQL syntax.
 272
 273 =cut
 274
 275 #gosh, false laziness w/DBSchema::Table::sql_alter_schema
 276
 277 sub sql_update_schema {
 278   my($self, $opt, $new, $dbh) = ( shift, _parse_opt(\@_), shift, _dbh(@_) );
 279
 280   my @r = ();
 281
 282   foreach my $table ( $new->tables ) {
 283
 284     if ( $self->table($table) ) {
 285
 286       warn "$table exists\n" if $DEBUG > 1;
 287
 288       push @r, $self->table($table)->sql_alter_table( $new->table($table),
 289                                                       $dbh,
 290                                                       $opt
 291                                                     );
 292
 293     } else {
 294
 295       warn "table $table does not exist.\n" if $DEBUG;
 296
 297       push @r,
 298         $new->table($table)->sql_create_table( $dbh );
 299
 300     }
 301
 302   }
 303
 304   if ( $opt->{'drop_tables'} ) {
 305
 306     warn "drop_tables enabled\n" if $DEBUG;
 307
 308     # drop tables not in $new
 309     foreach my $table ( grep !$new->table($_), $self->tables ) {
 310
 311       warn "table $table should be dropped.\n" if $DEBUG;
 312
 313       push @r, $self->table($table)->sql_drop_table( $dbh );
 314
 315     }
 316
 317   }
 318
 319   warn join("\n", @r). "\n"
 320     if $DEBUG > 1;
 321
 322   @r;
 323
 324 }
 325
 326 =item update_schema [ OPTIONS_HASHREF, ] PROTOTYPE_SCHEMA, DATABASE_HANDLE | DATA_SOURCE [ USERNAME PASSWORD [ ATTR ] ]
 327
 328 Same as sql_update_schema, except actually runs the SQL commands to update
 329 the schema.  Throws a fatal error if any statement fails.
 330
 331 =cut
 332
 333 sub update_schema {
 334   #my($self, $new, $dbh) = ( shift, shift, _dbh(@_) );
 335   my($self, $opt, $new, $dbh) = ( shift, _parse_opt(\@_), shift, _dbh(@_) );
 336
 337   foreach my $statement ( $self->sql_update_schema( $opt, $new, $dbh ) ) {
 338     $dbh->do( $statement )
 339       or die "Error: ". $dbh->errstr. "\n executing: $statement";
 340   }
 341
 342 }
 343
 344 =item pretty_print
 345
 346 Returns the data in this schema as Perl source, suitable for assigning to a
 347 hash.
 348
 349 =cut
 350
 351 sub pretty_print {
 352   my($self) = @_;
 353
 354   join("},\n\n",
 355     map {
 356       my $tablename = $_;
 357       my $table = $self->table($tablename);
 358       my %indices = $table->indices;
 359
 360       "'$tablename' => {\n".
 361         "  'columns' => [\n".
 362           join("", map {
 363                          #cant because -w complains about , in qw()
 364                          # (also biiiig problems with empty lengths)
 365                          #"    qw( $_ ".
 366                          #$table->column($_)->type. " ".
 367                          #( $table->column($_)->null ? 'NULL' : 0 ). " ".
 368                          #$table->column($_)->length. " ),\n"
 369                          "    '$_', ".
 370                          "'". $table->column($_)->type. "', ".
 371                          "'". $table->column($_)->null. "', ".
 372                          "'". $table->column($_)->length. "', ".
 373
 374                          ( ref($table->column($_)->default)
 375                              ? "\\'". ${ $table->column($_)->default }. "'"
 376                              : "'". $table->column($_)->default. "'"
 377                          ).', '.
 378
 379                          "'". $table->column($_)->local. "',\n"
 380                        } $table->columns
 381           ).
 382         "  ],\n".
 383         "  'primary_key' => '". $table->primary_key. "',\n".
 384
 385         #old style index representation..
 386
 387         (
 388           $table->{'unique'} # $table->_unique
 389             ? "  'unique' => [ ". join(', ',
 390                 map { "[ '". join("', '", @{$_}). "' ]" }
 391                     @{$table->_unique->lol_ref}
 392               ).  " ],\n"
 393             : ''
 394         ).
 395
 396         ( $table->{'index'} # $table->_index
 397             ? "  'index' => [ ". join(', ',
 398                 map { "[ '". join("', '", @{$_}). "' ]" }
 399                     @{$table->_index->lol_ref}
 400               ). " ],\n"
 401             : ''
 402         ).
 403
 404         #new style indices
 405         "  'indices' => { ". join( ",\n                 ",
 406
 407           map { my $iname = $_;
 408                 my $index = $indices{$iname};
 409                 "'$iname' => { \n".
 410                   ( $index->using
 411                       ? "              'using'  => '". $index->using ."',\n"
 412                       : ''
 413                   ).
 414                   "                   'unique'  => ". $index->unique .",\n".
 415                   "                   'columns' => [ '".
 416                                               join("', '", @{$index->columns} ).
 417                                               "' ],\n".
 418                 "                 },\n";
 419               }
 420               keys %indices
 421
 422         ). "\n               }, \n".
 423
 424         #foreign_keys
 425         "  'foreign_keys' => [ ". join( ",\n                 ",
 426
 427           map { my $name = $_->constraint;
 428                 "'$name' => { \n".
 429                 "                 },\n";
 430               }
 431             $table->foreign_keys
 432
 433         ). "\n               ], \n"
 434
 435       ;
 436
 437     } $self->tables
 438   ). "}\n";
 439 }
 440
 441 =cut
 442
 443 =item pretty_read HASHREF
 444
 445 This method is B<not> recommended.  If you need to load and save your schema
 446 to a file, see the L</load|load> and L</save|save> methods.
 447
 448 Creates a schema as specified by a data structure such as that created by
 449 B<pretty_print> method.
 450
 451 =cut
 452
 453 sub pretty_read {
 454   my($proto, $href) = @_;
 455
 456   my $schema = $proto->new( map {
 457
 458     my $tablename = $_;
 459     my $info = $href->{$tablename};
 460
 461     my @columns;
 462     while ( @{$info->{'columns'}} ) {
 463       push @columns, DBIx::DBSchema::Column->new(
 464         splice @{$info->{'columns'}}, 0, 6
 465       );
 466     }
 467
 468     DBIx::DBSchema::Table->new({
 469       'name'        => $tablename,
 470       'primary_key' => $info->{'primary_key'},
 471       'columns'     => \@columns,
 472
 473       #indices
 474       'indices'     => [ map { my $idx_info = $info->{'indices'}{$_};
 475                                DBIx::DBSchema::Index->new({
 476                                  'name'    => $_,
 477                                  #'using'   =>
 478                                  'unique'  => $idx_info->{'unique'},
 479                                  'columns' => $idx_info->{'columns'},
 480                                });
 481                              }
 482                              keys %{ $info->{'indices'} }
 483                        ],
 484     } );
 485
 486   } (keys %{$href}) );
 487
 488 }
 489
 490 # private subroutines
 491
 492 sub _tables_from_dbh {
 493   my($dbh) = @_;
 494   my $driver = _load_driver($dbh);
 495   my $db_catalog =
 496     scalar(eval "DBIx::DBSchema::DBD::$driver->default_db_catalog");
 497   my $db_schema  =
 498     scalar(eval "DBIx::DBSchema::DBD::$driver->default_db_schema");
 499   my $sth = $dbh->table_info($db_catalog, $db_schema, '', 'TABLE')
 500     or die $dbh->errstr;
 501   #map { $_->{TABLE_NAME} } grep { $_->{TABLE_TYPE} eq 'TABLE' }
 502   #  @{ $sth->fetchall_arrayref({ TABLE_NAME=>1, TABLE_TYPE=>1}) };
 503   map { $_->[0] } grep { $_->[1] =~ /^TABLE$/i }
 504     @{ $sth->fetchall_arrayref([2,3]) };
 505 }
 506
 507 =back
 508
 509 =head1 AUTHORS
 510
 511 Ivan Kohler <ivan-dbix-dbschema@420.am>
 512
 513 Charles Shapiro <charles.shapiro@numethods.com> and Mitchell Friedman
 514 <mitchell.friedman@numethods.com> contributed the start of a Sybase driver.
 515
 516 Daniel Hanks <hanksdc@about-inc.com> contributed the Oracle driver.
 517
 518 Jesse Vincent contributed the SQLite driver and fixes to quiet down
 519 internal usage of the old API.
 520
 521 Slaven Rezic <srezic@cpan.org> contributed column and table dropping, Pg
 522 bugfixes and more.
 523
 524 =head1 CONTRIBUTIONS
 525
 526 Contributions are welcome!  I'm especially keen on any interest in the top
 527 items/projects below under BUGS.
 528
 529 =head1 COPYRIGHT
 530
 531 Copyright (c) 2000-2007 Ivan Kohler
 532 Copyright (c) 2000 Mail Abuse Prevention System LLC
 533 Copyright (c) 2007-2013 Freeside Internet Services, Inc.
 534 All rights reserved.
 535 This program is free software; you can redistribute it and/or modify it under
 536 the same terms as Perl itself.
 537
 538 =head1 BUGS AND TODO
 539
 540 Multiple primary keys are not yet supported.
 541
 542 Foreign keys: need to support dropping, NOT VALID, reverse engineering w/mysql
 543
 544 Need to port and test with additional databases
 545
 546 Each DBIx::DBSchema object should have a name which corresponds to its name
 547 within the SQL database engine (DBI data source).
 548
 549 Need to support "using" index attribute in pretty_read and in reverse
 550 engineering
 551
 552 sql CREATE TABLE output should convert integers
 553 (i.e. use DBI qw(:sql_types);) to local types using DBI->type_info plus a hash
 554 to fudge things
 555
 556 =head2 PRETTY_ BUGS
 557
 558 pretty_print is actually pretty ugly.
 559
 560 pretty_print isn't so good about quoting values...  save/load is a much better
 561 alternative to using pretty_print/pretty_read
 562
 563 pretty_read is pretty ugly too.
 564
 565 pretty_read should *not* create and pass in old-style unique/index indices
 566 when nothing is given in the read.
 567
 568 Perhaps pretty_read should eval column types so that we can use DBI
 569 qw(:sql_types) here instead of externally.
 570
 571 perhaps we should just get rid of pretty_read entirely.  pretty_print is useful
 572 for debugging, but pretty_read is pretty bunk.
 573
 574 =head1 SEE ALSO
 575
 576 L<DBIx::DBSchema::Table>, L<DBIx::DBSchema::Index>,
 577 L<DBIx::DBSchema::Column>, L<DBIx::DBSchema::DBD>,
 578 L<DBIx::DBSchema::DBD::mysql>, L<DBIx::DBSchema::DBD::Pg>, L<FS::Record>,
 579 L<DBI>
 580
 581 =cut
 582
 583 1;
 584