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