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