to declare their attributes with and an init method to initialize the class from
this data.
-# $Id: Build.PL,v 1.2 2004-10-15 03:52:50 allenday Exp $
+# $Id: Build.PL,v 1.3 2004-11-05 13:19:31 grommit Exp $
use strict;
use Module::Build;
'bin/sqlt',
],
requires => {
- 'Class::Base' => 0,
- 'IO::Dir' => 0,
- 'Log::Log4perl' => 0,
- 'Template' => 2.10,
- 'Parse::RecDescent' => 1.94,
- 'Pod::Usage' => 0,
+ 'Class::Base' => 0,
+ 'Class::Data::Inheritable' => 0.02,
+ 'IO::Dir' => 0,
+ 'Log::Log4perl' => 0,
+ 'Template' => 2.10,
+ 'Parse::RecDescent' => 1.94,
+ 'Pod::Usage' => 0,
},
recommends => {
'GD' => 0,
package SQL::Translator::Schema;
# ----------------------------------------------------------------------
-# $Id: Schema.pm,v 1.19 2004-11-04 16:29:56 grommit Exp $
+# $Id: Schema.pm,v 1.20 2004-11-05 13:19:31 grommit Exp $
# ----------------------------------------------------------------------
# Copyright (C) 2002-4 SQLFairy Authors
#
use base 'SQL::Translator::Schema::Object';
use vars qw[ $VERSION $TABLE_ORDER $VIEW_ORDER $TRIGGER_ORDER $PROC_ORDER ];
-$VERSION = sprintf "%d.%02d", q$Revision: 1.19 $ =~ /(\d+)\.(\d+)/;
+$VERSION = sprintf "%d.%02d", q$Revision: 1.20 $ =~ /(\d+)\.(\d+)/;
# ----------------------------------------------------------------------
-sub init {
+
+__PACKAGE__->_attributes( qw/name database translator/ );
=pod
=cut
- my ( $self, $config ) = @_;
- $self->params( $config, qw[ name database translator ] )
- || return undef;
- return $self;
-}
-
sub as_graph {
my($self) = @_;
return SQL::Translator::Schema::Graph->new(translator => $self->translator);
package SQL::Translator::Schema::Constraint;
# ----------------------------------------------------------------------
-# $Id: Constraint.pm,v 1.14 2004-11-04 16:29:56 grommit Exp $
+# $Id: Constraint.pm,v 1.15 2004-11-05 13:19:31 grommit Exp $
# ----------------------------------------------------------------------
# Copyright (C) 2002-4 SQLFairy Authors
#
use vars qw($VERSION $TABLE_COUNT $VIEW_COUNT);
-$VERSION = sprintf "%d.%02d", q$Revision: 1.14 $ =~ /(\d+)\.(\d+)/;
+$VERSION = sprintf "%d.%02d", q$Revision: 1.15 $ =~ /(\d+)\.(\d+)/;
my %VALID_CONSTRAINT_TYPE = (
PRIMARY_KEY, 1,
);
# ----------------------------------------------------------------------
-sub init {
+__PACKAGE__->_attributes( qw/
+ table name type fields reference_fields reference_table
+ match_type on_delete on_update expression deferrable
+/);
+
+# Override to remove empty arrays from args.
+# t/14postgres-parser breaks without this.
+sub init {
+
=pod
=head2 new
=cut
- my ( $self, $config ) = @_;
- my @fields = qw[
- table name type fields reference_fields reference_table
- match_type on_delete on_update expression
- ];
-
- for my $arg ( @fields ) {
- next unless $config->{ $arg };
- next if ref $config->{ $arg } eq 'ARRAY' && ! @{ $config->{ $arg } };
- defined $self->$arg( $config->{ $arg } ) or return;
- }
-
- return $self;
+ my $self = shift;
+ foreach ( values %{$_[0]} ) { $_ = undef if ref($_) eq "ARRAY" && ! @$_; }
+ $self->SUPER::init(@_);
}
# ----------------------------------------------------------------------
package SQL::Translator::Schema::Field;
# ----------------------------------------------------------------------
-# $Id: Field.pm,v 1.20 2004-11-04 16:29:56 grommit Exp $
+# $Id: Field.pm,v 1.21 2004-11-05 13:19:31 grommit Exp $
# ----------------------------------------------------------------------
# Copyright (C) 2002-4 SQLFairy Authors
#
use vars qw($VERSION $TABLE_COUNT $VIEW_COUNT);
-$VERSION = sprintf "%d.%02d", q$Revision: 1.20 $ =~ /(\d+)\.(\d+)/;
+$VERSION = sprintf "%d.%02d", q$Revision: 1.21 $ =~ /(\d+)\.(\d+)/;
# Stringify to our name, being careful not to pass any args through so we don't
# accidentally set it to undef. We also have to tweak bool so the object is
;
# ----------------------------------------------------------------------
-sub init {
+
+__PACKAGE__->_attributes( qw/
+ table name data_type size is_primary_key is_nullable
+ is_auto_increment default_value comments extra is_foreign_key
+ is_unique order
+/);
=pod
=cut
- my ( $self, $config ) = @_;
-
- for my $arg (
- qw[
- table name data_type size is_primary_key is_nullable
- is_auto_increment default_value comments extra
- ]
- ) {
- next unless defined $config->{ $arg };
- defined $self->$arg( $config->{ $arg } ) or return;
- }
-
- return $self;
-}
-
# ----------------------------------------------------------------------
sub comments {
package SQL::Translator::Schema::Index;
# ----------------------------------------------------------------------
-# $Id: Index.pm,v 1.9 2004-11-04 16:29:56 grommit Exp $
+# $Id: Index.pm,v 1.10 2004-11-05 13:19:31 grommit Exp $
# ----------------------------------------------------------------------
# Copyright (C) 2002-4 SQLFairy Authors
#
use vars qw($VERSION $TABLE_COUNT $VIEW_COUNT);
-$VERSION = sprintf "%d.%02d", q$Revision: 1.9 $ =~ /(\d+)\.(\d+)/;
+$VERSION = sprintf "%d.%02d", q$Revision: 1.10 $ =~ /(\d+)\.(\d+)/;
my %VALID_INDEX_TYPE = (
UNIQUE, 1,
);
# ----------------------------------------------------------------------
-sub init {
+
+__PACKAGE__->_attributes( qw/
+ name type fields table
+/);
=pod
=cut
- my ( $self, $config ) = @_;
-
- for my $arg ( qw[ name type fields table ] ) {
- next unless $config->{ $arg };
- defined $self->$arg( $config->{ $arg } ) or return;
- }
-
- return $self;
-}
-
# ----------------------------------------------------------------------
sub fields {
package SQL::Translator::Schema::Object;
# ----------------------------------------------------------------------
-# $Id: Object.pm,v 1.1 2004-11-04 16:29:56 grommit Exp $
+# $Id: Object.pm,v 1.2 2004-11-05 13:19:31 grommit Exp $
# ----------------------------------------------------------------------
# Copyright (C) 2002-4 SQLFairy Authors
#
=head1 DESCSIPTION
-Doesn't currently provide any functionaliy apart from sub classing
-L<Class::Base>. Here to provide a single place to impliment global Schema
-object functionality.
+Base class for Schema objects. Sub classes L<Class::Base> and adds the following
+extra functionality.
=cut
use strict;
use Class::Base;
+use base 'Class::Data::Inheritable';
use base 'Class::Base';
use vars qw[ $VERSION ];
-$VERSION = sprintf "%d.%02d", q$Revision: 1.1 $ =~ /(\d+)\.(\d+)/;
+$VERSION = sprintf "%d.%02d", q$Revision: 1.2 $ =~ /(\d+)\.(\d+)/;
-1;
+=head1 Construction
-# ----------------------------------------------------------------------
+Derived classes should decalare their attributes using the C<_attributes>
+method. They can then inherit the C<init> method from here which will call
+accessors of the same name for any values given in the hash passed to C<new>.
+Note that you will have to impliment the accessors your self and we expect perl
+style methods; call with no args to get and with arg to set.
+
+e.g. If we setup our class as follows;
+
+ package SQL::Translator::Schema::Table;
+ use base qw/SQL::Translator::Schema::Object/;
+
+ __PACKAGE__->_attributes( qw/schema name/ );
+
+ sub name { ... }
+ sub schema { ... }
+
+Then we can construct it with
+
+ my $table = SQL::Translator::Schema::Table->new(
+ schema => $schema,
+ name => 'foo',
+ );
+
+and init will call C<< $table->name("foo") >> and C<< $table->schema($schema) >>
+to set it up. Any undefined args will be ignored.
+
+Multiple calls to C<_attributes> are cumulative and sub classes will inherit
+their parents attribute names.
+
+This is currently experimental, but will hopefull go on to form an introspection
+API for the Schema objects.
+
+=cut
+
+
+__PACKAGE__->mk_classdata("__attributes");
+__PACKAGE__->__attributes([]);
+
+# Set the classes attribute names. Multiple calls are cumulative.
+# We need to be careful to create a new ref so that all classes don't end up
+# with the same ref and hence the same attributes!
+sub _attributes {
+ my $class = shift;
+ if (@_) { $class->__attributes( [ @{$class->__attributes}, @_ ] ); }
+ return @{$class->__attributes};
+}
+
+# Call accessors for any args in hashref passed
+sub init {
+ my ( $self, $config ) = @_;
+
+ for my $arg ( $self->_attributes ) {
+ next unless defined $config->{$arg};
+ defined $self->$arg( $config->{$arg} ) or return;
+ }
+
+ return $self;
+}
+
+
+#=============================================================================
+
+1;
=pod
package SQL::Translator::Schema::Procedure;
# ----------------------------------------------------------------------
-# $Id: Procedure.pm,v 1.3 2004-11-04 16:29:56 grommit Exp $
+# $Id: Procedure.pm,v 1.4 2004-11-05 13:19:31 grommit Exp $
# ----------------------------------------------------------------------
# Copyright (C) 2002-4 SQLFairy Authors
#
use vars qw($VERSION);
-$VERSION = sprintf "%d.%02d", q$Revision: 1.3 $ =~ /(\d+)\.(\d+)/;
+$VERSION = sprintf "%d.%02d", q$Revision: 1.4 $ =~ /(\d+)\.(\d+)/;
# ----------------------------------------------------------------------
-sub init {
+
+__PACKAGE__->_attributes( qw/
+ name sql parameters comments owner sql schema order
+/);
=pod
=cut
- my ( $self, $config ) = @_;
-
- for my $arg ( qw[ name sql parameters comments owner sql schema ] ) {
- next unless $config->{ $arg };
- $self->$arg( $config->{ $arg } ) or return;
- }
-
- return $self;
-}
-
# ----------------------------------------------------------------------
sub parameters {
package SQL::Translator::Schema::Table;
# ----------------------------------------------------------------------
-# $Id: Table.pm,v 1.27 2004-11-04 16:29:56 grommit Exp $
+# $Id: Table.pm,v 1.28 2004-11-05 13:19:31 grommit Exp $
# ----------------------------------------------------------------------
# Copyright (C) 2002-4 SQLFairy Authors
#
use vars qw( $VERSION $FIELD_ORDER );
-$VERSION = sprintf "%d.%02d", q$Revision: 1.27 $ =~ /(\d+)\.(\d+)/;
+$VERSION = sprintf "%d.%02d", q$Revision: 1.28 $ =~ /(\d+)\.(\d+)/;
# Stringify to our name, being careful not to pass any args through so we don't
;
# ----------------------------------------------------------------------
-sub init {
+
+__PACKAGE__->_attributes( qw/schema name comments options order/ );
=pod
=cut
- my ( $self, $config ) = @_;
-
- for my $arg ( qw[ schema name comments ] ) {
- next unless defined $config->{ $arg };
- defined $self->$arg( $config->{ $arg } ) or return;
- }
-
- return $self;
-}
-
# ----------------------------------------------------------------------
sub add_constraint {
package SQL::Translator::Schema::Trigger;
# ----------------------------------------------------------------------
-# $Id: Trigger.pm,v 1.4 2004-11-04 16:29:56 grommit Exp $
+# $Id: Trigger.pm,v 1.5 2004-11-05 13:19:31 grommit Exp $
# ----------------------------------------------------------------------
# Copyright (C) 2002-4 SQLFairy Authors
#
use vars qw($VERSION $TABLE_COUNT $VIEW_COUNT);
-$VERSION = sprintf "%d.%02d", q$Revision: 1.4 $ =~ /(\d+)\.(\d+)/;
+$VERSION = sprintf "%d.%02d", q$Revision: 1.5 $ =~ /(\d+)\.(\d+)/;
# ----------------------------------------------------------------------
-sub init {
+
+__PACKAGE__->_attributes( qw/
+ name perform_action_when database_event fields on_table action schema
+ order
+/);
=pod
=cut
- my ( $self, $config ) = @_;
-
- for my $arg (
- qw[
- name perform_action_when database_event fields
- on_table action schema
- ]
- ) {
- next unless $config->{ $arg };
- $self->$arg( $config->{ $arg } );# or return;
- }
-
- return $self;
-}
-
# ----------------------------------------------------------------------
sub perform_action_when {
package SQL::Translator::Schema::View;
# ----------------------------------------------------------------------
-# $Id: View.pm,v 1.8 2004-11-04 16:29:56 grommit Exp $
+# $Id: View.pm,v 1.9 2004-11-05 13:19:31 grommit Exp $
# ----------------------------------------------------------------------
# Copyright (C) 2002-4 SQLFairy Authors
#
use vars qw($VERSION $TABLE_COUNT $VIEW_COUNT);
-$VERSION = sprintf "%d.%02d", q$Revision: 1.8 $ =~ /(\d+)\.(\d+)/;
+$VERSION = sprintf "%d.%02d", q$Revision: 1.9 $ =~ /(\d+)\.(\d+)/;
# ----------------------------------------------------------------------
-sub init {
+
+__PACKAGE__->_attributes( qw/
+ name sql fields schema order
+/);
=pod
=cut
- my ( $self, $config ) = @_;
-
- for my $arg ( qw[ name sql fields schema ] ) {
- next unless $config->{ $arg };
- $self->$arg( $config->{ $arg } ) or return;
- }
-
- return $self;
-}
-
# ----------------------------------------------------------------------
sub fields {
projects / dbsrgits/SQL-Translator.git / commitdiff