From: Marcus Ramberg Date: Fri, 27 Jan 2006 15:40:11 +0000 (+0000) Subject: handle the throw_exception bit. Drop DBIx::Class::Exception X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=701da8c4d6f0b78ffc015085aa410a6cacfcdb40;p=dbsrgits%2FDBIx-Class-Historic.git handle the throw_exception bit. Drop DBIx::Class::Exception --- diff --git a/Build.PL b/Build.PL index 7fac43b..629829c 100644 --- a/Build.PL +++ b/Build.PL @@ -21,6 +21,7 @@ my %arguments = ( # Following for CDBICompat only 'Class::Trigger' => 0, 'DBIx::ContextualFetch' => 0, + 'Carp::Clan' => 0, }, recommends => { 'Data::UUID' => 0, diff --git a/Changes b/Changes index d0c9623..a7780a2 100644 --- a/Changes +++ b/Changes @@ -1,5 +1,8 @@ Revision history for DBIx::Class + - Removed DBIx::Class::Exception + - unified throw_exception stuff, using Carp::Clan + - report query when sth generation fails. - multi-step prefetch! - inheritance fixes - test tweaks diff --git a/MANIFEST b/MANIFEST index c26ea8a..6519ab6 100644 --- a/MANIFEST +++ b/MANIFEST @@ -30,7 +30,6 @@ lib/DBIx/Class/Componentised.pm lib/DBIx/Class/Core.pm lib/DBIx/Class/Cursor.pm lib/DBIx/Class/DB.pm -lib/DBIx/Class/Exception.pm lib/DBIx/Class/InflateColumn.pm lib/DBIx/Class/Manual.pod lib/DBIx/Class/Manual/Cookbook.pod diff --git a/lib/DBIx/Class/AccessorGroup.pm b/lib/DBIx/Class/AccessorGroup.pm index 9a2dd11..79db519 100644 --- a/lib/DBIx/Class/AccessorGroup.pm +++ b/lib/DBIx/Class/AccessorGroup.pm @@ -3,6 +3,8 @@ package DBIx::Class::AccessorGroup; use strict; use warnings; +use Carp::Clan qw/^DBIx::Class/; + =head1 NAME DBIx::Class::AccessorGroup - Lets you build groups of accessors @@ -38,8 +40,7 @@ sub mk_group_accessors { foreach my $field (@fields) { if( $field eq 'DESTROY' ) { - require Carp; - &Carp::carp("Having a data accessor named DESTROY in ". + carp("Having a data accessor named DESTROY in ". "'$class' is unwise."); } @@ -102,8 +103,7 @@ sub make_group_ro_accessor { if(@_) { my $caller = caller; - require Carp; - Carp::croak("'$caller' cannot alter the value of '$field' on ". + croak("'$caller' cannot alter the value of '$field' on ". "objects of class '$class'"); } else { @@ -123,7 +123,7 @@ sub make_group_wo_accessor { unless (@_) { my $caller = caller; require Carp; - Carp::croak("'$caller' cannot access the value of '$field' on ". + croak("'$caller' cannot access the value of '$field' on ". "objects of class '$class'"); } else { diff --git a/lib/DBIx/Class/CDBICompat/AccessorMapping.pm b/lib/DBIx/Class/CDBICompat/AccessorMapping.pm index aec1653..71ca253 100644 --- a/lib/DBIx/Class/CDBICompat/AccessorMapping.pm +++ b/lib/DBIx/Class/CDBICompat/AccessorMapping.pm @@ -27,7 +27,7 @@ sub mk_group_accessors { sub new { my ($class, $attrs, @rest) = @_; - $class->throw( "create needs a hashref" ) unless ref $attrs eq 'HASH'; + $class->throw_exception( "create needs a hashref" ) unless ref $attrs eq 'HASH'; foreach my $col ($class->columns) { if ($class->can('accessor_name')) { my $acc = $class->accessor_name($col); diff --git a/lib/DBIx/Class/CDBICompat/Constraints.pm b/lib/DBIx/Class/CDBICompat/Constraints.pm index f712627..2452400 100644 --- a/lib/DBIx/Class/CDBICompat/Constraints.pm +++ b/lib/DBIx/Class/CDBICompat/Constraints.pm @@ -6,9 +6,9 @@ use warnings; sub constrain_column { my $class = shift; my $col = $class->find_column(+shift) - or return $class->throw("constraint_column needs a valid column"); + or return $class->throw_exception("constraint_column needs a valid column"); my $how = shift - or return $class->throw("constrain_column needs a constraint"); + or return $class->throw_exception("constrain_column needs a constraint"); if (ref $how eq "ARRAY") { my %hash = map { $_ => 1 } @$how; $class->add_constraint(list => $col => sub { exists $hash{ +shift } }); @@ -20,7 +20,7 @@ sub constrain_column { if (my $dispatch = $class->can($try_method)) { $class->$dispatch($col => ($how, @_)); } else { - $class->throw("Don't know how to constrain $col with $how"); + $class->throw_exception("Don't know how to constrain $col with $how"); } } } @@ -28,12 +28,12 @@ sub constrain_column { sub add_constraint { my $class = shift; $class->_invalid_object_method('add_constraint()') if ref $class; - my $name = shift or return $class->throw("Constraint needs a name"); + my $name = shift or return $class->throw_exception("Constraint needs a name"); my $column = $class->find_column(+shift) - or return $class->throw("Constraint $name needs a valid column"); + or return $class->throw_exception("Constraint $name needs a valid column"); my $code = shift - or return $class->throw("Constraint $name needs a code reference"); - return $class->throw("Constraint $name '$code' is not a code reference") + or return $class->throw_exception("Constraint $name needs a code reference"); + return $class->throw_exception("Constraint $name '$code' is not a code reference") unless ref($code) eq "CODE"; #$column->is_constrained(1); @@ -41,7 +41,7 @@ sub add_constraint { "before_set_$column" => sub { my ($self, $value, $column_values) = @_; $code->($value, $self, $column, $column_values) - or return $self->throw( + or return $self->throw_exception( "$class $column fails '$name' constraint with '$value'"); } ); diff --git a/lib/DBIx/Class/CDBICompat/HasA.pm b/lib/DBIx/Class/CDBICompat/HasA.pm index c0d4458..e360097 100644 --- a/lib/DBIx/Class/CDBICompat/HasA.pm +++ b/lib/DBIx/Class/CDBICompat/HasA.pm @@ -5,7 +5,7 @@ use warnings; sub has_a { my ($self, $col, $f_class, %args) = @_; - $self->throw( "No such column ${col}" ) unless $self->has_column($col); + $self->throw_exception( "No such column ${col}" ) unless $self->has_column($col); eval "require $f_class"; if ($args{'inflate'} || $args{'deflate'}) { # Non-database has_a if (!ref $args{'inflate'}) { diff --git a/lib/DBIx/Class/CDBICompat/ImaDBI.pm b/lib/DBIx/Class/CDBICompat/ImaDBI.pm index 7f645d5..5c8cd42 100644 --- a/lib/DBIx/Class/CDBICompat/ImaDBI.pm +++ b/lib/DBIx/Class/CDBICompat/ImaDBI.pm @@ -41,7 +41,7 @@ __PACKAGE__->mk_classdata('_transform_sql_handlers' => map { $from_class->relationship_info($_) } $from_class->relationships; } - $self->throw( "No relationship to JOIN from ${from_class} to ${to_class}" ) + $self->throw_exception( "No relationship to JOIN from ${from_class} to ${to_class}" ) unless $rel_obj; my $join = $from_class->storage->sql_maker->_join_condition( $from_class->result_source_instance->resolve_condition( diff --git a/lib/DBIx/Class/CDBICompat/ReadOnly.pm b/lib/DBIx/Class/CDBICompat/ReadOnly.pm index fe1d902..e5949a9 100644 --- a/lib/DBIx/Class/CDBICompat/ReadOnly.pm +++ b/lib/DBIx/Class/CDBICompat/ReadOnly.pm @@ -5,7 +5,7 @@ use warnings; sub make_read_only { my $proto = shift; - $proto->add_trigger("before_$_" => sub { shift->throw("$proto is read only") }) + $proto->add_trigger("before_$_" => sub { shift->throw_exception("$proto is read only") }) foreach qw/create delete update/; return $proto; } diff --git a/lib/DBIx/Class/CDBICompat/TempColumns.pm b/lib/DBIx/Class/CDBICompat/TempColumns.pm index 1bd5c93..9a44698 100644 --- a/lib/DBIx/Class/CDBICompat/TempColumns.pm +++ b/lib/DBIx/Class/CDBICompat/TempColumns.pm @@ -41,8 +41,8 @@ sub find_column { sub get_temp { my ($self, $column) = @_; - $self->throw( "Can't fetch data as class method" ) unless ref $self; - $self->throw( "No such TEMP column '${column}'" ) unless $self->_temp_columns->{$column} ; + $self->throw_exception( "Can't fetch data as class method" ) unless ref $self; + $self->throw_exception( "No such TEMP column '${column}'" ) unless $self->_temp_columns->{$column} ; return $self->{_temp_column_data}{$column} if exists $self->{_temp_column_data}{$column}; return undef; @@ -50,9 +50,9 @@ sub get_temp { sub set_temp { my ($self, $column, $value) = @_; - $self->throw( "No such TEMP column '${column}'" ) + $self->throw_exception( "No such TEMP column '${column}'" ) unless $self->_temp_columns->{$column}; - $self->throw( "set_temp called for ${column} without value" ) + $self->throw_exception( "set_temp called for ${column} without value" ) if @_ < 3; return $self->{_temp_column_data}{$column} = $value; } diff --git a/lib/DBIx/Class/Core.pm b/lib/DBIx/Class/Core.pm index 44a5f96..303d1cc 100644 --- a/lib/DBIx/Class/Core.pm +++ b/lib/DBIx/Class/Core.pm @@ -12,7 +12,6 @@ __PACKAGE__->load_components(qw/ PK Row ResultSourceProxy::Table - Exception AccessorGroup/); 1; @@ -45,8 +44,6 @@ The core modules currently are: =item L -=item L - =item L =back diff --git a/lib/DBIx/Class/Exception.pm b/lib/DBIx/Class/Exception.pm deleted file mode 100644 index 0580202..0000000 --- a/lib/DBIx/Class/Exception.pm +++ /dev/null @@ -1,71 +0,0 @@ -package DBIx::Class::Exception; - -use strict; -use vars qw[@ISA $DBIC_EXCEPTION_CLASS]; -use UNIVERSAL::require; - -BEGIN { - push( @ISA, $DBIC_EXCEPTION_CLASS || 'DBIx::Class::Exception::Base' ); -} - -package DBIx::Class::Exception::Base; - -use strict; -use Carp (); - -=head1 NAME - -DBIx::Class::Exception - DBIC Exception Class - -=head1 SYNOPSIS - - DBIx::Class::Exception->throw( qq/Fatal exception/ ); - -See also L. - -=head1 DESCRIPTION - -This is a generic Exception class for DBIx::Class. You can easily -replace this with any mechanism implementing 'throw' by setting -$DBix::Class::Exception::DBIC_EXCEPTION_CLASS - -=head1 METHODS - -=head2 throw( $message ) - -=head2 throw( message => $message ) - -=head2 throw( error => $error ) - -Throws a fatal exception. - -=cut - -sub throw { - my $class = shift; - my %params = @_ == 1 ? ( error => $_[0] ) : @_; - - my $message = $params{message} || $params{error} || $! || ''; - - local $Carp::CarpLevel = (caller(1) eq 'NEXT' ? 2 : 1); - - Carp::croak($message); -} - -=head1 AUTHOR - -Marcus Ramberg - -=head1 THANKS - -Thanks to the L framework, where this module was borrowed -from. - -=head1 COPYRIGHT - -This program is free software, you can redistribute it and/or modify -it under the same terms as Perl itself. - -=cut - -1; diff --git a/lib/DBIx/Class/InflateColumn.pm b/lib/DBIx/Class/InflateColumn.pm index 6a8e1e7..f60e112 100644 --- a/lib/DBIx/Class/InflateColumn.pm +++ b/lib/DBIx/Class/InflateColumn.pm @@ -3,7 +3,6 @@ package DBIx::Class::InflateColumn; use strict; use warnings; -use Carp qw/croak/; use base qw/DBIx::Class::Row/; @@ -59,8 +58,8 @@ used in the database layer. sub inflate_column { my ($self, $col, $attrs) = @_; - croak "No such column $col to inflate" unless $self->has_column($col); - croak "inflate_column needs attr hashref" unless ref $attrs eq 'HASH'; + $self->throw_exception("No such column $col to inflate") unless $self->has_column($col); + $self->throw_exception("inflate_column needs attr hashref") unless ref $attrs eq 'HASH'; $self->column_info($col)->{_inflate_info} = $attrs; $self->mk_group_accessors('inflated_column' => $col); return 1; @@ -69,26 +68,26 @@ sub inflate_column { sub _inflated_column { my ($self, $col, $value) = @_; return $value unless defined $value; # NULL is NULL is NULL - my $info = $self->column_info($col) || croak "No column info for $col"; + my $info = $self->column_info($col) || $self->throw_exception("No column info for $col"); return $value unless exists $info->{_inflate_info}; my $inflate = $info->{_inflate_info}{inflate}; - croak "No inflator for $col" unless defined $inflate; + $self->throw_exception("No inflator for $col") unless defined $inflate; return $inflate->($value, $self); } sub _deflated_column { my ($self, $col, $value) = @_; return $value unless ref $value; # If it's not an object, don't touch it - my $info = $self->column_info($col) || croak "No column info for $col"; + my $info = $self->column_info($col) || $self->throw_exception("No column info for $col"); return $value unless exists $info->{_inflate_info}; my $deflate = $info->{_inflate_info}{deflate}; - croak "No deflator for $col" unless defined $deflate; + $self->throw_exception("No deflator for $col") unless defined $deflate; return $deflate->($value, $self); } sub get_inflated_column { my ($self, $col) = @_; - $self->throw("$col is not an inflated column") unless + $self->throw_exception("$col is not an inflated column") unless exists $self->column_info($col)->{_inflate_info}; return $self->{_inflated_column}{$col} diff --git a/lib/DBIx/Class/PK.pm b/lib/DBIx/Class/PK.pm index 4889b63..ad406ca 100644 --- a/lib/DBIx/Class/PK.pm +++ b/lib/DBIx/Class/PK.pm @@ -61,7 +61,7 @@ a class method. sub id { my ($self) = @_; - $self->throw( "Can't call id() as a class method" ) unless ref $self; + $self->throw_exception( "Can't call id() as a class method" ) unless ref $self; my @pk = $self->_ident_values; return (wantarray ? @pk : $pk[0]); } @@ -76,7 +76,7 @@ L. sub ID { my ($self) = @_; - $self->throw( "Can't call ID() as a class method" ) unless ref $self; + $self->throw_exception( "Can't call ID() as a class method" ) unless ref $self; return undef unless $self->in_storage; return $self->_create_ID(map { $_ => $self->{_column_data}{$_} } $self->primary_columns); } diff --git a/lib/DBIx/Class/PK/Auto.pm b/lib/DBIx/Class/PK/Auto.pm index ac89dad..c2bb440 100644 --- a/lib/DBIx/Class/PK/Auto.pm +++ b/lib/DBIx/Class/PK/Auto.pm @@ -62,13 +62,13 @@ sub insert { (grep { $self->column_info($_)->{'auto_increment'} } $self->primary_columns) || $self->primary_columns; - $self->throw( "More than one possible key found for auto-inc on ".ref $self ) + $self->throw_exception( "More than one possible key found for auto-inc on ".ref $self ) if $too_many; unless (defined $self->get_column($pri)) { - $self->throw( "Can't auto-inc for $pri on ".ref $self.": no _last_insert_id method" ) + $self->throw_exception( "Can't auto-inc for $pri on ".ref $self.": no _last_insert_id method" ) unless $self->can('last_insert_id'); my $id = $self->last_insert_id; - $self->throw( "Can't get last insert id" ) unless $id; + $self->throw_exception( "Can't get last insert id" ) unless $id; $self->store_column($pri => $id); } return $ret; diff --git a/lib/DBIx/Class/Relationship/Accessor.pm b/lib/DBIx/Class/Relationship/Accessor.pm index 5c2c38d..b94f238 100644 --- a/lib/DBIx/Class/Relationship/Accessor.pm +++ b/lib/DBIx/Class/Relationship/Accessor.pm @@ -29,7 +29,7 @@ sub add_relationship_accessor { } }; } elsif ($acc_type eq 'filter') { - $class->throw("No such column $rel to filter") + $class->throw_exception("No such column $rel to filter") unless $class->has_column($rel); my $f_class = $class->relationship_info($rel)->{class}; $class->inflate_column($rel, @@ -39,7 +39,7 @@ sub add_relationship_accessor { }, deflate => sub { my ($val, $self) = @_; - $self->throw("$val isn't a $f_class") unless $val->isa($f_class); + $self->throw_exception("$val isn't a $f_class") unless $val->isa($f_class); return ($val->_ident_values)[0]; # WARNING: probably breaks for multi-pri sometimes. FIXME } @@ -49,7 +49,7 @@ sub add_relationship_accessor { $meth{$rel} = sub { shift->search_related($rel, @_) }; $meth{"add_to_${rel}"} = sub { shift->create_related($rel, @_); }; } else { - $class->throw("No such relationship accessor type $acc_type"); + $class->throw_exception("No such relationship accessor type $acc_type"); } { no strict 'refs'; diff --git a/lib/DBIx/Class/Relationship/Base.pm b/lib/DBIx/Class/Relationship/Base.pm index d10a7db..e4d7488 100644 --- a/lib/DBIx/Class/Relationship/Base.pm +++ b/lib/DBIx/Class/Relationship/Base.pm @@ -92,10 +92,10 @@ sub search_related { $attrs = { %{ pop(@_) } }; } my $rel_obj = $self->relationship_info($rel); - $self->throw( "No such relationship ${rel}" ) unless $rel_obj; + $self->throw_exception( "No such relationship ${rel}" ) unless $rel_obj; $attrs = { %{$rel_obj->{attrs} || {}}, %{$attrs || {}} }; - $self->throw( "Invalid query: @_" ) if (@_ > 1 && (@_ % 2 == 1)); + $self->throw_exception( "Invalid query: @_" ) if (@_ > 1 && (@_ % 2 == 1)); my $query = ((@_ > 1) ? {@_} : shift); my ($cond) = $self->result_source->resolve_condition($rel_obj->{cond}, $rel, $self); @@ -172,20 +172,20 @@ sub find_or_create_related { sub set_from_related { my ($self, $rel, $f_obj) = @_; my $rel_obj = $self->relationship_info($rel); - $self->throw( "No such relationship ${rel}" ) unless $rel_obj; + $self->throw_exception( "No such relationship ${rel}" ) unless $rel_obj; my $cond = $rel_obj->{cond}; - $self->throw( "set_from_related can only handle a hash condition; the " + $self->throw_exception( "set_from_related can only handle a hash condition; the " ."condition for $rel is of type ".(ref $cond ? ref $cond : 'plain scalar')) unless ref $cond eq 'HASH'; my $f_class = $self->result_source->schema->class($rel_obj->{class}); - $self->throw( "Object $f_obj isn't a ".$f_class ) + $self->throw_exception( "Object $f_obj isn't a ".$f_class ) unless $f_obj->isa($f_class); foreach my $key (keys %$cond) { next if ref $cond->{$key}; # Skip literals and complex conditions - $self->throw("set_from_related can't handle $key as key") + $self->throw_exception("set_from_related can't handle $key as key") unless $key =~ m/^foreign\.([^\.]+)$/; my $val = $f_obj->get_column($1); - $self->throw("set_from_related can't handle ".$cond->{$key}." as value") + $self->throw_exception("set_from_related can't handle ".$cond->{$key}." as value") unless $cond->{$key} =~ m/^self\.([^\.]+)$/; $self->set_column($1 => $val); } diff --git a/lib/DBIx/Class/Relationship/BelongsTo.pm b/lib/DBIx/Class/Relationship/BelongsTo.pm index 093d0be..e146b0a 100644 --- a/lib/DBIx/Class/Relationship/BelongsTo.pm +++ b/lib/DBIx/Class/Relationship/BelongsTo.pm @@ -7,7 +7,7 @@ sub belongs_to { my ($class, $rel, $f_class, $cond, $attrs) = @_; eval "require $f_class"; if ($@) { - $class->throw($@) unless $@ =~ /Can't locate/; + $class->throw_exception($@) unless $@ =~ /Can't locate/; } my %f_primaries; @@ -16,17 +16,17 @@ sub belongs_to { # single key relationship if (!ref $cond) { - $class->throw("Can't infer join condition for ${rel} on ${class}; unable to load ${f_class}") + $class->throw_exception("Can't infer join condition for ${rel} on ${class}; unable to load ${f_class}") unless $f_loaded; my ($pri, $too_many) = keys %f_primaries; - $class->throw("Can't infer join condition for ${rel} on ${class}; ${f_class} has no primary keys") + $class->throw_exception("Can't infer join condition for ${rel} on ${class}; ${f_class} has no primary keys") unless defined $pri; - $class->throw("Can't infer join condition for ${rel} on ${class}; ${f_class} has multiple primary key") + $class->throw_exception("Can't infer join condition for ${rel} on ${class}; ${f_class} has multiple primary key") if $too_many; my $fk = defined $cond ? $cond : $rel; - $class->throw("Can't infer join condition for ${rel} on ${class}; $fk is not a column") + $class->throw_exception("Can't infer join condition for ${rel} on ${class}; $fk is not a column") unless $class->has_column($fk); my $acc_type = $class->has_column($rel) ? 'filter' : 'single'; @@ -52,7 +52,7 @@ sub belongs_to { ); } else { - $class->throw('third argument for belongs_to must be undef, a column name, or a join condition'); + $class->throw_exception('third argument for belongs_to must be undef, a column name, or a join condition'); } return 1; } diff --git a/lib/DBIx/Class/Relationship/HasMany.pm b/lib/DBIx/Class/Relationship/HasMany.pm index fdf5dd6..716c292 100644 --- a/lib/DBIx/Class/Relationship/HasMany.pm +++ b/lib/DBIx/Class/Relationship/HasMany.pm @@ -8,12 +8,12 @@ sub has_many { eval "require $f_class"; if ($@) { - $class->throw($@) unless $@ =~ /Can't locate/; + $class->throw_exception($@) unless $@ =~ /Can't locate/; } unless (ref $cond) { my ($pri, $too_many) = $class->primary_columns; - $class->throw( "has_many can only infer join for a single primary key; ${class} has more" ) + $class->throw_exception( "has_many can only infer join for a single primary key; ${class} has more" ) if $too_many; my $f_key; my $f_class_loaded = eval { $f_class->columns }; @@ -26,7 +26,7 @@ sub has_many { $f_key = lc $1; # go ahead and guess; best we can do $guess = "using our class name '$class' as foreign key"; } - $class->throw("No such column ${f_key} on foreign class ${f_class} ($guess)") + $class->throw_exception("No such column ${f_key} on foreign class ${f_class} ($guess)") if $f_class_loaded && !$f_class->has_column($f_key); $cond = { "foreign.${f_key}" => "self.${pri}" }, } diff --git a/lib/DBIx/Class/Relationship/HasOne.pm b/lib/DBIx/Class/Relationship/HasOne.pm index bca5e5b..66662c9 100644 --- a/lib/DBIx/Class/Relationship/HasOne.pm +++ b/lib/DBIx/Class/Relationship/HasOne.pm @@ -15,12 +15,12 @@ sub _has_one { my ($class, $join_type, $rel, $f_class, $cond, $attrs) = @_; eval "require $f_class"; if ($@) { - $class->throw($@) unless $@ =~ /Can't locate/; + $class->throw_exception($@) unless $@ =~ /Can't locate/; } unless (ref $cond) { my ($pri, $too_many) = $class->primary_columns; - $class->throw( "might_have/has_one can only infer join for a single primary key; ${class} has more" ) + $class->throw_exception( "might_have/has_one can only infer join for a single primary key; ${class} has more" ) if $too_many; my $f_key; my $f_class_loaded = eval { $f_class->columns }; @@ -33,11 +33,11 @@ sub _has_one { $guess = "using given relationship '$rel' for foreign key"; } else { ($f_key, $too_many) = $f_class->primary_columns; - $class->throw( "might_have/has_one can only infer join for a single primary key; ${f_class} has more" ) + $class->throw_exception( "might_have/has_one can only infer join for a single primary key; ${f_class} has more" ) if $too_many; $guess = "using primary key of foreign class for foreign key"; } - $class->throw("No such column ${f_key} on foreign class ${f_class} ($guess)") + $class->throw_exception("No such column ${f_key} on foreign class ${f_class} ($guess)") if $f_class_loaded && !$f_class->has_column($f_key); $cond = { "foreign.${f_key}" => "self.${pri}" }; } diff --git a/lib/DBIx/Class/ResultSet.pm b/lib/DBIx/Class/ResultSet.pm index 4546c1f..e696555 100644 --- a/lib/DBIx/Class/ResultSet.pm +++ b/lib/DBIx/Class/ResultSet.pm @@ -2,7 +2,6 @@ package DBIx::Class::ResultSet; use strict; use warnings; -use Carp qw/croak/; use overload '0+' => 'count', 'bool' => sub { 1; }, @@ -10,6 +9,10 @@ use overload use Data::Page; use Storable; +use base qw/DBIx::Class/; +__PACKAGE__->load_components(qw/AccessorGroup/); +__PACKAGE__->mk_group_accessors('simple' => 'result_source'); + =head1 NAME DBIx::Class::ResultSet - Responsible for fetching and creating resultset. @@ -117,7 +120,7 @@ sub new { $attrs->{offset} += ($attrs->{rows} * ($attrs->{page} - 1)); } my $new = { - source => $source, + result_source => $source, cond => $attrs->{where}, from => $attrs->{from}, count => undef, @@ -161,7 +164,7 @@ sub search { $attrs->{where} = $where; } - my $rs = (ref $self)->new($self->{source}, $attrs); + my $rs = (ref $self)->new($self->result_source, $attrs); return (wantarray ? $rs->all : $rs); } @@ -208,15 +211,15 @@ sub find { my ($self, @vals) = @_; my $attrs = (@vals > 1 && ref $vals[$#vals] eq 'HASH' ? pop(@vals) : {}); - my @cols = $self->{source}->primary_columns; + my @cols = $self->result_source->primary_columns; if (exists $attrs->{key}) { - my %uniq = $self->{source}->unique_constraints; + my %uniq = $self->result_source->unique_constraints; $self->( "Unknown key " . $attrs->{key} . " on " . $self->name ) unless exists $uniq{$attrs->{key}}; @cols = @{ $uniq{$attrs->{key}} }; } #use Data::Dumper; warn Dumper($attrs, @vals, @cols); - $self->{source}->result_class->throw( "Can't find unless a primary key or unique constraint is defined" ) + $self->throw_exception( "Can't find unless a primary key or unique constraint is defined" ) unless @cols; my $query; @@ -229,10 +232,6 @@ sub find { $query = {@vals}; } #warn Dumper($query); - # Useless -> disabled - #$self->{source}->result_class->throw( "Can't find unless all primary keys are specified" ) - # unless (keys %$query >= @pk); # If we check 'em we run afoul of uc/lc - # column names etc. Not sure what to do yet return $self->search($query)->next; } @@ -247,12 +246,12 @@ records. sub search_related { my ($self, $rel, @rest) = @_; - my $rel_obj = $self->{source}->relationship_info($rel); - $self->{source}->result_class->throw( + my $rel_obj = $self->result_source->relationship_info($rel); + $self->throw_exception( "No such relationship ${rel} in search_related") unless $rel_obj; my $rs = $self->search(undef, { join => $rel }); - return $self->{source}->schema->resultset($rel_obj->{class} + return $self->result_source->schema->resultset($rel_obj->{class} )->search( undef, { %{$rs->{attrs}}, alias => $rel, @@ -269,10 +268,10 @@ Returns a storage-driven cursor to the given resultset. sub cursor { my ($self) = @_; - my ($source, $attrs) = @{$self}{qw/source attrs/}; + my ($attrs) = $self->{attrs}; $attrs = { %$attrs }; return $self->{cursor} - ||= $source->storage->select($self->{from}, $attrs->{select}, + ||= $self->result_source->storage->select($self->{from}, $attrs->{select}, $attrs->{where},$attrs); } @@ -309,7 +308,7 @@ sub slice { $attrs->{offset} ||= 0; $attrs->{offset} += $min; $attrs->{rows} = ($max ? ($max - $min + 1) : 1); - my $slice = (ref $self)->new($self->{source}, $attrs); + my $slice = (ref $self)->new($self->result_source, $attrs); return (wantarray ? $slice->all : $slice); } @@ -349,13 +348,20 @@ sub _construct_object { $target->[0]->{$col} = shift @row; } #use Data::Dumper; warn Dumper(\@as, $info); - my $new = $self->{source}->result_class->inflate_result( - $self->{source}, @$info); + my $new = $self->result_source->result_class->inflate_result( + $self->result_source, @$info); $new = $self->{attrs}{record_filter}->($new) if exists $self->{attrs}{record_filter}; return $new; } +=head2 result_source + +Returns a reference to the result source for this recordset. + +=cut + + =head2 count Performs an SQL C with the same query as the resultset was built @@ -367,7 +373,9 @@ on the resultset and counts the results of that. sub count { my $self = shift; return $self->search(@_)->count if @_ && defined $_[0]; - croak "Unable to ->count with a GROUP BY" if defined $self->{attrs}{group_by}; + $self->throw_exception( + "Unable to ->count with a GROUP BY" + ) if defined $self->{attrs}{group_by}; unless (defined $self->{count}) { my $attrs = { %{ $self->{attrs} }, select => { 'count' => '*' }, @@ -375,7 +383,7 @@ sub count { # offset, order by and page are not needed to count. record_filter is cdbi delete $attrs->{$_} for qw/rows offset order_by page pager record_filter/; - ($self->{count}) = (ref $self)->new($self->{source}, $attrs)->cursor->next; + ($self->{count}) = (ref $self)->new($self->result_source, $attrs)->cursor->next; } return 0 unless $self->{count}; my $count = $self->{count}; @@ -436,9 +444,9 @@ Sets the specified columns in the resultset to the supplied values. sub update { my ($self, $values) = @_; - croak "Values for update must be a hash" unless ref $values eq 'HASH'; - return $self->{source}->storage->update( - $self->{source}->from, $values, $self->{cond}); + $self->throw_exception("Values for update must be a hash") unless ref $values eq 'HASH'; + return $self->result_source->storage->update( + $self->result_source->from, $values, $self->{cond}); } =head2 update_all(\%values) @@ -450,7 +458,7 @@ will run cascade triggers while L will not. sub update_all { my ($self, $values) = @_; - croak "Values for update must be a hash" unless ref $values eq 'HASH'; + $self->throw_exception("Values for update must be a hash") unless ref $values eq 'HASH'; foreach my $obj ($self->all) { $obj->set_columns($values)->update; } @@ -465,7 +473,7 @@ Deletes the contents of the resultset from its result source. sub delete { my ($self) = @_; - $self->{source}->storage->delete($self->{source}->from, $self->{cond}); + $self->result_source->storage->delete($self->result_source->from, $self->{cond}); return 1; } @@ -492,7 +500,7 @@ sense for queries with a C attribute. sub pager { my ($self) = @_; my $attrs = $self->{attrs}; - croak "Can't create pager for non-paged rs" unless $self->{page}; + $self->throw_exception("Can't create pager for non-paged rs") unless $self->{page}; $attrs->{rows} ||= 10; $self->count; return $self->{pager} ||= Data::Page->new( @@ -509,7 +517,7 @@ sub page { my ($self, $page) = @_; my $attrs = { %{$self->{attrs}} }; $attrs->{page} = $page; - return (ref $self)->new($self->{source}, $attrs); + return (ref $self)->new($self->result_source, $attrs); } =head2 new_result(\%vals) @@ -520,17 +528,17 @@ Creates a result in the resultset's result class. sub new_result { my ($self, $values) = @_; - $self->{source}->result_class->throw( "new_result needs a hash" ) + $self->throw_exception( "new_result needs a hash" ) unless (ref $values eq 'HASH'); - $self->{source}->result_class->throw( "Can't abstract implicit construct, condition not a hash" ) + $self->throw_exception( "Can't abstract implicit construct, condition not a hash" ) if ($self->{cond} && !(ref $self->{cond} eq 'HASH')); my %new = %$values; my $alias = $self->{attrs}{alias}; foreach my $key (keys %{$self->{cond}||{}}) { $new{$1} = $self->{cond}{$key} if ($key =~ m/^(?:$alias\.)?([^\.]+)$/); } - my $obj = $self->{source}->result_class->new(\%new); - $obj->result_source($self->{source}) if $obj->can('result_source'); + my $obj = $self->result_source->result_class->new(\%new); + $obj->result_source($self->result_source) if $obj->can('result_source'); $obj; } @@ -544,7 +552,7 @@ Effectively a shortcut for C<< ->new_result(\%vals)->insert >>. sub create { my ($self, $attrs) = @_; - $self->{source}->result_class->throw( "create needs a hashref" ) unless ref $attrs eq 'HASH'; + $self->throw_exception( "create needs a hashref" ) unless ref $attrs eq 'HASH'; return $self->new_result($attrs)->insert; } @@ -622,7 +630,7 @@ sub update_or_create { my $attrs = (@_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {}); my $hash = ref $_[0] eq "HASH" ? shift : {@_}; - my %unique_constraints = $self->{source}->unique_constraints; + my %unique_constraints = $self->result_source->unique_constraints; my @constraint_names = (exists $attrs->{key} ? ($attrs->{key}) : keys %unique_constraints); @@ -655,6 +663,17 @@ sub update_or_create { return $row; } +=head2 throw_exception + +See Schema's throw_exception + +=cut + +sub throw_exception { + my $self=shift; + $self->result_source->schema->throw_exception(@_); +} + =head1 ATTRIBUTES The resultset takes various attributes that modify its behavior. Here's an diff --git a/lib/DBIx/Class/ResultSource.pm b/lib/DBIx/Class/ResultSource.pm index b4dbfd3..dcc57ad 100644 --- a/lib/DBIx/Class/ResultSource.pm +++ b/lib/DBIx/Class/ResultSource.pm @@ -4,8 +4,7 @@ use strict; use warnings; use DBIx::Class::ResultSet; - -use Carp qw/croak/; +use Carp::Clan qw/^DBIx::Class/; use Storable; @@ -109,7 +108,8 @@ Returns the column metadata hashref for a column. sub column_info { my ($self, $column) = @_; - croak "No such column $column" unless exists $self->_columns->{$column}; + $self->throw_exception("No such column $column") + unless exists $self->_columns->{$column}; if ( (! $self->_columns->{$column}->{data_type}) && $self->schema && $self->storage() ){ my $info; @@ -137,8 +137,9 @@ Returns all column names in the order they were declared to add_columns =cut sub columns { - croak "columns() is a read-only accessor, did you mean add_columns()?" if (@_ > 1); - return @{shift->{_ordered_columns}||[]}; + my $self=shift; + $self->throw_exception("columns() is a read-only accessor, did you mean add_columns()?") if (@_ > 1); + return @{$self->{_ordered_columns}||[]}; } =head2 set_primary_key(@cols) @@ -154,7 +155,7 @@ sub set_primary_key { my ($self, @cols) = @_; # check if primary key columns are valid columns for (@cols) { - $self->throw("No such column $_ on table ".$self->name) + $self->throw_exception("No such column $_ on table ".$self->name) unless $self->has_column($_); } $self->_primaries(\@cols); @@ -186,7 +187,7 @@ sub add_unique_constraint { my ($self, $name, $cols) = @_; for (@$cols) { - $self->throw("No such column $_ on table ".$self->name) + $self->throw_exception("No such column $_ on table ".$self->name) unless $self->has_column($_); } @@ -278,7 +279,7 @@ created, which calls C for the relationship. sub add_relationship { my ($self, $rel, $f_source_name, $cond, $attrs) = @_; - croak "Can't create relationship without join condition" unless $cond; + $self->throw_exception("Can't create relationship without join condition") unless $cond; $attrs ||= {}; my %rels = %{ $self->_relationships }; @@ -311,7 +312,7 @@ sub add_relationship { if ($@) { # If the resolve failed, back out and re-throw the error delete $rels{$rel}; # $self->_relationships(\%rels); - croak "Error creating relationship $rel: $@"; + $self->throw_exception("Error creating relationship $rel: $@"); } 1; } @@ -363,10 +364,10 @@ sub resolve_join { $self->related_source($_)->resolve_join($join->{$_}, $_) } keys %$join; } elsif (ref $join) { - croak ("No idea how to resolve join reftype ".ref $join); + $self->throw_exception("No idea how to resolve join reftype ".ref $join); } else { my $rel_info = $self->relationship_info($join); - croak("No such relationship ${join}") unless $rel_info; + $self->throw_exception("No such relationship ${join}") unless $rel_info; my $type = $rel_info->{attrs}{join_type} || ''; return [ { $join => $self->related_source($join)->from, -join_type => $type }, @@ -389,8 +390,8 @@ sub resolve_condition { my %ret; while (my ($k, $v) = each %{$cond}) { # XXX should probably check these are valid columns - $k =~ s/^foreign\.// || croak "Invalid rel cond key ${k}"; - $v =~ s/^self\.// || croak "Invalid rel cond val ${v}"; + $k =~ s/^foreign\.// || $self->throw_exception("Invalid rel cond key ${k}"); + $v =~ s/^self\.// || $self->throw_exception("Invalid rel cond val ${v}"); if (ref $for) { # Object #warn "$self $k $for $v"; $ret{$k} = $for->get_column($v); @@ -469,11 +470,11 @@ sub resolve_prefetch { return @ret; } elsif( ref $pre ) { - croak( "don't know how to resolve prefetch reftype " . ref $pre); + $self->throw_exception( "don't know how to resolve prefetch reftype " . ref $pre); } else { my $rel_info = $self->relationship_info( $pre ); - croak( $self->name . " has no such relationship '$pre'" ) unless $rel_info; + $self->throw_exception( $self->name . " has no such relationship '$pre'" ) unless $rel_info; my $prefix = $alias && $alias ne 'me' ? "$alias.$pre" : $pre; my @ret = map { "$prefix.$_" } $self->related_source($pre)->columns; #warn $alias, Dumper (\@ret); @@ -490,13 +491,29 @@ Returns the result source for the given relationship sub related_source { my ($self, $rel) = @_; if( !$self->has_relationship( $rel ) ) { - croak "No such relationship '$rel'"; + $self->throw_exception("No such relationship '$rel'"); } return $self->schema->source($self->relationship_info($rel)->{source}); } 1; +=head2 throw_exception + +See schema's throw_exception + +=cut + +sub throw_exception { + my $self = shift; + if (defined $self->schema) { + $self->schema->throw_exception(@_); + } else { + croak(@_); + } +} + + =head1 AUTHORS Matt S. Trout diff --git a/lib/DBIx/Class/Row.pm b/lib/DBIx/Class/Row.pm index 26b0c14..8a4bfc9 100644 --- a/lib/DBIx/Class/Row.pm +++ b/lib/DBIx/Class/Row.pm @@ -3,9 +3,8 @@ package DBIx::Class::Row; use strict; use warnings; -use Carp qw/croak/; - use base qw/DBIx::Class/; +use Carp::Clan qw/^DBIx::Class/; __PACKAGE__->load_components(qw/AccessorGroup/); @@ -37,9 +36,9 @@ sub new { $class = ref $class if ref $class; my $new = bless({ _column_data => { } }, $class); if ($attrs) { - $new->throw("attrs must be a hashref" ) unless ref($attrs) eq 'HASH'; + $new->throw_exception("attrs must be a hashref" ) unless ref($attrs) eq 'HASH'; while (my ($k, $v) = each %{$attrs}) { - croak "No such column $k on $class" unless $class->has_column($k); + $new->throw_exception("No such column $k on $class") unless $class->has_column($k); $new->store_column($k => $v); } } @@ -62,7 +61,7 @@ sub insert { $self->{result_source} ||= $self->result_source_instance if $self->can('result_source_instance'); my $source = $self->{result_source}; - croak "No result_source set on this object; can't insert" unless $source; + $self->throw_exception("No result_source set on this object; can't insert") unless $source; #use Data::Dumper; warn Dumper($self); $source->storage->insert($source->from, { $self->get_columns }); $self->in_storage(1); @@ -96,15 +95,15 @@ UPDATE query to commit any changes to the object to the db if required. sub update { my ($self, $upd) = @_; - $self->throw( "Not in database" ) unless $self->in_storage; + $self->throw_exception( "Not in database" ) unless $self->in_storage; my %to_update = $self->get_dirty_columns; return $self unless keys %to_update; my $rows = $self->result_source->storage->update( $self->result_source->from, \%to_update, $self->ident_condition); if ($rows == 0) { - $self->throw( "Can't update ${self}: row not found" ); + $self->throw_exception( "Can't update ${self}: row not found" ); } elsif ($rows > 1) { - $self->throw("Can't update ${self}: updated more than one row"); + $self->throw_exception("Can't update ${self}: updated more than one row"); } $self->{_dirty_columns} = {}; return $self; @@ -123,12 +122,12 @@ be re ->insert'ed before it can be ->update'ed sub delete { my $self = shift; if (ref $self) { - $self->throw( "Not in database" ) unless $self->in_storage; + $self->throw_exception( "Not in database" ) unless $self->in_storage; $self->result_source->storage->delete( $self->result_source->from, $self->ident_condition); $self->in_storage(undef); } else { - croak "Can't do class delete without a ResultSource instance" + $self->throw_exception("Can't do class delete without a ResultSource instance") unless $self->can('result_source_instance'); my $attrs = { }; if (@_ > 1 && ref $_[$#_] eq 'HASH') { @@ -152,10 +151,10 @@ the database and stored in the object. sub get_column { my ($self, $column) = @_; - $self->throw( "Can't fetch data as class method" ) unless ref $self; + $self->throw_exception( "Can't fetch data as class method" ) unless ref $self; return $self->{_column_data}{$column} if exists $self->{_column_data}{$column}; - $self->throw( "No such column '${column}'" ) unless $self->has_column($column); + $self->throw_exception( "No such column '${column}'" ) unless $self->has_column($column); return undef; } @@ -246,9 +245,9 @@ Sets a column value without marking it as dirty. sub store_column { my ($self, $column, $value) = @_; - $self->throw( "No such column '${column}'" ) + $self->throw_exception( "No such column '${column}'" ) unless exists $self->{_column_data}{$column} || $self->has_column($column); - $self->throw( "set_column called for ${column} without value" ) + $self->throw_exception( "set_column called for ${column} without value" ) if @_ < 3; return $self->{_column_data}{$column} = $value; } @@ -272,11 +271,11 @@ sub inflate_result { my $schema; PRE: foreach my $pre (keys %{$prefetch||{}}) { my $pre_source = $source->related_source($pre); - croak "Can't prefetch non-existant relationship ${pre}" unless $pre_source; + $class->throw_exception("Can't prefetch non-existant relationship ${pre}") unless $pre_source; my $fetched = $pre_source->result_class->inflate_result( $pre_source, @{$prefetch->{$pre}}); my $accessor = $source->relationship_info($pre)->{attrs}{accessor}; - $class->throw("No accessor for prefetched $pre") + $class->throw_exception("No accessor for prefetched $pre") unless defined $accessor; PRIMARY: foreach my $pri ($pre_source->primary_columns) { unless (defined $fetched->get_column($pri)) { @@ -289,7 +288,7 @@ sub inflate_result { } elsif ($accessor eq 'filter') { $new->{_inflated_column}{$pre} = $fetched; } else { - $class->throw("Don't know how to store prefetched $pre"); + $class->throw_exception("Don't know how to store prefetched $pre"); } } return $new; @@ -333,6 +332,22 @@ sub register_column { $class->mk_group_accessors('column' => $col); } + +=item throw_exception + +See Schema's throw_exception. + +=cut + +sub throw_exception { + my $self=shift; + if (ref $self && ref $self->result_source) { + $self->result_source->schema->throw_exception(@_); + } else { + croak(@_); + } +} + 1; =head1 AUTHORS diff --git a/lib/DBIx/Class/Schema.pm b/lib/DBIx/Class/Schema.pm index bfc27cd..787a018 100644 --- a/lib/DBIx/Class/Schema.pm +++ b/lib/DBIx/Class/Schema.pm @@ -3,12 +3,11 @@ package DBIx::Class::Schema; use strict; use warnings; -use Carp qw/croak/; +use Carp::Clan qw/^DBIx::Class/; use UNIVERSAL::require; use base qw/DBIx::Class/; -__PACKAGE__->load_components(qw/Exception/); __PACKAGE__->mk_classdata('class_mappings' => {}); __PACKAGE__->mk_classdata('source_registrations' => {}); __PACKAGE__->mk_classdata('storage_type' => '::DBI'); @@ -116,7 +115,7 @@ sub source { # if we got here, they probably passed a full class name my $mapped = $self->class_mappings->{$moniker}; - croak "Can't find source for ${moniker}" + $self->throw_exception("Can't find source for ${moniker}") unless $mapped && exists $sreg->{$mapped}; return $sreg->{$mapped}; } @@ -185,7 +184,7 @@ sub load_classes { } } else { eval "require Module::Find;"; - $class->throw("No arguments to load_classes and couldn't load". + $class->throw_exception("No arguments to load_classes and couldn't load". " Module::Find ($@)") if $@; my @comp = map { substr $_, length "${class}::" } Module::Find::findallmod($class); $comps_for{$class} = \@comp; @@ -344,6 +343,17 @@ sub clone { return $clone; } +=item throw_exception + +Defaults to using Carp::Clan to report errors from user perspective. + +=cut + +sub throw_exception { + my ($self) = shift; + croak @_; +} + 1; =head1 AUTHORS diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm index 47f88df..0989880 100644 --- a/lib/DBIx/Class/Storage/DBI.pm +++ b/lib/DBIx/Class/Storage/DBI.pm @@ -6,6 +6,7 @@ use DBI; use SQL::Abstract::Limit; use DBIx::Class::Storage::DBI::Cursor; use IO::File; +use Carp::Clan qw/DBIx::Class/; BEGIN { @@ -157,7 +158,7 @@ sub new { $new->transaction_depth(0); if (defined($ENV{DBIX_CLASS_STORAGE_DBI_DEBUG}) && ($ENV{DBIX_CLASS_STORAGE_DBI_DEBUG} =~ /=(.+)$/)) { - $new->debugfh(IO::File->new($1, 'w')||die "Cannot open trace file $1"); + $new->debugfh(IO::File->new($1, 'w')||croak "Cannot open trace file $1"); } else { $new->debugfh(IO::File->new('>&STDERR')); } @@ -280,13 +281,18 @@ sub _execute { $self->debugfh->print("$sql: @bind\n") if $self->debug; my $sth = $self->sth($sql,$op); @bind = map { ref $_ ? ''.$_ : $_ } @bind; # stringify args - my $rv = $sth->execute(@bind); + my $rv; + if ($sth) { + $rv = $sth->execute(@bind); + } else { + croak "'$sql' did not generate a statement."; + } return (wantarray ? ($rv, $sth, @bind) : $rv); } sub insert { my ($self, $ident, $to_insert) = @_; - $self->throw( "Couldn't insert ".join(', ', map "$_ => $to_insert->{$_}", keys %$to_insert)." into ${ident}" ) + croak( "Couldn't insert ".join(', ', map "$_ => $to_insert->{$_}", keys %$to_insert)." into ${ident}" ) unless ($self->_execute('insert' => [], $ident, $to_insert)); return $to_insert; } diff --git a/lib/DBIx/Class/UUIDColumns.pm b/lib/DBIx/Class/UUIDColumns.pm index 2d5baec..1873c90 100644 --- a/lib/DBIx/Class/UUIDColumns.pm +++ b/lib/DBIx/Class/UUIDColumns.pm @@ -1,8 +1,6 @@ package DBIx::Class::UUIDColumns; use base qw/DBIx::Class/; -use Carp qw/croak/; - use Data::UUID; __PACKAGE__->mk_classdata( 'uuid_auto_columns' => [] ); @@ -34,7 +32,7 @@ Note that the component needs to be loaded before Core. sub uuid_columns { my $self = shift; for (@_) { - croak "column $_ doesn't exist" unless $self->has_column($_); + $self->throw_exception("column $_ doesn't exist") unless $self->has_column($_); } $self->uuid_auto_columns(\@_); } diff --git a/lib/DBIx/Class/Validation.pm b/lib/DBIx/Class/Validation.pm index a3b7171..b51c9c8 100644 --- a/lib/DBIx/Class/Validation.pm +++ b/lib/DBIx/Class/Validation.pm @@ -4,7 +4,6 @@ use strict; use warnings; use base qw( DBIx::Class ); -use Carp qw( croak ); use English qw( -no_match_vars ); #local $^W = 0; # Silence C:D:I redefined sub errors. @@ -21,8 +20,8 @@ sub validation_module { my $module = shift; eval("use $module"); - croak("Unable to load the validation module '$module' because $EVAL_ERROR") if ($EVAL_ERROR); - croak("The '$module' module does not support the check method") if (!$module->can('check')); + $class->throw_exception("Unable to load the validation module '$module' because $EVAL_ERROR") if ($EVAL_ERROR); + $class->throw_exception("The '$module' module does not support the check method") if (!$module->can('check')); $class->_validation_module_accessor( $module ); } @@ -43,7 +42,7 @@ sub validate { my $profile = $self->validation_profile(); my $result = $module->check( \%data => $profile ); return $result if ($result->success()); - croak( $result ); + $self->throw_exception( $result ); } sub insert { diff --git a/t/20setuperrors.t b/t/20setuperrors.t index 3d36bd4..5144f56 100644 --- a/t/20setuperrors.t +++ b/t/20setuperrors.t @@ -11,5 +11,5 @@ eval { __PACKAGE__->columns qw/this doesnt work as expected/; }; -like($@,qr/^columns\(\) is a read-only/, +like($@,qr/\bcolumns\(\) is a read-only/, "columns() error when apparently misused");