From: Mark Addison Date: Fri, 5 Nov 2004 13:19:31 +0000 (+0000) Subject: Added _attributes class data to SQL::Translator::Schema::Object for sub classes X-Git-Tag: v0.11008~603 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=9371be50d82c80f4b62e1a682818ebae69fa9583;p=dbsrgits%2FSQL-Translator.git Added _attributes class data to SQL::Translator::Schema::Object for sub classes to declare their attributes with and an init method to initialize the class from this data. --- diff --git a/Build.PL b/Build.PL index c1aa962..345a75b 100644 --- a/Build.PL +++ b/Build.PL @@ -1,4 +1,4 @@ -# $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; @@ -19,12 +19,13 @@ my $builder = Module::Build->new( '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, diff --git a/lib/SQL/Translator/Schema.pm b/lib/SQL/Translator/Schema.pm index bbd5ae4..576526a 100644 --- a/lib/SQL/Translator/Schema.pm +++ b/lib/SQL/Translator/Schema.pm @@ -1,7 +1,7 @@ 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 # @@ -54,10 +54,11 @@ use SQL::Translator::Utils 'parse_list_arg'; 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 @@ -72,12 +73,6 @@ Object constructor. =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); diff --git a/lib/SQL/Translator/Schema/Constraint.pm b/lib/SQL/Translator/Schema/Constraint.pm index 423a592..4258268 100644 --- a/lib/SQL/Translator/Schema/Constraint.pm +++ b/lib/SQL/Translator/Schema/Constraint.pm @@ -1,7 +1,7 @@ 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 # @@ -51,7 +51,7 @@ use base 'SQL::Translator::Schema::Object'; 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, @@ -62,8 +62,16 @@ my %VALID_CONSTRAINT_TYPE = ( ); # ---------------------------------------------------------------------- -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 @@ -84,19 +92,9 @@ Object constructor. =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(@_); } # ---------------------------------------------------------------------- diff --git a/lib/SQL/Translator/Schema/Field.pm b/lib/SQL/Translator/Schema/Field.pm index e42ae93..00d74e9 100644 --- a/lib/SQL/Translator/Schema/Field.pm +++ b/lib/SQL/Translator/Schema/Field.pm @@ -1,7 +1,7 @@ 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 # @@ -50,7 +50,7 @@ use base 'SQL::Translator::Schema::Object'; 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 @@ -62,7 +62,12 @@ use overload ; # ---------------------------------------------------------------------- -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 @@ -77,21 +82,6 @@ Object constructor. =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 { diff --git a/lib/SQL/Translator/Schema/Index.pm b/lib/SQL/Translator/Schema/Index.pm index 7c3682d..d4902d8 100644 --- a/lib/SQL/Translator/Schema/Index.pm +++ b/lib/SQL/Translator/Schema/Index.pm @@ -1,7 +1,7 @@ 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 # @@ -53,7 +53,7 @@ use base 'SQL::Translator::Schema::Object'; 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, @@ -62,7 +62,10 @@ my %VALID_INDEX_TYPE = ( ); # ---------------------------------------------------------------------- -sub init { + +__PACKAGE__->_attributes( qw/ + name type fields table +/); =pod @@ -74,16 +77,6 @@ Object constructor. =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 { diff --git a/lib/SQL/Translator/Schema/Object.pm b/lib/SQL/Translator/Schema/Object.pm index 856c511..bff5fb3 100644 --- a/lib/SQL/Translator/Schema/Object.pm +++ b/lib/SQL/Translator/Schema/Object.pm @@ -1,7 +1,7 @@ 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 # @@ -30,24 +30,86 @@ SQL::Translator::Schema::Object - Base class SQL::Translator Schema objects. =head1 DESCSIPTION -Doesn't currently provide any functionaliy apart from sub classing -L. Here to provide a single place to impliment global Schema -object functionality. +Base class for Schema objects. Sub classes L 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 method from here which will call +accessors of the same name for any values given in the hash passed to C. +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 diff --git a/lib/SQL/Translator/Schema/Procedure.pm b/lib/SQL/Translator/Schema/Procedure.pm index bfc0f2e..89ab667 100644 --- a/lib/SQL/Translator/Schema/Procedure.pm +++ b/lib/SQL/Translator/Schema/Procedure.pm @@ -1,7 +1,7 @@ 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 # @@ -54,10 +54,13 @@ use base 'SQL::Translator::Schema::Object'; 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 @@ -69,16 +72,6 @@ Object constructor. =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 { diff --git a/lib/SQL/Translator/Schema/Table.pm b/lib/SQL/Translator/Schema/Table.pm index 64e3b83..6aa6fae 100644 --- a/lib/SQL/Translator/Schema/Table.pm +++ b/lib/SQL/Translator/Schema/Table.pm @@ -1,7 +1,7 @@ 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 # @@ -51,7 +51,7 @@ use base 'SQL::Translator::Schema::Object'; 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 @@ -64,7 +64,8 @@ use overload ; # ---------------------------------------------------------------------- -sub init { + +__PACKAGE__->_attributes( qw/schema name comments options order/ ); =pod @@ -79,16 +80,6 @@ Object constructor. =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 { diff --git a/lib/SQL/Translator/Schema/Trigger.pm b/lib/SQL/Translator/Schema/Trigger.pm index 90cfd5b..e3b0cd3 100644 --- a/lib/SQL/Translator/Schema/Trigger.pm +++ b/lib/SQL/Translator/Schema/Trigger.pm @@ -1,7 +1,7 @@ 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 # @@ -54,10 +54,14 @@ use base 'SQL::Translator::Schema::Object'; 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 @@ -69,21 +73,6 @@ Object constructor. =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 { diff --git a/lib/SQL/Translator/Schema/View.pm b/lib/SQL/Translator/Schema/View.pm index afd3b5b..acbb0ff 100644 --- a/lib/SQL/Translator/Schema/View.pm +++ b/lib/SQL/Translator/Schema/View.pm @@ -1,7 +1,7 @@ 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 # @@ -50,10 +50,13 @@ use base 'SQL::Translator::Schema::Object'; 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 @@ -65,16 +68,6 @@ Object constructor. =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 {