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