[dbsrgits/SQL-Translator.git] / lib / SQL / Translator / Schema / Trigger.pm

package SQL::Translator::Schema::Trigger;

# ----------------------------------------------------------------------
# $Id: Trigger.pm 1444 2009-02-07 15:53:56Z ashberlin $
# ----------------------------------------------------------------------
# Copyright (C) 2002-2009 SQLFairy Authors
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License as
# published by the Free Software Foundation; version 2.
#
# This program is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
# General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
# 02111-1307  USA
# -------------------------------------------------------------------

=pod

=head1 NAME

SQL::Translator::Schema::Trigger - SQL::Translator trigger object

=head1 SYNOPSIS

  use SQL::Translator::Schema::Trigger;
  my $trigger = SQL::Translator::Schema::Trigger->new(
      name                => 'foo',
      perform_action_when => 'before', # or after
      database_event      => 'insert', # Obsolete please use database_events!
	  database_events     => [qw/update instert/], # or update, update_on, delete
      fields              => [],       # fields if event is "update"
      on_table            => 'foo',    # table name
      action              => '...',    # text of trigger
      schema              => $schema,  # Schema object
  );

=head1 DESCRIPTION

C<SQL::Translator::Schema::Trigger> is the trigger object.

=head1 METHODS

=cut

use strict;
use SQL::Translator::Utils 'parse_list_arg';

use base 'SQL::Translator::Schema::Object';

use Carp;

use vars qw($TABLE_COUNT $VIEW_COUNT);

# ----------------------------------------------------------------------

__PACKAGE__->_attributes( qw/
    name schema perform_action_when database_event database_events fields table on_table action
    order
/);

=pod

=head2 new

Object constructor.

  my $schema = SQL::Translator::Schema::Trigger->new;

=cut

# ----------------------------------------------------------------------
sub perform_action_when {

=pod

=head2 perform_action_when

Gets or sets whether the event happens "before" or "after" the 
C<database_event>.

  $trigger->perform_action_when('after');

=cut

    my $self = shift;
    
    if ( my $arg = shift ) {
        $arg =  lc $arg;
        $arg =~ s/\s+/ /g;
        if ( $arg =~ m/^(before|after)$/i ) {
            $self->{'perform_action_when'} = $arg;
        }
        else {
            return 
                $self->error("Invalid argument '$arg' to perform_action_when");
        }
    }

    return $self->{'perform_action_when'};
}

# ----------------------------------------------------------------------
sub database_event {

=pod

=head2 database_event

Obosolete please use database_events!

=cut
    
	my $self = shift;
	
	
	if ( my $arg = shift ) {
		$self->database_events( [$arg] );
	}

	return $self->error("Please use database_events the trigger has more then one events!") 
    if (scalar @{$self->{'database_events'}} > 1);

  carp 'database_event is obsolete please use database_events';
	return (@{ $self->{'database_events'} })[0];
}
# ----------------------------------------------------------------------
sub database_events {

=pod

=head2 database_events

Gets or sets the events that triggers the trigger.

  my $ok = $trigger->database_events('insert');

=cut

	my $self = shift;
	
	if ( my $arg = shift ) {
		if (ref $arg eq "ARRAY"){
			map  {
				$_ = lc; 
				$_ =~ s/\s+/ /g;  
				return $self->error("Invalid event '$_' in database_events") unless ( $_ =~ /^(insert|update|update_on|delete)$/ );
			} @$arg ;
			@{ $self->{'database_events'} } = @$arg;
			
		}else{
			return $self->error("Invalid argument to database_events");
		};
		
	}

	return $self->{'database_events'};
}

# ----------------------------------------------------------------------
sub fields {

=pod

=head2 fields

Gets and set which fields to monitor for C<database_event>.

  $view->fields('id');
  $view->fields('id', 'name');
  $view->fields( 'id, name' );
  $view->fields( [ 'id', 'name' ] );
  $view->fields( qw[ id name ] );

  my @fields = $view->fields;

=cut

    my $self = shift;
    my $fields = parse_list_arg( @_ );

    if ( @$fields ) {
        my ( %unique, @unique );
        for my $f ( @$fields ) {
            next if $unique{ $f };
            $unique{ $f } = 1;
            push @unique, $f;
        }

        $self->{'fields'} = \@unique;
    }

    return wantarray ? @{ $self->{'fields'} || [] } : $self->{'fields'};
}

# ----------------------------------------------------------------------
sub table {

=pod

=head2 table

Gets or set the table on which the trigger works, as a L<SQL::Translator::Schema::Table> object.
  $trigger->table($triggered_table);

=cut

    my ($self, $arg) = @_;
    if ( @_ == 2 ) {
        $self->error("Table attribute of a ".__PACKAGE__.
                     " must be a SQL::Translator::Schema::Table") 
            unless ref $arg and $arg->isa('SQL::Translator::Schema::Table');
        $self->{table} = $arg;
    }
    return $self->{table};
}

# ----------------------------------------------------------------------
sub on_table {

=pod

=head2 on_table

Gets or set the table name on which the trigger works, as a string.
  $trigger->on_table('foo');

=cut

    my ($self, $arg) = @_;
    if ( @_ == 2 ) {
        my $table = $self->schema->get_table($arg);
        die "Table named $arg doesn't exist"
            if !$table;
        $self->table($table);
    }
    return $self->table->name;
}

# ----------------------------------------------------------------------
sub action {

=pod

=head2 action

Gets or set the actions of the trigger.

  $trigger->actions(
      q[
        BEGIN
          select ...;
          update ...;
        END
      ]
  );

=cut

    my $self = shift;
    my $arg  = shift || '';
    $self->{'action'} = $arg if $arg;
    return $self->{'action'};
}

# ----------------------------------------------------------------------
sub is_valid {

=pod

=head2 is_valid

Determine whether the trigger is valid or not.

  my $ok = $trigger->is_valid;

=cut

    my $self = shift;

    for my $attr ( 
        qw[ name perform_action_when database_event on_table action ] 
    ) {
        return $self->error("No $attr") unless $self->$attr();
    }
    
    return $self->error("Missing fields for UPDATE ON") if 
        $self->database_event eq 'update_on' && !$self->fields;

    return 1;
}

# ----------------------------------------------------------------------
sub name {

=pod

=head2 name

Get or set the trigger's name.

  my $name = $trigger->name('foo');

=cut

    my $self        = shift;
    $self->{'name'} = shift if @_;
    return $self->{'name'} || '';
}

# ----------------------------------------------------------------------
sub order {

=pod

=head2 order

Get or set the trigger's order.

  my $order = $trigger->order(3);

=cut

    my ( $self, $arg ) = @_;

    if ( defined $arg && $arg =~ /^\d+$/ ) {
        $self->{'order'} = $arg;
    }

    return $self->{'order'} || 0;
}

# ----------------------------------------------------------------------
sub schema {

=pod

=head2 schema

Get or set the trigger's schema object.

  $trigger->schema( $schema );
  my $schema = $trigger->schema;

=cut

    my $self = shift;
    if ( my $arg = shift ) {
        return $self->error('Not a schema object') unless
            UNIVERSAL::isa( $arg, 'SQL::Translator::Schema' );
        $self->{'schema'} = $arg;
    }

    return $self->{'schema'};
}

# ----------------------------------------------------------------------
sub compare_arrays {

=pod

=head2 compare_arrays

Compare two arrays.

=cut
	
	my ($first, $second) = @_;
	no warnings;  # silence spurious -w undef complaints

	return 0 unless (ref $first eq 'ARRAY' and ref $second eq 'ARRAY' ) ;
	return 0 unless @$first == @$second;
	my @first = sort @$first;
	my @second = sort @$second;
	for (my $i = 0; $i < scalar @first; $i++) {
		return 0 if @first[$i] ne @second[$i];
		}
	return 1;
}

# ----------------------------------------------------------------------
sub equals {

=pod

=head2 equals

Determines if this trigger is the same as another

  my $isIdentical = $trigger1->equals( $trigger2 );

=cut

    my $self = shift;
    my $other = shift;
    my $case_insensitive = shift;
    
    return 0 unless $self->SUPER::equals($other);
    return 0 unless $case_insensitive ? uc($self->name) eq uc($other->name) : $self->name eq $other->name;
    #return 0 unless $self->is_valid eq $other->is_valid;
    return 0 unless $self->perform_action_when eq $other->perform_action_when;
    return 0 unless compare_arrays($self->database_events,$other->database_events) ;
    return 0 unless $self->on_table eq $other->on_table;
    return 0 unless $self->action eq $other->action;
    return 0 unless $self->_compare_objects(scalar $self->extra, scalar $other->extra);
    return 1;
}

# ----------------------------------------------------------------------
sub DESTROY {
    my $self = shift;
    undef $self->{'schema'}; # destroy cyclical reference
}

1;

# ----------------------------------------------------------------------

=pod

=head1 AUTHOR

Ken Y. Clark E<lt>kclark@cpan.orgE<gt>.

=cut
Commit	Line	Data
e2cf647c	1	package SQL::Translator::Schema::Trigger;
	2
	3	# ----------------------------------------------------------------------
d4f84dd1	4	# $Id: Trigger.pm 1444 2009-02-07 15:53:56Z ashberlin $
e2cf647c	5	# ----------------------------------------------------------------------
478f608d	6	# Copyright (C) 2002-2009 SQLFairy Authors
e2cf647c	7	#
	8	# This program is free software; you can redistribute it and/or
	9	# modify it under the terms of the GNU General Public License as
	10	# published by the Free Software Foundation; version 2.
	11	#
	12	# This program is distributed in the hope that it will be useful, but
	13	# WITHOUT ANY WARRANTY; without even the implied warranty of
	14	# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
	15	# General Public License for more details.
	16	#
	17	# You should have received a copy of the GNU General Public License
	18	# along with this program; if not, write to the Free Software
	19	# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
	20	# 02111-1307 USA
	21	# -------------------------------------------------------------------
	22
	23	=pod
	24
	25	=head1 NAME
	26
	27	SQL::Translator::Schema::Trigger - SQL::Translator trigger object
	28
	29	=head1 SYNOPSIS
	30
	31	use SQL::Translator::Schema::Trigger;
	32	my $trigger = SQL::Translator::Schema::Trigger->new(
	33	name => 'foo',
	34	perform_action_when => 'before', # or after
8742e408	35	database_event => 'insert', # Obsolete please use database_events!
8742e408	36	database_events => [qw/update instert/], # or update, update_on, delete
e2cf647c	37	fields => [], # fields if event is "update"
	38	on_table => 'foo', # table name
	39	action => '...', # text of trigger
39ad1787	40	schema => $schema, # Schema object
e2cf647c	41	);
	42
	43	=head1 DESCRIPTION
	44
	45	C<SQL::Translator::Schema::Trigger> is the trigger object.
	46
	47	=head1 METHODS
	48
	49	=cut
	50
	51	use strict;
e2cf647c	52	use SQL::Translator::Utils 'parse_list_arg';
e2cf647c	53
b6a880d1	54	use base 'SQL::Translator::Schema::Object';
b6a880d1	55
d0fcb05d	56	use Carp;
d0fcb05d	57
478f608d	58	use vars qw($TABLE_COUNT $VIEW_COUNT);
e2cf647c	59
e2cf647c	60	# ----------------------------------------------------------------------
9371be50	61
9371be50	62	__PACKAGE__->_attributes( qw/
8742e408	63	name schema perform_action_when database_event database_events fields table on_table action
9371be50	64	order
9371be50	65	/);
e2cf647c	66
	67	=pod
	68
	69	=head2 new
	70
	71	Object constructor.
	72
	73	my $schema = SQL::Translator::Schema::Trigger->new;
	74
	75	=cut
	76
e2cf647c	77	# ----------------------------------------------------------------------
	78	sub perform_action_when {
	79
	80	=pod
	81
	82	=head2 perform_action_when
	83
	84	Gets or sets whether the event happens "before" or "after" the
	85	C<database_event>.
	86
	87	$trigger->perform_action_when('after');
	88
	89	=cut
	90
	91	my $self = shift;
	92
	93	if ( my $arg = shift ) {
	94	$arg = lc $arg;
	95	$arg =~ s/\s+/ /g;
	96	if ( $arg =~ m/^(before\|after)$/i ) {
	97	$self->{'perform_action_when'} = $arg;
	98	}
	99	else {
	100	return
	101	$self->error("Invalid argument '$arg' to perform_action_when");
	102	}
	103	}
	104
	105	return $self->{'perform_action_when'};
	106	}
	107
	108	# ----------------------------------------------------------------------
	109	sub database_event {
	110
	111	=pod
	112
	113	=head2 database_event
	114
8742e408	115	Obosolete please use database_events!
e2cf647c	116
e2cf647c	117	=cut
8742e408	118
	119	my $self = shift;
	120
	121
	122	if ( my $arg = shift ) {
	123	$self->database_events( [$arg] );
	124	}
	125
d0fcb05d	126	return $self->error("Please use database_events the trigger has more then one events!")
	127	if (scalar @{$self->{'database_events'}} > 1);
	128
	129	carp 'database_event is obsolete please use database_events';
8742e408	130	return (@{ $self->{'database_events'} })[0];
	131	}
	132	# ----------------------------------------------------------------------
	133	sub database_events {
e2cf647c	134
8742e408	135	=pod
e2cf647c	136
8742e408	137	=head2 database_events
e2cf647c	138
8742e408	139	Gets or sets the events that triggers the trigger.
8742e408	140
d0fcb05d	141	my $ok = $trigger->database_events('insert');
8742e408	142
	143	=cut
	144
	145	my $self = shift;
	146
	147	if ( my $arg = shift ) {
	148	if (ref $arg eq "ARRAY"){
	149	map {
	150	$_ = lc;
	151	$_ =~ s/\s+/ /g;
	152	return $self->error("Invalid event '$_' in database_events") unless ( $_ =~ /^(insert\|update\|update_on\|delete)$/ );
	153	} @$arg ;
	154	@{ $self->{'database_events'} } = @$arg;
	155
	156	}else{
	157	return $self->error("Invalid argument to database_events");
	158	};
	159
	160	}
	161
	162	return $self->{'database_events'};
e2cf647c	163	}
	164
	165	# ----------------------------------------------------------------------
	166	sub fields {
	167
	168	=pod
	169
	170	=head2 fields
	171
	172	Gets and set which fields to monitor for C<database_event>.
	173
	174	$view->fields('id');
	175	$view->fields('id', 'name');
	176	$view->fields( 'id, name' );
	177	$view->fields( [ 'id', 'name' ] );
	178	$view->fields( qw[ id name ] );
	179
	180	my @fields = $view->fields;
	181
	182	=cut
	183
	184	my $self = shift;
	185	my $fields = parse_list_arg( @_ );
	186
	187	if ( @$fields ) {
	188	my ( %unique, @unique );
	189	for my $f ( @$fields ) {
	190	next if $unique{ $f };
	191	$unique{ $f } = 1;
	192	push @unique, $f;
	193	}
	194
	195	$self->{'fields'} = \@unique;
	196	}
	197
	198	return wantarray ? @{ $self->{'fields'} \|\| [] } : $self->{'fields'};
	199	}
	200
	201	# ----------------------------------------------------------------------
8ce5d615	202	sub table {
	203
	204	=pod
	205
	206	=head2 table
	207
	208	Gets or set the table on which the trigger works, as a L<SQL::Translator::Schema::Table> object.
	209	$trigger->table($triggered_table);
	210
	211	=cut
	212
	213	my ($self, $arg) = @_;
	214	if ( @_ == 2 ) {
	215	$self->error("Table attribute of a ".__PACKAGE__.
	216	" must be a SQL::Translator::Schema::Table")
	217	unless ref $arg and $arg->isa('SQL::Translator::Schema::Table');
	218	$self->{table} = $arg;
	219	}
	220	return $self->{table};
	221	}
	222
	223	# ----------------------------------------------------------------------
e2cf647c	224	sub on_table {
	225
	226	=pod
	227
	228	=head2 on_table
	229
8ce5d615	230	Gets or set the table name on which the trigger works, as a string.
8ce5d615	231	$trigger->on_table('foo');
e2cf647c	232
	233	=cut
	234
8ce5d615	235	my ($self, $arg) = @_;
	236	if ( @_ == 2 ) {
	237	my $table = $self->schema->get_table($arg);
	238	die "Table named $arg doesn't exist"
	239	if !$table;
	240	$self->table($table);
	241	}
	242	return $self->table->name;
e2cf647c	243	}
	244
	245	# ----------------------------------------------------------------------
	246	sub action {
	247
	248	=pod
	249
	250	=head2 action
	251
	252	Gets or set the actions of the trigger.
	253
	254	$trigger->actions(
	255	q[
	256	BEGIN
	257	select ...;
	258	update ...;
	259	END
	260	]
	261	);
	262
	263	=cut
	264
	265	my $self = shift;
	266	my $arg = shift \|\| '';
	267	$self->{'action'} = $arg if $arg;
	268	return $self->{'action'};
	269	}
	270
	271	# ----------------------------------------------------------------------
	272	sub is_valid {
	273
	274	=pod
	275
	276	=head2 is_valid
	277
	278	Determine whether the trigger is valid or not.
	279
	280	my $ok = $trigger->is_valid;
	281
	282	=cut
	283
	284	my $self = shift;
	285
	286	for my $attr (
	287	qw[ name perform_action_when database_event on_table action ]
	288	) {
	289	return $self->error("No $attr") unless $self->$attr();
	290	}
	291
	292	return $self->error("Missing fields for UPDATE ON") if
	293	$self->database_event eq 'update_on' && !$self->fields;
	294
	295	return 1;
	296	}
	297
	298	# ----------------------------------------------------------------------
	299	sub name {
	300
	301	=pod
	302
	303	=head2 name
	304
	305	Get or set the trigger's name.
	306
307	my $name = $trigger->name('foo');
308
309	=cut
310
311	my $self = shift;
312	$self->{'name'} = shift if @_;
313	return $self->{'name'} \|\| '';
314	}
315
316	# ----------------------------------------------------------------------
317	sub order {
318
319	=pod
320
321	=head2 order
322
323	Get or set the trigger's order.
324
325	my $order = $trigger->order(3);
326
327	=cut
328
329	my ( $self, $arg ) = @_;
330
331	if ( defined $arg && $arg =~ /^\d+$/ ) {
332	$self->{'order'} = $arg;
333	}
334
335	return $self->{'order'} \|\| 0;
336	}
337
39ad1787	338	# ----------------------------------------------------------------------
	339	sub schema {
	340
	341	=pod
	342
	343	=head2 schema
	344
	345	Get or set the trigger's schema object.
	346
	347	$trigger->schema( $schema );
	348	my $schema = $trigger->schema;
	349
	350	=cut
	351
	352	my $self = shift;
	353	if ( my $arg = shift ) {
	354	return $self->error('Not a schema object') unless
	355	UNIVERSAL::isa( $arg, 'SQL::Translator::Schema' );
	356	$self->{'schema'} = $arg;
	357	}
	358
	359	return $self->{'schema'};
	360	}
	361
	362	# ----------------------------------------------------------------------
8742e408	363	sub compare_arrays {
	364
	365	=pod
	366
	367	=head2 compare_arrays
	368
	369	Compare two arrays.
	370
	371	=cut
	372
	373	my ($first, $second) = @_;
	374	no warnings; # silence spurious -w undef complaints
	375
	376	return 0 unless (ref $first eq 'ARRAY' and ref $second eq 'ARRAY' ) ;
	377	return 0 unless @$first == @$second;
	378	my @first = sort @$first;
	379	my @second = sort @$second;
	380	for (my $i = 0; $i < scalar @first; $i++) {
	381	return 0 if @first[$i] ne @second[$i];
	382	}
	383	return 1;
	384	}
	385
	386	# ----------------------------------------------------------------------
abf315bb	387	sub equals {
	388
	389	=pod
	390
	391	=head2 equals
	392
	393	Determines if this trigger is the same as another
	394
	395	my $isIdentical = $trigger1->equals( $trigger2 );
	396
	397	=cut
	398
	399	my $self = shift;
	400	my $other = shift;
6be9534b	401	my $case_insensitive = shift;
abf315bb	402
abf315bb	403	return 0 unless $self->SUPER::equals($other);
6be9534b	404	return 0 unless $case_insensitive ? uc($self->name) eq uc($other->name) : $self->name eq $other->name;
4598b71c	405	#return 0 unless $self->is_valid eq $other->is_valid;
abf315bb	406	return 0 unless $self->perform_action_when eq $other->perform_action_when;
8742e408	407	return 0 unless compare_arrays($self->database_events,$other->database_events) ;
abf315bb	408	return 0 unless $self->on_table eq $other->on_table;
abf315bb	409	return 0 unless $self->action eq $other->action;
4598b71c	410	return 0 unless $self->_compare_objects(scalar $self->extra, scalar $other->extra);
abf315bb	411	return 1;
	412	}
	413
	414	# ----------------------------------------------------------------------
39ad1787	415	sub DESTROY {
	416	my $self = shift;
	417	undef $self->{'schema'}; # destroy cyclical reference
	418	}
	419
e2cf647c	420	1;
	421
	422	# ----------------------------------------------------------------------
	423
	424	=pod
	425
	426	=head1 AUTHOR
	427
	428	Ken Y. Clark E<lt>kclark@cpan.orgE<gt>.
	429
	430	=cut