lib/SQL/Translator/Schema/Object.pm

   1 package SQL::Translator::Schema::Object;
   2
   3 # ----------------------------------------------------------------------
   4 # $Id: Object.pm,v 1.4 2005-01-13 09:44:15 grommit Exp $
   5 # ----------------------------------------------------------------------
   6 # Copyright (C) 2002-4 SQLFairy Authors
   7 #
   8 # This program is free software; you can redistribute it and/or
   9 # modify it under the terms of the GNU General Public License as
  10 # published by the Free Software Foundation; version 2.
  11 #
  12 # This program is distributed in the hope that it will be useful, but
  13 # WITHOUT ANY WARRANTY; without even the implied warranty of
  14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15 # General Public License for more details.
  16 #
  17 # You should have received a copy of the GNU General Public License
  18 # along with this program; if not, write to the Free Software
  19 # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
  20 # 02111-1307  USA
  21 # -------------------------------------------------------------------
  22
  23 =pod
  24
  25 =head1 NAME
  26
  27 SQL::Translator::Schema::Object - Base class SQL::Translator Schema objects.
  28
  29 =head1 SYNOPSIS
  30
  31 =head1 DESCSIPTION
  32
  33 Base class for Schema objects. Sub classes L<Class::Base> and adds the following
  34 extra functionality.
  35
  36 =cut
  37
  38 use strict;
  39 use Class::Base;
  40 use base 'Class::Data::Inheritable';
  41 use base 'Class::Base';
  42
  43 use vars qw[ $VERSION ];
  44
  45 $VERSION = sprintf "%d.%02d", q$Revision: 1.4 $ =~ /(\d+)\.(\d+)/;
  46
  47
  48 =head1 Construction
  49
  50 Derived classes should decalare their attributes using the C<_attributes>
  51 method. They can then inherit the C<init> method from here which will call
  52 accessors of the same name for any values given in the hash passed to C<new>.
  53 Note that you will have to impliment the accessors your self and we expect perl
  54 style methods; call with no args to get and with arg to set.
  55
  56 e.g. If we setup our class as follows;
  57
  58  package SQL::Translator::Schema::Table;
  59  use base qw/SQL::Translator::Schema::Object/;
  60
  61  __PACKAGE__->_attributes( qw/schema name/ );
  62
  63  sub name   { ... }
  64  sub schema { ... }
  65
  66 Then we can construct it with
  67
  68  my $table  =  SQL::Translator::Schema::Table->new(
  69      schema => $schema,
  70      name   => 'foo',
  71  );
  72
  73 and init will call C<< $table->name("foo") >> and C<< $table->schema($schema) >>
  74 to set it up. Any undefined args will be ignored.
  75
  76 Multiple calls to C<_attributes> are cumulative and sub classes will inherit
  77 their parents attribute names.
  78
  79 This is currently experimental, but will hopefull go on to form an introspection
  80 API for the Schema objects.
  81
  82 =cut
  83
  84
  85 __PACKAGE__->mk_classdata("__attributes");
  86
  87 # Define any global attributes here
  88 __PACKAGE__->__attributes([qw/extra/]);
  89
  90 # Set the classes attribute names. Multiple calls are cumulative.
  91 # We need to be careful to create a new ref so that all classes don't end up
  92 # with the same ref and hence the same attributes!
  93 sub _attributes {
  94     my $class = shift;
  95     if (@_) { $class->__attributes( [ @{$class->__attributes}, @_ ] ); }
  96     return @{$class->__attributes};
  97 }
  98
  99 # Call accessors for any args in hashref passed
 100 sub init {
 101     my ( $self, $config ) = @_;
 102
 103     for my $arg ( $self->_attributes ) {
 104         next unless defined $config->{$arg};
 105         defined $self->$arg( $config->{$arg} ) or return;
 106     }
 107
 108     return $self;
 109 }
 110
 111 # ----------------------------------------------------------------------
 112 sub extra {
 113
 114 =pod
 115
 116 =head1 Global Attributes
 117
 118 The following attributes are defined here, therefore all schema objects will
 119 have them.
 120
 121 =head2 extra
 122
 123 Get or set the objects "extra" attibutes (e.g., "ZEROFILL" for MySQL fields).
 124 Call with no args to get all the extra data.
 125 Call with a single name arg to get the value of the named extra attribute,
 126 returned as a scalar. Call with a hash or hashref to set extra attributes.
 127 Returns a hash or a hashref.
 128
 129   $field->extra( qualifier => 'ZEROFILL' );
 130
 131   $qualifier = $field->extra('qualifier');
 132
 133   %extra = $field->extra;
 134   $extra = $field->extra;
 135
 136 =cut
 137
 138     my $self = shift;
 139     @_ = %{$_[0]} if ref $_[0] eq "HASH";
 140     my $extra = $self->{'extra'} ||= {};
 141
 142     if (@_==1) {
 143         return exists($extra->{$_[0]}) ? $extra->{$_[0]} : undef ;
 144     }
 145     elsif (@_) {
 146         my %args = @_;
 147         while ( my ( $key, $value ) = each %args ) {
 148             $extra->{$key} = $value;
 149         }
 150     }
 151
 152     return wantarray ? %$extra : $extra;
 153 }
 154
 155 #=============================================================================
 156
 157 1;
 158
 159 =pod
 160
 161 =head1 SEE ALSO
 162
 163 =head1 TODO
 164
 165 =head1 BUGS
 166
 167 =head1 AUTHOR
 168
 169 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>, Mark Addison E<lt>mark.addison@itn.co.ukE<gt>
 170
 171 =cut