Use 'isa' checks for attribute validation

To maintain compatibility with the existing set-error-and-return-undef
API, we must jump through some hoops:

  1) Throw an object that won't be mangled by Moo's isa error prefixing
  2) Wrap things that might throw that to set ->error and return undef
  3) Store errors in the class when there is no object (i.e. ->new)

diff --git a/Makefile.PL b/Makefile.PL
index 05c765a..6378634 100644 (file)
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -20,6 +20,7 @@ my $deps = {
     'File::Spec'               => '0',
     'XML::Writer'              => '0.500',
     'Moo'                      => '0.009007',
+    'Try::Tiny'                => '0.04',
   },
   recommends => {
     'Template'                 => '2.20',

diff --git a/lib/SQL/Translator/Schema/Index.pm b/lib/SQL/Translator/Schema/Index.pm
index 7834350..3084ca3 100644 (file)
--- a/lib/SQL/Translator/Schema/Index.pm
+++ b/lib/SQL/Translator/Schema/Index.pm
@@ -27,7 +27,8 @@ Primary and unique keys are table constraints, not indices.
 
 use Moo;
 use SQL::Translator::Schema::Constants;
-use SQL::Translator::Utils 'parse_list_arg';
+use SQL::Translator::Utils qw(parse_list_arg ex2err throw);
+use SQL::Translator::Types qw(schema_obj);
 use List::MoreUtils qw(uniq);
 
 with qw(
@@ -54,14 +55,6 @@ Object constructor.
 
   my $schema = SQL::Translator::Schema::Index->new;
 
-=cut
-
-sub BUILD {
-    my ($self) = @_;
-    $self->$_(scalar $self->$_)
-        foreach qw(fields options);
-}
-
 =head2 fields
 
 Gets and set the fields the index is on.  Accepts a string, list or
@@ -140,7 +133,7 @@ an array or array reference.
 has options => (
     is => 'rw',
     default => sub { [] },
-    coerce => sub { parse_list_arg($_[0]) },
+    coerce => \&parse_list_arg,
 );
 
 around options => sub {
@@ -161,18 +154,9 @@ Get or set the index's table object.
 
 =cut
 
-has table => ( is => 'rw' );
-
-around table => sub {
-    my $orig = shift;
-    my $self = shift;
-    if ( my $arg = $_[0] ) {
-        return $self->error('Not a table object') unless
-            UNIVERSAL::isa( $arg, 'SQL::Translator::Schema::Table' );
-    }
+has table => ( is => 'rw', isa => schema_obj('Table') );
 
-    return $self->$orig(@_);
-};
+around table => \&ex2err;
 
 =head2 type
 
@@ -189,19 +173,17 @@ uppercase.
 
 =cut
 
-has type => ( is => 'rw', default => sub { 'NORMAL' } );
-
-around type => sub {
-    my ( $orig, $self) = (shift, shift);
-
-    if ( my $type = $_[0] ) {
-        my $type = uc $type;
-        return $self->error("Invalid index type: $type")
-            unless $VALID_INDEX_TYPE{ $type };
-    }
+has type => (
+    is => 'rw',
+    isa => sub {
+        my $type = uc $_[0] or return;
+        throw("Invalid index type: $type") unless $VALID_INDEX_TYPE{$type};
+    },
+    coerce => sub { uc $_[0] },
+    default => sub { 'NORMAL' },
+);
 
-    return $self->$orig(@_);
-};
+around type => \&ex2err;
 
 =head2 equals
 
@@ -253,6 +235,9 @@ sub DESTROY {
     undef $self->{'table'}; # destroy cyclical reference
 }
 
+# Must come after all 'has' declarations
+around new => \&ex2err;
+
 1;
 
 =pod

diff --git a/lib/SQL/Translator/Schema/Role/Error.pm b/lib/SQL/Translator/Schema/Role/Error.pm
index 4478376..5be21cd 100644 (file)
--- a/lib/SQL/Translator/Schema/Role/Error.pm
+++ b/lib/SQL/Translator/Schema/Role/Error.pm
@@ -6,8 +6,16 @@ has error => (is => 'rw', default => sub { '' });
 around error => sub {
     my ($orig, $self) = (shift, shift);
 
+    # Emulate horrible Class::Base API
+    unless (ref ($self)) {
+        my $errref = do { no strict 'refs'; \${"${self}::_ERROR"} };
+        return $$errref unless @_;
+        $$errref = $_[0];
+        return undef;
+    }
+
     return $self->$orig unless @_;
-    $self->$orig(ref($_[0]) ? $_[0] : join('', @_));
+    $self->$orig(@_);
     return undef;
 };
 

diff --git a/lib/SQL/Translator/Types.pm b/lib/SQL/Translator/Types.pm
new file mode 100644 (file)
index 0000000..02a5b8a
--- /dev/null
+++ b/lib/SQL/Translator/Types.pm
@@ -0,0 +1,20 @@
+package SQL::Translator::Types;
+use strictures 1;
+
+use SQL::Translator::Utils qw(throw);
+use Scalar::Util qw(blessed);
+
+use Exporter qw(import);
+our @EXPORT_OK = qw(schema_obj);
+
+sub schema_obj {
+    my ($class) = @_;
+    my $name = lc $class;
+    $class = 'SQL::Translator::Schema' . ($class eq 'Schema' ? '' : "::$class");
+    return sub {
+        throw("Not a $name object")
+            unless blessed($_[0]) and $_[0]->isa($class);
+    };
+}
+
+1;

diff --git a/lib/SQL/Translator/Utils.pm b/lib/SQL/Translator/Utils.pm
index 3f314db..a258bb3 100644 (file)
--- a/lib/SQL/Translator/Utils.pm
+++ b/lib/SQL/Translator/Utils.pm
@@ -4,6 +4,8 @@ use strict;
 use warnings;
 use Digest::SHA qw( sha1_hex );
 use File::Spec;
+use Scalar::Util qw(blessed);
+use Try::Tiny;
 
 our $VERSION = '1.59';
 our $DEFAULT_COMMENT = '-- ';
@@ -13,6 +15,7 @@ our @EXPORT_OK = qw(
     debug normalize_name header_comment parse_list_arg truncate_id_uniquely
     $DEFAULT_COMMENT parse_mysql_version parse_dbms_version
     ddl_parser_instance
+    throw ex2err
 );
 use constant COLLISION_TAG_LENGTH => 8;
 
@@ -304,6 +307,33 @@ sub _find_co_root {
     ;
 }
 
+{
+    package SQL::Translator::Utils::Error;
+
+    use overload
+        '""' => sub { ${$_[0]} },
+        fallback => 1;
+
+    sub new {
+        my ($class, $msg) = @_;
+        bless \$msg, $class;
+    }
+}
+
+sub throw {
+    die SQL::Translator::Utils::Error->new($_[0]);
+}
+
+sub ex2err {
+    my ($orig, $self, @args) = @_;
+    return try {
+        $self->$orig(@args);
+    } catch {
+        die $_ unless blessed($_) && $_->isa("SQL::Translator::Utils::Error");
+        $self->error("$_");
+    };
+}
+
 1;
 
 =pod