Clean up option parsing and identifier quoting in Producer::PostgreSQL
[dbsrgits/SQL-Translator.git] / lib / SQL / Translator / Schema / Trigger.pm
1 package SQL::Translator::Schema::Trigger;
2
3 =pod
4
5 =head1 NAME
6
7 SQL::Translator::Schema::Trigger - SQL::Translator trigger object
8
9 =head1 SYNOPSIS
10
11   use SQL::Translator::Schema::Trigger;
12   my $trigger = SQL::Translator::Schema::Trigger->new(
13     name                => 'foo',
14     perform_action_when => 'before', # or after
15     database_events     => [qw/update insert/], # also update, update_on, delete
16     fields              => [],       # if event is "update"
17     on_table            => 'foo',    # table name
18     action              => '...',    # text of trigger
19     schema              => $schema,  # Schema object
20     scope               => 'row',    # or statement
21   );
22
23 =head1 DESCRIPTION
24
25 C<SQL::Translator::Schema::Trigger> is the trigger object.
26
27 =head1 METHODS
28
29 =cut
30
31 use Moo;
32 use SQL::Translator::Utils qw(parse_list_arg ex2err throw);
33 use SQL::Translator::Types qw(schema_obj enum);
34 use List::MoreUtils qw(uniq);
35 use Sub::Quote qw(quote_sub);
36
37 extends 'SQL::Translator::Schema::Object';
38
39 our $VERSION = '1.59';
40
41 =head2 new
42
43 Object constructor.
44
45   my $schema = SQL::Translator::Schema::Trigger->new;
46
47 =cut
48
49 around BUILDARGS => sub {
50     my ($orig, $self, @args) = @_;
51     my $args = $self->$orig(@args);
52     if (exists $args->{on_table}) {
53         my $arg = delete $args->{on_table};
54         my $table = $args->{schema}->get_table($arg)
55             or die "Table named $arg doesn't exist";
56         $args->{table} = $table;
57     }
58     if (exists $args->{database_event}) {
59         $args->{database_events} = delete $args->{database_event};
60     }
61     return $args;
62 };
63
64 =head2 perform_action_when
65
66 Gets or sets whether the event happens "before" or "after" the
67 C<database_event>.
68
69   $trigger->perform_action_when('after');
70
71 =cut
72
73 has perform_action_when => (
74     is => 'rw',
75     coerce => quote_sub(q{ defined $_[0] ? lc $_[0] : $_[0] }),
76     isa => enum([qw(before after)], {
77         msg => "Invalid argument '%s' to perform_action_when",
78         allow_undef => 1,
79     }),
80 );
81
82 around perform_action_when => \&ex2err;
83
84 sub database_event {
85
86 =pod
87
88 =head2 database_event
89
90 Obsolete please use database_events!
91
92 =cut
93
94     my $self = shift;
95
96     return $self->database_events( @_ );
97 }
98
99 =head2 database_events
100
101 Gets or sets the events that triggers the trigger.
102
103   my $ok = $trigger->database_events('insert');
104
105 =cut
106
107 has database_events => (
108     is => 'rw',
109     coerce => quote_sub(q{ [ map { lc } ref $_[0] eq 'ARRAY' ? @{$_[0]} : ($_[0]) ] }),
110     isa => sub {
111         my @args    = @{$_[0]};
112         my %valid   = map { $_, 1 } qw[ insert update update_on delete ];
113         my @invalid = grep { !defined $valid{ $_ } } @args;
114
115         if ( @invalid ) {
116             throw(
117                 sprintf("Invalid events '%s' in database_events",
118                     join(', ', @invalid)
119                 )
120             );
121         }
122     },
123 );
124
125 around database_events => sub {
126     my ($orig,$self) = (shift, shift);
127
128     if (@_) {
129         ex2err($orig, $self, ref $_[0] eq 'ARRAY' ? $_[0] : \@_)
130             or return;
131     }
132
133     return wantarray
134         ? @{ $self->$orig || [] }
135         : $self->$orig;
136 };
137
138 =head2 fields
139
140 Gets and set which fields to monitor for C<database_event>.
141
142   $view->fields('id');
143   $view->fields('id', 'name');
144   $view->fields( 'id, name' );
145   $view->fields( [ 'id', 'name' ] );
146   $view->fields( qw[ id name ] );
147
148   my @fields = $view->fields;
149
150 =cut
151
152 has fields => (
153     is => 'rw',
154     coerce => sub {
155         my @fields = uniq @{parse_list_arg($_[0])};
156         @fields ? \@fields : undef;
157     },
158 );
159
160 around fields => sub {
161     my $orig   = shift;
162     my $self   = shift;
163     my $fields = parse_list_arg( @_ );
164     $self->$orig($fields) if @$fields;
165
166     return wantarray ? @{ $self->$orig || [] } : $self->$orig;
167 };
168
169 =head2 table
170
171 Gets or set the table on which the trigger works, as a L<SQL::Translator::Schema::Table> object.
172   $trigger->table($triggered_table);
173
174 =cut
175
176 has table => ( is => 'rw', isa => schema_obj('Table'), weak_ref => 1 );
177
178 around table => \&ex2err;
179
180 sub on_table {
181
182 =pod
183
184 =head2 on_table
185
186 Gets or set the table name on which the trigger works, as a string.
187   $trigger->on_table('foo');
188
189 =cut
190
191     my ($self, $arg) = @_;
192     if ( @_ == 2 ) {
193         my $table = $self->schema->get_table($arg);
194         die "Table named $arg doesn't exist"
195             if !$table;
196         $self->table($table);
197     }
198     return $self->table->name;
199 }
200
201 =head2 action
202
203 Gets or set the action of the trigger.
204
205   $trigger->action(
206       q[
207         BEGIN
208           select ...;
209           update ...;
210         END
211       ]
212   );
213
214 =cut
215
216 has action => ( is => 'rw', default => quote_sub(q{ '' }) );
217
218 sub is_valid {
219
220 =pod
221
222 =head2 is_valid
223
224 Determine whether the trigger is valid or not.
225
226   my $ok = $trigger->is_valid;
227
228 =cut
229
230     my $self = shift;
231
232     for my $attr (
233         qw[ name perform_action_when database_events on_table action ]
234     ) {
235         return $self->error("Invalid: missing '$attr'") unless $self->$attr();
236     }
237
238     return $self->error("Missing fields for UPDATE ON") if
239         $self->database_event eq 'update_on' && !$self->fields;
240
241     return 1;
242 }
243
244 =head2 name
245
246 Get or set the trigger's name.
247
248   my $name = $trigger->name('foo');
249
250 =cut
251
252 has name => ( is => 'rw', default => quote_sub(q{ '' }) );
253
254 =head2 order
255
256 Get or set the trigger's order.
257
258   my $order = $trigger->order(3);
259
260 =cut
261
262 has order => ( is => 'rw', default => quote_sub(q{ 0 }) );
263
264 around order => sub {
265     my ( $orig, $self, $arg ) = @_;
266
267     if ( defined $arg && $arg =~ /^\d+$/ ) {
268         return $self->$orig($arg);
269     }
270
271     return $self->$orig;
272 };
273
274 =head2 scope
275
276 Get or set the trigger's scope (row or statement).
277
278     my $scope = $trigger->scope('statement');
279
280 =cut
281
282 has scope => (
283     is => 'rw',
284     isa => enum([qw(row statement)], {
285         msg => "Invalid scope '%s'", icase => 1, allow_undef => 1,
286     }),
287 );
288
289 around scope => \&ex2err;
290
291
292 =head2 schema
293
294 Get or set the trigger's schema object.
295
296   $trigger->schema( $schema );
297   my $schema = $trigger->schema;
298
299 =cut
300
301 has schema => (is => 'rw', isa => schema_obj('Schema'), weak_ref => 1 );
302
303 around schema => \&ex2err;
304
305 sub compare_arrays {
306
307 =pod
308
309 =head2 compare_arrays
310
311 Compare two arrays.
312
313 =cut
314
315     my ($first, $second) = @_;
316     no warnings;  # silence spurious -w undef complaints
317
318     return 0 unless (ref $first eq 'ARRAY' and ref $second eq 'ARRAY' ) ;
319
320     return 0 unless @$first == @$second;
321
322     my @first = sort @$first;
323
324     my @second = sort @$second;
325
326     for (my $i = 0; $i < scalar @first; $i++) {
327         return 0 if @first[$i] ne @second[$i];
328     }
329
330     return 1;
331 }
332
333 =head2 equals
334
335 Determines if this trigger is the same as another
336
337   my $is_identical = $trigger1->equals( $trigger2 );
338
339 =cut
340
341 around equals => sub {
342     my $orig             = shift;
343     my $self             = shift;
344     my $other            = shift;
345     my $case_insensitive = shift;
346
347     return 0 unless $self->$orig($other);
348
349     my %names;
350     for my $name ( $self->name, $other->name ) {
351         $name = lc $name if $case_insensitive;
352         $names{ $name }++;
353     }
354
355     if ( keys %names > 1 ) {
356         return $self->error('Names not equal');
357     }
358
359     if ( !$self->perform_action_when eq $other->perform_action_when ) {
360         return $self->error('perform_action_when differs');
361     }
362
363     if (
364         !compare_arrays( [$self->database_events], [$other->database_events] )
365     ) {
366         return $self->error('database_events differ');
367     }
368
369     if ( $self->on_table ne $other->on_table ) {
370         return $self->error('on_table differs');
371     }
372
373     if ( $self->action ne $other->action ) {
374         return $self->error('action differs');
375     }
376
377     if (
378         !$self->_compare_objects( scalar $self->extra, scalar $other->extra )
379     ) {
380         return $self->error('extras differ');
381     }
382
383     return 1;
384 };
385
386 # Must come after all 'has' declarations
387 around new => \&ex2err;
388
389 1;
390
391 =pod
392
393 =head1 AUTHORS
394
395 Anonymous,
396 Ken Youens-Clark E<lt>kclark@cpan.orgE<gt>.
397
398 =cut