[dbsrgits/SQL-Translator.git] / lib / SQL / Translator / Schema.pm

package SQL::Translator::Schema;

# ----------------------------------------------------------------------
# $Id: Schema.pm,v 1.12 2003-10-08 18:35:15 phrrngtn Exp $
# ----------------------------------------------------------------------
# Copyright (C) 2003 Ken Y. Clark <kclark@cpan.org>
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License as
# published by the Free Software Foundation; version 2.
#
# This program is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
# General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
# 02111-1307  USA
# -------------------------------------------------------------------

=pod

=head1 NAME

SQL::Translator::Schema - SQL::Translator schema object

=head1 SYNOPSIS

  use SQL::Translator::Schema;
  my $schema = SQL::Translator::Schema->new;
  my $table  = $schema->add_table( name => 'foo' );
  my $view   = $schema->add_view( name => 'bar', sql => '...' );

=head1 DESCSIPTION

C<SQL::Translator::Schema> is the object that accepts, validates, and
returns the database structure.

=head1 METHODS

=cut

use strict;
use Class::Base;
use SQL::Translator::Schema::Constants;
use SQL::Translator::Schema::Procedure;
use SQL::Translator::Schema::Table;
use SQL::Translator::Schema::Trigger;
use SQL::Translator::Schema::View;
use SQL::Translator::Utils 'parse_list_arg';

use base 'Class::Base';
use vars qw[ $VERSION $TABLE_ORDER $VIEW_ORDER $TRIGGER_ORDER $PROC_ORDER ];

$VERSION = sprintf "%d.%02d", q$Revision: 1.12 $ =~ /(\d+)\.(\d+)/;

# ----------------------------------------------------------------------
sub init {

=pod

=head2 new

Object constructor.

  my $schema   =  SQL::Translator->new(
      name     => 'Foo',
      database => 'MySQL',
  );

=cut

    my ( $self, $config ) = @_;
    $self->params( $config, qw[ name database ] ) || return undef;
    return $self;
}

# ----------------------------------------------------------------------
sub add_table {

=pod

=head2 add_table

Add a table object.  Returns the new SQL::Translator::Schema::Table object.
The "name" parameter is required.  If you try to create a table with the
same name as an existing table, you will get an error and the table will 
not be created.

  my $t1 = $schema->add_table( name => 'foo' ) or die $schema->error;
  my $t2 = SQL::Translator::Schema::Table->new( name => 'bar' );
  $t2    = $schema->add_table( $table_bar ) or die $schema->error;

=cut

    my $self        = shift;
    my $table_class = 'SQL::Translator::Schema::Table';
    my $table;

    if ( UNIVERSAL::isa( $_[0], $table_class ) ) {
        $table = shift;
        $table->schema( $self );
    }
    else {
        my %args = @_;
        $args{'schema'} = $self;
        $table = $table_class->new( \%args ) or return 
            $self->error( $table_class->error );
    }

    $table->order( ++$TABLE_ORDER );
    my $table_name = $table->name or return $self->error('No table name');

    if ( defined $self->{'tables'}{ $table_name } ) {
        return $self->error(qq[Can't create table: "$table_name" exists]);
    }
    else {
        $self->{'tables'}{ $table_name } = $table;
    }

    return $table;
}

# ----------------------------------------------------------------------
sub add_procedure {

=pod

=head2 add_procedure

Add a procedure object.  Returns the new
SQL::Translator::Schema::Procedure object.  The "name" parameter is
required.  If you try to create a procedure with the same name as an
existing procedure, you will get an error and the procedure will not
be created.

  my $p1 = $schema->add_procedure( name => 'foo' );
  my $p2 = SQL::Translator::Schema::Procedure->new( name => 'bar' );
  $p2    = $schema->add_procedure( $procedure_bar ) or die $schema->error;

=cut

    my $self            = shift;
    my $procedure_class = 'SQL::Translator::Schema::Procedure';
    my $procedure;

    if ( UNIVERSAL::isa( $_[0], $procedure_class ) ) {
        $procedure = shift;
        $procedure->schema( $self );
    }
    else {
        my %args = @_;
        $args{'schema'} = $self;
        return $self->error('No procedure name') unless $args{'name'};
        $procedure = $procedure_class->new( \%args ) or 
            return $self->error( $procedure_class->error );
    }

    $procedure->order( ++$PROC_ORDER );
    my $procedure_name = $procedure->name or return 
        $self->error('No procedure name');

    if ( defined $self->{'procedures'}{ $procedure_name } ) { 
        return $self->error(
            qq[Can't create procedure: "$procedure_name" exists]
        );
    }
    else {
        $self->{'procedures'}{ $procedure_name } = $procedure;
    }

    return $procedure;
}

# ----------------------------------------------------------------------
sub add_trigger {

=pod

=head2 add_trigger

Add a trigger object.  Returns the new SQL::Translator::Schema::Trigger object.
The "name" parameter is required.  If you try to create a trigger with the
same name as an existing trigger, you will get an error and the trigger will 
not be created.

  my $t1 = $schema->add_trigger( name => 'foo' );
  my $t2 = SQL::Translator::Schema::Trigger->new( name => 'bar' );
  $t2    = $schema->add_trigger( $trigger_bar ) or die $schema->error;

=cut

    my $self          = shift;
    my $trigger_class = 'SQL::Translator::Schema::Trigger';
    my $trigger;

    if ( UNIVERSAL::isa( $_[0], $trigger_class ) ) {
        $trigger = shift;
        $trigger->schema( $self );
    }
    else {
        my %args = @_;
        $args{'schema'} = $self;
        return $self->error('No trigger name') unless $args{'name'};
        $trigger = $trigger_class->new( \%args ) or 
            return $self->error( $trigger_class->error );
    }

    $trigger->order( ++$TRIGGER_ORDER );
    my $trigger_name = $trigger->name or return $self->error('No trigger name');

    if ( defined $self->{'triggers'}{ $trigger_name } ) { 
        return $self->error(qq[Can't create trigger: "$trigger_name" exists]);
    }
    else {
        $self->{'triggers'}{ $trigger_name } = $trigger;
    }

    return $trigger;
}

# ----------------------------------------------------------------------
sub add_view {

=pod

=head2 add_view

Add a view object.  Returns the new SQL::Translator::Schema::View object.
The "name" parameter is required.  If you try to create a view with the
same name as an existing view, you will get an error and the view will 
not be created.

  my $v1 = $schema->add_view( name => 'foo' );
  my $v2 = SQL::Translator::Schema::View->new( name => 'bar' );
  $v2    = $schema->add_view( $view_bar ) or die $schema->error;

=cut

    my $self        = shift;
    my $view_class = 'SQL::Translator::Schema::View';
    my $view;

    if ( UNIVERSAL::isa( $_[0], $view_class ) ) {
        $view = shift;
        $view->schema( $self );
    }
    else {
        my %args = @_;
        $args{'schema'} = $self;
        return $self->error('No view name') unless $args{'name'};
        $view = $view_class->new( \%args ) or return $view_class->error;
    }

    $view->order( ++$VIEW_ORDER );
    my $view_name = $view->name or return $self->error('No view name');

    if ( defined $self->{'views'}{ $view_name } ) { 
        return $self->error(qq[Can't create view: "$view_name" exists]);
    }
    else {
        $self->{'views'}{ $view_name } = $view;
    }

    return $view;
}

# ----------------------------------------------------------------------
sub database {

=pod

=head2 database

Get or set the schema's database.  (optional)

  my $database = $schema->database('PostgreSQL');

=cut

    my $self = shift;
    $self->{'database'} = shift if @_;
    return $self->{'database'} || '';
}

# ----------------------------------------------------------------------
sub is_valid {

=pod

=head2 is_valid

Returns true if all the tables and views are valid.

  my $ok = $schema->is_valid or die $schema->error;

=cut

    my $self = shift;

    return $self->error('No tables') unless $self->get_tables;

    for my $object ( $self->get_tables, $self->get_views ) {
        return $object->error unless $object->is_valid;
    }

    return 1;
}

# ----------------------------------------------------------------------
sub get_procedure {

=pod

=head2 get_procedure

Returns a procedure by the name provided.

  my $procedure = $schema->get_procedure('foo');

=cut

    my $self       = shift;
    my $procedure_name = shift or return $self->error('No procedure name');
    return $self->error( qq[Table "$procedure_name" does not exist] ) unless
        exists $self->{'procedures'}{ $procedure_name };
    return $self->{'procedures'}{ $procedure_name };
}

# ----------------------------------------------------------------------
sub get_procedures {

=pod

=head2 get_procedures

Returns all the procedures as an array or array reference.

  my @procedures = $schema->get_procedures;

=cut

    my $self   = shift;
    my @procedures = 
        map  { $_->[1] } 
        sort { $a->[0] <=> $b->[0] } 
        map  { [ $_->order, $_ ] }
        values %{ $self->{'procedures'} };

    if ( @procedures ) {
        return wantarray ? @procedures : \@procedures;
    }
    else {
        $self->error('No procedures');
        return wantarray ? () : undef;
    }
}

# ----------------------------------------------------------------------
sub get_table {

=pod

=head2 get_table

Returns a table by the name provided.

  my $table = $schema->get_table('foo');

=cut

    my $self       = shift;
    my $table_name = shift or return $self->error('No table name');
    return $self->error( qq[Table "$table_name" does not exist] ) unless
        exists $self->{'tables'}{ $table_name };
    return $self->{'tables'}{ $table_name };
}

# ----------------------------------------------------------------------
sub get_tables {

=pod

=head2 get_tables

Returns all the tables as an array or array reference.

  my @tables = $schema->get_tables;

=cut

    my $self   = shift;
    my @tables = 
        map  { $_->[1] } 
        sort { $a->[0] <=> $b->[0] } 
        map  { [ $_->order, $_ ] }
        values %{ $self->{'tables'} };

    if ( @tables ) {
        return wantarray ? @tables : \@tables;
    }
    else {
        $self->error('No tables');
        return wantarray ? () : undef;
    }
}

# ----------------------------------------------------------------------
sub get_trigger {

=pod

=head2 get_trigger

Returns a trigger by the name provided.

  my $trigger = $schema->get_trigger('foo');

=cut

    my $self       = shift;
    my $trigger_name = shift or return $self->error('No trigger name');
    return $self->error( qq[Table "$trigger_name" does not exist] ) unless
        exists $self->{'triggers'}{ $trigger_name };
    return $self->{'triggers'}{ $trigger_name };
}

# ----------------------------------------------------------------------
sub get_triggers {

=pod

=head2 get_triggers

Returns all the triggers as an array or array reference.

  my @triggers = $schema->get_triggers;

=cut

    my $self   = shift;
    my @triggers = 
        map  { $_->[1] } 
        sort { $a->[0] <=> $b->[0] } 
        map  { [ $_->order, $_ ] }
        values %{ $self->{'triggers'} };

    if ( @triggers ) {
        return wantarray ? @triggers : \@triggers;
    }
    else {
        $self->error('No triggers');
        return wantarray ? () : undef;
    }
}

# ----------------------------------------------------------------------
sub get_view {

=pod

=head2 get_view

Returns a view by the name provided.

  my $view = $schema->get_view('foo');

=cut

    my $self      = shift;
    my $view_name = shift or return $self->error('No view name');
    return $self->error('View "$view_name" does not exist') unless
        exists $self->{'views'}{ $view_name };
    return $self->{'views'}{ $view_name };
}

# ----------------------------------------------------------------------
sub get_views {

=pod

=head2 get_views

Returns all the views as an array or array reference.

  my @views = $schema->get_views;

=cut

    my $self  = shift;
    my @views = 
        map  { $_->[1] } 
        sort { $a->[0] <=> $b->[0] } 
        map  { [ $_->order, $_ ] }
        values %{ $self->{'views'} };

    if ( @views ) {
        return wantarray ? @views : \@views;
    }
    else {
        $self->error('No views');
        return wantarray ? () : undef;
    }
}

# ----------------------------------------------------------------------
sub make_natural_joins {

=pod

=head2 make_natural_joins

Creates foriegn key relationships among like-named fields in different
tables.  Accepts the following arguments:

=over 4

=item * join_pk_only 

A True or False argument which determins whether or not to perform 
the joins from primary keys to fields of the same name in other tables

=item * skip_fields

A list of fields to skip in the joins

=back 4

  $schema->make_natural_joins(
      join_pk_only => 1,
      skip_fields  => 'name,department_id',
  );

=cut

    my $self         = shift;
    my %args         = @_;
    my $join_pk_only = $args{'join_pk_only'} || 0;
    my %skip_fields  = map { s/^\s+|\s+$//g; $_, 1 } @{ 
        parse_list_arg( $args{'skip_fields'} ) 
    };

    my ( %common_keys, %pk );
    for my $table ( $self->get_tables ) {
        for my $field ( $table->get_fields ) {
            my $field_name = $field->name or next;
            next if $skip_fields{ $field_name };
            $pk{ $field_name } = 1 if $field->is_primary_key;
            push @{ $common_keys{ $field_name } }, $table->name;
        }
    } 
   
    for my $field ( keys %common_keys ) {
        next if $join_pk_only and !defined $pk{ $field };

        my @table_names = @{ $common_keys{ $field } };
        next unless scalar @table_names > 1;

        for my $i ( 0 .. $#table_names ) {
            my $table1 = $self->get_table( $table_names[ $i ] ) or next;

            for my $j ( 1 .. $#table_names ) {
                my $table2 = $self->get_table( $table_names[ $j ] ) or next;
                next if $table1->name eq $table2->name;

                $table1->add_constraint(
                    type             => FOREIGN_KEY,
                    fields           => $field,
                    reference_table  => $table2->name,
                    reference_fields => $field,
                );
            }               
        }
    } 

    return 1;
}

# ----------------------------------------------------------------------
sub name {

=pod

=head2 name

Get or set the schema's name.  (optional)

  my $schema_name = $schema->name('Foo Database');

=cut

    my $self = shift;
    $self->{'name'} = shift if @_;
    return $self->{'name'} || '';
}

# ----------------------------------------------------------------------
sub DESTROY {
    my $self = shift;
    undef $_ for values %{ $self->{'tables'} };
    undef $_ for values %{ $self->{'views'}  };
}

1;

# ----------------------------------------------------------------------

=pod

=head1 AUTHOR

Ken Y. Clark E<lt>kclark@cpan.orgE<gt>

=cut
Commit	Line	Data
3c5de62a	1	package SQL::Translator::Schema;
	2
	3	# ----------------------------------------------------------------------
42624697	4	# $Id: Schema.pm,v 1.12 2003-10-08 18:35:15 phrrngtn Exp $
3c5de62a	5	# ----------------------------------------------------------------------
	6	# Copyright (C) 2003 Ken Y. Clark <kclark@cpan.org>
	7	#
	8	# This program is free software; you can redistribute it and/or
	9	# modify it under the terms of the GNU General Public License as
	10	# published by the Free Software Foundation; version 2.
	11	#
	12	# This program is distributed in the hope that it will be useful, but
	13	# WITHOUT ANY WARRANTY; without even the implied warranty of
	14	# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
	15	# General Public License for more details.
	16	#
	17	# You should have received a copy of the GNU General Public License
	18	# along with this program; if not, write to the Free Software
	19	# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
	20	# 02111-1307 USA
	21	# -------------------------------------------------------------------
	22
	23	=pod
	24
	25	=head1 NAME
	26
	27	SQL::Translator::Schema - SQL::Translator schema object
	28
	29	=head1 SYNOPSIS
	30
	31	use SQL::Translator::Schema;
76dce619	32	my $schema = SQL::Translator::Schema->new;
	33	my $table = $schema->add_table( name => 'foo' );
	34	my $view = $schema->add_view( name => 'bar', sql => '...' );
3c5de62a	35
	36	=head1 DESCSIPTION
	37
	38	C<SQL::Translator::Schema> is the object that accepts, validates, and
	39	returns the database structure.
	40
	41	=head1 METHODS
	42
	43	=cut
	44
	45	use strict;
	46	use Class::Base;
9480e70b	47	use SQL::Translator::Schema::Constants;
daf24e05	48	use SQL::Translator::Schema::Procedure;
3c5de62a	49	use SQL::Translator::Schema::Table;
5974bee7	50	use SQL::Translator::Schema::Trigger;
3c5de62a	51	use SQL::Translator::Schema::View;
5974bee7	52	use SQL::Translator::Utils 'parse_list_arg';
3c5de62a	53
3c5de62a	54	use base 'Class::Base';
daf24e05	55	use vars qw[ $VERSION $TABLE_ORDER $VIEW_ORDER $TRIGGER_ORDER $PROC_ORDER ];
3c5de62a	56
42624697	57	$VERSION = sprintf "%d.%02d", q$Revision: 1.12 $ =~ /(\d+)\.(\d+)/;
3c5de62a	58
	59	# ----------------------------------------------------------------------
	60	sub init {
	61
	62	=pod
	63
	64	=head2 new
	65
	66	Object constructor.
	67
99248301	68	my $schema = SQL::Translator->new(
	69	name => 'Foo',
	70	database => 'MySQL',
	71	);
3c5de62a	72
	73	=cut
	74
	75	my ( $self, $config ) = @_;
99248301	76	$self->params( $config, qw[ name database ] ) \|\| return undef;
3c5de62a	77	return $self;
	78	}
	79
	80	# ----------------------------------------------------------------------
76dce619	81	sub add_table {
3c5de62a	82
	83	=pod
	84
76dce619	85	=head2 add_table
3c5de62a	86
76dce619	87	Add a table object. Returns the new SQL::Translator::Schema::Table object.
99248301	88	The "name" parameter is required. If you try to create a table with the
	89	same name as an existing table, you will get an error and the table will
	90	not be created.
3c5de62a	91
68e8e2e1	92	my $t1 = $schema->add_table( name => 'foo' ) or die $schema->error;
	93	my $t2 = SQL::Translator::Schema::Table->new( name => 'bar' );
	94	$t2 = $schema->add_table( $table_bar ) or die $schema->error;
3c5de62a	95
	96	=cut
	97
99248301	98	my $self = shift;
	99	my $table_class = 'SQL::Translator::Schema::Table';
	100	my $table;
	101
	102	if ( UNIVERSAL::isa( $_[0], $table_class ) ) {
	103	$table = shift;
	104	$table->schema( $self );
	105	}
	106	else {
	107	my %args = @_;
	108	$args{'schema'} = $self;
	109	$table = $table_class->new( \%args ) or return
	110	$self->error( $table_class->error );
	111	}
3c5de62a	112
d0b43695	113	$table->order( ++$TABLE_ORDER );
99248301	114	my $table_name = $table->name or return $self->error('No table name');
	115
	116	if ( defined $self->{'tables'}{ $table_name } ) {
	117	return $self->error(qq[Can't create table: "$table_name" exists]);
	118	}
	119	else {
	120	$self->{'tables'}{ $table_name } = $table;
99248301	121	}
3c5de62a	122
	123	return $table;
	124	}
	125
	126	# ----------------------------------------------------------------------
daf24e05	127	sub add_procedure {
	128
	129	=pod
	130
	131	=head2 add_procedure
	132
	133	Add a procedure object. Returns the new
	134	SQL::Translator::Schema::Procedure object. The "name" parameter is
	135	required. If you try to create a procedure with the same name as an
	136	existing procedure, you will get an error and the procedure will not
	137	be created.
	138
	139	my $p1 = $schema->add_procedure( name => 'foo' );
	140	my $p2 = SQL::Translator::Schema::Procedure->new( name => 'bar' );
	141	$p2 = $schema->add_procedure( $procedure_bar ) or die $schema->error;
	142
	143	=cut
	144
	145	my $self = shift;
	146	my $procedure_class = 'SQL::Translator::Schema::Procedure';
	147	my $procedure;
	148
	149	if ( UNIVERSAL::isa( $_[0], $procedure_class ) ) {
	150	$procedure = shift;
	151	$procedure->schema( $self );
	152	}
	153	else {
	154	my %args = @_;
	155	$args{'schema'} = $self;
	156	return $self->error('No procedure name') unless $args{'name'};
	157	$procedure = $procedure_class->new( \%args ) or
	158	return $self->error( $procedure_class->error );
	159	}
	160
	161	$procedure->order( ++$PROC_ORDER );
	162	my $procedure_name = $procedure->name or return
	163	$self->error('No procedure name');
	164
	165	if ( defined $self->{'procedures'}{ $procedure_name } ) {
	166	return $self->error(
	167	qq[Can't create procedure: "$procedure_name" exists]
	168	);
	169	}
	170	else {
	171	$self->{'procedures'}{ $procedure_name } = $procedure;
	172	}
	173
	174	return $procedure;
	175	}
	176
	177	# ----------------------------------------------------------------------
5974bee7	178	sub add_trigger {
	179
	180	=pod
	181
	182	=head2 add_trigger
	183
	184	Add a trigger object. Returns the new SQL::Translator::Schema::Trigger object.
	185	The "name" parameter is required. If you try to create a trigger with the
	186	same name as an existing trigger, you will get an error and the trigger will
	187	not be created.
	188
	189	my $t1 = $schema->add_trigger( name => 'foo' );
	190	my $t2 = SQL::Translator::Schema::Trigger->new( name => 'bar' );
	191	$t2 = $schema->add_trigger( $trigger_bar ) or die $schema->error;
	192
	193	=cut
	194
	195	my $self = shift;
	196	my $trigger_class = 'SQL::Translator::Schema::Trigger';
	197	my $trigger;
	198
	199	if ( UNIVERSAL::isa( $_[0], $trigger_class ) ) {
	200	$trigger = shift;
daf24e05	201	$trigger->schema( $self );
5974bee7	202	}
	203	else {
	204	my %args = @_;
daf24e05	205	$args{'schema'} = $self;
5974bee7	206	return $self->error('No trigger name') unless $args{'name'};
	207	$trigger = $trigger_class->new( \%args ) or
	208	return $self->error( $trigger_class->error );
	209	}
	210
	211	$trigger->order( ++$TRIGGER_ORDER );
	212	my $trigger_name = $trigger->name or return $self->error('No trigger name');
	213
	214	if ( defined $self->{'triggers'}{ $trigger_name } ) {
	215	return $self->error(qq[Can't create trigger: "$trigger_name" exists]);
	216	}
	217	else {
	218	$self->{'triggers'}{ $trigger_name } = $trigger;
	219	}
	220
	221	return $trigger;
	222	}
	223
	224	# ----------------------------------------------------------------------
76dce619	225	sub add_view {
3c5de62a	226
	227	=pod
	228
76dce619	229	=head2 add_view
3c5de62a	230
76dce619	231	Add a view object. Returns the new SQL::Translator::Schema::View object.
99248301	232	The "name" parameter is required. If you try to create a view with the
	233	same name as an existing view, you will get an error and the view will
	234	not be created.
	235
68e8e2e1	236	my $v1 = $schema->add_view( name => 'foo' );
	237	my $v2 = SQL::Translator::Schema::View->new( name => 'bar' );
	238	$v2 = $schema->add_view( $view_bar ) or die $schema->error;
3c5de62a	239
	240	=cut
	241
99248301	242	my $self = shift;
	243	my $view_class = 'SQL::Translator::Schema::View';
	244	my $view;
	245
	246	if ( UNIVERSAL::isa( $_[0], $view_class ) ) {
	247	$view = shift;
daf24e05	248	$view->schema( $self );
99248301	249	}
	250	else {
	251	my %args = @_;
daf24e05	252	$args{'schema'} = $self;
99248301	253	return $self->error('No view name') unless $args{'name'};
	254	$view = $view_class->new( \%args ) or return $view_class->error;
	255	}
3c5de62a	256
d0b43695	257	$view->order( ++$VIEW_ORDER );
99248301	258	my $view_name = $view->name or return $self->error('No view name');
	259
	260	if ( defined $self->{'views'}{ $view_name } ) {
	261	return $self->error(qq[Can't create view: "$view_name" exists]);
	262	}
	263	else {
	264	$self->{'views'}{ $view_name } = $view;
99248301	265	}
3c5de62a	266
76dce619	267	return $view;
3c5de62a	268	}
	269
	270	# ----------------------------------------------------------------------
99248301	271	sub database {
	272
	273	=pod
	274
	275	=head2 database
	276
	277	Get or set the schema's database. (optional)
	278
	279	my $database = $schema->database('PostgreSQL');
	280
	281	=cut
	282
	283	my $self = shift;
	284	$self->{'database'} = shift if @_;
	285	return $self->{'database'} \|\| '';
	286	}
	287
	288	# ----------------------------------------------------------------------
76dce619	289	sub is_valid {
3c5de62a	290
	291	=pod
	292
76dce619	293	=head2 is_valid
3c5de62a	294
76dce619	295	Returns true if all the tables and views are valid.
3c5de62a	296
76dce619	297	my $ok = $schema->is_valid or die $schema->error;
	298
	299	=cut
	300
	301	my $self = shift;
	302
	303	return $self->error('No tables') unless $self->get_tables;
	304
	305	for my $object ( $self->get_tables, $self->get_views ) {
	306	return $object->error unless $object->is_valid;
	307	}
	308
	309	return 1;
	310	}
	311
	312	# ----------------------------------------------------------------------
daf24e05	313	sub get_procedure {
	314
	315	=pod
	316
	317	=head2 get_procedure
	318
	319	Returns a procedure by the name provided.
	320
	321	my $procedure = $schema->get_procedure('foo');
	322
	323	=cut
	324
	325	my $self = shift;
	326	my $procedure_name = shift or return $self->error('No procedure name');
	327	return $self->error( qq[Table "$procedure_name" does not exist] ) unless
	328	exists $self->{'procedures'}{ $procedure_name };
	329	return $self->{'procedures'}{ $procedure_name };
	330	}
	331
	332	# ----------------------------------------------------------------------
	333	sub get_procedures {
	334
	335	=pod
	336
	337	=head2 get_procedures
	338
	339	Returns all the procedures as an array or array reference.
	340
	341	my @procedures = $schema->get_procedures;
	342
	343	=cut
	344
	345	my $self = shift;
	346	my @procedures =
	347	map { $_->[1] }
	348	sort { $a->[0] <=> $b->[0] }
	349	map { [ $_->order, $_ ] }
	350	values %{ $self->{'procedures'} };
	351
	352	if ( @procedures ) {
	353	return wantarray ? @procedures : \@procedures;
	354	}
	355	else {
	356	$self->error('No procedures');
	357	return wantarray ? () : undef;
	358	}
	359	}
	360
	361	# ----------------------------------------------------------------------
76dce619	362	sub get_table {
	363
	364	=pod
	365
	366	=head2 get_table
	367
	368	Returns a table by the name provided.
	369
	370	my $table = $schema->get_table('foo');
	371
	372	=cut
	373
	374	my $self = shift;
	375	my $table_name = shift or return $self->error('No table name');
99248301	376	return $self->error( qq[Table "$table_name" does not exist] ) unless
76dce619	377	exists $self->{'tables'}{ $table_name };
	378	return $self->{'tables'}{ $table_name };
	379	}
	380
	381	# ----------------------------------------------------------------------
	382	sub get_tables {
	383
	384	=pod
	385
	386	=head2 get_tables
	387
	388	Returns all the tables as an array or array reference.
	389
	390	my @tables = $schema->get_tables;
	391
	392	=cut
	393
	394	my $self = shift;
d0b43695	395	my @tables =
	396	map { $_->[1] }
	397	sort { $a->[0] <=> $b->[0] }
	398	map { [ $_->order, $_ ] }
76dce619	399	values %{ $self->{'tables'} };
	400
	401	if ( @tables ) {
	402	return wantarray ? @tables : \@tables;
	403	}
	404	else {
	405	$self->error('No tables');
	406	return wantarray ? () : undef;
	407	}
	408	}
	409
	410	# ----------------------------------------------------------------------
daf24e05	411	sub get_trigger {
	412
	413	=pod
	414
	415	=head2 get_trigger
	416
	417	Returns a trigger by the name provided.
	418
	419	my $trigger = $schema->get_trigger('foo');
	420
	421	=cut
	422
	423	my $self = shift;
	424	my $trigger_name = shift or return $self->error('No trigger name');
	425	return $self->error( qq[Table "$trigger_name" does not exist] ) unless
	426	exists $self->{'triggers'}{ $trigger_name };
	427	return $self->{'triggers'}{ $trigger_name };
	428	}
	429
	430	# ----------------------------------------------------------------------
	431	sub get_triggers {
	432
	433	=pod
	434
	435	=head2 get_triggers
	436
	437	Returns all the triggers as an array or array reference.
	438
	439	my @triggers = $schema->get_triggers;
	440
	441	=cut
	442
	443	my $self = shift;
	444	my @triggers =
	445	map { $_->[1] }
	446	sort { $a->[0] <=> $b->[0] }
	447	map { [ $_->order, $_ ] }
	448	values %{ $self->{'triggers'} };
	449
	450	if ( @triggers ) {
	451	return wantarray ? @triggers : \@triggers;
	452	}
	453	else {
	454	$self->error('No triggers');
	455	return wantarray ? () : undef;
	456	}
	457	}
	458
	459	# ----------------------------------------------------------------------
76dce619	460	sub get_view {
	461
	462	=pod
	463
	464	=head2 get_view
	465
	466	Returns a view by the name provided.
	467
	468	my $view = $schema->get_view('foo');
3c5de62a	469
	470	=cut
	471
	472	my $self = shift;
76dce619	473	my $view_name = shift or return $self->error('No view name');
	474	return $self->error('View "$view_name" does not exist') unless
	475	exists $self->{'views'}{ $view_name };
	476	return $self->{'views'}{ $view_name };
	477	}
3c5de62a	478
76dce619	479	# ----------------------------------------------------------------------
76dce619	480	sub get_views {
3c5de62a	481
76dce619	482	=pod
	483
	484	=head2 get_views
	485
	486	Returns all the views as an array or array reference.
	487
	488	my @views = $schema->get_views;
	489
	490	=cut
	491
	492	my $self = shift;
d0b43695	493	my @views =
	494	map { $_->[1] }
	495	sort { $a->[0] <=> $b->[0] }
	496	map { [ $_->order, $_ ] }
99248301	497	values %{ $self->{'views'} };
76dce619	498
	499	if ( @views ) {
	500	return wantarray ? @views : \@views;
	501	}
	502	else {
	503	$self->error('No views');
	504	return wantarray ? () : undef;
	505	}
3c5de62a	506	}
3c5de62a	507
99248301	508	# ----------------------------------------------------------------------
9480e70b	509	sub make_natural_joins {
	510
	511	=pod
	512
	513	=head2 make_natural_joins
	514
	515	Creates foriegn key relationships among like-named fields in different
	516	tables. Accepts the following arguments:
	517
	518	=over 4
	519
	520	=item * join_pk_only
	521
	522	A True or False argument which determins whether or not to perform
	523	the joins from primary keys to fields of the same name in other tables
	524
	525	=item * skip_fields
	526
	527	A list of fields to skip in the joins
	528
	529	=back 4
	530
	531	$schema->make_natural_joins(
	532	join_pk_only => 1,
	533	skip_fields => 'name,department_id',
	534	);
	535
	536	=cut
	537
	538	my $self = shift;
	539	my %args = @_;
	540	my $join_pk_only = $args{'join_pk_only'} \|\| 0;
40c522c6	541	my %skip_fields = map { s/^\s+\|\s+$//g; $_, 1 } @{
	542	parse_list_arg( $args{'skip_fields'} )
	543	};
9480e70b	544
	545	my ( %common_keys, %pk );
	546	for my $table ( $self->get_tables ) {
	547	for my $field ( $table->get_fields ) {
	548	my $field_name = $field->name or next;
	549	next if $skip_fields{ $field_name };
	550	$pk{ $field_name } = 1 if $field->is_primary_key;
	551	push @{ $common_keys{ $field_name } }, $table->name;
	552	}
	553	}
	554
	555	for my $field ( keys %common_keys ) {
	556	next if $join_pk_only and !defined $pk{ $field };
	557
	558	my @table_names = @{ $common_keys{ $field } };
	559	next unless scalar @table_names > 1;
	560
	561	for my $i ( 0 .. $#table_names ) {
	562	my $table1 = $self->get_table( $table_names[ $i ] ) or next;
	563
	564	for my $j ( 1 .. $#table_names ) {
	565	my $table2 = $self->get_table( $table_names[ $j ] ) or next;
	566	next if $table1->name eq $table2->name;
	567
	568	$table1->add_constraint(
	569	type => FOREIGN_KEY,
	570	fields => $field,
	571	reference_table => $table2->name,
	572	reference_fields => $field,
	573	);
	574	}
	575	}
	576	}
	577
	578	return 1;
	579	}
	580
	581	# ----------------------------------------------------------------------
99248301	582	sub name {
	583
	584	=pod
	585
	586	=head2 name
	587
	588	Get or set the schema's name. (optional)
	589
	590	my $schema_name = $schema->name('Foo Database');
	591
	592	=cut
	593
	594	my $self = shift;
	595	$self->{'name'} = shift if @_;
	596	return $self->{'name'} \|\| '';
	597	}
	598
d0b43695	599	# ----------------------------------------------------------------------
	600	sub DESTROY {
	601	my $self = shift;
	602	undef $_ for values %{ $self->{'tables'} };
	603	undef $_ for values %{ $self->{'views'} };
	604	}
	605
3c5de62a	606	1;
	607
	608	# ----------------------------------------------------------------------
	609
	610	=pod
	611
	612	=head1 AUTHOR
	613
	614	Ken Y. Clark E<lt>kclark@cpan.orgE<gt>
	615
	616	=cut