diff options
Diffstat (limited to 'install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema')
9 files changed, 1542 insertions, 0 deletions
diff --git a/install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/ColGroup.pm b/install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/ColGroup.pm new file mode 100644 index 000000000..ceeb223ca --- /dev/null +++ b/install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/ColGroup.pm @@ -0,0 +1,141 @@ +package DBIx::DBSchema::ColGroup; + +use strict; +use vars qw(@ISA); +#use Exporter; + +#@ISA = qw(Exporter); +@ISA = qw(); + +=head1 NAME + +DBIx::DBSchema::ColGroup - Column group objects + +=head1 SYNOPSIS + + use DBIx::DBSchema::ColGroup; + + $colgroup = new DBIx::DBSchema::ColGroup ( $lol_ref ); + $colgroup = new DBIx::DBSchema::ColGroup ( \@lol ); + $colgroup = new DBIx::DBSchema::ColGroup ( + [ + [ 'single_column' ], + [ 'multiple_columns', 'another_column', ], + ] + ); + + $lol_ref = $colgroup->lol_ref; + + @sql_lists = $colgroup->sql_list; + + @singles = $colgroup->singles; + +=head1 DESCRIPTION + +DBIx::DBSchema::ColGroup objects represent sets of sets of columns. (IOW a +"list of lists" - see L<perllol>.) + +=head1 METHODS + +=over 4 + +=item new [ LOL_REF ] + +Creates a new DBIx::DBSchema::ColGroup object. Pass a reference to a list of +lists of column names. + +=cut + +sub new { + my($proto, $lol) = @_; + + my $class = ref($proto) || $proto; + my $self = { + 'lol' => $lol, + }; + + bless ($self, $class); + +} + +=item lol_ref + +Returns a reference to a list of lists of column names. + +=cut + +sub lol_ref { + my($self) = @_; + $self->{'lol'}; +} + +=item sql_list + +Returns a flat list of comma-separated values, for SQL statements. + +For example: + + @lol = ( + [ 'single_column' ], + [ 'multiple_columns', 'another_column', ], + ); + + $colgroup = new DBIx::DBSchema::ColGroup ( \@lol ); + + print join("\n", $colgroup->sql_list), "\n"; + +Will print: + + single_column + multiple_columns, another_column + +=cut + +sub sql_list { #returns a flat list of comman-separates lists (for sql) + my($self)=@_; + grep $_ ne '', map join(', ', @{$_}), @{$self->{'lol'}}; +} + +=item singles + +Returns a flat list of all single item lists. + +=cut + +sub singles { #returns single-field groups as a flat list + my($self)=@_; + #map ${$_}[0], grep scalar(@{$_}) == 1, @{$self->{'lol'}}; + map { + ${$_}[0] =~ /^(\w+)$/ + #aah! + or die "Illegal column ", ${$_}[0], " in colgroup!"; + $1; + } grep scalar(@{$_}) == 1, @{$self->{'lol'}}; +} + +=back + +=head1 AUTHOR + +Ivan Kohler <ivan-dbix-dbschema@420.am> + +=head1 COPYRIGHT + +Copyright (c) 2000 Ivan Kohler +Copyright (c) 2000 Mail Abuse Prevention System LLC +All rights reserved. +This program is free software; you can redistribute it and/or modify it under +the same terms as Perl itself. + +=head1 BUGS + +=head1 SEE ALSO + +L<DBIx::DBSchema::Table>, L<DBIx::DBSchema::ColGroup::Unique>, +L<DBIx::DBSchema::ColGroup::Index>, L<DBIx::DBSchema>, L<perllol>, L<perldsc>, +L<DBI> + +=cut + +1; + diff --git a/install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/ColGroup/Index.pm b/install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/ColGroup/Index.pm new file mode 100644 index 000000000..1a92baae1 --- /dev/null +++ b/install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/ColGroup/Index.pm @@ -0,0 +1,37 @@ +package DBIx::DBSchema::ColGroup::Index; + +use strict; +use vars qw(@ISA); +use DBIx::DBSchema::ColGroup; + +@ISA=qw(DBIx::DBSchema::ColGroup); + +=head1 NAME + +DBIx::DBSchema::ColGroup::Index - Index column group object + +=head1 SYNOPSIS + + use DBIx::DBSchema::ColGroup::Index; + + # see DBIx::DBSchema::ColGroup methods + +=head1 DESCRIPTION + +DBIx::DBSchema::ColGroup::Index objects represent the (non-unique) indices of a +database table (L<DBIx::DBSchema::Table>). DBIx::DBSchema::ColGroup::Index +inherits from DBIx::DBSchema::ColGroup. + +=head1 BUGS + +Is this empty subclass needed? + +=head1 SEE ALSO + +L<DBIx::DBSchema::ColGroup>, L<DBIx::DBSchema::ColGroup::Unique>, +L<DBIx::DBSchema::Table>, L<DBIx::DBSchema>, L<FS::Record> + +=cut + +1; + diff --git a/install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/ColGroup/Unique.pm b/install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/ColGroup/Unique.pm new file mode 100644 index 000000000..450043fdf --- /dev/null +++ b/install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/ColGroup/Unique.pm @@ -0,0 +1,38 @@ +package DBIx::DBSchema::ColGroup::Unique; + +use strict; +use vars qw(@ISA); +use DBIx::DBSchema::ColGroup; + +@ISA=qw(DBIx::DBSchema::ColGroup); + +=head1 NAME + +DBIx::DBSchema::ColGroup::Unique - Unique column group object + +=head1 SYNOPSIS + + use DBIx::DBSchema::ColGroup::Unique; + + # see DBIx::DBSchema::ColGroup methods + +=head1 DESCRIPTION + +DBIx::DBSchema::ColGroup::Unique objects represent the unique indices of a +database table (L<DBIx::DBSchema::Table>). DBIx::DBSchema::ColGroup:Unique +inherits from DBIx::DBSchema::ColGroup. + +=head1 BUGS + +Is this empty subclass needed? + +=head1 SEE ALSO + +L<DBIx::DBSchema::ColGroup>, L<DBIx::DBSchema::ColGroup::Index>, +L<DBIx::DBSchema::Table>, L<DBIx::DBSchema>, L<FS::Record> + +=cut + +1; + + diff --git a/install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/Column.pm b/install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/Column.pm new file mode 100644 index 000000000..4e26646e7 --- /dev/null +++ b/install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/Column.pm @@ -0,0 +1,300 @@ +package DBIx::DBSchema::Column; + +use strict; +use vars qw(@ISA $VERSION); +#use Carp; +#use Exporter; + +#@ISA = qw(Exporter); +@ISA = qw(); + +$VERSION = '0.02'; + +=head1 NAME + +DBIx::DBSchema::Column - Column objects + +=head1 SYNOPSIS + + use DBIx::DBSchema::Column; + + #named params with a hashref (preferred) + $column = new DBIx::DBSchema::Column ( { + 'name' => 'column_name', + 'type' => 'varchar' + 'null' => 'NOT NULL', + 'length' => 64, + 'default' => ' + 'local' => '', + } ); + + #list + $column = new DBIx::DBSchema::Column ( $name, $sql_type, $nullability, $length, $default, $local ); + + $name = $column->name; + $column->name( 'name' ); + + $sql_type = $column->type; + $column->type( 'sql_type' ); + + $null = $column->null; + $column->null( 'NULL' ); + $column->null( 'NOT NULL' ); + $column->null( '' ); + + $length = $column->length; + $column->length( '10' ); + $column->length( '8,2' ); + + $default = $column->default; + $column->default( 'Roo' ); + + $sql_line = $column->line; + $sql_line = $column->line($datasrc); + +=head1 DESCRIPTION + +DBIx::DBSchema::Column objects represent columns in tables (see +L<DBIx::DBSchema::Table>). + +=head1 METHODS + +=over 4 + +=item new HASHREF + +=item new [ name [ , type [ , null [ , length [ , default [ , local ] ] ] ] ] ] + +Creates a new DBIx::DBSchema::Column object. Takes a hashref of named +parameters, or a list. B<name> is the name of the column. B<type> is the SQL +data type. B<null> is the nullability of the column (intrepreted using Perl's +rules for truth, with one exception: `NOT NULL' is false). B<length> is the +SQL length of the column. B<default> is the default value of the column. +B<local> is reserved for database-specific information. + +=cut + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + + my $self; + if ( ref($_[0]) ) { + $self = shift; + } else { + $self = { map { $_ => shift } qw(name type null length default local) }; + } + + #croak "Illegal name: ". $self->{'name'} + # if grep $self->{'name'} eq $_, @reserved_words; + + $self->{'null'} =~ s/^NOT NULL$//i; + $self->{'null'} = 'NULL' if $self->{'null'}; + + bless ($self, $class); + +} + +=item name [ NAME ] + +Returns or sets the column name. + +=cut + +sub name { + my($self,$value)=@_; + if ( defined($value) ) { + #croak "Illegal name: $name" if grep $name eq $_, @reserved_words; + $self->{'name'} = $value; + } else { + $self->{'name'}; + } +} + +=item type [ TYPE ] + +Returns or sets the column type. + +=cut + +sub type { + my($self,$value)=@_; + if ( defined($value) ) { + $self->{'type'} = $value; + } else { + $self->{'type'}; + } +} + +=item null [ NULL ] + +Returns or sets the column null flag (the empty string is equivalent to +`NOT NULL') + +=cut + +sub null { + my($self,$value)=@_; + if ( defined($value) ) { + $value =~ s/^NOT NULL$//i; + $value = 'NULL' if $value; + $self->{'null'} = $value; + } else { + $self->{'null'}; + } +} + +=item length [ LENGTH ] + +Returns or sets the column length. + +=cut + +sub length { + my($self,$value)=@_; + if ( defined($value) ) { + $self->{'length'} = $value; + } else { + $self->{'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. + +=cut + +sub local { + my($self,$value)=@_; + if ( defined($value) ) { + $self->{'local'} = $value; + } else { + $self->{'local'}; + } +} + +=item line [ DATABASE_HANDLE | DATA_SOURCE [ USERNAME PASSWORD [ ATTR ] ] ] + +Returns an SQL column definition. + +The data source can be specified by passing an open DBI database handle, or by +passing the DBI data source name, username and password. + +Although the username and password are optional, it is best to call this method +with a database handle or data source including a valid username and password - +a DBI connection will be opened and the quoting and type mapping will be more +reliable. + +If passed a DBI data source (or handle) such as `DBI:mysql:database' or +`DBI:Pg:dbname=database', will use syntax specific to that database engine. +Currently supported databases are MySQL and PostgreSQL. Non-standard syntax +for other engines (if applicable) may also be supported in the future. + +=cut + +sub line { + my($self,$dbh) = (shift, shift); + + my $created_dbh = 0; + unless ( ref($dbh) || ! @_ ) { + $dbh = DBI->connect( $dbh, @_ ) or die $DBI::errstr; + my $gratuitous = $DBI::errstr; #surpress superfluous `used only once' error + $created_dbh = 1; + } + + my $driver = DBIx::DBSchema::_load_driver($dbh); + my %typemap; + %typemap = eval "\%DBIx::DBSchema::DBD::${driver}::typemap" if $driver; + my $type = defined( $typemap{uc($self->type)} ) + ? $typemap{uc($self->type)} + : $self->type; + + my $null = $self->null; + + my $default; + if ( defined($self->default) && $self->default ne '' + && ref($dbh) + # false laziness: nicked from FS::Record::_quote + && ( $self->default !~ /^\-?\d+(\.\d+)?$/ + || $type =~ /(char|binary|blob|text)$/i + ) + ) { + $default = $dbh->quote($self->default); + } else { + $default = $self->default; + } + + #this should be a callback into the driver + if ( $driver eq 'mysql' ) { #yucky mysql hack + $null ||= "NOT NULL"; + $self->local('AUTO_INCREMENT') if uc($self->type) eq 'SERIAL'; + } elsif ( $driver eq 'Pg' ) { #yucky Pg hack + $null ||= "NOT NULL"; + $null =~ s/^NULL$//; + } + + my $r = join(' ', + $self->name, + $type. ( ( defined($self->length) && $self->length ) + ? '('.$self->length.')' + : '' + ), + $null, + ( ( defined($default) && $default ne '' ) + ? 'DEFAULT '. $default + : '' + ), + ( ( $driver eq 'mysql' && defined($self->local) ) + ? $self->local + : '' + ), + ); + $dbh->disconnect if $created_dbh; + $r; + +} + +=back + +=head1 AUTHOR + +Ivan Kohler <ivan-dbix-dbschema@420.am> + +=head1 COPYRIGHT + +Copyright (c) 2000 Ivan Kohler +Copyright (c) 2000 Mail Abuse Prevention System LLC +All rights reserved. +This program is free software; you can redistribute it and/or modify it under +the same terms as Perl itself. + +=head1 BUGS + +line() has database-specific foo that probably ought to be abstracted into +the DBIx::DBSchema:DBD:: modules. + +=head1 SEE ALSO + +L<DBIx::DBSchema::Table>, L<DBIx::DBSchema>, L<DBIx::DBSchema::DBD>, L<DBI> + +=cut + +1; + diff --git a/install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/DBD.pm b/install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/DBD.pm new file mode 100644 index 000000000..a4c60003e --- /dev/null +++ b/install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/DBD.pm @@ -0,0 +1,113 @@ +package DBIx::DBSchema::DBD; + +use strict; +use vars qw($VERSION); + +$VERSION = '0.02'; + +=head1 NAME + +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 +is the same as the DBD:: driver for this database. Drivers should implement the +following class methods: + +=over 4 + +=item columns CLASS DBI_DBH TABLE + +Given an active DBI database handle, return a listref of listrefs (see +L<perllol>), 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<columns> 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 + +Given an active DBI database handle, return the primary key for the specified +table. + +=item unique CLASS DBI_DBH TABLE + +Given an active DBI database handle, return a hashref of unique indices. The +keys of the hashref are index names, and the values are arrayrefs which point +a list of column names for each. See L<perldsc/"HASHES OF LISTS"> and +L<DBIx::DBSchema::ColGroup>. + +=item index CLASS DBI_DBH TABLE + +Given an active DBI database handle, return a hashref of (non-unique) indices. +The keys of the hashref are index names, and the values are arrayrefs which +point a list of column names for each. See L<perldsc/"HASHES OF LISTS"> and +L<DBIx::DBSchema::ColGroup>. + +=back + +=head1 TYPE MAPPING + +You can define a %typemap array for your driver to map "standard" data +types to database-specific types. For example, the MySQL TIMESTAMP field +has non-standard auto-updating semantics; the MySQL DATETIME type is +what other databases and the ODBC standard call TIMESTAMP, so one of the +entries in the MySQL %typemap is: + + 'TIMESTAMP' => 'DATETIME', + +Another example is the Pg %typemap which maps the standard types BLOB and +LONG VARBINARY to the Pg-specific BYTEA: + + 'BLOB' => 'BYTEA', + 'LONG VARBINARY' => 'BYTEA', + +Make sure you use all uppercase-keys. + +=head1 AUTHOR + +Ivan Kohler <ivan-dbix-dbschema@420.am> + +=head1 COPYRIGHT + +Copyright (c) 2000 Ivan Kohler +Copyright (c) 2000 Mail Abuse Prevention System LLC +All rights reserved. +This program is free software; you can redistribute it and/or modify it under +the same terms as Perl itself. + +=head1 BUGS + +=head1 SEE ALSO + +L<DBIx::DBSchema>, L<DBIx::DBSchema::DBD::mysql>, L<DBIx::DBSchema::DBD::Pg>, +L<DBIx::DBSchema::ColGroup>, L<DBI>, L<DBI::DBD>, L<perllol>, +L<perldsc/"HASHES OF LISTS"> + +=cut + +1; + diff --git a/install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/DBD/Pg.pm b/install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/DBD/Pg.pm new file mode 100644 index 000000000..018b89028 --- /dev/null +++ b/install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/DBD/Pg.pm @@ -0,0 +1,175 @@ +package DBIx::DBSchema::DBD::Pg; + +use strict; +use vars qw($VERSION @ISA %typemap); +use DBD::Pg 1.22; +use DBIx::DBSchema::DBD; + +$VERSION = '0.08'; +@ISA = qw(DBIx::DBSchema::DBD); + +%typemap = ( + 'BLOB' => 'BYTEA', + 'LONG VARBINARY' => 'BYTEA', +); + +=head1 NAME + +DBIx::DBSchema::DBD::Pg - PostgreSQL native driver for DBIx::DBSchema + +=head1 SYNOPSIS + +use DBI; +use DBIx::DBSchema; + +$dbh = DBI->connect('dbi:Pg:dbname=database', 'user', 'pass'); +$schema = new_native DBIx::DBSchema $dbh; + +=head1 DESCRIPTION + +This module implements a PostgreSQL-native driver for DBIx::DBSchema. + +=cut + +sub columns { + my($proto, $dbh, $table) = @_; + my $sth = $dbh->prepare(<<END) or die $dbh->errstr; + SELECT a.attname, t.typname, a.attlen, a.atttypmod, a.attnotnull, + a.atthasdef, a.attnum + FROM pg_class c, pg_attribute a, pg_type t + WHERE c.relname = '$table' + AND a.attnum > 0 AND a.attrelid = c.oid AND a.atttypid = t.oid + ORDER BY a.attnum +END + $sth->execute or die $sth->errstr; + + map { + + my $default = ''; + if ( $_->{atthasdef} ) { + my $attnum = $_->{attnum}; + my $d_sth = $dbh->prepare(<<END) or die $dbh->errstr; + SELECT substring(d.adsrc for 128) FROM pg_attrdef d, pg_class c + WHERE c.relname = '$table' AND c.oid = d.adrelid AND d.adnum = $attnum +END + $d_sth->execute or die $d_sth->errstr; + + $default = $d_sth->fetchrow_arrayref->[0]; + }; + + my $len = ''; + if ( $_->{attlen} == -1 && $_->{atttypmod} != -1 + && $_->{typname} ne 'text' ) { + $len = $_->{atttypmod} - 4; + if ( $_->{typname} eq 'numeric' ) { + $len = ($len >> 16). ','. ($len & 0xffff); + } + } + + my $type = $_->{'typname'}; + $type = 'char' if $type eq 'bpchar'; + + [ + $_->{'attname'}, + $type, + ! $_->{'attnotnull'}, + $len, + $default, + '' #local + ]; + + } @{ $sth->fetchall_arrayref({}) }; +} + +sub primary_key { + my($proto, $dbh, $table) = @_; + my $sth = $dbh->prepare(<<END) or die $dbh->errstr; + SELECT a.attname, a.attnum + FROM pg_class c, pg_attribute a, pg_type t + WHERE c.relname = '${table}_pkey' + AND a.attnum > 0 AND a.attrelid = c.oid AND a.atttypid = t.oid +END + $sth->execute or die $sth->errstr; + my $row = $sth->fetchrow_hashref or return ''; + $row->{'attname'}; +} + +sub unique { + my($proto, $dbh, $table) = @_; + my $gratuitous = { map { $_ => [ $proto->_index_fields($dbh, $_ ) ] } + grep { $proto->_is_unique($dbh, $_ ) } + $proto->_all_indices($dbh, $table) + }; +} + +sub index { + my($proto, $dbh, $table) = @_; + my $gratuitous = { map { $_ => [ $proto->_index_fields($dbh, $_ ) ] } + grep { ! $proto->_is_unique($dbh, $_ ) } + $proto->_all_indices($dbh, $table) + }; +} + +sub _all_indices { + my($proto, $dbh, $table) = @_; + my $sth = $dbh->prepare(<<END) or die $dbh->errstr; + SELECT c2.relname + FROM pg_class c, pg_class c2, pg_index i + WHERE c.relname = '$table' AND c.oid = i.indrelid AND i.indexrelid = c2.oid +END + $sth->execute or die $sth->errstr; + map { $_->{'relname'} } + grep { $_->{'relname'} !~ /_pkey$/ } + @{ $sth->fetchall_arrayref({}) }; +} + +sub _index_fields { + my($proto, $dbh, $index) = @_; + my $sth = $dbh->prepare(<<END) or die $dbh->errstr; + SELECT a.attname, a.attnum + FROM pg_class c, pg_attribute a, pg_type t + WHERE c.relname = '$index' + AND a.attnum > 0 AND a.attrelid = c.oid AND a.atttypid = t.oid +END + $sth->execute or die $sth->errstr; + map { $_->{'attname'} } @{ $sth->fetchall_arrayref({}) }; +} + +sub _is_unique { + my($proto, $dbh, $index) = @_; + my $sth = $dbh->prepare(<<END) or die $dbh->errstr; + SELECT i.indisunique + FROM pg_index i, pg_class c, pg_am a + WHERE i.indexrelid = c.oid AND c.relname = '$index' AND c.relam = a.oid +END + $sth->execute or die $sth->errstr; + my $row = $sth->fetchrow_hashref or die 'guru meditation #420'; + $row->{'indisunique'}; +} + +=head1 AUTHOR + +Ivan Kohler <ivan-dbix-dbschema@420.am> + +=head1 COPYRIGHT + +Copyright (c) 2000 Ivan Kohler +Copyright (c) 2000 Mail Abuse Prevention System LLC +All rights reserved. +This program is free software; you can redistribute it and/or modify it under +the same terms as Perl itself. + +=head1 BUGS + +Yes. + +columns doesn't return column default information. + +=head1 SEE ALSO + +L<DBIx::DBSchema>, L<DBIx::DBSchema::DBD>, L<DBI>, L<DBI::DBD> + +=cut + +1; + diff --git a/install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/DBD/Sybase.pm b/install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/DBD/Sybase.pm new file mode 100755 index 000000000..4a740693a --- /dev/null +++ b/install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/DBD/Sybase.pm @@ -0,0 +1,141 @@ +package DBIx::DBSchema::DBD::Sybase; + +use strict; +use vars qw($VERSION @ISA %typemap); +use DBIx::DBSchema::DBD; + +$VERSION = '0.03'; +@ISA = qw(DBIx::DBSchema::DBD); + +%typemap = ( +# 'empty' => 'empty' +); + +=head1 NAME + +DBIx::DBSchema::DBD::Sybase - Sybase database driver for DBIx::DBSchema + +=head1 SYNOPSIS + +use DBI; +use DBIx::DBSchema; + +$dbh = DBI->connect('dbi:Sybase:dbname=database', 'user', 'pass'); +$schema = new_native DBIx::DBSchema $dbh; + +=head1 DESCRIPTION + +This module implements a Sybase driver for DBIx::DBSchema. + +=cut + +sub columns { + my($proto, $dbh, $table) = @_; + + my $sth = $dbh->prepare("sp_columns \@table_name=$table") + or die $dbh->errstr; + + $sth->execute or die $sth->errstr; + my @cols = map { + [ + $_->{'column_name'}, + $_->{'type_name'}, + ($_->{'nullable'} ? 1 : ''), + $_->{'length'}, + '', #default + '' #local + ] + } @{ $sth->fetchall_arrayref({}) }; + $sth->finish; + + @cols; +} + +sub primary_key { + return("StubbedPrimaryKey"); +} + + +sub unique { + my($proto, $dbh, $table) = @_; + my $gratuitous = { map { $_ => [ $proto->_index_fields($dbh, $table, $_ ) ] } + grep { $proto->_is_unique($dbh, $_ ) } + $proto->_all_indices($dbh, $table) + }; +} + +sub index { + my($proto, $dbh, $table) = @_; + my $gratuitous = { map { $_ => [ $proto->_index_fields($dbh, $table, $_ ) ] } + grep { ! $proto->_is_unique($dbh, $_ ) } + $proto->_all_indices($dbh, $table) + }; +} + +sub _all_indices { + my($proto, $dbh, $table) = @_; + + my $sth = $dbh->prepare_cached(<<END) or die $dbh->errstr; + SELECT name + FROM sysindexes + WHERE id = object_id('$table') and indid between 1 and 254 +END + $sth->execute or die $sth->errstr; + my @indices = map { $_->[0] } @{ $sth->fetchall_arrayref() }; + $sth->finish; + $sth = undef; + @indices; +} + +sub _index_fields { + my($proto, $dbh, $table, $index) = @_; + + my @keys; + + my ($indid) = $dbh->selectrow_array("select indid from sysindexes where id = object_id('$table') and name = '$index'"); + for (1..30) { + push @keys, $dbh->selectrow_array("select index_col('$table', $indid, $_)") || (); + } + + return @keys; +} + +sub _is_unique { + my($proto, $dbh, $table, $index) = @_; + + my ($isunique) = $dbh->selectrow_array("select status & 2 from sysindexes where id = object_id('$table') and name = '$index'"); + + return $isunique; +} + +=head1 AUTHOR + +Charles Shapiro <charles.shapiro@numethods.com> +(courtesy of Ivan Kohler <ivan-dbix-dbschema@420.am>) + +Mitchell Friedman <mitchell.friedman@numethods.com> + +Bernd Dulfer <bernd@widd.de> + +=head1 COPYRIGHT + +Copyright (c) 2001 Charles Shapiro, Mitchell J. Friedman +Copyright (c) 2001 nuMethods LLC. +All rights reserved. +This program is free software; you can redistribute it and/or modify it under +the same terms as Perl itself. + +=head1 BUGS + +Yes. + +The B<primary_key> method does not yet work. + +=head1 SEE ALSO + +L<DBIx::DBSchema>, L<DBIx::DBSchema::DBD>, L<DBI>, L<DBI::DBD> + +=cut + +1; + diff --git a/install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/DBD/mysql.pm b/install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/DBD/mysql.pm new file mode 100644 index 000000000..f3804dd28 --- /dev/null +++ b/install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/DBD/mysql.pm @@ -0,0 +1,126 @@ +package DBIx::DBSchema::DBD::mysql; + +use strict; +use vars qw($VERSION @ISA %typemap); +use DBIx::DBSchema::DBD; + +$VERSION = '0.03'; +@ISA = qw(DBIx::DBSchema::DBD); + +%typemap = ( + 'TIMESTAMP' => 'DATETIME', + 'SERIAL' => 'INTEGER', + 'BOOL' => 'TINYINT', + 'LONG VARBINARY' => 'LONGBLOB', +); + +=head1 NAME + +DBIx::DBSchema::DBD::mysql - MySQL native driver for DBIx::DBSchema + +=head1 SYNOPSIS + +use DBI; +use DBIx::DBSchema; + +$dbh = DBI->connect('dbi:mysql:database', 'user', 'pass'); +$schema = new_native DBIx::DBSchema $dbh; + +=head1 DESCRIPTION + +This module implements a MySQL-native driver for DBIx::DBSchema. + +=cut + +sub columns { + my($proto, $dbh, $table ) = @_; + my $sth = $dbh->prepare("SHOW COLUMNS FROM $table") or die $dbh->errstr; + $sth->execute or die $sth->errstr; + map { + $_->{'Type'} =~ /^(\w+)\(?([\d\,]+)?\)?( unsigned)?$/ + or die "Illegal type: ". $_->{'Type'}. "\n"; + my($type, $length) = ($1, $2); + [ + $_->{'Field'}, + $type, + $_->{'Null'}, + $length, + $_->{'Default'}, + $_->{'Extra'} + ] + } @{ $sth->fetchall_arrayref( {} ) }; +} + +#sub primary_key { +# my($proto, $dbh, $table ) = @_; +# my $primary_key = ''; +# my $sth = $dbh->prepare("SHOW INDEX FROM $table") +# or die $dbh->errstr; +# $sth->execute or die $sth->errstr; +# my @pkey = map { $_->{'Column_name'} } grep { +# $_->{'Key_name'} eq "PRIMARY" +# } @{ $sth->fetchall_arrayref( {} ) }; +# scalar(@pkey) ? $pkey[0] : ''; +#} + +sub primary_key { + my($proto, $dbh, $table) = @_; + my($pkey, $unique_href, $index_href) = $proto->_show_index($dbh, $table); + $pkey; +} + +sub unique { + my($proto, $dbh, $table) = @_; + my($pkey, $unique_href, $index_href) = $proto->_show_index($dbh, $table); + $unique_href; +} + +sub index { + my($proto, $dbh, $table) = @_; + my($pkey, $unique_href, $index_href) = $proto->_show_index($dbh, $table); + $index_href; +} + +sub _show_index { + my($proto, $dbh, $table ) = @_; + my $sth = $dbh->prepare("SHOW INDEX FROM $table") + or die $dbh->errstr; + $sth->execute or die $sth->errstr; + + my $pkey = ''; + my(%index, %unique); + foreach my $row ( @{ $sth->fetchall_arrayref({}) } ) { + if ( $row->{'Key_name'} eq 'PRIMARY' ) { + $pkey = $row->{'Column_name'}; + } elsif ( $row->{'Non_unique'} ) { #index + push @{ $index{ $row->{'Key_name'} } }, $row->{'Column_name'}; + } else { #unique + push @{ $unique{ $row->{'Key_name'} } }, $row->{'Column_name'}; + } + } + + ( $pkey, \%unique, \%index ); +} + +=head1 AUTHOR + +Ivan Kohler <ivan-dbix-dbschema@420.am> + +=head1 COPYRIGHT + +Copyright (c) 2000 Ivan Kohler +Copyright (c) 2000 Mail Abuse Prevention System LLC +All rights reserved. +This program is free software; you can redistribute it and/or modify it under +the same terms as Perl itself. + +=head1 BUGS + +=head1 SEE ALSO + +L<DBIx::DBSchema>, L<DBIx::DBSchema::DBD>, L<DBI>, L<DBI::DBD> + +=cut + +1; + diff --git a/install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/Table.pm b/install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/Table.pm new file mode 100644 index 000000000..2d6272ecb --- /dev/null +++ b/install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/Table.pm @@ -0,0 +1,471 @@ +package DBIx::DBSchema::Table; + +use strict; +use vars qw(@ISA %create_params); +#use Carp; +#use Exporter; +use DBIx::DBSchema::Column 0.02; +use DBIx::DBSchema::ColGroup::Unique; +use DBIx::DBSchema::ColGroup::Index; + +#@ISA = qw(Exporter); +@ISA = qw(); + +=head1 NAME + +DBIx::DBSchema::Table - Table objects + +=head1 SYNOPSIS + + use DBIx::DBSchema::Table; + + #old style (depriciated) + $table = new DBIx::DBSchema::Table ( + "table_name", + "primary_key", + $dbix_dbschema_colgroup_unique_object, + $dbix_dbschema_colgroup_index_object, + @dbix_dbschema_column_objects, + ); + + #new style (preferred), pass a hashref of parameters + $table = new DBIx::DBSchema::Table ( + { + name => "table_name", + primary_key => "primary_key", + unique => $dbix_dbschema_colgroup_unique_object, + 'index' => $dbix_dbschema_colgroup_index_object, + columns => \@dbix_dbschema_column_objects, + } + ); + + $table->addcolumn ( $dbix_dbschema_column_object ); + + $table_name = $table->name; + $table->name("table_name"); + + $primary_key = $table->primary_key; + $table->primary_key("primary_key"); + + $dbix_dbschema_colgroup_unique_object = $table->unique; + $table->unique( $dbix_dbschema__colgroup_unique_object ); + + $dbix_dbschema_colgroup_index_object = $table->index; + $table->index( $dbix_dbschema_colgroup_index_object ); + + @column_names = $table->columns; + + $dbix_dbschema_column_object = $table->column("column"); + + #preferred + @sql_statements = $table->sql_create_table( $dbh ); + @sql_statements = $table->sql_create_table( $datasrc, $username, $password ); + + #possible problems + @sql_statements = $table->sql_create_table( $datasrc ); + @sql_statements = $table->sql_create_table; + +=head1 DESCRIPTION + +DBIx::DBSchema::Table objects represent a single database table. + +=head1 METHODS + +=over 4 + +=item new [ TABLE_NAME [ , PRIMARY_KEY [ , UNIQUE [ , INDEX [ , COLUMN... ] ] ] ] ] + +=item new HASHREF + +Creates a new DBIx::DBSchema::Table object. The preferred usage is to pass a +hash reference of named parameters. + + { + name => TABLE_NAME, + primary_key => PRIMARY_KEY, + unique => UNIQUE, + 'index' => INDEX, + columns => COLUMNS + } + +TABLE_NAME is the name of the table. PRIMARY_KEY is the primary key (may be +empty). UNIQUE is a DBIx::DBSchema::ColGroup::Unique object (see +L<DBIx::DBSchema::ColGroup::Unique>). INDEX is a +DBIx::DBSchema::ColGroup::Index object (see +L<DBIx::DBSchema::ColGroup::Index>). COLUMNS is a reference to an array of +DBIx::DBSchema::Column objects (see L<DBIx::DBSchema::Column>). + +=cut + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + + my $self; + if ( ref($_[0]) ) { + + $self = shift; + $self->{column_order} = [ map { $_->name } @{$self->{columns}} ]; + $self->{columns} = { map { $_->name, $_ } @{$self->{columns}} }; + + } else { + + my($name,$primary_key,$unique,$index,@columns) = @_; + + my %columns = map { $_->name, $_ } @columns; + my @column_order = map { $_->name } @columns; + + $self = { + 'name' => $name, + 'primary_key' => $primary_key, + 'unique' => $unique, + 'index' => $index, + 'columns' => \%columns, + 'column_order' => \@column_order, + }; + + } + + #check $primary_key, $unique and $index to make sure they are $columns ? + # (and sanity check?) + + bless ($self, $class); + +} + +=item new_odbc DATABASE_HANDLE TABLE_NAME + +Creates a new DBIx::DBSchema::Table object from the supplied DBI database +handle for the specified table. This uses the experimental DBI type_info +method to create a table with standard (ODBC) SQL column types that most +closely correspond to any non-portable column types. Use this to import a +schema that you wish to use with many different database engines. Although +primary key and (unique) index information will only be imported from databases +with DBIx::DBSchema::DBD drivers (currently MySQL and PostgreSQL), import of +column names and attributes *should* work for any database. + +Note: the _odbc refers to the column types used and nothing else - you do not +have to have ODBC installed or connect to the database via ODBC. + +=cut + +%create_params = ( +# undef => sub { '' }, + '' => sub { '' }, + 'max length' => sub { $_[0]->{PRECISION}->[$_[1]]; }, + 'precision,scale' => + sub { $_[0]->{PRECISION}->[$_[1]]. ','. $_[0]->{SCALE}->[$_[1]]; } +); + +sub new_odbc { + my( $proto, $dbh, $name) = @_; + my $driver = DBIx::DBSchema::_load_driver($dbh); + my $sth = _null_sth($dbh, $name); + my $sthpos = 0; + $proto->new ( + $name, + scalar(eval "DBIx::DBSchema::DBD::$driver->primary_key(\$dbh, \$name)"), + DBIx::DBSchema::ColGroup::Unique->new( + $driver + ? [values %{eval "DBIx::DBSchema::DBD::$driver->unique(\$dbh, \$name)"}] + : [] + ), + DBIx::DBSchema::ColGroup::Index->new( + $driver + ? [ values %{eval "DBIx::DBSchema::DBD::$driver->index(\$dbh, \$name)"} ] + : [] + ), + map { + my $type_info = scalar($dbh->type_info($sth->{TYPE}->[$sthpos])) + or die "DBI::type_info ". $dbh->{Driver}->{Name}. " driver ". + "returned no results for type ". $sth->{TYPE}->[$sthpos]; + 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++ ), $driver && #default + ${ [ + eval "DBIx::DBSchema::DBD::$driver->column(\$dbh, \$name, \$_)" + ] }[4] + # DB-local + } @{$sth->{NAME}} + ); +} + +=item new_native DATABASE_HANDLE TABLE_NAME + +Creates a new DBIx::DBSchema::Table object from the supplied DBI database +handle for the specified table. This uses database-native methods to read the +schema, and will preserve any non-portable column types. The method is only +available if there is a DBIx::DBSchema::DBD for the corresponding database +engine (currently, MySQL and PostgreSQL). + +=cut + +sub new_native { + my( $proto, $dbh, $name) = @_; + my $driver = DBIx::DBSchema::_load_driver($dbh); + $proto->new ( + $name, + scalar(eval "DBIx::DBSchema::DBD::$driver->primary_key(\$dbh, \$name)"), + DBIx::DBSchema::ColGroup::Unique->new( + [ values %{eval "DBIx::DBSchema::DBD::$driver->unique(\$dbh, \$name)"} ] + ), + DBIx::DBSchema::ColGroup::Index->new( + [ values %{eval "DBIx::DBSchema::DBD::$driver->index(\$dbh, \$name)"} ] + ), + map { + DBIx::DBSchema::Column->new( @{$_} ) + } eval "DBIx::DBSchema::DBD::$driver->columns(\$dbh, \$name)" + ); +} + +=item addcolumn COLUMN + +Adds this DBIx::DBSchema::Column object. + +=cut + +sub addcolumn { + my($self,$column)=@_; + ${$self->{'columns'}}{$column->name}=$column; #sanity check? + push @{$self->{'column_order'}}, $column->name; +} + +=item delcolumn COLUMN_NAME + +Deletes this column. Returns false if no column of this name was found to +remove, true otherwise. + +=cut + +sub delcolumn { + my($self,$column) = @_; + return 0 unless exists $self->{'columns'}{$column}; + delete $self->{'columns'}{$column}; + @{$self->{'column_order'}}= grep { $_ ne $column } @{$self->{'column_order'}}; 1; +} + +=item name [ TABLE_NAME ] + +Returns or sets the table name. + +=cut + +sub name { + my($self,$value)=@_; + if ( defined($value) ) { + $self->{name} = $value; + } else { + $self->{name}; + } +} + +=item primary_key [ PRIMARY_KEY ] + +Returns or sets the primary key. + +=cut + +sub primary_key { + my($self,$value)=@_; + if ( defined($value) ) { + $self->{primary_key} = $value; + } else { + #$self->{primary_key}; + #hmm. maybe should untaint the entire structure when it comes off disk + # cause if you don't trust that, ? + $self->{primary_key} =~ /^(\w*)$/ + #aah! + or die "Illegal primary key: ", $self->{primary_key}; + $1; + } +} + +=item unique [ UNIQUE ] + +Returns or sets the DBIx::DBSchema::ColGroup::Unique object. + +=cut + +sub unique { + my($self,$value)=@_; + if ( defined($value) ) { + $self->{unique} = $value; + } else { + $self->{unique}; + } +} + +=item index [ INDEX ] + +Returns or sets the DBIx::DBSchema::ColGroup::Index object. + +=cut + +sub index { + my($self,$value)=@_; + if ( defined($value) ) { + $self->{'index'} = $value; + } else { + $self->{'index'}; + } +} + +=item columns + +Returns a list consisting of the names of all columns. + +=cut + +sub columns { + my($self)=@_; + #keys %{$self->{'columns'}}; + #must preserve order + @{ $self->{'column_order'} }; +} + +=item column COLUMN_NAME + +Returns the column object (see L<DBIx::DBSchema::Column>) for the specified +COLUMN_NAME. + +=cut + +sub column { + my($self,$column)=@_; + $self->{'columns'}->{$column}; +} + +=item sql_create_table [ DATABASE_HANDLE | DATA_SOURCE [ USERNAME PASSWORD [ ATTR ] ] ] + +Returns a list of SQL statments to create this table. + +The data source can be specified by passing an open DBI database handle, or by +passing the DBI data source name, username and password. + +Although the username and password are optional, it is best to call this method +with a database handle or data source including a valid username and password - +a DBI connection will be opened and the quoting and type mapping will be more +reliable. + +If passed a DBI data source (or handle) such as `DBI:mysql:database', will use +MySQL- or PostgreSQL-specific syntax. Non-standard syntax for other engines +(if applicable) may also be supported in the future. + +=cut + +sub sql_create_table { + my($self, $dbh) = (shift, shift); + + my $created_dbh = 0; + unless ( ref($dbh) || ! @_ ) { + $dbh = DBI->connect( $dbh, @_ ) or die $DBI::errstr; + my $gratuitous = $DBI::errstr; #surpress superfluous `used only once' error + $created_dbh = 1; + } + #false laziness: nicked from DBSchema::_load_driver + my $driver; + if ( ref($dbh) ) { + $driver = $dbh->{Driver}->{Name}; + } else { + my $discard = $dbh; + $discard =~ 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"; + } + #eofalse + +#should be in the DBD somehwere :/ +# my $saved_pkey = ''; +# if ( $driver eq 'Pg' && $self->primary_key ) { +# my $pcolumn = $self->column( ( +# grep { $self->column($_)->name eq $self->primary_key } $self->columns +# )[0] ); +##AUTO-INCREMENT# $pcolumn->type('serial') if lc($pcolumn->type) eq 'integer'; +# $pcolumn->local( $pcolumn->local. ' PRIMARY KEY' ); +# #my $saved_pkey = $self->primary_key; +# #$self->primary_key(''); +# #change it back afterwords :/ +# } + + my @columns = map { $self->column($_)->line($dbh) } $self->columns; + + push @columns, "PRIMARY KEY (". $self->primary_key. ")" + #if $self->primary_key && $driver ne 'Pg'; + if $self->primary_key; + + my $indexnum = 1; + + my @r = ( + "CREATE TABLE ". $self->name. " (\n ". join(",\n ", @columns). "\n)\n" + ); + + push @r, map { + #my($index) = $self->name. "__". $_ . "_idx"; + #$index =~ s/,\s*/_/g; + my $index = $self->name. $indexnum++; + "CREATE UNIQUE INDEX $index ON ". $self->name. " ($_)\n" + } $self->unique->sql_list + if $self->unique; + + push @r, map { + #my($index) = $self->name. "__". $_ . "_idx"; + #$index =~ s/,\s*/_/g; + my $index = $self->name. $indexnum++; + "CREATE INDEX $index ON ". $self->name. " ($_)\n" + } $self->index->sql_list + if $self->index; + + #$self->primary_key($saved_pkey) if $saved_pkey; + $dbh->disconnect if $created_dbh; + @r; +} + +# + +sub _null_sth { + my($dbh, $table) = @_; + my $sth = $dbh->prepare("SELECT * FROM $table WHERE 1=0") + or die $dbh->errstr; + $sth->execute or die $sth->errstr; + $sth; +} + +=back + +=head1 AUTHOR + +Ivan Kohler <ivan-dbix-dbschema@420.am> + +Thanks to Mark Ethan Trostler <mark@zzo.com> for a patch to allow tables +with no indices. + +=head1 COPYRIGHT + +Copyright (c) 2000 Ivan Kohler +Copyright (c) 2000 Mail Abuse Prevention System LLC +All rights reserved. +This program is free software; you can redistribute it and/or modify it under +the same terms as Perl itself. + +=head1 BUGS + +sql_create_table() has database-specific foo that probably ought to be +abstracted into the DBIx::DBSchema::DBD:: modules. + +sql_create_table may change or destroy the object's data. If you need to use +the object after sql_create_table, make a copy beforehand. + +Some of the logic in new_odbc might be better abstracted into Column.pm etc. + +=head1 SEE ALSO + +L<DBIx::DBSchema>, L<DBIx::DBSchema::ColGroup::Unique>, +L<DBIx::DBSchema::ColGroup::Index>, L<DBIx::DBSchema::Column>, L<DBI> + +=cut + +1; + |