install/5.005/DBIx-DBSchema-0.23-5.005kludge/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 0.02;
   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       name        => "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 Note: the _odbc refers to the column types used and nothing else - you do not
 148 have to have ODBC installed or connect to the database via ODBC.
 149
 150 =cut
 151
 152 %create_params = (
 153 #  undef             => sub { '' },
 154   ''                => sub { '' },
 155   'max length'      => sub { $_[0]->{PRECISION}->[$_[1]]; },
 156   'precision,scale' =>
 157     sub { $_[0]->{PRECISION}->[$_[1]]. ','. $_[0]->{SCALE}->[$_[1]]; }
 158 );
 159
 160 sub new_odbc {
 161   my( $proto, $dbh, $name) = @_;
 162   my $driver = DBIx::DBSchema::_load_driver($dbh);
 163   my $sth = _null_sth($dbh, $name);
 164   my $sthpos = 0;
 165   $proto->new (
 166     $name,
 167     scalar(eval "DBIx::DBSchema::DBD::$driver->primary_key(\$dbh, \$name)"),
 168     DBIx::DBSchema::ColGroup::Unique->new(
 169       $driver
 170        ? [values %{eval "DBIx::DBSchema::DBD::$driver->unique(\$dbh, \$name)"}]
 171        : []
 172     ),
 173     DBIx::DBSchema::ColGroup::Index->new(
 174       $driver
 175       ? [ values %{eval "DBIx::DBSchema::DBD::$driver->index(\$dbh, \$name)"} ]
 176       : []
 177     ),
 178     map {
 179       my $type_info = scalar($dbh->type_info($sth->{TYPE}->[$sthpos]))
 180         or die "DBI::type_info ". $dbh->{Driver}->{Name}. " driver ".
 181                "returned no results for type ".  $sth->{TYPE}->[$sthpos];
 182       new DBIx::DBSchema::Column
 183           $_,
 184           $type_info->{'TYPE_NAME'},
 185           #"SQL_". uc($type_info->{'TYPE_NAME'}),
 186           $sth->{NULLABLE}->[$sthpos],
 187           &{ $create_params{ $type_info->{CREATE_PARAMS} } }( $sth, $sthpos++ ),          $driver && #default
 188             ${ [
 189               eval "DBIx::DBSchema::DBD::$driver->column(\$dbh, \$name, \$_)"
 190             ] }[4]
 191           # DB-local
 192     } @{$sth->{NAME}}
 193   );
 194 }
 195
 196 =item new_native DATABASE_HANDLE TABLE_NAME
 197
 198 Creates a new DBIx::DBSchema::Table object from the supplied DBI database
 199 handle for the specified table.  This uses database-native methods to read the
 200 schema, and will preserve any non-portable column types.  The method is only
 201 available if there is a DBIx::DBSchema::DBD for the corresponding database
 202 engine (currently, MySQL and PostgreSQL).
 203
 204 =cut
 205
 206 sub new_native {
 207   my( $proto, $dbh, $name) = @_;
 208   my $driver = DBIx::DBSchema::_load_driver($dbh);
 209   $proto->new (
 210     $name,
 211     scalar(eval "DBIx::DBSchema::DBD::$driver->primary_key(\$dbh, \$name)"),
 212     DBIx::DBSchema::ColGroup::Unique->new(
 213       [ values %{eval "DBIx::DBSchema::DBD::$driver->unique(\$dbh, \$name)"} ]
 214     ),
 215     DBIx::DBSchema::ColGroup::Index->new(
 216       [ values %{eval "DBIx::DBSchema::DBD::$driver->index(\$dbh, \$name)"} ]
 217     ),
 218     map {
 219       DBIx::DBSchema::Column->new( @{$_} )
 220     } eval "DBIx::DBSchema::DBD::$driver->columns(\$dbh, \$name)"
 221   );
 222 }
 223
 224 =item addcolumn COLUMN
 225
 226 Adds this DBIx::DBSchema::Column object.
 227
 228 =cut
 229
 230 sub addcolumn {
 231   my($self,$column)=@_;
 232   ${$self->{'columns'}}{$column->name}=$column; #sanity check?
 233   push @{$self->{'column_order'}}, $column->name;
 234 }
 235
 236 =item delcolumn COLUMN_NAME
 237
 238 Deletes this column.  Returns false if no column of this name was found to
 239 remove, true otherwise.
 240
 241 =cut
 242
 243 sub delcolumn {
 244   my($self,$column) = @_;
 245   return 0 unless exists $self->{'columns'}{$column};
 246   delete $self->{'columns'}{$column};
 247   @{$self->{'column_order'}}= grep { $_ ne $column } @{$self->{'column_order'}};  1;
 248 }
 249
 250 =item name [ TABLE_NAME ]
 251
 252 Returns or sets the table name.
 253
 254 =cut
 255
 256 sub name {
 257   my($self,$value)=@_;
 258   if ( defined($value) ) {
 259     $self->{name} = $value;
 260   } else {
 261     $self->{name};
 262   }
 263 }
 264
 265 =item primary_key [ PRIMARY_KEY ]
 266
 267 Returns or sets the primary key.
 268
 269 =cut
 270
 271 sub primary_key {
 272   my($self,$value)=@_;
 273   if ( defined($value) ) {
 274     $self->{primary_key} = $value;
 275   } else {
 276     #$self->{primary_key};
 277     #hmm.  maybe should untaint the entire structure when it comes off disk
 278     # cause if you don't trust that, ?
 279     $self->{primary_key} =~ /^(\w*)$/
 280       #aah!
 281       or die "Illegal primary key: ", $self->{primary_key};
 282     $1;
 283   }
 284 }
 285
 286 =item unique [ UNIQUE ]
 287
 288 Returns or sets the DBIx::DBSchema::ColGroup::Unique object.
 289
 290 =cut
 291
 292 sub unique {
 293   my($self,$value)=@_;
 294   if ( defined($value) ) {
 295     $self->{unique} = $value;
 296   } else {
 297     $self->{unique};
 298   }
 299 }
 300
 301 =item index [ INDEX ]
 302
 303 Returns or sets the DBIx::DBSchema::ColGroup::Index object.
 304
 305 =cut
 306
 307 sub index {
 308   my($self,$value)=@_;
 309   if ( defined($value) ) {
 310     $self->{'index'} = $value;
 311   } else {
 312     $self->{'index'};
 313   }
 314 }
 315
 316 =item columns
 317
 318 Returns a list consisting of the names of all columns.
 319
 320 =cut
 321
 322 sub columns {
 323   my($self)=@_;
 324   #keys %{$self->{'columns'}};
 325   #must preserve order
 326   @{ $self->{'column_order'} };
 327 }
 328
 329 =item column COLUMN_NAME
 330
 331 Returns the column object (see L<DBIx::DBSchema::Column>) for the specified
 332 COLUMN_NAME.
 333
 334 =cut
 335
 336 sub column {
 337   my($self,$column)=@_;
 338   $self->{'columns'}->{$column};
 339 }
 340
 341 =item sql_create_table [ DATABASE_HANDLE | DATA_SOURCE [ USERNAME PASSWORD [ ATTR ] ] ]
 342
 343 Returns a list of SQL statments to create this table.
 344
 345 The data source can be specified by passing an open DBI database handle, or by
 346 passing the DBI data source name, username and password.
 347
 348 Although the username and password are optional, it is best to call this method
 349 with a database handle or data source including a valid username and password -
 350 a DBI connection will be opened and the quoting and type mapping will be more
 351 reliable.
 352
 353 If passed a DBI data source (or handle) such as `DBI:mysql:database', will use
 354 MySQL- or PostgreSQL-specific syntax.  Non-standard syntax for other engines
 355 (if applicable) may also be supported in the future.
 356
 357 =cut
 358
 359 sub sql_create_table {
 360   my($self, $dbh) = (shift, shift);
 361
 362   my $created_dbh = 0;
 363   unless ( ref($dbh) || ! @_ ) {
 364     $dbh = DBI->connect( $dbh, @_ ) or die $DBI::errstr;
 365     my $gratuitous = $DBI::errstr; #surpress superfluous `used only once' error
 366     $created_dbh = 1;
 367   }
 368   #false laziness: nicked from DBSchema::_load_driver
 369   my $driver;
 370   if ( ref($dbh) ) {
 371     $driver = $dbh->{Driver}->{Name};
 372   } else {
 373     my $discard = $dbh;
 374     $discard =~ s/^dbi:(\w*?)(?:\((.*?)\))?://i #nicked from DBI->connect
 375                         or '' =~ /()/; # ensure $1 etc are empty if match fails
 376     $driver = $1 or die "can't parse data source: $dbh";
 377   }
 378   #eofalse
 379
 380 #should be in the DBD somehwere :/
 381 #  my $saved_pkey = '';
 382 #  if ( $driver eq 'Pg' && $self->primary_key ) {
 383 #    my $pcolumn = $self->column( (
 384 #      grep { $self->column($_)->name eq $self->primary_key } $self->columns
 385 #    )[0] );
 386 ##AUTO-INCREMENT#    $pcolumn->type('serial') if lc($pcolumn->type) eq 'integer';
 387 #    $pcolumn->local( $pcolumn->local. ' PRIMARY KEY' );
 388 #    #my $saved_pkey = $self->primary_key;
 389 #    #$self->primary_key('');
 390 #    #change it back afterwords :/
 391 #  }
 392
 393   my @columns = map { $self->column($_)->line($dbh) } $self->columns;
 394
 395   push @columns, "PRIMARY KEY (". $self->primary_key. ")"
 396     #if $self->primary_key && $driver ne 'Pg';
 397     if $self->primary_key;
 398
 399   my $indexnum = 1;
 400
 401   my @r = (
 402     "CREATE TABLE ". $self->name. " (\n  ". join(",\n  ", @columns). "\n)\n"
 403   );
 404
 405   push @r, map {
 406                  #my($index) = $self->name. "__". $_ . "_idx";
 407                  #$index =~ s/,\s*/_/g;
 408                  my $index = $self->name. $indexnum++;
 409                  "CREATE UNIQUE INDEX $index ON ". $self->name. " ($_)\n"
 410                } $self->unique->sql_list
 411     if $self->unique;
 412
 413   push @r, map {
 414                  #my($index) = $self->name. "__". $_ . "_idx";
 415                  #$index =~ s/,\s*/_/g;
 416                  my $index = $self->name. $indexnum++;
 417                  "CREATE INDEX $index ON ". $self->name. " ($_)\n"
 418                } $self->index->sql_list
 419     if $self->index;
 420
 421   #$self->primary_key($saved_pkey) if $saved_pkey;
 422   $dbh->disconnect if $created_dbh;
 423   @r;
 424 }
 425
 426 #
 427
 428 sub _null_sth {
 429   my($dbh, $table) = @_;
 430   my $sth = $dbh->prepare("SELECT * FROM $table WHERE 1=0")
 431     or die $dbh->errstr;
 432   $sth->execute or die $sth->errstr;
 433   $sth;
 434 }
 435
 436 =back
 437
 438 =head1 AUTHOR
 439
 440 Ivan Kohler <ivan-dbix-dbschema@420.am>
 441
 442 Thanks to Mark Ethan Trostler <mark@zzo.com> for a patch to allow tables
 443 with no indices.
 444
 445 =head1 COPYRIGHT
 446
 447 Copyright (c) 2000 Ivan Kohler
 448 Copyright (c) 2000 Mail Abuse Prevention System LLC
 449 All rights reserved.
 450 This program is free software; you can redistribute it and/or modify it under
 451 the same terms as Perl itself.
 452
 453 =head1 BUGS
 454
 455 sql_create_table() has database-specific foo that probably ought to be
 456 abstracted into the DBIx::DBSchema::DBD:: modules.
 457
 458 sql_create_table may change or destroy the object's data.  If you need to use
 459 the object after sql_create_table, make a copy beforehand.
 460
 461 Some of the logic in new_odbc might be better abstracted into Column.pm etc.
 462
 463 =head1 SEE ALSO
 464
 465 L<DBIx::DBSchema>, L<DBIx::DBSchema::ColGroup::Unique>,
 466 L<DBIx::DBSchema::ColGroup::Index>, L<DBIx::DBSchema::Column>, L<DBI>
 467
 468 =cut
 469
 470 1;
 471