lib/SQL/Translator/Schema/Procedure.pm

   1 package SQL::Translator::Schema::Procedure;
   2
   3 =pod
   4
   5 =head1 NAME
   6
   7 SQL::Translator::Schema::Procedure - SQL::Translator procedure object
   8
   9 =head1 SYNOPSIS
  10
  11   use SQL::Translator::Schema::Procedure;
  12   my $procedure  = SQL::Translator::Schema::Procedure->new(
  13       name       => 'foo',
  14       sql        => 'CREATE PROC foo AS SELECT * FROM bar',
  15       parameters => 'foo,bar',
  16       owner      => 'nomar',
  17       comments   => 'blah blah blah',
  18       schema     => $schema,
  19   );
  20
  21 =head1 DESCRIPTION
  22
  23 C<SQL::Translator::Schema::Procedure> is a class for dealing with
  24 stored procedures (and possibly other pieces of nameable SQL code?).
  25
  26 =head1 METHODS
  27
  28 =cut
  29
  30 use strict;
  31 use warnings;
  32 use SQL::Translator::Utils 'parse_list_arg';
  33
  34 use base 'SQL::Translator::Schema::Object';
  35
  36 use vars qw($VERSION);
  37
  38 $VERSION = '1.59';
  39
  40 __PACKAGE__->_attributes( qw/
  41     name sql parameters comments owner sql schema order
  42 /);
  43
  44 =pod
  45
  46 =head2 new
  47
  48 Object constructor.
  49
  50   my $schema = SQL::Translator::Schema::Procedure->new;
  51
  52 =cut
  53
  54 sub parameters {
  55
  56 =pod
  57
  58 =head2 parameters
  59
  60 Gets and set the parameters of the stored procedure.
  61
  62   $procedure->parameters('id');
  63   $procedure->parameters('id', 'name');
  64   $procedure->parameters( 'id, name' );
  65   $procedure->parameters( [ 'id', 'name' ] );
  66   $procedure->parameters( qw[ id name ] );
  67
  68   my @parameters = $procedure->parameters;
  69
  70 =cut
  71
  72     my $self   = shift;
  73     my $parameters = parse_list_arg( @_ );
  74
  75     if ( @$parameters ) {
  76         my ( %unique, @unique );
  77         for my $p ( @$parameters ) {
  78             next if $unique{ $p };
  79             $unique{ $p } = 1;
  80             push @unique, $p;
  81         }
  82
  83         $self->{'parameters'} = \@unique;
  84     }
  85
  86     return wantarray ? @{ $self->{'parameters'} || [] } : ($self->{'parameters'} || '');
  87 }
  88
  89 sub name {
  90
  91 =pod
  92
  93 =head2 name
  94
  95 Get or set the procedure's name.
  96
  97   $procedure->name('foo');
  98   my $name = $procedure->name;
  99
 100 =cut
 101
 102     my $self        = shift;
 103     $self->{'name'} = shift if @_;
 104     return $self->{'name'} || '';
 105 }
 106
 107 sub sql {
 108
 109 =pod
 110
 111 =head2 sql
 112
 113 Get or set the procedure's SQL.
 114
 115   $procedure->sql('select * from foo');
 116   my $sql = $procedure->sql;
 117
 118 =cut
 119
 120     my $self       = shift;
 121     $self->{'sql'} = shift if @_;
 122     return $self->{'sql'} || '';
 123 }
 124
 125 sub order {
 126
 127 =pod
 128
 129 =head2 order
 130
 131 Get or set the order of the procedure.
 132
 133   $procedure->order( 3 );
 134   my $order = $procedure->order;
 135
 136 =cut
 137
 138     my $self         = shift;
 139     $self->{'order'} = shift if @_;
 140     return $self->{'order'};
 141 }
 142
 143 sub owner {
 144
 145 =pod
 146
 147 =head2 owner
 148
 149 Get or set the owner of the procedure.
 150
 151   $procedure->owner('nomar');
 152   my $sql = $procedure->owner;
 153
 154 =cut
 155
 156     my $self         = shift;
 157     $self->{'owner'} = shift if @_;
 158     return $self->{'owner'} || '';
 159 }
 160
 161 sub comments {
 162
 163 =pod
 164
 165 =head2 comments
 166
 167 Get or set the comments on a procedure.
 168
 169   $procedure->comments('foo');
 170   $procedure->comments('bar');
 171   print join( ', ', $procedure->comments ); # prints "foo, bar"
 172
 173 =cut
 174
 175     my $self = shift;
 176
 177     for my $arg ( @_ ) {
 178         $arg = $arg->[0] if ref $arg;
 179         push @{ $self->{'comments'} }, $arg if $arg;
 180     }
 181
 182     if ( @{ $self->{'comments'} || [] } ) {
 183         return wantarray
 184             ? @{ $self->{'comments'} || [] }
 185             : join( "\n", @{ $self->{'comments'} || [] } );
 186     }
 187     else {
 188         return wantarray ? () : '';
 189     }
 190 }
 191
 192 sub schema {
 193
 194 =pod
 195
 196 =head2 schema
 197
 198 Get or set the procedures's schema object.
 199
 200   $procedure->schema( $schema );
 201   my $schema = $procedure->schema;
 202
 203 =cut
 204
 205     my $self = shift;
 206     if ( my $arg = shift ) {
 207         return $self->error('Not a schema object') unless
 208             UNIVERSAL::isa( $arg, 'SQL::Translator::Schema' );
 209         $self->{'schema'} = $arg;
 210     }
 211
 212     return $self->{'schema'};
 213 }
 214
 215 sub equals {
 216
 217 =pod
 218
 219 =head2 equals
 220
 221 Determines if this procedure is the same as another
 222
 223   my $isIdentical = $procedure1->equals( $procedure2 );
 224
 225 =cut
 226
 227     my $self = shift;
 228     my $other = shift;
 229     my $case_insensitive = shift;
 230     my $ignore_sql = shift;
 231
 232     return 0 unless $self->SUPER::equals($other);
 233     return 0 unless $case_insensitive ? uc($self->name) eq uc($other->name) : $self->name eq $other->name;
 234
 235     unless ($ignore_sql) {
 236         my $selfSql = $self->sql;
 237         my $otherSql = $other->sql;
 238         # Remove comments
 239         $selfSql =~ s/--.*$//mg;
 240         $otherSql =~ s/--.*$//mg;
 241         # Collapse whitespace to space to avoid whitespace comparison issues
 242         $selfSql =~ s/\s+/ /sg;
 243         $otherSql =~ s/\s+/ /sg;
 244         return 0 unless $selfSql eq $otherSql;
 245     }
 246
 247     return 0 unless $self->_compare_objects(scalar $self->parameters, scalar $other->parameters);
 248 #    return 0 unless $self->comments eq $other->comments;
 249 #    return 0 unless $case_insensitive ? uc($self->owner) eq uc($other->owner) : $self->owner eq $other->owner;
 250     return 0 unless $self->_compare_objects(scalar $self->extra, scalar $other->extra);
 251     return 1;
 252 }
 253
 254 sub DESTROY {
 255     my $self = shift;
 256     undef $self->{'schema'}; # destroy cyclical reference
 257 }
 258
 259 1;
 260
 261 =pod
 262
 263 =head1 AUTHORS
 264
 265 Ken Youens-Clark E<lt>kclark@cshl.orgE<gt>,
 266 Paul Harrington E<lt>Paul-Harrington@deshaw.comE<gt>.
 267
 268 =cut