X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FSQL%2FTranslator%2FSchema%2FObject.pm;h=96cc00da352c282ed628ca8df171b2152da6ce92;hb=abf315bb9c2c78e40da9af6519e5daae76d60f08;hp=856c5110c333cf194ba06c0f326ead2d93783b71;hpb=b6a880d1daac518c07475bad0c7ef74d0416386b;p=dbsrgits%2FSQL-Translator.git

diff --git a/lib/SQL/Translator/Schema/Object.pm b/lib/SQL/Translator/Schema/Object.pm
index 856c511..96cc00d 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.5 2005-06-27 21:58:42 duality72 Exp $
 # ----------------------------------------------------------------------
 # Copyright (C) 2002-4 SQLFairy Authors
 #
@@ -30,24 +30,163 @@ SQL::Translator::Schema::Object - Base class SQL::Translator Schema objects.
 
 =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 Data::Compare;
 
 use vars qw[ $VERSION ];
 
-$VERSION = sprintf "%d.%02d", q$Revision: 1.1 $ =~ /(\d+)\.(\d+)/;
+$VERSION = sprintf "%d.%02d", q$Revision: 1.5 $ =~ /(\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");
+
+# Define any global attributes here
+__PACKAGE__->__attributes([qw/extra/]); 
+
+# 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;
+}
+
+# ----------------------------------------------------------------------
+sub extra {
+
+=pod
+
+=head1 Global Attributes
+
+The following attributes are defined here, therefore all schema objects will
+have them.
+
+=head2 extra
+
+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.
+
+  $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 equals {
+
+=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 $self eq $other;
+    return 0 unless $other->isa( __PACKAGE__ );
+    return 1;
+}
 
 # ----------------------------------------------------------------------
+sub _compare_objects($$;$) {
+	my $self = shift;
+	# Suppress spurious Data::Compare warnings
+	local $SIG{__WARN__} = sub {};
+	Data::Compare::Compare(shift, shift, shift);
+}
+
+#=============================================================================
+
+1;
 
 =pod