lib/SQL/Translator/Schema/Object.pm

   1 package SQL::Translator::Schema::Object;
   2
   3 # ----------------------------------------------------------------------
   4 # $Id$
   5 # ----------------------------------------------------------------------
   6 # Copyright (C) 2002-4 SQLFairy Authors
   7 #
   8 # This program is free software; you can redistribute it and/or
   9 # modify it under the terms of the GNU General Public License as
  10 # published by the Free Software Foundation; version 2.
  11 #
  12 # This program is distributed in the hope that it will be useful, but
  13 # WITHOUT ANY WARRANTY; without even the implied warranty of
  14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15 # General Public License for more details.
  16 #
  17 # You should have received a copy of the GNU General Public License
  18 # along with this program; if not, write to the Free Software
  19 # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
  20 # 02111-1307  USA
  21 # -------------------------------------------------------------------
  22
  23 =pod
  24
  25 =head1 NAME
  26
  27 SQL::Translator::Schema::Object - Base class SQL::Translator Schema objects.
  28
  29 =head1 SYNOPSIS
  30
  31 =head1 DESCSIPTION
  32
  33 Base class for Schema objects. Sub classes L<Class::Base> and adds the following
  34 extra functionality.
  35
  36 =cut
  37
  38 use strict;
  39 use Class::Base;
  40 use base 'Class::Data::Inheritable';
  41 use base 'Class::Base';
  42 use Class::MakeMethods::Utility::Ref qw( ref_compare );
  43
  44 use vars qw[ $VERSION ];
  45
  46 $VERSION = sprintf "%d.%02d", q$Revision$ =~ /(\d+)\.(\d+)/;
  47
  48
  49 =head1 Construction
  50
  51 Derived classes should declare their attributes using the C<_attributes>
  52 method. They can then inherit the C<init> method from here which will call
  53 accessors of the same name for any values given in the hash passed to C<new>.
  54 Note that you will have to impliment the accessors your self and we expect perl
  55 style methods; call with no args to get and with arg to set.
  56
  57 e.g. If we setup our class as follows;
  58
  59  package SQL::Translator::Schema::Table;
  60  use base qw/SQL::Translator::Schema::Object/;
  61
  62  __PACKAGE__->_attributes( qw/schema name/ );
  63
  64  sub name   { ... }
  65  sub schema { ... }
  66
  67 Then we can construct it with
  68
  69  my $table  =  SQL::Translator::Schema::Table->new(
  70      schema => $schema,
  71      name   => 'foo',
  72  );
  73
  74 and init will call C<< $table->name("foo") >> and C<< $table->schema($schema) >>
  75 to set it up. Any undefined args will be ignored.
  76
  77 Multiple calls to C<_attributes> are cumulative and sub classes will inherit
  78 their parents attribute names.
  79
  80 This is currently experimental, but will hopefull go on to form an introspection
  81 API for the Schema objects.
  82
  83 =cut
  84
  85
  86 __PACKAGE__->mk_classdata("__attributes");
  87
  88 # Define any global attributes here
  89 __PACKAGE__->__attributes([qw/extra/]);
  90
  91 # Set the classes attribute names. Multiple calls are cumulative.
  92 # We need to be careful to create a new ref so that all classes don't end up
  93 # with the same ref and hence the same attributes!
  94 sub _attributes {
  95     my $class = shift;
  96     if (@_) { $class->__attributes( [ @{$class->__attributes}, @_ ] ); }
  97     return @{$class->__attributes};
  98 }
  99
 100 # Call accessors for any args in hashref passed
 101 sub init {
 102     my ( $self, $config ) = @_;
 103
 104     for my $arg ( $self->_attributes ) {
 105         next unless defined $config->{$arg};
 106         defined $self->$arg( $config->{$arg} ) or return;
 107     }
 108
 109     return $self;
 110 }
 111
 112 # ----------------------------------------------------------------------
 113 sub extra {
 114
 115 =pod
 116
 117 =head1 Global Attributes
 118
 119 The following attributes are defined here, therefore all schema objects will
 120 have them.
 121
 122 =head2 extra
 123
 124 Get or set the objects "extra" attibutes (e.g., "ZEROFILL" for MySQL fields).
 125 Call with no args to get all the extra data.
 126 Call with a single name arg to get the value of the named extra attribute,
 127 returned as a scalar. Call with a hash or hashref to set extra attributes.
 128 Returns a hash or a hashref.
 129
 130   $field->extra( qualifier => 'ZEROFILL' );
 131
 132   $qualifier = $field->extra('qualifier');
 133
 134   %extra = $field->extra;
 135   $extra = $field->extra;
 136
 137 =cut
 138
 139     my $self = shift;
 140     @_ = %{$_[0]} if ref $_[0] eq "HASH";
 141     my $extra = $self->{'extra'} ||= {};
 142
 143     if (@_==1) {
 144         return exists($extra->{$_[0]}) ? $extra->{$_[0]} : undef ;
 145     }
 146     elsif (@_) {
 147         my %args = @_;
 148         while ( my ( $key, $value ) = each %args ) {
 149             $extra->{$key} = $value;
 150         }
 151     }
 152
 153     return wantarray ? %$extra : $extra;
 154 }
 155
 156
 157 # ----------------------------------------------------------------------
 158 sub equals {
 159
 160 =pod
 161
 162 =head2 equals
 163
 164 Determines if this object is the same as another.
 165
 166   my $isIdentical = $object1->equals( $object2 );
 167
 168 =cut
 169
 170     my $self = shift;
 171     my $other = shift;
 172
 173     return 0 unless $other;
 174     return 1 if overload::StrVal($self) eq overload::StrVal($other);
 175     return 0 unless $other->isa( __PACKAGE__ );
 176     return 1;
 177 }
 178
 179 # ----------------------------------------------------------------------
 180 sub _compare_objects {
 181         my $self = shift;
 182         my $obj1 = shift;
 183         my $obj2 = shift;
 184         my $result = (ref_compare($obj1, $obj2) == 0);
 185 #       if ( !$result ) {
 186 #               use Carp qw(cluck);
 187 #               cluck("How did I get here?");
 188 #               use Data::Dumper;
 189 #               $Data::Dumper::Maxdepth = 1;
 190 #               print "obj1: ", Dumper($obj1), "\n";
 191 #               print "obj2: ", Dumper($obj2), "\n";
 192 #       }
 193         return $result;
 194 }
 195
 196 #=============================================================================
 197
 198 1;
 199
 200 =pod
 201
 202 =head1 SEE ALSO
 203
 204 =head1 TODO
 205
 206 =head1 BUGS
 207
 208 =head1 AUTHOR
 209
 210 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>, Mark Addison E<lt>mark.addison@itn.co.ukE<gt>
 211
 212 =cut