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