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