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