Commit | Line | Data |
b6a880d1 |
1 | package SQL::Translator::Schema::Object; |
2 | |
3 | # ---------------------------------------------------------------------- |
b1789409 |
4 | # $Id: Object.pm,v 1.3 2004-11-05 15:03:10 grommit Exp $ |
b6a880d1 |
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 | |
9371be50 |
33 | Base class for Schema objects. Sub classes L<Class::Base> and adds the following |
34 | extra functionality. |
b6a880d1 |
35 | |
36 | =cut |
37 | |
38 | use strict; |
39 | use Class::Base; |
9371be50 |
40 | use base 'Class::Data::Inheritable'; |
b6a880d1 |
41 | use base 'Class::Base'; |
42 | |
43 | use vars qw[ $VERSION ]; |
44 | |
b1789409 |
45 | $VERSION = sprintf "%d.%02d", q$Revision: 1.3 $ =~ /(\d+)\.(\d+)/; |
b6a880d1 |
46 | |
47 | |
9371be50 |
48 | =head1 Construction |
b6a880d1 |
49 | |
9371be50 |
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"); |
b1789409 |
86 | |
87 | # Define any global attributes here |
88 | __PACKAGE__->__attributes([qw/extra/]); |
9371be50 |
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 | |
b1789409 |
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 | } |
9371be50 |
140 | |
141 | #============================================================================= |
142 | |
143 | 1; |
b6a880d1 |
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 |