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.59';
  45
  46
  47 =head1 Construction
  48
  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.
  54
  55 e.g. If we setup our class as follows;
  56
  57  package SQL::Translator::Schema::Table;
  58  use base qw/SQL::Translator::Schema::Object/;
  59
  60  __PACKAGE__->_attributes( qw/schema name/ );
  61
  62  sub name   { ... }
  63  sub schema { ... }
  64
  65 Then we can construct it with
  66
  67  my $table  =  SQL::Translator::Schema::Table->new(
  68      schema => $schema,
  69      name   => 'foo',
  70  );
  71
  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.
  74
  75 Multiple calls to C<_attributes> are cumulative and sub classes will inherit
  76 their parents attribute names.
  77
  78 This is currently experimental, but will hopefull go on to form an introspection
  79 API for the Schema objects.
  80
  81 =cut
  82
  83
  84 __PACKAGE__->mk_classdata("__attributes");
  85
  86 # Define any global attributes here
  87 __PACKAGE__->__attributes([qw/extra/]);
  88
  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!
  92 sub _attributes {
  93     my $class = shift;
  94     if (@_) { $class->__attributes( [ @{$class->__attributes}, @_ ] ); }
  95     return @{$class->__attributes};
  96 }
  97
  98 # Call accessors for any args in hashref passed
  99 sub init {
 100     my ( $self, $config ) = @_;
 101
 102     for my $arg ( $self->_attributes ) {
 103         next unless defined $config->{$arg};
 104         defined $self->$arg( $config->{$arg} ) or return;
 105     }
 106
 107     return $self;
 108 }
 109
 110 # ----------------------------------------------------------------------
 111 sub extra {
 112
 113 =pod
 114
 115 =head1 Global Attributes
 116
 117 The following attributes are defined here, therefore all schema objects will
 118 have them.
 119
 120 =head2 extra
 121
 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.
 127
 128   $field->extra( qualifier => 'ZEROFILL' );
 129
 130   $qualifier = $field->extra('qualifier');
 131
 132   %extra = $field->extra;
 133   $extra = $field->extra;
 134
 135 =cut
 136
 137     my $self = shift;
 138     @_ = %{$_[0]} if ref $_[0] eq "HASH";
 139     my $extra = $self->{'extra'} ||= {};
 140
 141     if (@_==1) {
 142         return exists($extra->{$_[0]}) ? $extra->{$_[0]} : undef ;
 143     }
 144     elsif (@_) {
 145         my %args = @_;
 146         while ( my ( $key, $value ) = each %args ) {
 147             $extra->{$key} = $value;
 148         }
 149     }
 150
 151     return wantarray ? %$extra : $extra;
 152 }
 153
 154 # ----------------------------------------------------------------------
 155 sub remove_extra {
 156
 157 =head2 remove_extra
 158
 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.
 163
 164   # remove all extra attributes
 165   $field->remove_extra();
 166
 167   # remove timezone and locale attributes only
 168   $field->remove_extra(qw/timezone locale/);
 169
 170 =cut
 171
 172     my ( $self, @keys ) = @_;
 173     unless (@keys) {
 174         $self->{'extra'} = {};
 175     }
 176     else {
 177         delete $self->{'extra'}{$_} for @keys;
 178     }
 179 }
 180
 181 # ----------------------------------------------------------------------
 182 sub equals {
 183
 184 =pod
 185
 186 =head2 equals
 187
 188 Determines if this object is the same as another.
 189
 190   my $isIdentical = $object1->equals( $object2 );
 191
 192 =cut
 193
 194     my $self = shift;
 195     my $other = shift;
 196
 197     return 0 unless $other;
 198     return 1 if overload::StrVal($self) eq overload::StrVal($other);
 199     return 0 unless $other->isa( __PACKAGE__ );
 200     return 1;
 201 }
 202
 203 # ----------------------------------------------------------------------
 204 sub _compare_objects {
 205         my $self = shift;
 206         my $obj1 = shift;
 207         my $obj2 = shift;
 208         my $result = (ref_compare($obj1, $obj2) == 0);
 209 #       if ( !$result ) {
 210 #               use Carp qw(cluck);
 211 #               cluck("How did I get here?");
 212 #               use Data::Dumper;
 213 #               $Data::Dumper::Maxdepth = 1;
 214 #               print "obj1: ", Dumper($obj1), "\n";
 215 #               print "obj2: ", Dumper($obj2), "\n";
 216 #       }
 217         return $result;
 218 }
 219
 220 #=============================================================================
 221
 222 1;
 223
 224 =pod
 225
 226 =head1 SEE ALSO
 227
 228 =head1 TODO
 229
 230 =head1 BUGS
 231
 232 =head1 AUTHOR
 233
 234 Ken Youens-Clark E<lt>kclark@cpan.orgE<gt>,
 235 Mark Addison E<lt>mark.addison@itn.co.ukE<gt>.
 236
 237 =cut