lib/SQL/Translator/Schema/Trigger.pm

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