1 package SQL::Translator::Schema::Object;
3 # ----------------------------------------------------------------------
4 # Copyright (C) 2002-2009 SQLFairy Authors
6 # This program is free software; you can redistribute it and/or
7 # modify it under the terms of the GNU General Public License as
8 # published by the Free Software Foundation; version 2.
10 # This program is distributed in the hope that it will be useful, but
11 # WITHOUT ANY WARRANTY; without even the implied warranty of
12 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 # General Public License for more details.
15 # You should have received a copy of the GNU General Public License
16 # along with this program; if not, write to the Free Software
17 # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
19 # -------------------------------------------------------------------
25 SQL::Translator::Schema::Object - Base class SQL::Translator Schema objects.
31 Base class for Schema objects. Sub classes L<Class::Base> and adds the following
38 use base 'Class::Data::Inheritable';
39 use base 'Class::Base';
40 use Class::MakeMethods::Utility::Ref qw( ref_compare );
42 use vars qw[ $VERSION ];
49 Derived classes should declare their attributes using the C<_attributes>
50 method. They can then inherit the C<init> method from here which will call
51 accessors of the same name for any values given in the hash passed to C<new>.
52 Note that you will have to impliment the accessors your self and we expect perl
53 style methods; call with no args to get and with arg to set.
55 e.g. If we setup our class as follows;
57 package SQL::Translator::Schema::Table;
58 use base qw/SQL::Translator::Schema::Object/;
60 __PACKAGE__->_attributes( qw/schema name/ );
65 Then we can construct it with
67 my $table = SQL::Translator::Schema::Table->new(
72 and init will call C<< $table->name("foo") >> and C<< $table->schema($schema) >>
73 to set it up. Any undefined args will be ignored.
75 Multiple calls to C<_attributes> are cumulative and sub classes will inherit
76 their parents attribute names.
78 This is currently experimental, but will hopefull go on to form an introspection
79 API for the Schema objects.
84 __PACKAGE__->mk_classdata("__attributes");
86 # Define any global attributes here
87 __PACKAGE__->__attributes([qw/extra/]);
89 # Set the classes attribute names. Multiple calls are cumulative.
90 # We need to be careful to create a new ref so that all classes don't end up
91 # with the same ref and hence the same attributes!
94 if (@_) { $class->__attributes( [ @{$class->__attributes}, @_ ] ); }
95 return @{$class->__attributes};
98 # Call accessors for any args in hashref passed
100 my ( $self, $config ) = @_;
102 for my $arg ( $self->_attributes ) {
103 next unless defined $config->{$arg};
104 defined $self->$arg( $config->{$arg} ) or return;
110 # ----------------------------------------------------------------------
115 =head1 Global Attributes
117 The following attributes are defined here, therefore all schema objects will
122 Get or set the objects "extra" attibutes (e.g., "ZEROFILL" for MySQL fields).
123 Call with no args to get all the extra data.
124 Call with a single name arg to get the value of the named extra attribute,
125 returned as a scalar. Call with a hash or hashref to set extra attributes.
126 Returns a hash or a hashref.
128 $field->extra( qualifier => 'ZEROFILL' );
130 $qualifier = $field->extra('qualifier');
132 %extra = $field->extra;
133 $extra = $field->extra;
138 @_ = %{$_[0]} if ref $_[0] eq "HASH";
139 my $extra = $self->{'extra'} ||= {};
142 return exists($extra->{$_[0]}) ? $extra->{$_[0]} : undef ;
146 while ( my ( $key, $value ) = each %args ) {
147 $extra->{$key} = $value;
151 return wantarray ? %$extra : $extra;
154 # ----------------------------------------------------------------------
159 L</extra> can only be used to get or set "extra" attributes but not to
160 remove some. Call with no args to remove all extra attributes that
161 have been set before. Call with a list of key names to remove
162 certain extra attributes only.
164 # remove all extra attributes
165 $field->remove_extra();
167 # remove timezone and locale attributes only
168 $field->remove_extra(qw/timezone locale/);
172 my ( $self, @keys ) = @_;
174 $self->{'extra'} = {};
177 delete $self->{'extra'}{$_} for @keys;
181 # ----------------------------------------------------------------------
188 Determines if this object is the same as another.
190 my $isIdentical = $object1->equals( $object2 );
197 return 0 unless $other;
198 return 1 if overload::StrVal($self) eq overload::StrVal($other);
199 return 0 unless $other->isa( __PACKAGE__ );
203 # ----------------------------------------------------------------------
204 sub _compare_objects {
208 my $result = (ref_compare($obj1, $obj2) == 0);
210 # use Carp qw(cluck);
211 # cluck("How did I get here?");
213 # $Data::Dumper::Maxdepth = 1;
214 # print "obj1: ", Dumper($obj1), "\n";
215 # print "obj2: ", Dumper($obj2), "\n";
220 #=============================================================================
234 Ken Youens-Clark E<lt>kclark@cpan.orgE<gt>,
235 Mark Addison E<lt>mark.addison@itn.co.ukE<gt>.