lib/SQL/Translator/Schema/Object.pm

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