DBSchema/Table.pm

   1 package DBIx::DBSchema::Table;
   2
   3 use strict;
   4 use vars qw(@ISA %create_params);
   5 #use Carp;
   6 #use Exporter;
   7 use DBIx::DBSchema::Column;
   8 use DBIx::DBSchema::ColGroup::Unique;
   9 use DBIx::DBSchema::ColGroup::Index;
  10
  11 #@ISA = qw(Exporter);
  12 @ISA = qw();
  13
  14 =head1 NAME
  15
  16 DBIx::DBSchema::Table - Table objects
  17
  18 =head1 SYNOPSIS
  19
  20   use DBIx::DBSchema::Table;
  21
  22   #old style (depriciated)
  23   $table = new DBIx::DBSchema::Table (
  24     "table_name",
  25     "primary_key",
  26     $dbix_dbschema_colgroup_unique_object,
  27     $dbix_dbschema_colgroup_index_object,
  28     @dbix_dbschema_column_objects,
  29   );
  30
  31   #new style (preferred), pass a hashref of parameters
  32   $table = new DBIx::DBSchema::Table (
  33     {
  34       table       => "table_name",
  35       primary_key => "primary_key",
  36       unique      => $dbix_dbschema_colgroup_unique_object,
  37       'index'     => $dbix_dbschema_colgroup_index_object,
  38       columns     => \@dbix_dbschema_column_objects,
  39     }
  40   );
  41
  42   $table->addcolumn ( $dbix_dbschema_column_object );
  43
  44   $table_name = $table->name;
  45   $table->name("table_name");
  46
  47   $primary_key = $table->primary_key;
  48   $table->primary_key("primary_key");
  49
  50   $dbix_dbschema_colgroup_unique_object = $table->unique;
  51   $table->unique( $dbix_dbschema__colgroup_unique_object );
  52
  53   $dbix_dbschema_colgroup_index_object = $table->index;
  54   $table->index( $dbix_dbschema_colgroup_index_object );
  55
  56   @column_names = $table->columns;
  57
  58   $dbix_dbschema_column_object = $table->column("column");
  59
  60   #preferred
  61   @sql_statements = $table->sql_create_table $dbh;
  62   @sql_statements = $table->sql_create_table $datasrc, $username, $password;
  63
  64   #possible problems
  65   @sql_statements = $table->sql_create_table $datasrc;
  66   @sql_statements = $table->sql_create_table;
  67
  68 =head1 DESCRIPTION
  69
  70 DBIx::DBSchema::Table objects represent a single database table.
  71
  72 =head1 METHODS
  73
  74 =over 4
  75
  76 =item new [ TABLE_NAME [ , PRIMARY_KEY [ , UNIQUE [ , INDEX [ , COLUMN... ] ] ] ] ]
  77
  78 =item new HASHREF
  79
  80 Creates a new DBIx::DBSchema::Table object.  The preferred usage is to pass a
  81 hash reference of named parameters.
  82
  83   {
  84     name        => TABLE_NAME,
  85     primary_key => PRIMARY_KEY,
  86     unique      => UNIQUE,
  87     'index'     => INDEX,
  88     columns     => COLUMNS
  89   }
  90
  91 TABLE_NAME is the name of the table.  PRIMARY_KEY is the primary key (may be
  92 empty).  UNIQUE is a DBIx::DBSchema::ColGroup::Unique object (see
  93 L<DBIx::DBSchema::ColGroup::Unique>).  INDEX is a
  94 DBIx::DBSchema::ColGroup::Index object (see
  95 L<DBIx::DBSchema::ColGroup::Index>).  COLUMNS is a reference to an array of
  96 DBIx::DBSchema::Column objects (see L<DBIx::DBSchema::Column>).
  97
  98 =cut
  99
 100 sub new {
 101   my $proto = shift;
 102   my $class = ref($proto) || $proto;
 103
 104   my $self;
 105   if ( ref($_[0]) ) {
 106
 107     $self = shift;
 108     $self->{column_order} = [ map { $_->_name } @{$self->{columns}} ];
 109     $self->{columns} = { map { $_->name, $_ } @{$self->{columns}} };
 110
 111   } else {
 112
 113     my($name,$primary_key,$unique,$index,@columns) = @_;
 114
 115     my %columns = map { $_->name, $_ } @columns;
 116     my @column_order = map { $_->name } @columns;
 117
 118     $self = {
 119       'name'         => $name,
 120       'primary_key'  => $primary_key,
 121       'unique'       => $unique,
 122       'index'        => $index,
 123       'columns'      => \%columns,
 124       'column_order' => \@column_order,
 125     };
 126
 127   }
 128
 129   #check $primary_key, $unique and $index to make sure they are $columns ?
 130   # (and sanity check?)
 131
 132   bless ($self, $class);
 133
 134 }
 135
 136 =item new_odbc DATABASE_HANDLE TABLE_NAME
 137
 138 Creates a new DBIx::DBSchema::Table object from the supplied DBI database
 139 handle for the specified table.  This uses the experimental DBI type_info
 140 method to create a table with standard (ODBC) SQL column types that most
 141 closely correspond to any non-portable column types.   Use this to import a
 142 schema that you wish to use with many different database engines.  Although
 143 primary key and (unique) index information will only be imported from databases
 144 with DBIx::DBSchema::DBD drivers (currently MySQL and PostgreSQL), import of
 145 column names and attributes *should* work for any database.
 146
 147 =cut
 148
 149 %create_params = (
 150 #  undef             => sub { '' },
 151   ''                => sub { '' },
 152   'max length'      => sub { $_[0]->{PRECISION}->[$_[1]]; },
 153   'precision,scale' =>
 154     sub { $_[0]->{PRECISION}->[$_[1]]. ','. $_[0]->{SCALE}->[$_[1]]; }
 155 );
 156
 157 sub new_odbc {
 158   my( $proto, $dbh, $name) = @_;
 159   my $driver = DBIx::DBSchema::_load_driver($dbh);
 160   my $sth = _null_sth($dbh, $name);
 161   my $sthpos = 0;
 162   $proto->new (
 163     $name,
 164     scalar(eval "DBIx::DBSchema::DBD::$driver->primary_key(\$dbh, \$name)"),
 165     DBIx::DBSchema::ColGroup::Unique->new(
 166       $driver
 167        ? [values %{eval "DBIx::DBSchema::DBD::$driver->unique(\$dbh, \$name)"}]
 168        : []
 169     ),
 170     DBIx::DBSchema::ColGroup::Index->new(
 171       $driver
 172       ? [ values %{eval "DBIx::DBSchema::DBD::$driver->index(\$dbh, \$name)"} ]
 173       : []
 174     ),
 175     map {
 176       my $type_info = scalar($dbh->type_info($sth->{TYPE}->[$sthpos]))
 177         or die "DBI::type_info ". $dbh->{Driver}->{Name}. " driver ".
 178                "returned no results for type ".  $sth->{TYPE}->[$sthpos];
 179       new DBIx::DBSchema::Column
 180           $_,
 181           $type_info->{'TYPE_NAME'},
 182           #"SQL_". uc($type_info->{'TYPE_NAME'}),
 183           $sth->{NULLABLE}->[$sthpos],
 184           &{ $create_params{ $type_info->{CREATE_PARAMS} } }( $sth, $sthpos++ ),          $driver && #default
 185             ${ [
 186               eval "DBIx::DBSchema::DBD::$driver->column(\$dbh, \$name, \$_)"
 187             ] }[4]
 188           # DB-local
 189     } @{$sth->{NAME}}
 190   );
 191 }
 192
 193 =item new_native DATABASE_HANDLE TABLE_NAME
 194
 195 Creates a new DBIx::DBSchema::Table object from the supplied DBI database
 196 handle for the specified table.  This uses database-native methods to read the
 197 schema, and will preserve any non-portable column types.  The method is only
 198 available if there is a DBIx::DBSchema::DBD for the corresponding database
 199 engine (currently, MySQL and PostgreSQL).
 200
 201 =cut
 202
 203 sub new_native {
 204   my( $proto, $dbh, $name) = @_;
 205   my $driver = DBIx::DBSchema::_load_driver($dbh);
 206   $proto->new (
 207     $name,
 208     scalar(eval "DBIx::DBSchema::DBD::$driver->primary_key(\$dbh, \$name)"),
 209     DBIx::DBSchema::ColGroup::Unique->new(
 210       [ values %{eval "DBIx::DBSchema::DBD::$driver->unique(\$dbh, \$name)"} ]
 211     ),
 212     DBIx::DBSchema::ColGroup::Index->new(
 213       [ values %{eval "DBIx::DBSchema::DBD::$driver->index(\$dbh, \$name)"} ]
 214     ),
 215     map {
 216       DBIx::DBSchema::Column->new( @{$_} )
 217     } eval "DBIx::DBSchema::DBD::$driver->columns(\$dbh, \$name)"
 218   );
 219 }
 220
 221 =item addcolumn COLUMN
 222
 223 Adds this DBIx::DBSchema::Column object.
 224
 225 =cut
 226
 227 sub addcolumn {
 228   my($self,$column)=@_;
 229   ${$self->{'columns'}}{$column->name}=$column; #sanity check?
 230   push @{$self->{'column_order'}}, $column->name;
 231 }
 232
 233 =item delcolumn COLUMN_NAME
 234
 235 Deletes this column.  Returns false if no column of this name was found to
 236 remove, true otherwise.
 237
 238 =cut
 239
 240 sub delcolumn {
 241   my($self,$column) = @_;
 242   return 0 unless exists $self->{'columns'}{$column};
 243   delete $self->{'columns'}{$column};
 244   @{$self->{'column_order'}}= grep { $_ ne $column } @{$self->{'column_order'}};  1;
 245 }
 246
 247 =item name [ TABLE_NAME ]
 248
 249 Returns or sets the table name.
 250
 251 =cut
 252
 253 sub name {
 254   my($self,$value)=@_;
 255   if ( defined($value) ) {
 256     $self->{name} = $value;
 257   } else {
 258     $self->{name};
 259   }
 260 }
 261
 262 =item primary_key [ PRIMARY_KEY ]
 263
 264 Returns or sets the primary key.
 265
 266 =cut
 267
 268 sub primary_key {
 269   my($self,$value)=@_;
 270   if ( defined($value) ) {
 271     $self->{primary_key} = $value;
 272   } else {
 273     #$self->{primary_key};
 274     #hmm.  maybe should untaint the entire structure when it comes off disk
 275     # cause if you don't trust that, ?
 276     $self->{primary_key} =~ /^(\w*)$/
 277       #aah!
 278       or die "Illegal primary key: ", $self->{primary_key};
 279     $1;
 280   }
 281 }
 282
 283 =item unique [ UNIQUE ]
 284
 285 Returns or sets the DBIx::DBSchema::ColGroup::Unique object.
 286
 287 =cut
 288
 289 sub unique {
 290   my($self,$value)=@_;
 291   if ( defined($value) ) {
 292     $self->{unique} = $value;
 293   } else {
 294     $self->{unique};
 295   }
 296 }
 297
 298 =item index [ INDEX ]
 299
 300 Returns or sets the DBIx::DBSchema::ColGroup::Index object.
 301
 302 =cut
 303
 304 sub index {
 305   my($self,$value)=@_;
 306   if ( defined($value) ) {
 307     $self->{'index'} = $value;
 308   } else {
 309     $self->{'index'};
 310   }
 311 }
 312
 313 =item columns
 314
 315 Returns a list consisting of the names of all columns.
 316
 317 =cut
 318
 319 sub columns {
 320   my($self)=@_;
 321   #keys %{$self->{'columns'}};
 322   #must preserve order
 323   @{ $self->{'column_order'} };
 324 }
 325
 326 =item column COLUMN_NAME
 327
 328 Returns the column object (see L<DBIx::DBSchema::Column>) for the specified
 329 COLUMN_NAME.
 330
 331 =cut
 332
 333 sub column {
 334   my($self,$column)=@_;
 335   $self->{'columns'}->{$column};
 336 }
 337
 338 =item sql_create_table [ DATABASE_HANDLE | DATA_SOURCE [ USERNAME PASSWORD [ ATTR ] ] ]
 339
 340 Returns a list of SQL statments to create this table.
 341
 342 The data source can be specified by passing an open DBI database handle, or by
 343 passing the DBI data source name, username and password.
 344
 345 Although the username and password are optional, it is best to call this method
 346 with a database handle or data source including a valid username and password -
 347 a DBI connection will be opened and the quoting and type mapping will be more
 348 reliable.
 349
 350 If passed a DBI data source (or handle) such as `DBI:mysql:database', will use
 351 MySQL- or PostgreSQL-specific syntax.  Non-standard syntax for other engines
 352 (if applicable) may also be supported in the future.
 353
 354 =cut
 355
 356 sub sql_create_table {
 357   my($self, $dbh) = (shift, shift);
 358
 359   my $created_dbh = 0;
 360   unless ( ref($dbh) || ! @_ ) {
 361     $dbh = DBI->connect( $dbh, @_ ) or die $DBI::errstr;
 362     my $gratuitous = $DBI::errstr; #surpress superfluous `used only once' error
 363     $created_dbh = 1;
 364   }
 365   #false laziness: nicked from DBSchema::_load_driver
 366   my $driver;
 367   if ( ref($dbh) ) {
 368     $driver = $dbh->{Driver}->{Name};
 369   } else {
 370     my $discard = $dbh;
 371     $discard =~ s/^dbi:(\w*?)(?:\((.*?)\))?://i #nicked from DBI->connect
 372                         or '' =~ /()/; # ensure $1 etc are empty if match fails
 373     $driver = $1 or die "can't parse data source: $dbh";
 374   }
 375   #eofalse
 376
 377 #should be in the DBD somehwere :/
 378 #  my $saved_pkey = '';
 379 #  if ( $driver eq 'Pg' && $self->primary_key ) {
 380 #    my $pcolumn = $self->column( (
 381 #      grep { $self->column($_)->name eq $self->primary_key } $self->columns
 382 #    )[0] );
 383 ##AUTO-INCREMENT#    $pcolumn->type('serial') if lc($pcolumn->type) eq 'integer';
 384 #    $pcolumn->local( $pcolumn->local. ' PRIMARY KEY' );
 385 #    #my $saved_pkey = $self->primary_key;
 386 #    #$self->primary_key('');
 387 #    #change it back afterwords :/
 388 #  }
 389
 390   my(@columns)=map { $self->column($_)->line($dbh) } $self->columns;
 391
 392   push @columns, "PRIMARY KEY (". $self->primary_key. ")"
 393     #if $self->primary_key && $driver ne 'Pg';
 394     if $self->primary_key;
 395
 396   my $indexnum = 1;
 397
 398   my @r = (
 399     "CREATE TABLE ". $self->name. " (\n  ". join(",\n  ", @columns). "\n)\n"
 400   );
 401
 402   push @r, map {
 403                  #my($index) = $self->name. "__". $_ . "_idx";
 404                  #$index =~ s/,\s*/_/g;
 405                  my $index = $self->name. $indexnum++;
 406                  "CREATE UNIQUE INDEX $index ON ". $self->name. " ($_)\n"
 407                } $self->unique->sql_list
 408     if $self->unique;
 409
 410   push @r, map {
 411                  #my($index) = $self->name. "__". $_ . "_idx";
 412                  #$index =~ s/,\s*/_/g;
 413                  my $index = $self->name. $indexnum++;
 414                  "CREATE INDEX $index ON ". $self->name. " ($_)\n"
 415                } $self->index->sql_list
 416     if $self->index;
 417
 418   #$self->primary_key($saved_pkey) if $saved_pkey;
 419   $dbh->disconnect if $created_dbh;
 420   @r;
 421 }
 422
 423 #
 424
 425 sub _null_sth {
 426   my($dbh, $table) = @_;
 427   my $sth = $dbh->prepare("SELECT * FROM $table WHERE 1=0")
 428     or die $dbh->errstr;
 429   $sth->execute or die $sth->errstr;
 430   $sth;
 431 }
 432
 433 =back
 434
 435 =head1 AUTHOR
 436
 437 Ivan Kohler <ivan-dbix-dbschema@420.am>
 438
 439 Thanks to Mark Ethan Trostler <mark@zzo.com> for a patch to allow tables
 440 with no indices.
 441
 442 =head1 COPYRIGHT
 443
 444 Copyright (c) 2000 Ivan Kohler
 445 Copyright (c) 2000 Mail Abuse Prevention System LLC
 446 All rights reserved.
 447 This program is free software; you can redistribute it and/or modify it under
 448 the same terms as Perl itself.
 449
 450 =head1 BUGS
 451
 452 sql_create_table() has database-specific foo that probably ought to be
 453 abstracted into the DBIx::DBSchema::DBD:: modules.
 454
 455 sql_create_table may change or destroy the object's data.  If you need to use
 456 the object after sql_create_table, make a copy beforehand.
 457
 458 Some of the logic in new_odbc might be better abstracted into Column.pm etc.
 459
 460 =head1 SEE ALSO
 461
 462 L<DBIx::DBSchema>, L<DBIx::DBSchema::ColGroup::Unique>,
 463 L<DBIx::DBSchema::ColGroup::Index>, L<DBIx::DBSchema::Column>, L<DBI>
 464
 465 =cut
 466
 467 1;
 468