lib/SQL/Translator/Schema/Procedure.pm

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