lib/SQL/Translator/Schema/Object.pm

   1 package SQL::Translator::Schema::Object;
   2
   3 # ----------------------------------------------------------------------
   4 # $Id: Object.pm,v 1.3 2004-11-05 15:03:10 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.3 $ =~ /(\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 Accepts a hash(ref) of name/value pairs to store;  returns a hash.
 125
 126   $field->extra( qualifier => 'ZEROFILL' );
 127   my %extra = $field->extra;
 128
 129 =cut
 130
 131     my $self = shift;
 132     my $args = ref $_[0] eq 'HASH' ? shift : { @_ };
 133
 134     while ( my ( $key, $value ) = each %$args ) {
 135         $self->{'extra'}{ $key } = $value;
 136     }
 137
 138     return %{ $self->{'extra'} || {} };
 139 }
 140
 141 #=============================================================================
 142
 143 1;
 144
 145 =pod
 146
 147 =head1 SEE ALSO
 148
 149 =head1 TODO
 150
 151 =head1 BUGS
 152
 153 =head1 AUTHOR
 154
 155 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>, Mark Addison E<lt>mark.addison@itn.co.ukE<gt>
 156
 157 =cut