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