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