From 5606f44c8c8134c605d5f5cb05b2e57a4b34e0b3 Mon Sep 17 00:00:00 2001 From: ivan Date: Sat, 7 Oct 2000 16:54:44 +0000 Subject: [PATCH] added typemap foo and default values --- DBSchema.pm | 20 ++++++++++++---- DBSchema/Column.pm | 55 +++++++++++++++++++++++++++++++++++-------- DBSchema/DBD.pm | 31 ++++++++++++++++++++---- DBSchema/DBD/Pg.pm | 15 +++++++++--- DBSchema/DBD/mysql.pm | 19 ++++++++++++--- DBSchema/Table.pm | 9 ++++--- MANIFEST | 1 + MANIFEST.SKIP | 1 + 8 files changed, 124 insertions(+), 27 deletions(-) create mode 100644 MANIFEST.SKIP diff --git a/DBSchema.pm b/DBSchema.pm index 8801737..847873d 100644 --- a/DBSchema.pm +++ b/DBSchema.pm @@ -14,7 +14,7 @@ use DBIx::DBSchema::ColGroup::Index; #@ISA = qw(Exporter); @ISA = (); -$VERSION = "0.11"; +$VERSION = "0.12"; =head1 NAME @@ -43,7 +43,7 @@ DBIx::DBSchema - Database-independent schema objects $perl_code = $schema->pretty_print; %hash = eval $perl_code; - $schema = pretty_read DBIx::DBSchema \%hash; + use DBI qw(:sql_types); $schema = pretty_read DBIx::DBSchema \%hash; =head1 DESCRIPTION @@ -232,6 +232,7 @@ sub pretty_print { "'". $self->table($table)->column($_)->type. "', ". "'". $self->table($table)->column($_)->null. "', ". "'". $self->table($table)->column($_)->length. "', ". + "'". $self->table($table)->column($_)->default. "', ". "'". $self->table($table)->column($_)->local. "',\n" } $self->table($table)->columns ). @@ -265,7 +266,7 @@ sub pretty_read { my(@columns); while ( @{$href->{$_}{'columns'}} ) { push @columns, DBIx::DBSchema::Column->new( - splice @{$href->{$_}{'columns'}}, 0, 5 + splice @{$href->{$_}{'columns'}}, 0, 6 ); } DBIx::DBSchema::Table->new( @@ -282,7 +283,15 @@ sub pretty_read { sub _load_driver { my($dbh) = @_; - my $driver = $dbh->{Driver}->{Name}; + my $driver; + if ( ref($dbh) ) { + $driver = $dbh->{Driver}->{Name}; + } else { + $dbh =~ s/^dbi:(\w*?)(?:\((.*?)\))?://i #nicked from DBI->connect + or '' =~ /()/; # ensure $1 etc are empty if match fails + $driver = $1 or die "can't parse data source: $dbh"; + } + #require "DBIx/DBSchema/DBD/$driver.pm"; #$driver; eval 'require "DBIx/DBSchema/DBD/$driver.pm"' and $driver; @@ -318,6 +327,9 @@ within the SQL database engine (DBI data source). pretty_print is actually pretty ugly. +Perhaps pretty_read should eval column types so that we can use DBI +qw(:sql_types) here instead of externally. + =head1 SEE ALSO L, L, diff --git a/DBSchema/Column.pm b/DBSchema/Column.pm index 7e2aad2..617d720 100644 --- a/DBSchema/Column.pm +++ b/DBSchema/Column.pm @@ -20,7 +20,7 @@ DBIx::DBSchema::Column - Column objects $column = new DBIx::DBSchema::Column ( $name, $sql_type, 'NULL' ); $column = new DBIx::DBSchema::Column ( $name, $sql_type, '', $length ); $column = new DBIx::DBSchema::Column ( $name, $sql_type, 'NULL', $length ); - $column = new DBIx::DBSchema::Column ( $name, $sql_type, 'NULL', $length, $local ); + $column = new DBIx::DBSchema::Column ( $name, $sql_type, 'NULL', $length, $default, $local ); $name = $column->name; $column->name( 'name' ); @@ -37,6 +37,9 @@ DBIx::DBSchema::Column - Column objects $column->length( '10' ); $column->length( '8,2' ); + $default = $column->default; + $column->default( 'Roo' ); + $sql_line = $column->line; $sql_line = $column->line($datasrc); @@ -49,17 +52,18 @@ L). =over 4 -=item new [ NAME [ , SQL_TYPE [ , NULL [ , LENGTH [ , LOCAL ] ] ] ] ] +=item new [ NAME [ , SQL_TYPE [ , NULL [ , LENGTH [ , DEFAULT [ , LOCAL ] ] ] ] ] ] Creates a new DBIx::DBSchema::Column object. NAME is the name of the column. SQL_TYPE is the SQL data type. NULL is the nullability of the column (the empty string is equivalent to `NOT NULL'). LENGTH is the SQL length of the -column. LOCAL is reserved for database-specific information. +column. DEFAULT is the default value of the column. LOCAL is reserved for +database-specific information. =cut sub new { - my($proto,$name,$type,$null,$length,$local)=@_; + my($proto,$name,$type,$null,$length,$default,$local)=@_; #croak "Illegal name: $name" if grep $name eq $_, @reserved_words; @@ -68,11 +72,12 @@ sub new { my $class = ref($proto) || $proto; my $self = { - 'name' => $name, - 'type' => $type, - 'null' => $null, - 'length' => $length, - 'local' => $local, + 'name' => $name, + 'type' => $type, + 'null' => $null, + 'length' => $length, + 'default' => $default, + 'local' => $local, }; bless ($self, $class); @@ -143,6 +148,22 @@ sub length { } } +=item default [ LOCAL ] + +Returns or sets the default value. + +=cut + +sub default { + my($self,$value)=@_; + if ( defined($value) ) { + $self->{'default'} = $value; + } else { + $self->{'default'}; + } +} + + =item local [ LOCAL ] Returns or sets the database-specific field. @@ -171,7 +192,15 @@ for other engines (if applicable) may also be supported in the future. sub line { my($self,$datasrc)=@_; + + my $driver = DBIx::DBSchema::_load_driver($datasrc); + my %typemap = eval "\%DBIx::DBSchema::DBD::${driver}::typemap"; + my $type = defined( $typemap{uc($self->type)} ) + ? $typemap{uc($self->type)} + : $self->type; + my($null)=$self->null; + if ( $datasrc =~ /^dbi:mysql:/i ) { #yucky mysql hack $null ||= "NOT NULL" } @@ -179,15 +208,21 @@ sub line { $null ||= "NOT NULL"; $null =~ s/^NULL$//; } + join(' ', $self->name, - $self->type. ( $self->length ? '('.$self->length.')' : '' ), + $type. ( $self->length ? '('.$self->length.')' : '' ), $null, + ( ( defined($self->default) && $self->default ne '' ) + ? 'DEFAULT '. $self->default + : '' + ), ( ( $datasrc =~ /^dbi:mysql:/i ) ? $self->local : '' ), ); + } =back diff --git a/DBSchema/DBD.pm b/DBSchema/DBD.pm index c9ce8e4..c0a8652 100644 --- a/DBSchema/DBD.pm +++ b/DBSchema/DBD.pm @@ -3,16 +3,20 @@ package DBIx::DBSchema::DBD; use strict; use vars qw($VERSION); -$VERSION = '0.01'; +$VERSION = '0.02'; =head1 NAME -DBIx::DBSchema::DBD - DBIx::DBSchema Driver Writer's Guide +DBIx::DBSchema::DBD - DBIx::DBSchema Driver Writer's Guide and Base Class =head1 SYNOPSIS perldoc DBIx::DBSchema::DBD + package DBIx::DBSchema::DBD::FooBase + use DBIx::DBSchmea::DBD; + @ISA = qw(DBIx::DBSchema::DBD); + =head1 DESCRIPTION Drivers should be named DBIx::DBSchema::DBD::DatabaseName, where DatabaseName @@ -24,8 +28,25 @@ following class methods: =item columns CLASS DBI_DBH TABLE Given an active DBI database handle, return a listref of listrefs (see -L), each containing five elements: column name, column type, -nullability, column length, and a field reserved for driver-specific use. +L), each containing six elements: column name, column type, +nullability, column length, column default, and a field reserved for +driver-specific use. + +=item column CLASS DBI_DBH TABLE COLUMN + +Same as B above, except return the listref for a single column. You +can inherit from DBIx::DBSchema::DBD to provide this function. + +=cut + +sub column { + my($proto, $dbh, $table, $column) = @_; + #@a = grep { $_->[0] eq $column } @{ $proto->columns( $dbh, $table ) }; + #$a[0]; + @{ [ + grep { $_->[0] eq $column } @{ $proto->columns( $dbh, $table ) } + ] }[0]; #force list context on grep, return scalar of first element +} =item primary_key CLASS DBI_DBH TABLE @@ -62,6 +83,8 @@ the same terms as Perl itself. =head1 BUGS +%typemap needs to be documented. + =head1 SEE ALSO L, L, L, diff --git a/DBSchema/DBD/Pg.pm b/DBSchema/DBD/Pg.pm index 2dfeec0..23ab42b 100644 --- a/DBSchema/DBD/Pg.pm +++ b/DBSchema/DBD/Pg.pm @@ -1,9 +1,15 @@ package DBIx::DBSchema::DBD::Pg; use strict; -use vars qw($VERSION); +use vars qw($VERSION @ISA %typemap); +use DBIx::DBSchema::DBD; -$VERSION = '0.01'; +$VERSION = '0.02'; +@ISA = qw(DBIx::DBSchema::DBD); + +%typemap = ( + 'BLOB' => 'TEXT', +); =head1 NAME @@ -41,7 +47,8 @@ END ? $_->{'atttypmod'} - 4 : '' ), - '' + '', #default + '' #local ] } @{ $sth->fetchall_arrayref({}) }; } @@ -128,6 +135,8 @@ the same terms as Perl itself. Yes. +columns doesn't return column default information. + =head1 SEE ALSO L, L, L, L diff --git a/DBSchema/DBD/mysql.pm b/DBSchema/DBD/mysql.pm index e378861..63877f7 100644 --- a/DBSchema/DBD/mysql.pm +++ b/DBSchema/DBD/mysql.pm @@ -1,9 +1,15 @@ package DBIx::DBSchema::DBD::mysql; use strict; -use vars qw($VERSION); +use vars qw($VERSION @ISA %typemap); +use DBIx::DBSchema::DBD; -$VERSION = '0.01'; +$VERSION = '0.02'; +@ISA = qw(DBIx::DBSchema::DBD); + +%typemap = ( + 'TIMESTAMP' => 'DATETIME', +); =head1 NAME @@ -31,7 +37,14 @@ sub columns { $_->{'Type'} =~ /^(\w+)\(?([\d\,]+)?\)?( unsigned)?$/ or die "Illegal type: ". $_->{'Type'}. "\n"; my($type, $length) = ($1, $2); - [ $_->{'Field'}, $type, $_->{'Null'}, $length, $_->{'Extra'} ] + [ + $_->{'Field'}, + $type, + $_->{'Null'}, + $length, + $_->{'Default'}, + $_->{'Extra'} + ] } @{ $sth->fetchall_arrayref( {} ) }; } diff --git a/DBSchema/Table.pm b/DBSchema/Table.pm index 179bbe8..6919331 100644 --- a/DBSchema/Table.pm +++ b/DBSchema/Table.pm @@ -137,10 +137,13 @@ sub new_odbc { new DBIx::DBSchema::Column $_, $type_info->{'TYPE_NAME'}, + #"SQL_". uc($type_info->{'TYPE_NAME'}), $sth->{NULLABLE}->[$sthpos], - &{ - $create_params{ $type_info->{CREATE_PARAMS} } - }( $sth, $sthpos++ ) + &{ $create_params{ $type_info->{CREATE_PARAMS} } }( $sth, $sthpos++ ), $driver && #default + ${ [ + eval "DBIx::DBSchema::DBD::$driver->column(\$dbh, \$name, \$_)" + ] }[4] + # DB-local } @{$sth->{NAME}} ); } diff --git a/MANIFEST b/MANIFEST index 165823a..2178549 100644 --- a/MANIFEST +++ b/MANIFEST @@ -1,5 +1,6 @@ Changes MANIFEST +MANIFEST.SKIP README Makefile.PL DBSchema.pm diff --git a/MANIFEST.SKIP b/MANIFEST.SKIP new file mode 100644 index 0000000..ae335e7 --- /dev/null +++ b/MANIFEST.SKIP @@ -0,0 +1 @@ +CVS/ -- 2.20.1