File Coverage

blib/lib/DBIx/DBSchema/Column.pm
Criterion Covered Total %
statement 62 132 46.9
branch 22 84 26.1
condition 9 38 23.6
subroutine 14 18 77.7
pod 14 14 100.0
total 121 286 42.3


line stmt bran cond sub pod time code
1             package DBIx::DBSchema::Column;
2              
3 2     2   645 use strict;
  2         4  
  2         54  
4 2     2   9 use vars qw($VERSION);
  2         3  
  2         82  
5 2     2   9 use Carp;
  2         3  
  2         109  
6 2     2   328 use DBIx::DBSchema::_util qw(_load_driver _dbh _parse_opt);
  2         4  
  2         2871  
7              
8             $VERSION = '0.14';
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).
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 is the name of the column. B is the SQL
70             data type. B is the nullability of the column (intrepreted using Perl's
71             rules for truth, with one exception: `NOT NULL' is false). B is the
72             SQL length of the column. B is the default value of the column.
73             B is reserved for database-specific information.
74              
75             Note: If you pass a scalar reference as the B 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 or explicit empty strings as C<''> as
76             defaults.
77              
78             =cut
79              
80             sub new {
81 1     1 1 511 my $proto = shift;
82 1   33     7 my $class = ref($proto) || $proto;
83              
84 1         1 my $self;
85 1 50       4 if ( ref($_[0]) ) {
86 1         2 $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 0         0 $self = { map { $_ => shift } qw(name type null length default local) };
  0         0  
93             }
94              
95             #croak "Illegal name: ". $self->{'name'}
96             # if grep $self->{'name'} eq $_, @reserved_words;
97              
98 1         15 $self->{'null'} =~ s/^NOT NULL$//i;
99 1 50       4 $self->{'null'} = 'NULL' if $self->{'null'};
100              
101 1         3 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 1     1 1 2 my($self,$value)=@_;
113 1 50       3 if ( defined($value) ) {
114             #croak "Illegal name: $name" if grep $name eq $_, @reserved_words;
115 0         0 $self->{'name'} = $value;
116             } else {
117 1         3 $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 4     4 1 7 my($self,$value)=@_;
129 4 50       36 if ( defined($value) ) {
130 0         0 $self->{'type'} = $value;
131             } else {
132 4         27 $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 1     1 1 2 my($self,$value)=@_;
145 1 50       2 if ( defined($value) ) {
146 0         0 $value =~ s/^NOT NULL$//i;
147 0 0       0 $value = 'NULL' if $value;
148 0         0 $self->{'null'} = $value;
149             } else {
150 1         2 $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 1     1 1 3 my($self,$value)=@_;
162 1 50       2 if ( defined($value) ) {
163 0         0 $self->{'length'} = $value;
164             } else {
165 1         10 $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 8     8 1 11 my($self,$value)=@_;
177 8 50       12 if ( defined($value) ) {
178 0         0 $self->{'default'} = $value;
179             } else {
180 8         29 $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 1     1 1 2 my($self,$value)=@_;
193 1 50       2 if ( defined($value) ) {
194 0         0 $self->{'local'} = $value;
195             } else {
196 1         2 $self->{'local'};
197             }
198             }
199              
200             =item table_obj [ TABLE_OBJ ]
201              
202             Returns or sets the table object (see L). Typically
203             set internally when a column object is added to a table object.
204              
205             =cut
206              
207             sub table_obj {
208 0     0 1 0 my($self,$value)=@_;
209 0 0       0 if ( defined($value) ) {
210 0         0 $self->{'table_obj'} = $value;
211             } else {
212 0         0 $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 1     1 1 1 my $self = shift;
225 1 50       7 $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 1     1 1 6 my($self, $dbh) = ( shift, _dbh(@_) );
249              
250 1 50       3 my $driver = $dbh ? _load_driver($dbh) : '';
251 1         4 my $dbd = "DBIx::DBSchema::DBD::$driver";
252              
253             ##
254             # type mapping
255             ##
256              
257 1         2 my %typemap;
258 1 50       45 %typemap = eval "\%${dbd}::typemap" if $driver;
259             my $type = defined( $typemap{uc($self->type)} )
260 1 50       6 ? $typemap{uc($self->type)}
261             : $self->type;
262              
263             ##
264             # callback into the database-specific driver
265             ##
266              
267 1         4 my $hashref = $dbd->column_callback( $dbh, $self->table_name, $self );
268              
269             $type = $hashref->{'effective_type'}
270 1 50       3 if $hashref->{'effective_type'};
271              
272 1         2 my $null = $self->null;
273              
274             #we seem to do this for mysql/Pg/SQLite, i think this should be the default
275             #add something to $hashref if drivers need to overrdide?
276 1   50     5 $null ||= "NOT NULL";
277              
278 1 50       2 $null =~ s/^NULL$// unless $hashref->{'explicit_null'};
279              
280 1   33     5 my $default = $hashref->{'effective_default'} || $self->quoted_default($dbh);
281 1 50       3 $default = "DEFAULT $default" if $default ne '';
282              
283 1         3 my $local = $self->local;
284             $local = $hashref->{'effective_local'}
285 1 50       2 if $hashref->{'effective_local'};
286              
287             ##
288             # return column line
289             ##
290              
291 1 50 33     3 join(' ',
    50          
292             $self->name,
293             $type. ( ( defined($self->length) && $self->length )
294             ? '('.$self->length.')'
295             : ''
296             ),
297             $null,
298             $default,
299             ( defined($local) ? $local : ''),
300             );
301              
302             }
303              
304             =item quoted_default DATABASE_HANDLE
305              
306             Returns this column's default value quoted for the database.
307              
308             =cut
309              
310             sub quoted_default {
311 2     2 1 5 my($self, $dbh) = @_;
312 2 100       6 my $driver = $dbh ? _load_driver($dbh) : '';
313              
314 2 50       6 return ${$self->default} if ref($self->default);
  0         0  
315              
316 2         5 my $dbd = "DBIx::DBSchema::DBD::$driver";
317              
318 2 50 66     4 return $dbh->quote($self->default)
      66        
      33        
319             if defined($self->default)
320             && $self->default ne ''
321             && ref($dbh)
322             && $dbd->column_value_needs_quoting($self);
323            
324 2         5 return $self->default;
325              
326             }
327              
328             =item sql_add_column [ DBH ]
329              
330             Returns SQL to add this column to an existing table. (To create a new table,
331             see L instead.)
332              
333             NOTE: This interface has changed in 0.41
334              
335             Returns two listrefs. The first is a list of column alteration SQL fragments
336             for an ALTER TABLE statement. The second is a list of full SQL statements that
337             should be run after the ALTER TABLE statement.
338              
339             The data source can be specified by passing an open DBI database handle, or by
340             passing the DBI data source name, username and password.
341              
342             Although the username and password are optional, it is best to call this method
343             with a database handle or data source including a valid username and password -
344             a DBI connection will be opened and the quoting and type mapping will be more
345             reliable.
346              
347             If passed a DBI data source (or handle) such as `DBI:Pg:dbname=database', will
348             use PostgreSQL-specific syntax. Non-standard syntax for other engines (if
349             applicable) may also be supported in the future.
350              
351             =cut
352              
353             sub sql_add_column {
354 0     0 1   my($self, $dbh) = ( shift, _dbh(@_) );
355              
356 0 0         die "$self: this column is not assigned to a table"
357             unless $self->table_name;
358              
359 0 0         my $driver = $dbh ? _load_driver($dbh) : '';
360              
361 0           my @alter_table = ();
362 0           my @sql = ();
363 0           my $table = $self->table_name;
364              
365 0           my $dbd = "DBIx::DBSchema::DBD::$driver";
366 0           my $hashref = $dbd->add_column_callback( $dbh, $table, $self );
367              
368 0           my $real_type = '';
369 0 0         if ( $hashref->{'effective_type'} ) {
370 0           $real_type = $self->type;
371 0           $self->type($hashref->{'effective_type'});
372             }
373              
374 0           my $real_null = undef;
375 0 0         if ( exists($hashref->{'effective_null'}) ) {
376 0           $real_null = $self->null;
377 0           $self->null($hashref->{'effective_null'});
378             }
379              
380 0           push @alter_table, "ADD COLUMN ". $self->line($dbh);
381              
382 0 0         push @sql, @{ $hashref->{'sql_after'} } if $hashref->{'sql_after'};
  0            
383              
384 0 0         push @sql, "ALTER TABLE $table ADD PRIMARY KEY ( ".
385             $self->table_obj->primary_key. " )"
386             if $self->name eq $self->table_obj->primary_key;
387              
388 0 0         $self->type($real_type) if $real_type;
389 0 0         $self->null($real_null) if defined $real_null;
390              
391 0           (\@alter_table, \@sql);
392              
393             }
394              
395             =item sql_alter_column PROTOTYPE_COLUMN [ DATABASE_HANDLE | DATA_SOURCE [ USERNAME PASSWORD [ ATTR ] ] ]
396              
397             Returns SQL to alter this column so that it is identical to the provided
398             prototype column, also a DBIx::DBSchema::Column object.
399              
400             NOTE: This interface has changed in 0.41
401              
402             Returns two listrefs. The first is a list of column alteration SQL fragments
403             for an ALTER TABLE statement. The second is a list of full SQL statements that
404             should be run after the ALTER TABLE statement.
405              
406             Optionally, the data source can be specified by passing an open DBI database
407             handle, or by passing the DBI data source name, username and password.
408              
409             If passed a DBI data source (or handle) such as `DBI:Pg:dbname=database', will
410             use PostgreSQL-specific syntax. Non-standard syntax for other engines (if
411             applicable) may also be supported in the future.
412              
413             If not passed a data source (or handle), or if there is no driver for the
414             specified database, will attempt to use generic SQL syntax.
415              
416             =cut
417              
418             sub sql_alter_column {
419 0     0 1   my($self, $opt, $new, $dbh) = ( shift, _parse_opt(\@_), shift, _dbh(@_) );
420              
421 0           my $table = $self->table_name;
422 0 0         die "$self: this column is not assigned to a table"
423             unless $table;
424              
425 0           my $name = $self->name;
426              
427 0 0         my $driver = $dbh ? _load_driver($dbh) : '';
428              
429 0           my @alter_table = ();
430 0           my @sql = ();
431              
432 0           my $dbd = "DBIx::DBSchema::DBD::$driver";
433 0           my $hashref = $dbd->alter_column_callback( $dbh, $table, $self, $new );
434              
435 0 0         if ( $hashref->{'sql_alter'} ) {
436              
437 0           push @sql, $hashref->{'sql_alter'};
438              
439             } else {
440              
441             # change the name...
442             # not yet implemented. how do we tell which old column it was?
443              
444             # change the type...
445 0 0         if ( $hashref->{'sql_alter_type'} ) {
446 0           push @alter_table, $hashref->{'sql_alter_type'};
447             }
448              
449             # change nullability...
450              
451 0 0         if ( $hashref->{'sql_alter_null'} ) {
452              
453 0           push @sql, $hashref->{'sql_alter_null'};
454              
455             } else {
456              
457             # change nullability from NOT NULL to NULL
458 0 0 0       if ( ! $self->null && $new->null ) {
459            
460 0           push @alter_table, "ALTER COLUMN $name DROP NOT NULL";
461            
462             }
463            
464             # change nullability from NULL to NOT NULL...
465             # this one could be more complicated, need to set a DEFAULT value and update
466             # the table first...
467 0 0 0       if ( $self->null && ! $new->null ) {
468            
469 0           push @alter_table, "ALTER COLUMN $name SET NOT NULL";
470            
471             }
472              
473             }
474              
475             # change default
476 0           my $old_default = $self->quoted_default($dbh);
477 0           my $new_default = $new->quoted_default($dbh);
478 0 0 0       if ( $old_default ne $new_default
      0        
479             && ( uc($old_default) ne 'NOW()' || uc($new_default) ne 'NOW()' )
480             )
481             {
482              
483             #warn "old default: $old_default / new default: $new_default\n";
484              
485 0           my $alter = "ALTER COLUMN $name";
486              
487 0 0         if ( $new_default ne '' ) {
    0          
488             #warn "changing from $old_default to $new_default\n";
489 0           push @alter_table, "$alter SET DEFAULT $new_default";
490             } elsif ( $old_default !~ /^nextval/i ) { #Pg-specific :(
491 0           push @alter_table, "$alter DROP DEFAULT";
492              
493             push @sql, "UPDATE TABLE $table SET $name = NULL WHERE $name = ''"
494 0 0 0       if $opt->{'nullify_default'} && $old_default eq "''" && $new->null;
      0        
495             }
496              
497             }
498              
499             # change other stuff... (what next?)
500              
501             }
502              
503 0           (\@alter_table, \@sql);
504              
505             }
506              
507             =item sql_drop_column [ DBH ]
508              
509             Returns SQL to drop this column from an existing table.
510              
511             NOTE: This interface has changed in 0.41
512              
513             Returns a list of column alteration SQL fragments for an ALTER TABLE statement.
514              
515             The optional database handle or DBI data source/username/password is not yet
516             used.
517              
518             =cut
519              
520             sub sql_drop_column {
521 0     0 1   my( $self, $dbh ) = ( shift, _dbh(@_) );
522            
523 0           my $table = $self->table_name;
524 0           my $name = $self->name;
525            
526 0           ("DROP COLUMN $name"); # XXX what about indexes???
527             }
528              
529             =back
530              
531             =head1 AUTHOR
532              
533             Ivan Kohler
534              
535             =head1 COPYRIGHT
536              
537             Copyright (c) 2000-2006 Ivan Kohler
538             Copyright (c) 2007-2013 Freeside Internet Services, Inc.
539             All rights reserved.
540             This program is free software; you can redistribute it and/or modify it under
541             the same terms as Perl itself.
542              
543             =head1 BUGS
544              
545             The new() method should warn that
546             "Old-style $class creation without named parameters is deprecated!"
547              
548             Better documentation is needed for sql_add_column
549              
550             sql_alter_column() has database-specific foo that should be abstracted info
551             DBIx::DBSchema::DBD::Pg
552              
553             nullify_default option should be documented
554              
555             =head1 SEE ALSO
556              
557             L, L, L, L
558              
559             =cut
560              
561             1;
562