DBSchema/Column.pm

   1 package DBIx::DBSchema::Column;
   2
   3 use strict;
   4 use vars qw($VERSION);
   5 use Carp;
   6 use DBIx::DBSchema::_util qw(_load_driver _dbh);
   7
   8 $VERSION = '0.09';
   9
  10 =head1 NAME
  11
  12 DBIx::DBSchema::Column - Column objects
  13
  14 =head1 SYNOPSIS
  15
  16   use DBIx::DBSchema::Column;
  17
  18   #named params with a hashref (preferred)
  19   $column = new DBIx::DBSchema::Column ( {
  20     'name'    => 'column_name',
  21     'type'    => 'varchar'
  22     'null'    => 'NOT NULL',
  23     'length'  => 64,
  24     'default' => '',
  25     'local'   => '',
  26   } );
  27
  28   #list
  29   $column = new DBIx::DBSchema::Column ( $name, $sql_type, $nullability, $length, $default, $local );
  30
  31   $name = $column->name;
  32   $column->name( 'name' );
  33
  34   $sql_type = $column->type;
  35   $column->type( 'sql_type' );
  36
  37   $null = $column->null;
  38   $column->null( 'NULL' );
  39   $column->null( 'NOT NULL' );
  40   $column->null( '' );
  41
  42   $length = $column->length;
  43   $column->length( '10' );
  44   $column->length( '8,2' );
  45
  46   $default = $column->default;
  47   $column->default( 'Roo' );
  48
  49   $sql_line = $column->line;
  50   $sql_line = $column->line($datasrc);
  51
  52   $sql_add_column = $column->sql_add_column;
  53   $sql_add_column = $column->sql_add_column($datasrc);
  54
  55 =head1 DESCRIPTION
  56
  57 DBIx::DBSchema::Column objects represent columns in tables (see
  58 L<DBIx::DBSchema::Table>).
  59
  60 =head1 METHODS
  61
  62 =over 4
  63
  64 =item new HASHREF
  65
  66 =item new [ name [ , type [ , null [ , length  [ , default [ , local ] ] ] ] ] ]
  67
  68 Creates a new DBIx::DBSchema::Column object.  Takes a hashref of named
  69 parameters, or a list.  B<name> is the name of the column.  B<type> is the SQL
  70 data type.  B<null> is the nullability of the column (intrepreted using Perl's
  71 rules for truth, with one exception: `NOT NULL' is false).  B<length> is the
  72 SQL length of the column.  B<default> is the default value of the column.
  73 B<local> is reserved for database-specific information.
  74
  75 Note: If you pass a scalar reference as the B<default> rather than a scalar value, it will be dereferenced and quoting will be forced off.  This can be used to pass SQL functions such as C<$now()> or explicit empty strings as C<''> as
  76 defaults.
  77
  78 =cut
  79
  80 sub new {
  81   my $proto = shift;
  82   my $class = ref($proto) || $proto;
  83
  84   my $self;
  85   if ( ref($_[0]) ) {
  86     $self = shift;
  87   } else {
  88     #carp "Old-style $class creation without named parameters is deprecated!";
  89     #croak "FATAL: old-style $class creation no longer supported;".
  90     #      " use named parameters";
  91
  92     $self = { map { $_ => shift } qw(name type null length default local) };
  93   }
  94
  95   #croak "Illegal name: ". $self->{'name'}
  96   #  if grep $self->{'name'} eq $_, @reserved_words;
  97
  98   $self->{'null'} =~ s/^NOT NULL$//i;
  99   $self->{'null'} = 'NULL' if $self->{'null'};
 100
 101   bless ($self, $class);
 102
 103 }
 104
 105 =item name [ NAME ]
 106
 107 Returns or sets the column name.
 108
 109 =cut
 110
 111 sub name {
 112   my($self,$value)=@_;
 113   if ( defined($value) ) {
 114   #croak "Illegal name: $name" if grep $name eq $_, @reserved_words;
 115     $self->{'name'} = $value;
 116   } else {
 117     $self->{'name'};
 118   }
 119 }
 120
 121 =item type [ TYPE ]
 122
 123 Returns or sets the column type.
 124
 125 =cut
 126
 127 sub type {
 128   my($self,$value)=@_;
 129   if ( defined($value) ) {
 130     $self->{'type'} = $value;
 131   } else {
 132     $self->{'type'};
 133   }
 134 }
 135
 136 =item null [ NULL ]
 137
 138 Returns or sets the column null flag (the empty string is equivalent to
 139 `NOT NULL')
 140
 141 =cut
 142
 143 sub null {
 144   my($self,$value)=@_;
 145   if ( defined($value) ) {
 146     $value =~ s/^NOT NULL$//i;
 147     $value = 'NULL' if $value;
 148     $self->{'null'} = $value;
 149   } else {
 150     $self->{'null'};
 151   }
 152 }
 153
 154 =item length [ LENGTH ]
 155
 156 Returns or sets the column length.
 157
 158 =cut
 159
 160 sub length {
 161   my($self,$value)=@_;
 162   if ( defined($value) ) {
 163     $self->{'length'} = $value;
 164   } else {
 165     $self->{'length'};
 166   }
 167 }
 168
 169 =item default [ LOCAL ]
 170
 171 Returns or sets the default value.
 172
 173 =cut
 174
 175 sub default {
 176   my($self,$value)=@_;
 177   if ( defined($value) ) {
 178     $self->{'default'} = $value;
 179   } else {
 180     $self->{'default'};
 181   }
 182 }
 183
 184
 185 =item local [ LOCAL ]
 186
 187 Returns or sets the database-specific field.
 188
 189 =cut
 190
 191 sub local {
 192   my($self,$value)=@_;
 193   if ( defined($value) ) {
 194     $self->{'local'} = $value;
 195   } else {
 196     $self->{'local'};
 197   }
 198 }
 199
 200 =item table_obj [ TABLE_OBJ ]
 201
 202 Returns or sets the table object (see L<DBIx::DBSchema::Table>).  Typically
 203 set internally when a column object is added to a table object.
 204
 205 =cut
 206
 207 sub table_obj {
 208   my($self,$value)=@_;
 209   if ( defined($value) ) {
 210     $self->{'table_obj'} = $value;
 211   } else {
 212     $self->{'table_obj'};
 213   }
 214 }
 215
 216 =item table_name
 217
 218 Returns the table name, or the empty string if this column has not yet been
 219 assigned to a table.
 220
 221 =cut
 222
 223 sub table_name {
 224   my $self = shift;
 225   $self->{'table_obj'} ? $self->{'table_obj'}->name : '';
 226 }
 227
 228 =item line [ DATABASE_HANDLE | DATA_SOURCE [ USERNAME PASSWORD [ ATTR ] ] ]
 229
 230 Returns an SQL column definition.
 231
 232 The data source can be specified by passing an open DBI database handle, or by
 233 passing the DBI data source name, username and password.
 234
 235 Although the username and password are optional, it is best to call this method
 236 with a database handle or data source including a valid username and password -
 237 a DBI connection will be opened and the quoting and type mapping will be more
 238 reliable.
 239
 240 If passed a DBI data source (or handle) such as `DBI:mysql:database' or
 241 `DBI:Pg:dbname=database', will use syntax specific to that database engine.
 242 Currently supported databases are MySQL and PostgreSQL.  Non-standard syntax
 243 for other engines (if applicable) may also be supported in the future.
 244
 245 =cut
 246
 247 sub line {
 248   my($self, $dbh) = ( shift, _dbh(@_) );
 249
 250   my $driver = $dbh ? _load_driver($dbh) : '';
 251
 252   my %typemap;
 253   %typemap = eval "\%DBIx::DBSchema::DBD::${driver}::typemap" if $driver;
 254   my $type = defined( $typemap{uc($self->type)} )
 255     ? $typemap{uc($self->type)}
 256     : $self->type;
 257
 258   my $null = $self->null;
 259
 260   my $default;
 261   if ( defined($self->default) && !ref($self->default) && $self->default ne ''
 262        && ref($dbh)
 263        # false laziness: nicked from FS::Record::_quote
 264        && ( $self->default !~ /^\-?\d+(\.\d+)?$/
 265             || $type =~ /(char|binary|blob|text)$/i
 266           )
 267   ) {
 268     $default = $dbh->quote($self->default);
 269   } else {
 270     $default = ref($self->default) ? ${$self->default} : $self->default;
 271   }
 272
 273   #this should be a callback into the driver
 274   if ( $driver eq 'mysql' ) { #yucky mysql hack
 275     $null ||= "NOT NULL";
 276     $self->local('AUTO_INCREMENT') if uc($self->type) eq 'SERIAL';
 277   } elsif ( $driver =~ /^(?:Pg|SQLite)$/ ) { #yucky Pg/SQLite hack
 278     $null ||= "NOT NULL";
 279     $null =~ s/^NULL$//;
 280   }
 281
 282   join(' ',
 283     $self->name,
 284     $type. ( ( defined($self->length) && $self->length )
 285              ? '('.$self->length.')'
 286              : ''
 287            ),
 288     $null,
 289     ( ( defined($default) && $default ne '' )
 290       ? 'DEFAULT '. $default
 291       : ''
 292     ),
 293     ( ( $driver eq 'mysql' && defined($self->local) )
 294       ? $self->local
 295       : ''
 296     ),
 297   );
 298
 299 }
 300
 301 =item sql_add_column [ DBH ]
 302
 303 Returns a list of SQL statements to add this column to an existing table.  (To
 304 create a new table, see L<DBIx::DBSchema::Table/sql_create_table> instead.)
 305
 306 The data source can be specified by passing an open DBI database handle, or by
 307 passing the DBI data source name, username and password.
 308
 309 Although the username and password are optional, it is best to call this method
 310 with a database handle or data source including a valid username and password -
 311 a DBI connection will be opened and the quoting and type mapping will be more
 312 reliable.
 313
 314 If passed a DBI data source (or handle) such as `DBI:Pg:dbname=database', will
 315 use PostgreSQL-specific syntax.  Non-standard syntax for other engines (if
 316 applicable) may also be supported in the future.
 317
 318 =cut
 319
 320 sub sql_add_column {
 321   my($self, $dbh) = ( shift, _dbh(@_) );
 322
 323   die "$self: this column is not assigned to a table"
 324     unless $self->table_name;
 325
 326   my $driver = $dbh ? _load_driver($dbh) : '';
 327
 328   my @after_add = ();
 329
 330   my $real_type = '';
 331   if (  $driver eq 'Pg' && $self->type eq 'serial' ) {
 332     $real_type = 'serial';
 333     $self->type('int');
 334
 335     push @after_add, sub {
 336       my($table, $column) = @_;
 337
 338       #needs more work for old Pg?
 339
 340       my $pg_server_version = $dbh->{'pg_server_version'};
 341       unless ( $pg_server_version =~ /\d/ ) {
 342         warn "WARNING: no pg_server_version!  Assuming >= 7.3\n";
 343         $pg_server_version = 70300;
 344       }
 345
 346       my $nextval;
 347       if ( $pg_server_version >= 70300 ) {
 348         $nextval = "nextval('public.${table}_${column}_seq'::text)";
 349       } else {
 350         $nextval = "nextval('${table}_${column}_seq'::text)";
 351       }
 352
 353       (
 354         "ALTER TABLE $table ALTER COLUMN $column SET DEFAULT $nextval",
 355         "CREATE SEQUENCE ${table}_${column}_seq",
 356         "UPDATE $table SET $column = $nextval WHERE $column IS NULL",
 357         #"ALTER TABLE $table ALTER $column SET NOT NULL",
 358       );
 359
 360     };
 361
 362   }
 363
 364   my $real_null = undef;
 365   if ( $driver eq 'Pg' && ! $self->null ) {
 366     $real_null = $self->null;
 367     $self->null('NULL');
 368
 369     my $pg_server_version = $dbh->{'pg_server_version'};
 370     unless ( $pg_server_version =~ /\d/ ) {
 371       warn "WARNING: no pg_server_version!  Assuming >= 7.3\n";
 372       $pg_server_version = 70300;
 373     }
 374
 375     if ( $pg_server_version >= 70300 ) { #this did work on 7.3
 376     #if ( $pg_server_version > 70400 ) {
 377
 378       push @after_add, sub {
 379         my($table, $column) = @_;
 380         "ALTER TABLE $table ALTER $column SET NOT NULL";
 381       };
 382
 383     } else {
 384
 385       push @after_add, sub {
 386         my($table, $column) = @_;
 387         "UPDATE pg_attribute SET attnotnull = TRUE ".
 388         " WHERE attname = '$column' ".
 389         " AND attrelid = ( SELECT oid FROM pg_class WHERE relname = '$table' )";
 390       };
 391
 392     }
 393
 394   }
 395
 396   my @r = ();
 397   my $table = $self->table_name;
 398   my $column = $self->name;
 399
 400   push @r, "ALTER TABLE $table ADD COLUMN ". $self->line($dbh);
 401
 402   push @r, &{$_}($table, $column) foreach @after_add;
 403
 404   push @r, "ALTER TABLE $table ADD PRIMARY KEY ( ".
 405              $self->table_obj->primary_key. " )"
 406     if $self->name eq $self->table_obj->primary_key;
 407
 408   $self->type($real_type) if $real_type;
 409   $self->null($real_null) if defined $real_null;
 410
 411   @r;
 412
 413 }
 414
 415 =item sql_alter_column PROTOTYPE_COLUMN  [ DATABASE_HANDLE | DATA_SOURCE [ USERNAME PASSWORD [ ATTR ] ] ]
 416
 417 Returns a list of SQL statements to alter this column so that it is identical
 418 to the provided prototype column, also a DBIx::DBSchema::Column object.
 419
 420  #Optionally, the data source can be specified by passing an open DBI database
 421  #handle, or by passing the DBI data source name, username and password.
 422  #
 423  #If passed a DBI data source (or handle) such as `DBI:Pg:dbname=database', will
 424  #use PostgreSQL-specific syntax.  Non-standard syntax for other engines (if
 425  #applicable) may also be supported in the future.
 426  #
 427  #If not passed a data source (or handle), or if there is no driver for the
 428  #specified database, will attempt to use generic SQL syntax.
 429
 430
 431 Or should, someday.  Right now it knows how to change NOT NULL into NULL and
 432 vice-versa.
 433
 434 =cut
 435
 436 sub sql_alter_column {
 437   my( $self, $new, $dbh ) = ( shift, shift, _dbh(@_) );
 438
 439   my $table = $self->table_name;
 440   die "$self: this column is not assigned to a table"
 441     unless $table;
 442
 443   my $name = $self->name;
 444
 445   my $driver = $dbh ? _load_driver($dbh) : '';
 446
 447   my @r = ();
 448
 449   # change the name...
 450
 451   # change the type...
 452
 453   # change nullability from NOT NULL to NULL
 454   if ( ! $self->null && $new->null ) {
 455
 456     my $alter = "ALTER TABLE $table ALTER COLUMN $name DROP NOT NULL";
 457
 458     if ( $driver eq 'Pg' ) {
 459
 460       my $pg_server_version = $dbh->{'pg_server_version'};
 461       unless ( $pg_server_version =~ /\d/ ) {
 462         warn "WARNING: no pg_server_version!  Assuming >= 7.3\n";
 463         $pg_server_version = 70300;
 464       }
 465
 466       if ( $pg_server_version < 70300 ) {
 467         $alter = "UPDATE pg_attribute SET attnotnull = FALSE
 468                     WHERE attname = '$name'
 469                       AND attrelid = ( SELECT oid FROM pg_class
 470                                          WHERE relname = '$table'
 471                                      )";
 472       }
 473
 474     }
 475
 476     push @r, $alter;
 477
 478   }
 479
 480   # change nullability from NULL to NOT NULL...
 481   # this one could be more complicated, need to set a DEFAULT value and update
 482   # the table first...
 483   if ( $self->null && ! $new->null ) {
 484
 485     my $alter = "ALTER TABLE $table ALTER COLUMN $name SET NOT NULL";
 486
 487     if ( $driver eq 'Pg' ) {
 488
 489       my $pg_server_version = $dbh->{'pg_server_version'};
 490       unless ( $pg_server_version =~ /\d/ ) {
 491         warn "WARNING: no pg_server_version!  Assuming >= 7.3\n";
 492         $pg_server_version = 70300;
 493       }
 494
 495       if ( $pg_server_version < 70300 ) {
 496         push @r, "UPDATE pg_attribute SET attnotnull = TRUE
 497                     WHERE attname = '$name'
 498                       AND attrelid = ( SELECT oid FROM pg_class
 499                                          WHERE relname = '$table'
 500                                      )";
 501       }
 502
 503     }
 504
 505     push @r, $alter;
 506
 507   }
 508
 509   # change other stuff...
 510
 511   @r;
 512
 513 }
 514
 515 =back
 516
 517 =head1 AUTHOR
 518
 519 Ivan Kohler <ivan-dbix-dbschema@420.am>
 520
 521 =head1 COPYRIGHT
 522
 523 Copyright (c) 2000-2006 Ivan Kohler
 524 All rights reserved.
 525 This program is free software; you can redistribute it and/or modify it under
 526 the same terms as Perl itself.
 527
 528 =head1 BUGS
 529
 530 The new() method should warn that
 531 "Old-style $class creation without named parameters is deprecated!"
 532
 533 Better documentation is needed for sql_add_column
 534
 535 line() and sql_add_column() hav database-specific foo that should be abstracted
 536 into the DBIx::DBSchema:DBD:: modules.
 537
 538 =head1 SEE ALSO
 539
 540 L<DBIx::DBSchema::Table>, L<DBIx::DBSchema>, L<DBIx::DBSchema::DBD>, L<DBI>
 541
 542 =cut
 543
 544 1;
 545