DBSchema.pm

   1 package DBIx::DBSchema;
   2
   3 use strict;
   4 use vars qw(@ISA $VERSION);
   5 #use Exporter;
   6 #use Carp qw(verbose);
   7 use DBI;
   8 use FreezeThaw qw(freeze thaw cmpStr);
   9 use DBIx::DBSchema::Table;
  10
  11 #@ISA = qw(Exporter);
  12 @ISA = ();
  13
  14 $VERSION = "0.1";
  15
  16 =head1 NAME
  17
  18 DBIx::DBSchema - Database-independent schema objects
  19
  20 =head1 SYNOPSIS
  21
  22   use DBIx::DBSchema;
  23
  24   $schema = new DBIx::DBSchema @dbix_dbschema_table_objects;
  25   $schema = new_from_dsn DBIx::DBSchema $dsn, $user, $pass;
  26   $schema = new_odbc DBIx::DBSchema $dbh;
  27   $schema = new_native DBIx::DBSchema $dbh;
  28
  29   $schema->save("filename");
  30   $schema = load DBIx::DBSchema "filename";
  31
  32   $schema->addtable($dbix_dbschema_table_object);
  33
  34   @table_names = $schema->tables;
  35
  36   $DBIx_DBSchema_table_object = $schema->table("table_name");
  37
  38   $sql_string = $schema->sql($dsn);
  39
  40   $perl_code = $schema->pretty_print;
  41   %hash = eval $perl_code;
  42   $schema = pretty_read DBIx::DBSchema \%hash;
  43
  44 =head1 DESCRIPTION
  45
  46 DBIx::DBSchema objects are collections of DBIx::DBSchema::Table objects and
  47 represent a database schema.
  48
  49 =head1 METHODS
  50
  51 =over 4
  52
  53 =item new TABLE_OBJECT, TABLE_OBJECT, ...
  54
  55 Creates a new DBIx::DBSchema object.
  56
  57 =cut
  58
  59 sub new {
  60   my($proto, @tables) = @_;
  61   my %tables = map  { $_->name, $_ } @tables; #check for duplicates?
  62
  63   my $class = ref($proto) || $proto;
  64   my $self = {
  65     'tables' => \%tables,
  66   };
  67
  68   bless ($self, $class);
  69
  70 }
  71
  72 =item new_odbc_from_dsn DATA_SOURCE USERNAME PASSWORD
  73
  74 Connects to the specified DBI data source and creates a DBIx::DBSchema object
  75 from it using new_odbc.
  76
  77 =cut
  78
  79 sub new_odbc_from_dsn {
  80   my($proto, $dsn, $user, $pass ) = @_;
  81   my $dbh = DBI->connect( $dsn, $user, $pass ) or die $DBI::errstr;
  82   my $self = $proto->new_odbc($dbh);
  83   $dbh->disconnect; #silly DBI
  84   $self;
  85 }
  86
  87 =item new_odbc DATABASE_HANDLE
  88
  89 Creates a new DBIx::DBSchema object from the supplied DBI database handle.
  90 This uses the experimental DBI type_info method to create a schema with
  91 standard (ODBC) SQL column types that most closely correspond to any
  92 non-portable column types.  Use this to import a schema that you wish to use
  93 with many different database engines.  Although primary key and (unique) index
  94 information will only be read from databases with DBIx::DBSchema::DBD drivers
  95 (currently MySQL and PostgreSQL), import of column names and attributes
  96 *should* work for any database.
  97
  98 =cut
  99
 100 sub new_odbc {
 101   my($proto, $dbh) = @_;
 102   $proto->new(
 103     map { new_odbc DBIx::DBSchema::Table $dbh, $_ } _tables_from_dbh($dbh)
 104   );
 105 }
 106
 107 =item new_native_from_dsn DATA_SOURCE USERNAME PASSWORD
 108
 109 Connects to the specified DBI data source and creates a DBIx::DBSchema object
 110 from it using new_native.
 111
 112 =cut
 113
 114 sub new_native_from_dsn {
 115   my($proto, $dsn, $user, $pass) = @_;
 116   my $dbh = DBI->connect( $dsn, $user, $pass ) or die $DBI::errstr;
 117   my $self = $proto->new_native($dbh);
 118   $dbh->disconnect; #silly DBI
 119   $self;
 120 }
 121
 122 =item new_native DATABASE_HANDLE
 123
 124 Creates a new DBIx::DBSchema object from the supplied DBI database handle.  This
 125 uses database-native methods to read the schema, and will preserve any
 126 non-portable column types.  The method is only available if there is a
 127 DBIx::DBSchema::DBD for the corresponding database engine (currently, MySQL and
 128 PostgreSQL).
 129
 130 =cut
 131
 132 sub new_native {
 133   my($proto, $dbh) = @_;
 134   $proto->new(
 135     map { new_native DBIx::DBSchema::Table ( $dbh, $_ ) } _tables_from_dbh($dbh)
 136   );
 137 }
 138
 139 =item load FILENAME
 140
 141 Loads a DBIx::DBSchema object from a file.
 142
 143 =cut
 144
 145 sub load {
 146   my($proto,$file)=@_; #use $proto ?
 147   open(FILE,"<$file") or die "Can't open $file: $!";
 148   my($string)=join('',<FILE>); #can $string have newlines?  pry not?
 149   close FILE or die "Can't close $file: $!";
 150   my($self)=thaw $string;
 151   #no bless needed?
 152   $self;
 153 }
 154
 155 =item save FILENAME
 156
 157 Saves a DBIx::DBSchema object to a file.
 158
 159 =cut
 160
 161 sub save {
 162   my($self,$file)=@_;
 163   my($string)=freeze $self;
 164   open(FILE,">$file") or die "Can't open $file: $!";
 165   print FILE $string;
 166   close FILE or die "Can't close file: $!";
 167   my($check_self)=thaw $string;
 168   die "Verify error: Can't freeze and thaw dbdef $self"
 169     if (cmpStr($self,$check_self));
 170 }
 171
 172 =item addtable TABLE_OBJECT
 173
 174 Adds the given DBIx::DBSchema::Table object to this DBIx::DBSchema.
 175
 176 =cut
 177
 178 sub addtable {
 179   my($self,$table)=@_;
 180   $self->{'tables'}->{$table->name} = $table; #check for dupliates?
 181 }
 182
 183 =item tables
 184
 185 Returns a list of the names of all tables.
 186
 187 =cut
 188
 189 sub tables {
 190   my($self)=@_;
 191   keys %{$self->{'tables'}};
 192 }
 193
 194 =item table TABLENAME
 195
 196 Returns the specified DBIx::DBSchema::Table object.
 197
 198 =cut
 199
 200 sub table {
 201   my($self,$table)=@_;
 202   $self->{'tables'}->{$table};
 203 }
 204
 205 =item sql_string [ DATASRC ]
 206
 207 Returns a list of SQL `CREATE' statements for this schema.
 208
 209 If passed a DBI data source such as `DBI:mysql:database' or
 210 `DBI:Pg:dbname=database', will use syntax specific to that database engine.
 211 Currently supported databases are MySQL and PostgreSQL.
 212
 213 If not passed a data source, or if there is no driver for the specified
 214 database, will attempt to use generic SQL syntax.
 215
 216 =cut
 217
 218 sub sql_string {
 219   my($self, $datasrc) = @_;
 220   map { $self->table($_)->sql_create_table($datasrc); } $self->tables;
 221 }
 222
 223 =item pretty_print
 224
 225 Returns the data in this schema as Perl source, suitable for assigning to a
 226 hash.
 227
 228 =cut
 229
 230 sub pretty_print {
 231   my($self) = @_;
 232   join("},\n\n",
 233     map {
 234       my $table = $_;
 235       "'$table' => {\n".
 236         "  'columns' => [\n".
 237           join("", map {
 238                          "    '$_', ".
 239                          "'". $self->table($table)->column($_)->type. "', ".
 240                          "'". $self->table($table)->column($_)->null. "', ".
 241                          "'". $self->table($table)->column($_)->length. "'\n"
 242                        } $self->table($table)->columns
 243           ).
 244         "  ],\n".
 245         "  'primary_key' => '". $self->table($table)->primary_key. "',\n".
 246         "  'unique' => [ ". join(', ',
 247           map { "[ '". join("', '", @{$_}). "' ]" }
 248             @{$self->table($table)->unique->lol_ref}
 249           ).  " ],\n".
 250         "  'index' => [ ". join(', ',
 251           map { "[ '". join("', '", @{$_}). "' ]" }
 252             @{$self->table($table)->index->lol_ref}
 253           ). " ],\n"
 254         #"  'index' => [ ".    " ],\n"
 255     } $self->tables
 256   ), "}\n";
 257 }
 258
 259 =cut
 260
 261 =item pretty_read HASHREF
 262
 263 Creates a schema as specified by a data structure such as that created by
 264 B<pretty_print> method.
 265
 266 =cut
 267
 268 sub pretty_read {
 269   die "unimplemented (pull from fs-setup)";
 270   my($proto) = @_;
 271 }
 272
 273 # private subroutines
 274
 275 sub _load_driver {
 276   my($dbh) = @_;
 277   my $driver = $dbh->{Driver}->{Name};
 278   #require "DBIx/DBSchema/DBD/$driver.pm";
 279   #$driver;
 280   eval 'require "DBIx/DBSchema/DBD/$driver.pm"' and $driver;
 281 }
 282
 283 sub _tables_from_dbh {
 284   my($dbh) = @_;
 285   my $sth = $dbh->table_info or die $dbh->errstr;
 286   #map { $_->{TABLE_NAME} } grep { $_->{TABLE_TYPE} eq 'TABLE' }
 287   #  @{ $sth->fetchall_arrayref({ TABLE_NAME=>1, TABLE_TYPE=>1}) };
 288   map { $_->[0] } grep { $_->[1] =~ /^TABLE$/i }
 289     @{ $sth->fetchall_arrayref([2,3]) };
 290 }
 291
 292 =back
 293
 294 =head1 AUTHOR
 295
 296 Ivan Kohler <ivan-dbix-dbschema@420.am>
 297
 298 =head1 COPYRIGHT
 299
 300 Copyright (c) 2000 Ivan Kohler
 301 Copyright (c) 2000 Mail Abuse Prevention System LLC
 302 All rights reserved.
 303 This program is free software; you can redistribute it and/or modify it under
 304 the same terms as Perl itself.
 305
 306 =head1 BUGS
 307
 308 Each DBIx::DBSchema object should have a name which corresponds to its name
 309 within the SQL database engine (DBI data source).
 310
 311 pretty_print is atrocious.
 312
 313 =head1 SEE ALSO
 314
 315 L<DBIx::DBSchema::Table>, L<DBIx::DBSchema::ColGroup>,
 316 L<DBIx::DBSchema::ColGroup::Unique>, L<DBIx::DBSchema::ColGroup::Index>,
 317 L<DBIx::DBSchema::Column>, L<DBIx::DBSchema::DBD>, L<DBIx::DBSchema::mysql>,
 318 L<DBIx::DBSchema::Pg>, L<FS::Record>, L<DBI>
 319
 320 =cut
 321
 322 1;
 323