Commit | Line | Data |
b6a880d1 |
1 | package SQL::Translator::Schema::Object; |
2 | |
b6a880d1 |
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 | |
9371be50 |
13 | Base class for Schema objects. Sub classes L<Class::Base> and adds the following |
ea93df61 |
14 | extra functionality. |
b6a880d1 |
15 | |
16 | =cut |
17 | |
18 | use strict; |
f27f9229 |
19 | use warnings; |
9371be50 |
20 | use base 'Class::Data::Inheritable'; |
b6a880d1 |
21 | use base 'Class::Base'; |
1abbbee1 |
22 | use Data::Dumper (); |
b6a880d1 |
23 | |
0c04c5a2 |
24 | our $VERSION = '1.59'; |
11ad2df9 |
25 | |
9371be50 |
26 | =head1 Construction |
b6a880d1 |
27 | |
4faaaac6 |
28 | Derived classes should declare their attributes using the C<_attributes> |
9371be50 |
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/; |
ea93df61 |
38 | |
9371be50 |
39 | __PACKAGE__->_attributes( qw/schema name/ ); |
40 | |
41 | sub name { ... } |
42 | sub schema { ... } |
43 | |
44 | Then we can construct it with |
45 | |
ea93df61 |
46 | my $table = SQL::Translator::Schema::Table->new( |
9371be50 |
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"); |
b1789409 |
64 | |
65 | # Define any global attributes here |
ea93df61 |
66 | __PACKAGE__->__attributes([qw/extra/]); |
9371be50 |
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 ) = @_; |
ea93df61 |
80 | |
9371be50 |
81 | for my $arg ( $self->_attributes ) { |
82 | next unless defined $config->{$arg}; |
ea93df61 |
83 | defined $self->$arg( $config->{$arg} ) or return; |
9371be50 |
84 | } |
85 | |
86 | return $self; |
87 | } |
88 | |
b1789409 |
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). |
24324d76 |
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. |
b1789409 |
105 | |
106 | $field->extra( qualifier => 'ZEROFILL' ); |
ea93df61 |
107 | |
24324d76 |
108 | $qualifier = $field->extra('qualifier'); |
ea93df61 |
109 | |
24324d76 |
110 | %extra = $field->extra; |
111 | $extra = $field->extra; |
ea93df61 |
112 | |
b1789409 |
113 | =cut |
114 | |
115 | my $self = shift; |
24324d76 |
116 | @_ = %{$_[0]} if ref $_[0] eq "HASH"; |
117 | my $extra = $self->{'extra'} ||= {}; |
b1789409 |
118 | |
ea93df61 |
119 | if (@_==1) { |
24324d76 |
120 | return exists($extra->{$_[0]}) ? $extra->{$_[0]} : undef ; |
b1789409 |
121 | } |
24324d76 |
122 | elsif (@_) { |
123 | my %args = @_; |
124 | while ( my ( $key, $value ) = each %args ) { |
125 | $extra->{$key} = $value; |
126 | } |
127 | } |
ea93df61 |
128 | |
24324d76 |
129 | return wantarray ? %$extra : $extra; |
b1789409 |
130 | } |
9371be50 |
131 | |
12018c09 |
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 |
ea93df61 |
142 | $field->remove_extra(); |
143 | |
12018c09 |
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 | } |
a9a72385 |
157 | |
a9a72385 |
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; |
ea93df61 |
172 | |
a9a72385 |
173 | return 0 unless $other; |
57059659 |
174 | return 1 if overload::StrVal($self) eq overload::StrVal($other); |
a9a72385 |
175 | return 0 unless $other->isa( __PACKAGE__ ); |
176 | return 1; |
177 | } |
178 | |
7db5f121 |
179 | sub _compare_objects { |
1abbbee1 |
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 | ); |
ea93df61 |
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; |
a9a72385 |
196 | } |
197 | |
9371be50 |
198 | 1; |
b6a880d1 |
199 | |
200 | =pod |
201 | |
11ad2df9 |
202 | =head1 SEE ALSO |
203 | |
204 | =head1 TODO |
205 | |
206 | =head1 BUGS |
207 | |
b6a880d1 |
208 | =head1 AUTHOR |
209 | |
ea93df61 |
210 | Ken Youens-Clark E<lt>kclark@cpan.orgE<gt>, |
c3b0b535 |
211 | Mark Addison E<lt>mark.addison@itn.co.ukE<gt>. |
b6a880d1 |
212 | |
213 | =cut |