lib/SQL/Translator/Schema/Trigger.pm

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