lib/SQL/Translator/Schema/Object.pm

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