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