--- /dev/null
+Revision history for Perl extension DBIx::DBSchema.
+
+0.02 Mon Sep 25 21:30:32 2000
+ - change name from DBIx::Schema
+
+0.01 Sun Sep 17 07:57:35 2000
+ - original version; created by h2xs 1.19
+
--- /dev/null
+package DBIx::DBSchema;
+
+use strict;
+use vars qw(@ISA $VERSION);
+#use Exporter;
+#use Carp qw(verbose);
+use DBI;
+use FreezeThaw qw(freeze thaw cmpStr);
+use DBIx::DBSchema::Table;
+
+#@ISA = qw(Exporter);
+@ISA = ();
+
+$VERSION = "0.1";
+
+=head1 NAME
+
+DBIx::DBSchema - Database-independent schema objects
+
+=head1 SYNOPSIS
+
+ use DBIx::DBSchema;
+
+ $schema = new DBIx::DBSchema @dbix_dbschema_table_objects;
+ $schema = new_from_dsn DBIx::DBSchema $dsn, $user, $pass;
+ $schema = new_odbc DBIx::DBSchema $dbh;
+ $schema = new_native DBIx::DBSchema $dbh;
+
+ $schema->save("filename");
+ $schema = load DBIx::DBSchema "filename";
+
+ $schema->addtable($dbix_dbschema_table_object);
+
+ @table_names = $schema->tables;
+
+ $DBIx_DBSchema_table_object = $schema->table("table_name");
+
+ $sql_string = $schema->sql($dsn);
+
+ $perl_code = $schema->pretty_print;
+ %hash = eval $perl_code;
+ $schema = pretty_read DBIx::DBSchema \%hash;
+
+=head1 DESCRIPTION
+
+DBIx::DBSchema objects are collections of DBIx::DBSchema::Table objects and
+represent a database schema.
+
+=head1 METHODS
+
+=over 4
+
+=item new TABLE_OBJECT, TABLE_OBJECT, ...
+
+Creates a new DBIx::DBSchema object.
+
+=cut
+
+sub new {
+ my($proto, @tables) = @_;
+ my %tables = map { $_->name, $_ } @tables; #check for duplicates?
+
+ my $class = ref($proto) || $proto;
+ my $self = {
+ 'tables' => \%tables,
+ };
+
+ bless ($self, $class);
+
+}
+
+=item new_odbc_from_dsn DATA_SOURCE USERNAME PASSWORD
+
+Connects to the specified DBI data source and creates a DBIx::DBSchema object
+from it using new_odbc.
+
+=cut
+
+sub new_odbc_from_dsn {
+ my($proto, $dsn, $user, $pass ) = @_;
+ my $dbh = DBI->connect( $dsn, $user, $pass ) or die $DBI::errstr;
+ my $self = $proto->new_odbc($dbh);
+ $dbh->disconnect; #silly DBI
+ $self;
+}
+
+=item new_odbc DATABASE_HANDLE
+
+Creates a new DBIx::DBSchema object from the supplied DBI database handle.
+This uses the experimental DBI type_info method to create a schema 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 read from databases with DBIx::DBSchema::DBD drivers
+(currently MySQL and PostgreSQL), import of column names and attributes
+*should* work for any database.
+
+=cut
+
+sub new_odbc {
+ my($proto, $dbh) = @_;
+ $proto->new(
+ map { new_odbc DBIx::DBSchema::Table $dbh, $_ } _tables_from_dbh($dbh)
+ );
+}
+
+=item new_native_from_dsn DATA_SOURCE USERNAME PASSWORD
+
+Connects to the specified DBI data source and creates a DBIx::DBSchema object
+from it using new_native.
+
+=cut
+
+sub new_native_from_dsn {
+ my($proto, $dsn, $user, $pass) = @_;
+ my $dbh = DBI->connect( $dsn, $user, $pass ) or die $DBI::errstr;
+ my $self = $proto->new_native($dbh);
+ $dbh->disconnect; #silly DBI
+ $self;
+}
+
+=item new_native DATABASE_HANDLE
+
+Creates a new DBIx::DBSchema object from the supplied DBI database handle. 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) = @_;
+ $proto->new(
+ map { new_native DBIx::DBSchema::Table ( $dbh, $_ ) } _tables_from_dbh($dbh)
+ );
+}
+
+=item load FILENAME
+
+Loads a DBIx::DBSchema object from a file.
+
+=cut
+
+sub load {
+ my($proto,$file)=@_; #use $proto ?
+ open(FILE,"<$file") or die "Can't open $file: $!";
+ my($string)=join('',<FILE>); #can $string have newlines? pry not?
+ close FILE or die "Can't close $file: $!";
+ my($self)=thaw $string;
+ #no bless needed?
+ $self;
+}
+
+=item save FILENAME
+
+Saves a DBIx::DBSchema object to a file.
+
+=cut
+
+sub save {
+ my($self,$file)=@_;
+ my($string)=freeze $self;
+ open(FILE,">$file") or die "Can't open $file: $!";
+ print FILE $string;
+ close FILE or die "Can't close file: $!";
+ my($check_self)=thaw $string;
+ die "Verify error: Can't freeze and thaw dbdef $self"
+ if (cmpStr($self,$check_self));
+}
+
+=item addtable TABLE_OBJECT
+
+Adds the given DBIx::DBSchema::Table object to this DBIx::DBSchema.
+
+=cut
+
+sub addtable {
+ my($self,$table)=@_;
+ $self->{'tables'}->{$table->name} = $table; #check for dupliates?
+}
+
+=item tables
+
+Returns a list of the names of all tables.
+
+=cut
+
+sub tables {
+ my($self)=@_;
+ keys %{$self->{'tables'}};
+}
+
+=item table TABLENAME
+
+Returns the specified DBIx::DBSchema::Table object.
+
+=cut
+
+sub table {
+ my($self,$table)=@_;
+ $self->{'tables'}->{$table};
+}
+
+=item sql_string [ DATASRC ]
+
+Returns a list of SQL `CREATE' statements for this schema.
+
+If passed a DBI data source 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.
+
+If not passed a data source, or if there is no driver for the specified
+database, will attempt to use generic SQL syntax.
+
+=cut
+
+sub sql_string {
+ my($self, $datasrc) = @_;
+ map { $self->table($_)->sql_create_table($datasrc); } $self->tables;
+}
+
+=item pretty_print
+
+Returns the data in this schema as Perl source, suitable for assigning to a
+hash.
+
+=cut
+
+sub pretty_print {
+ my($self) = @_;
+ join("},\n\n",
+ map {
+ my $table = $_;
+ "'$table' => {\n".
+ " 'columns' => [\n".
+ join("", map {
+ " '$_', ".
+ "'". $self->table($table)->column($_)->type. "', ".
+ "'". $self->table($table)->column($_)->null. "', ".
+ "'". $self->table($table)->column($_)->length. "'\n"
+ } $self->table($table)->columns
+ ).
+ " ],\n".
+ " 'primary_key' => '". $self->table($table)->primary_key. "',\n".
+ " 'unique' => [ ". join(', ',
+ map { "[ '". join("', '", @{$_}). "' ]" }
+ @{$self->table($table)->unique->lol_ref}
+ ). " ],\n".
+ " 'index' => [ ". join(', ',
+ map { "[ '". join("', '", @{$_}). "' ]" }
+ @{$self->table($table)->index->lol_ref}
+ ). " ],\n"
+ #" 'index' => [ ". " ],\n"
+ } $self->tables
+ ), "}\n";
+}
+
+=cut
+
+=item pretty_read HASHREF
+
+Creates a schema as specified by a data structure such as that created by
+B<pretty_print> method.
+
+=cut
+
+sub pretty_read {
+ die "unimplemented (pull from fs-setup)";
+ my($proto) = @_;
+}
+
+# private subroutines
+
+sub _load_driver {
+ my($dbh) = @_;
+ my $driver = $dbh->{Driver}->{Name};
+ #require "DBIx/DBSchema/DBD/$driver.pm";
+ #$driver;
+ eval 'require "DBIx/DBSchema/DBD/$driver.pm"' and $driver;
+}
+
+sub _tables_from_dbh {
+ my($dbh) = @_;
+ my $sth = $dbh->table_info or die $dbh->errstr;
+ #map { $_->{TABLE_NAME} } grep { $_->{TABLE_TYPE} eq 'TABLE' }
+ # @{ $sth->fetchall_arrayref({ TABLE_NAME=>1, TABLE_TYPE=>1}) };
+ map { $_->[0] } grep { $_->[1] =~ /^TABLE$/i }
+ @{ $sth->fetchall_arrayref([2,3]) };
+}
+
+=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
+
+Each DBIx::DBSchema object should have a name which corresponds to its name
+within the SQL database engine (DBI data source).
+
+pretty_print is atrocious.
+
+=head1 SEE ALSO
+
+L<DBIx::DBSchema::Table>, L<DBIx::DBSchema::ColGroup>,
+L<DBIx::DBSchema::ColGroup::Unique>, L<DBIx::DBSchema::ColGroup::Index>,
+L<DBIx::DBSchema::Column>, L<DBIx::DBSchema::DBD>, L<DBIx::DBSchema::mysql>,
+L<DBIx::DBSchema::Pg>, L<FS::Record>, L<DBI>
+
+=cut
+
+1;
+
--- /dev/null
+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;
+
--- /dev/null
+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;
+
--- /dev/null
+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;
+
+
--- /dev/null
+package DBIx::DBSchema::Column;
+
+use strict;
+use vars qw(@ISA);
+#use Carp;
+#use Exporter;
+
+#@ISA = qw(Exporter);
+@ISA = qw();
+
+=head1 NAME
+
+DBIx::DBSchema::Column - Column objects
+
+=head1 SYNOPSIS
+
+ use DBIx::DBSchema::Column;
+
+ $column = new DBIx::DBSchema::Column ( $name, $sql_type, '' );
+ $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 );
+
+ $name = $column->name;
+ $column->name( 'name' );
+
+ $sql_type = $column->type;
+ $column->sql_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' );
+
+ $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 [ NAME [ , SQL_TYPE [ , NULL [ , LENGTH ] ] ] ]
+
+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.
+
+=cut
+
+sub new {
+ my($proto,$name,$type,$null,$length)=@_;
+
+ #croak "Illegal name: $name" if grep $name eq $_, @reserved_words;
+
+ $null =~ s/^NOT NULL$//i;
+ $null = 'NULL' if $null;
+
+ my $class = ref($proto) || $proto;
+ my $self = {
+ 'name' => $name,
+ 'type' => $type,
+ 'null' => $null,
+ 'length' => $length,
+ };
+
+ 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 line [ $datasrc ]
+
+Returns an SQL column definition.
+
+If passed a DBI data source 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,$datasrc)=@_;
+ my($null)=$self->null;
+ if ( $datasrc =~ /^dbi:mysql:/i ) { #yucky mysql hack
+ $null ||= "NOT NULL"
+ }
+ if ( $datasrc =~ /^dbi:pg/i ) { #yucky Pg hack
+ $null ||= "NOT NULL";
+ $null =~ s/^NULL$//;
+ }
+ join(' ',
+ $self->name,
+ $self->type. ( $self->length ? '('.$self->length.')' : '' ),
+ $null,
+ );
+}
+
+=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;
+
--- /dev/null
+package DBIx::DBSchema::DBD;
+
+use strict;
+use vars qw($VERSION);
+
+$VERSION = '0.01';
+
+=head1 NAME
+
+DBIx::DBSchema::DBD - DBIx::DBSchema Driver Writer's Guide
+
+=head1 SYNOPSIS
+
+ perldoc 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 four elements: column name, column type,
+nullability, and column length.
+
+=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 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;
+
--- /dev/null
+package DBIx::DBSchema::DBD::Pg;
+
+use strict;
+use vars qw($VERSION);
+
+$VERSION = '0.01';
+
+=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
+ 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
+END
+ $sth->execute or die $sth->errstr;
+ map {
+ [
+ $_->{'attname'},
+ $_->{'typname'},
+ ! $_->{'attnotnull'},
+ $_->{'attlen'} == -1
+ ? $_->{'atttypmod'} - 4
+ : ''
+ ]
+ } @{ $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.
+
+=head1 SEE ALSO
+
+L<DBIx::DBSchema>, L<DBIx::DBSchema::DBD>, L<DBI>, L<DBI::DBD>
+
+=cut
+
+1;
+
--- /dev/null
+package DBIx::DBSchema::DBD::mysql;
+
+use strict;
+use vars qw($VERSION);
+
+$VERSION = '0.01';
+
+=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 ]
+ } @{ $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;
+
--- /dev/null
+package DBIx::DBSchema::Table;
+
+use strict;
+use vars qw(@ISA %create_params);
+#use Carp;
+use Exporter;
+use DBIx::DBSchema::Column;
+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;
+
+ $table = new DBIx::DBSchema::Table (
+ "table_name",
+ "primary_key",
+ $dbix_dbschema_colgroup_unique_object,
+ $dbix_dbschema_colgroup_index_object,
+ @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");
+
+ @sql_statements = $table->sql_create_table;
+ @sql_statements = $table->sql_create_table $datasrc;
+
+=head1 DESCRIPTION
+
+DBIx::DBSchema::Table objects represent a single database table.
+
+=head1 METHODS
+
+=over 4
+
+=item new [ TABLE_NAME [ , PRIMARY_KEY [ , UNIQUE [ , INDEX [ , COLUMN... ] ] ] ] ]
+
+Creates a new DBIx::DBSchema::Table object. 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>). The rest of the arguments should be
+DBIx::DBSchema::Column objects (see L<DBIx::DBSchema::Column>).
+
+=cut
+
+sub new {
+ my($proto,$name,$primary_key,$unique,$index,@columns)=@_;
+
+ my(%columns) = map { $_->name, $_ } @columns;
+
+ #check $primary_key, $unique and $index to make sure they are $columns ?
+ # (and sanity check?)
+
+ my $class = ref($proto) || $proto;
+ my $self = {
+ 'name' => $name,
+ 'primary_key' => $primary_key,
+ 'unique' => $unique,
+ 'index' => $index,
+ 'columns' => \%columns,
+ };
+
+ 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.
+
+=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 $driver = DBIx::DBSchema::_load_driver(DBI->connect("dbi:CSV:dbname=testfile", "postgres", ""));
+ 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 "null return from DBI::type_info";
+ new DBIx::DBSchema::Column
+ $_,
+ $type_info->{'TYPE_NAME'},
+ $sth->{NULLABLE}->[$sthpos],
+ &{
+ $create_params{ $type_info->{CREATE_PARAMS} }
+ }( $sth, $sthpos++ )
+ } @{$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?
+}
+
+=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'}};
+}
+
+=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 [ DATASRC ]
+
+Returns a list of SQL statments to create this table.
+
+If passed a DBI data source such as `DBI:mysql:database', will use
+MySQL-specific syntax. PostgreSQL is also supported (requires no special
+syntax). Non-standard syntax for other engines (if applicable) may also be
+supported in the future.
+
+=cut
+
+sub sql_create_table {
+ my($self,$datasrc)=@_;
+
+ my(@columns)=map { $self->column($_)->line($datasrc) } $self->columns;
+ push @columns, "PRIMARY KEY (". $self->primary_key. ")"
+ if $self->primary_key;
+ if ( $datasrc =~ /^dbd:mysql:/i ) { #yucky mysql hack
+ push @columns, map "UNIQUE ($_)", $self->unique->sql_list;
+ push @columns, map "INDEX ($_)", $self->index->sql_list;
+ }
+
+ "CREATE TABLE ". $self->name. " ( ". join(", ", @columns). " )",
+ ( map {
+ my($index) = $self->name. "__". $_ . "_index";
+ $index =~ s/,\s*/_/g;
+ "CREATE UNIQUE INDEX $index ON ". $self->name. " ($_)"
+ } $self->unique->sql_list ),
+ ( map {
+ my($index) = $self->name. "__". $_ . "_index";
+ $index =~ s/,\s*/_/g;
+ "CREATE INDEX $index ON ". $self->name. " ($_)"
+ } $self->index->sql_list ),
+ ;
+
+}
+
+#
+
+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>
+
+=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.
+
+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;
+
--- /dev/null
+Changes
+MANIFEST
+README
+Makefile.PL
+DBSchema.pm
+test.pl
+DBSchema/Table.pm
+DBSchema/ColGroup.pm
+DBSchema/ColGroup/Index.pm
+DBSchema/ColGroup/Unique.pm
+DBSchema/Column.pm
+DBSchema/DBD.pm
+DBSchema/DBD/mysql.pm
+DBSchema/DBD/Pg.pm
--- /dev/null
+use ExtUtils::MakeMaker;
+# See lib/ExtUtils/MakeMaker.pm for details of how to influence
+# the contents of the Makefile that is written.
+WriteMakefile(
+ 'NAME' => 'DBIx::DBSchema',
+ 'VERSION_FROM' => 'DBSchema.pm', # finds $VERSION
+ 'PREREQ_PM' => {
+ 'DBI' => 0,
+ },
+);
--- /dev/null
+DBIx::DBSchema
+
+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.
+
+This module implements an OO-interface to database schemas. Using this module,
+you can create a database schema with an OO Perl interface. You can read the
+schema from an existing database. You can save the schema to disk and restore
+it a different process. Most importantly, DBIx::DBSchema can write SQL
+statements to create the given schema.
+
+Currently supported databases are MySQL and PostgreSQL. DBIx::DBSchema will
+attempt to use generic SQL syntax for other databases. Assistance adding
+support for other databases is welcomed.
+
+To install:
+ perl Makefile.PL
+ make
+ make test # nothing substantial yet
+ make install
+
+Documentation will then be available via `man DBIx::DBSchema' or
+`perldoc DBIx::DBSchema'.
+
+Anonymous CVS access is available:
+ $ export CVSROOT=":pserver:anonymous@cleanwhisker.420.am:/home/cvs/cvsroot"
+ $ cvs login
+ (Logging in to anonymous@cleanwhisker.420.am)
+ CVS password: anonymous
+ $ cvs checkout DBIx-DBSchema
+as well as <http://www.420.am/cgi-bin/cvsweb/DBIx-DBSchema>.
+
+A mailing list is available. Send a blank message to
+<ivan-dbix-dbschema-users-subscribe@420.am>.
+
+Homepage: <http://www.420.am/dbix-dbschema>
+
+$Id: README,v 1.2 2000-09-27 11:51:36 ivan Exp $
--- /dev/null
+# Before `make install' is performed this script should be runnable with
+# `make test'. After `make install' it should work as `perl test.pl'
+
+######################### We start with some black magic to print on failure.
+
+# Change 1..1 below to 1..last_test_to_print .
+# (It may become useful if the test is moved to ./t subdirectory.)
+
+BEGIN { $| = 1; print "1..1\n"; }
+END {print "not ok 1\n" unless $loaded;}
+use DBIx::DBSchema;
+$loaded = 1;
+print "ok 1\n";
+
+######################### End of black magic.
+
+# Insert your test code below (better if it prints "ok 13"
+# (correspondingly "not ok 13") depending on the success of chunk 13
+# of the test code):
+
projects / DBIx-DBSchema.git / commitdiff