lib/SQL/Translator/Schema/Trigger.pm

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