lib/SQL/Translator/Schema/Object.pm

   1 package SQL::Translator::Schema::Object;
   2
   3 # ----------------------------------------------------------------------
   4 # $Id: Object.pm 1440 2009-01-17 16:31:57Z jawnsy $
   5 # ----------------------------------------------------------------------
   6 # Copyright (C) 2002-2009 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 =head1 Construction
  45
  46 Derived classes should declare their attributes using the C<_attributes>
  47 method. They can then inherit the C<init> method from here which will call
  48 accessors of the same name for any values given in the hash passed to C<new>.
  49 Note that you will have to impliment the accessors your self and we expect perl
  50 style methods; call with no args to get and with arg to set.
  51
  52 e.g. If we setup our class as follows;
  53
  54  package SQL::Translator::Schema::Table;
  55  use base qw/SQL::Translator::Schema::Object/;
  56
  57  __PACKAGE__->_attributes( qw/schema name/ );
  58
  59  sub name   { ... }
  60  sub schema { ... }
  61
  62 Then we can construct it with
  63
  64  my $table  =  SQL::Translator::Schema::Table->new(
  65      schema => $schema,
  66      name   => 'foo',
  67  );
  68
  69 and init will call C<< $table->name("foo") >> and C<< $table->schema($schema) >>
  70 to set it up. Any undefined args will be ignored.
  71
  72 Multiple calls to C<_attributes> are cumulative and sub classes will inherit
  73 their parents attribute names.
  74
  75 This is currently experimental, but will hopefull go on to form an introspection
  76 API for the Schema objects.
  77
  78 =cut
  79
  80
  81 __PACKAGE__->mk_classdata("__attributes");
  82
  83 # Define any global attributes here
  84 __PACKAGE__->__attributes([qw/extra/]);
  85
  86 # Set the classes attribute names. Multiple calls are cumulative.
  87 # We need to be careful to create a new ref so that all classes don't end up
  88 # with the same ref and hence the same attributes!
  89 sub _attributes {
  90     my $class = shift;
  91     if (@_) { $class->__attributes( [ @{$class->__attributes}, @_ ] ); }
  92     return @{$class->__attributes};
  93 }
  94
  95 # Call accessors for any args in hashref passed
  96 sub init {
  97     my ( $self, $config ) = @_;
  98
  99     for my $arg ( $self->_attributes ) {
 100         next unless defined $config->{$arg};
 101         defined $self->$arg( $config->{$arg} ) or return;
 102     }
 103
 104     return $self;
 105 }
 106
 107 # ----------------------------------------------------------------------
 108 sub extra {
 109
 110 =pod
 111
 112 =head1 Global Attributes
 113
 114 The following attributes are defined here, therefore all schema objects will
 115 have them.
 116
 117 =head2 extra
 118
 119 Get or set the objects "extra" attibutes (e.g., "ZEROFILL" for MySQL fields).
 120 Call with no args to get all the extra data.
 121 Call with a single name arg to get the value of the named extra attribute,
 122 returned as a scalar. Call with a hash or hashref to set extra attributes.
 123 Returns a hash or a hashref.
 124
 125   $field->extra( qualifier => 'ZEROFILL' );
 126
 127   $qualifier = $field->extra('qualifier');
 128
 129   %extra = $field->extra;
 130   $extra = $field->extra;
 131
 132 =cut
 133
 134     my $self = shift;
 135     @_ = %{$_[0]} if ref $_[0] eq "HASH";
 136     my $extra = $self->{'extra'} ||= {};
 137
 138     if (@_==1) {
 139         return exists($extra->{$_[0]}) ? $extra->{$_[0]} : undef ;
 140     }
 141     elsif (@_) {
 142         my %args = @_;
 143         while ( my ( $key, $value ) = each %args ) {
 144             $extra->{$key} = $value;
 145         }
 146     }
 147
 148     return wantarray ? %$extra : $extra;
 149 }
 150
 151
 152 # ----------------------------------------------------------------------
 153 sub equals {
 154
 155 =pod
 156
 157 =head2 equals
 158
 159 Determines if this object is the same as another.
 160
 161   my $isIdentical = $object1->equals( $object2 );
 162
 163 =cut
 164
 165     my $self = shift;
 166     my $other = shift;
 167
 168     return 0 unless $other;
 169     return 1 if overload::StrVal($self) eq overload::StrVal($other);
 170     return 0 unless $other->isa( __PACKAGE__ );
 171     return 1;
 172 }
 173
 174 # ----------------------------------------------------------------------
 175 sub _compare_objects {
 176         my $self = shift;
 177         my $obj1 = shift;
 178         my $obj2 = shift;
 179         my $result = (ref_compare($obj1, $obj2) == 0);
 180 #       if ( !$result ) {
 181 #               use Carp qw(cluck);
 182 #               cluck("How did I get here?");
 183 #               use Data::Dumper;
 184 #               $Data::Dumper::Maxdepth = 1;
 185 #               print "obj1: ", Dumper($obj1), "\n";
 186 #               print "obj2: ", Dumper($obj2), "\n";
 187 #       }
 188         return $result;
 189 }
 190
 191 #=============================================================================
 192
 193 1;
 194
 195 =pod
 196
 197 =head1 SEE ALSO
 198
 199 =head1 TODO
 200
 201 =head1 BUGS
 202
 203 =head1 AUTHOR
 204
 205 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>, Mark Addison E<lt>mark.addison@itn.co.ukE<gt>
 206
 207 =cut