X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FSQL%2FTranslator%2FSchema%2FObject.pm;h=291e5a63a5539adad6e458659bf8f393deaf2ba5;hb=dd13bc8b07104583c80d8352bc51a0331a1b0547;hp=c2aa3332106504704995bdd66e4019a1a785906e;hpb=44659089c28216f1984873bc4aa8641e2e0e3410;p=dbsrgits%2FSQL-Translator.git diff --git a/lib/SQL/Translator/Schema/Object.pm b/lib/SQL/Translator/Schema/Object.pm index c2aa333..291e5a6 100644 --- a/lib/SQL/Translator/Schema/Object.pm +++ b/lib/SQL/Translator/Schema/Object.pm @@ -1,237 +1,50 @@ package SQL::Translator::Schema::Object; -# ---------------------------------------------------------------------- -# Copyright (C) 2002-2009 SQLFairy Authors -# -# 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::Object - Base class SQL::Translator Schema objects. +SQL::Translator::Schema::Object - Base class for SQL::Translator schema objects =head1 SYNOPSIS -=head1 DESCSIPTION - -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 Class::MakeMethods::Utility::Ref qw( ref_compare ); - -use vars qw[ $VERSION ]; - -$VERSION = '1.59'; - - -=head1 Construction - -Derived classes should declare 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 SQL::Translator::Schema::Foo; + use Moo; + extends 'SQL::Translator::Schema::Object'; +=head1 DESCRIPTION -__PACKAGE__->mk_classdata("__attributes"); +Base class for Schema objects. A Moo class consuming the following +roles. -# Define any global attributes here -__PACKAGE__->__attributes([qw/extra/]); +=over -# 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}; -} +=item L -# 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; - } +Provides C<< $obj->error >>, similar to L. - return $self; -} +=item L -# ---------------------------------------------------------------------- -sub extra { +Removes undefined constructor arguments, for backwards compatibility. -=pod +=item L -=head1 Global Attributes +Provides an C attribute storing a hashref of arbitrary data. -The following attributes are defined here, therefore all schema objects will -have them. +=item L -=head2 extra +Provides an C<< $obj->equals($other) >> method for testing object +equality. -Get or set the objects "extra" attibutes (e.g., "ZEROFILL" for MySQL fields). -Call with no args to get all the extra data. -Call with a single name arg to get the value of the named extra attribute, -returned as a scalar. Call with a hash or hashref to set extra attributes. -Returns a hash or a hashref. +=back - $field->extra( qualifier => 'ZEROFILL' ); - - $qualifier = $field->extra('qualifier'); - - %extra = $field->extra; - $extra = $field->extra; - =cut - my $self = shift; - @_ = %{$_[0]} if ref $_[0] eq "HASH"; - my $extra = $self->{'extra'} ||= {}; - - if (@_==1) { - return exists($extra->{$_[0]}) ? $extra->{$_[0]} : undef ; - } - elsif (@_) { - my %args = @_; - while ( my ( $key, $value ) = each %args ) { - $extra->{$key} = $value; - } - } - - return wantarray ? %$extra : $extra; -} - -# ---------------------------------------------------------------------- -sub remove_extra { - -=head2 remove_extra - -L can only be used to get or set "extra" attributes but not to -remove some. Call with no args to remove all extra attributes that -have been set before. Call with a list of key names to remove -certain extra attributes only. - - # remove all extra attributes - $field->remove_extra(); - - # remove timezone and locale attributes only - $field->remove_extra(qw/timezone locale/); - -=cut - - my ( $self, @keys ) = @_; - unless (@keys) { - $self->{'extra'} = {}; - } - else { - delete $self->{'extra'}{$_} for @keys; - } -} - -# ---------------------------------------------------------------------- -sub equals { +use Moo 1.000003; -=pod - -=head2 equals - -Determines if this object is the same as another. - - my $isIdentical = $object1->equals( $object2 ); - -=cut - - my $self = shift; - my $other = shift; - - return 0 unless $other; - return 1 if overload::StrVal($self) eq overload::StrVal($other); - return 0 unless $other->isa( __PACKAGE__ ); - return 1; -} - -# ---------------------------------------------------------------------- -sub _compare_objects { - my $self = shift; - my $obj1 = shift; - my $obj2 = shift; - my $result = (ref_compare($obj1, $obj2) == 0); -# if ( !$result ) { -# use Carp qw(cluck); -# cluck("How did I get here?"); -# use Data::Dumper; -# $Data::Dumper::Maxdepth = 1; -# print "obj1: ", Dumper($obj1), "\n"; -# print "obj2: ", Dumper($obj2), "\n"; -# } - return $result; -} - -#============================================================================= +with qw( + SQL::Translator::Role::Error + SQL::Translator::Role::BuildArgs + SQL::Translator::Schema::Role::Extra + SQL::Translator::Schema::Role::Compare +); 1; - -=pod - -=head1 SEE ALSO - -=head1 TODO - -=head1 BUGS - -=head1 AUTHOR - -Ken Youens-Clark Ekclark@cpan.orgE, -Mark Addison Emark.addison@itn.co.ukE. - -=cut