Commit | Line | Data |
b6a880d1 |
1 | package SQL::Translator::Schema::Object; |
2 | |
3 | # ---------------------------------------------------------------------- |
478f608d |
4 | # Copyright (C) 2002-2009 SQLFairy Authors |
b6a880d1 |
5 | # |
6 | # This program is free software; you can redistribute it and/or |
7 | # modify it under the terms of the GNU General Public License as |
8 | # published by the Free Software Foundation; version 2. |
9 | # |
10 | # This program is distributed in the hope that it will be useful, but |
11 | # WITHOUT ANY WARRANTY; without even the implied warranty of |
12 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
13 | # General Public License for more details. |
14 | # |
15 | # You should have received a copy of the GNU General Public License |
16 | # along with this program; if not, write to the Free Software |
17 | # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA |
18 | # 02111-1307 USA |
19 | # ------------------------------------------------------------------- |
20 | |
21 | =pod |
22 | |
23 | =head1 NAME |
24 | |
25 | SQL::Translator::Schema::Object - Base class SQL::Translator Schema objects. |
26 | |
27 | =head1 SYNOPSIS |
28 | |
29 | =head1 DESCSIPTION |
30 | |
9371be50 |
31 | Base class for Schema objects. Sub classes L<Class::Base> and adds the following |
32 | extra functionality. |
b6a880d1 |
33 | |
34 | =cut |
35 | |
36 | use strict; |
37 | use Class::Base; |
9371be50 |
38 | use base 'Class::Data::Inheritable'; |
b6a880d1 |
39 | use base 'Class::Base'; |
7db5f121 |
40 | use Class::MakeMethods::Utility::Ref qw( ref_compare ); |
b6a880d1 |
41 | |
da06ac74 |
42 | use vars qw[ $VERSION ]; |
43 | |
ba506e52 |
44 | $VERSION = '1.60'; |
da06ac74 |
45 | |
9371be50 |
46 | =head1 Construction |
b6a880d1 |
47 | |
4faaaac6 |
48 | Derived classes should declare their attributes using the C<_attributes> |
9371be50 |
49 | method. They can then inherit the C<init> method from here which will call |
50 | accessors of the same name for any values given in the hash passed to C<new>. |
51 | Note that you will have to impliment the accessors your self and we expect perl |
52 | style methods; call with no args to get and with arg to set. |
53 | |
54 | e.g. If we setup our class as follows; |
55 | |
56 | package SQL::Translator::Schema::Table; |
57 | use base qw/SQL::Translator::Schema::Object/; |
58 | |
59 | __PACKAGE__->_attributes( qw/schema name/ ); |
60 | |
61 | sub name { ... } |
62 | sub schema { ... } |
63 | |
64 | Then we can construct it with |
65 | |
66 | my $table = SQL::Translator::Schema::Table->new( |
67 | schema => $schema, |
68 | name => 'foo', |
69 | ); |
70 | |
71 | and init will call C<< $table->name("foo") >> and C<< $table->schema($schema) >> |
72 | to set it up. Any undefined args will be ignored. |
73 | |
74 | Multiple calls to C<_attributes> are cumulative and sub classes will inherit |
75 | their parents attribute names. |
76 | |
77 | This is currently experimental, but will hopefull go on to form an introspection |
78 | API for the Schema objects. |
79 | |
80 | =cut |
81 | |
82 | |
83 | __PACKAGE__->mk_classdata("__attributes"); |
b1789409 |
84 | |
85 | # Define any global attributes here |
86 | __PACKAGE__->__attributes([qw/extra/]); |
9371be50 |
87 | |
88 | # Set the classes attribute names. Multiple calls are cumulative. |
89 | # We need to be careful to create a new ref so that all classes don't end up |
90 | # with the same ref and hence the same attributes! |
91 | sub _attributes { |
92 | my $class = shift; |
93 | if (@_) { $class->__attributes( [ @{$class->__attributes}, @_ ] ); } |
94 | return @{$class->__attributes}; |
95 | } |
96 | |
97 | # Call accessors for any args in hashref passed |
98 | sub init { |
99 | my ( $self, $config ) = @_; |
100 | |
101 | for my $arg ( $self->_attributes ) { |
102 | next unless defined $config->{$arg}; |
103 | defined $self->$arg( $config->{$arg} ) or return; |
104 | } |
105 | |
106 | return $self; |
107 | } |
108 | |
b1789409 |
109 | # ---------------------------------------------------------------------- |
110 | sub extra { |
111 | |
112 | =pod |
113 | |
114 | =head1 Global Attributes |
115 | |
116 | The following attributes are defined here, therefore all schema objects will |
117 | have them. |
118 | |
119 | =head2 extra |
120 | |
121 | Get or set the objects "extra" attibutes (e.g., "ZEROFILL" for MySQL fields). |
24324d76 |
122 | Call with no args to get all the extra data. |
123 | Call with a single name arg to get the value of the named extra attribute, |
124 | returned as a scalar. Call with a hash or hashref to set extra attributes. |
125 | Returns a hash or a hashref. |
b1789409 |
126 | |
127 | $field->extra( qualifier => 'ZEROFILL' ); |
24324d76 |
128 | |
129 | $qualifier = $field->extra('qualifier'); |
130 | |
131 | %extra = $field->extra; |
132 | $extra = $field->extra; |
133 | |
b1789409 |
134 | =cut |
135 | |
136 | my $self = shift; |
24324d76 |
137 | @_ = %{$_[0]} if ref $_[0] eq "HASH"; |
138 | my $extra = $self->{'extra'} ||= {}; |
b1789409 |
139 | |
24324d76 |
140 | if (@_==1) { |
141 | return exists($extra->{$_[0]}) ? $extra->{$_[0]} : undef ; |
b1789409 |
142 | } |
24324d76 |
143 | elsif (@_) { |
144 | my %args = @_; |
145 | while ( my ( $key, $value ) = each %args ) { |
146 | $extra->{$key} = $value; |
147 | } |
148 | } |
149 | |
150 | return wantarray ? %$extra : $extra; |
b1789409 |
151 | } |
9371be50 |
152 | |
12018c09 |
153 | # ---------------------------------------------------------------------- |
154 | sub remove_extra { |
155 | |
156 | =head2 remove_extra |
157 | |
158 | L</extra> can only be used to get or set "extra" attributes but not to |
159 | remove some. Call with no args to remove all extra attributes that |
160 | have been set before. Call with a list of key names to remove |
161 | certain extra attributes only. |
162 | |
163 | # remove all extra attributes |
164 | $field->remove_extra(); |
165 | |
166 | # remove timezone and locale attributes only |
167 | $field->remove_extra(qw/timezone locale/); |
168 | |
169 | =cut |
170 | |
171 | my ( $self, @keys ) = @_; |
172 | unless (@keys) { |
173 | $self->{'extra'} = {}; |
174 | } |
175 | else { |
176 | delete $self->{'extra'}{$_} for @keys; |
177 | } |
178 | } |
a9a72385 |
179 | |
180 | # ---------------------------------------------------------------------- |
181 | sub equals { |
182 | |
183 | =pod |
184 | |
185 | =head2 equals |
186 | |
187 | Determines if this object is the same as another. |
188 | |
189 | my $isIdentical = $object1->equals( $object2 ); |
190 | |
191 | =cut |
192 | |
193 | my $self = shift; |
194 | my $other = shift; |
195 | |
196 | return 0 unless $other; |
57059659 |
197 | return 1 if overload::StrVal($self) eq overload::StrVal($other); |
a9a72385 |
198 | return 0 unless $other->isa( __PACKAGE__ ); |
199 | return 1; |
200 | } |
201 | |
202 | # ---------------------------------------------------------------------- |
7db5f121 |
203 | sub _compare_objects { |
ba506e52 |
204 | my $self = shift; |
205 | my $obj1 = shift; |
206 | my $obj2 = shift; |
7db5f121 |
207 | my $result = (ref_compare($obj1, $obj2) == 0); |
ba506e52 |
208 | |
7db5f121 |
209 | return $result; |
a9a72385 |
210 | } |
211 | |
9371be50 |
212 | #============================================================================= |
213 | |
214 | 1; |
b6a880d1 |
215 | |
216 | =pod |
217 | |
b6a880d1 |
218 | =head1 AUTHOR |
219 | |
c3b0b535 |
220 | Ken Youens-Clark E<lt>kclark@cpan.orgE<gt>, |
221 | Mark Addison E<lt>mark.addison@itn.co.ukE<gt>. |
b6a880d1 |
222 | |
223 | =cut |