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 Moo;
  31 use SQL::Translator::Utils qw(ex2err);
  32 use SQL::Translator::Role::ListAttr;
  33 use SQL::Translator::Types qw(schema_obj);
  34 use Sub::Quote qw(quote_sub);
  35
  36 extends 'SQL::Translator::Schema::Object';
  37
  38 our $VERSION = '1.59';
  39
  40 =head2 new
  41
  42 Object constructor.
  43
  44   my $schema = SQL::Translator::Schema::Procedure->new;
  45
  46 =cut
  47
  48 =head2 parameters
  49
  50 Gets and set the parameters of the stored procedure.
  51
  52   $procedure->parameters('id');
  53   $procedure->parameters('id', 'name');
  54   $procedure->parameters( 'id, name' );
  55   $procedure->parameters( [ 'id', 'name' ] );
  56   $procedure->parameters( qw[ id name ] );
  57
  58   my @parameters = $procedure->parameters;
  59
  60 =cut
  61
  62 with ListAttr parameters => ( uniq => 1 );
  63
  64 =head2 name
  65
  66 Get or set the procedure's name.
  67
  68   $procedure->name('foo');
  69   my $name = $procedure->name;
  70
  71 =cut
  72
  73 has name => ( is => 'rw', default => quote_sub(q{ '' }) );
  74
  75 =head2 sql
  76
  77 Get or set the procedure's SQL.
  78
  79   $procedure->sql('select * from foo');
  80   my $sql = $procedure->sql;
  81
  82 =cut
  83
  84 has sql => ( is => 'rw', default => quote_sub(q{ '' }) );
  85
  86 =head2 order
  87
  88 Get or set the order of the procedure.
  89
  90   $procedure->order( 3 );
  91   my $order = $procedure->order;
  92
  93 =cut
  94
  95 has order => ( is => 'rw' );
  96
  97
  98 =head2 owner
  99
 100 Get or set the owner of the procedure.
 101
 102   $procedure->owner('nomar');
 103   my $sql = $procedure->owner;
 104
 105 =cut
 106
 107 has owner => ( is => 'rw', default => quote_sub(q{ '' }) );
 108
 109 =head2 comments
 110
 111 Get or set the comments on a procedure.
 112
 113   $procedure->comments('foo');
 114   $procedure->comments('bar');
 115   print join( ', ', $procedure->comments ); # prints "foo, bar"
 116
 117 =cut
 118
 119 has comments => (
 120     is => 'rw',
 121     coerce => quote_sub(q{ ref($_[0]) eq 'ARRAY' ? $_[0] : [$_[0]] }),
 122     default => quote_sub(q{ [] }),
 123 );
 124
 125 around comments => sub {
 126     my $orig     = shift;
 127     my $self     = shift;
 128     my @comments = ref $_[0] ? @{ $_[0] } : @_;
 129
 130     for my $arg ( @comments ) {
 131         $arg = $arg->[0] if ref $arg;
 132         push @{ $self->$orig }, $arg if defined $arg && $arg;
 133     }
 134
 135     return wantarray ? @{ $self->$orig } : join( "\n", @{ $self->$orig } );
 136 };
 137
 138 =head2 schema
 139
 140 Get or set the procedures's schema object.
 141
 142   $procedure->schema( $schema );
 143   my $schema = $procedure->schema;
 144
 145 =cut
 146
 147 has schema => ( is => 'rw', isa => schema_obj('Schema'), weak_ref => 1 );
 148
 149 around schema => \&ex2err;
 150
 151 =head2 equals
 152
 153 Determines if this procedure is the same as another
 154
 155   my $isIdentical = $procedure1->equals( $procedure2 );
 156
 157 =cut
 158
 159 around equals => sub {
 160     my $orig = shift;
 161     my $self = shift;
 162     my $other = shift;
 163     my $case_insensitive = shift;
 164     my $ignore_sql = shift;
 165
 166     return 0 unless $self->$orig($other);
 167     return 0 unless $case_insensitive ? uc($self->name) eq uc($other->name) : $self->name eq $other->name;
 168
 169     unless ($ignore_sql) {
 170         my $selfSql = $self->sql;
 171         my $otherSql = $other->sql;
 172         # Remove comments
 173         $selfSql =~ s/--.*$//mg;
 174         $otherSql =~ s/--.*$//mg;
 175         # Collapse whitespace to space to avoid whitespace comparison issues
 176         $selfSql =~ s/\s+/ /sg;
 177         $otherSql =~ s/\s+/ /sg;
 178         return 0 unless $selfSql eq $otherSql;
 179     }
 180
 181     return 0 unless $self->_compare_objects(scalar $self->parameters, scalar $other->parameters);
 182 #    return 0 unless $self->comments eq $other->comments;
 183 #    return 0 unless $case_insensitive ? uc($self->owner) eq uc($other->owner) : $self->owner eq $other->owner;
 184     return 0 unless $self->_compare_objects(scalar $self->extra, scalar $other->extra);
 185     return 1;
 186 };
 187
 188 # Must come after all 'has' declarations
 189 around new => \&ex2err;
 190
 191 1;
 192
 193 =pod
 194
 195 =head1 AUTHORS
 196
 197 Ken Youens-Clark E<lt>kclark@cshl.orgE<gt>,
 198 Paul Harrington E<lt>Paul-Harrington@deshaw.comE<gt>.
 199
 200 =cut