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