From: Marcus Ramberg Date: Sun, 31 Jul 2005 23:41:50 +0000 (+0000) Subject: Add ::Exception, and use throw instead of die. X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=78bab9cad621ac5e3d1d12b02c41d662dec7a22a;p=dbsrgits%2FDBIx-Class-Historic.git Add ::Exception, and use throw instead of die. --- diff --git a/lib/DBIx/Class/CDBICompat/AccessorMapping.pm b/lib/DBIx/Class/CDBICompat/AccessorMapping.pm index bb4f214..6d5e4b0 100644 --- a/lib/DBIx/Class/CDBICompat/AccessorMapping.pm +++ b/lib/DBIx/Class/CDBICompat/AccessorMapping.pm @@ -29,7 +29,7 @@ sub mk_group_accessors { sub create { my ($class, $attrs, @rest) = @_; - die "create needs a hashref" unless ref $attrs eq 'HASH'; + $class->throw( "create needs a hashref" ) unless ref $attrs eq 'HASH'; $attrs = { %$attrs }; my %att; foreach my $col (keys %{ $class->_columns }) { diff --git a/lib/DBIx/Class/CDBICompat/HasA.pm b/lib/DBIx/Class/CDBICompat/HasA.pm index 88e7cac..43f7609 100644 --- a/lib/DBIx/Class/CDBICompat/HasA.pm +++ b/lib/DBIx/Class/CDBICompat/HasA.pm @@ -5,10 +5,10 @@ use warnings; sub has_a { my ($self, $col, $f_class) = @_; - die "No such column ${col}" unless $self->_columns->{$col}; + $self->throw( "No such column ${col}" ) unless $self->_columns->{$col}; eval "require $f_class"; my ($pri, $too_many) = keys %{ $f_class->_primaries }; - die "has_a only works with a single primary key; ${f_class} has more" + $self->throw( "has_a only works with a single primary key; ${f_class} has more" ) if $too_many; $self->add_relationship($col, $f_class, { "foreign.${pri}" => "self.${col}" }, @@ -47,7 +47,7 @@ sub store_has_a { return $self->store_column($rel, $obj); } my $rel_obj = $self->_relationships->{$rel}; - die "Can't set $rel: object $obj is not of class ".$rel_obj->{class} + $self->throw( "Can't set $rel: object $obj is not of class ".$rel_obj->{class} ) unless $obj->isa($rel_obj->{class}); $self->{_relationship_data}{$rel} = $obj; #warn "Storing $obj: ".($obj->_ident_values)[0]; @@ -75,7 +75,7 @@ sub _cond_value { if ( my $rel_obj = $self->_relationships->{$key} ) { my $rel_type = $rel_obj->{attrs}{_type} || ''; if ($rel_type eq 'has_a' && ref $value) { - die "Object $value is not of class ".$rel_obj->{class} + $self->throw( "Object $value is not of class ".$rel_obj->{class} ) unless $value->isa($rel_obj->{class}); $value = ($value->_ident_values)[0]; #warn $value; diff --git a/lib/DBIx/Class/CDBICompat/HasMany.pm b/lib/DBIx/Class/CDBICompat/HasMany.pm index 4bf3449..3099bf6 100644 --- a/lib/DBIx/Class/CDBICompat/HasMany.pm +++ b/lib/DBIx/Class/CDBICompat/HasMany.pm @@ -14,7 +14,7 @@ sub has_many { if (!$self_key || $self_key eq 'id') { my ($pri, $too_many) = keys %{ $class->_primaries }; - die "has_many only works with a single primary key; ${class} has more" + $class->throw( "has_many only works with a single primary key; ${class} has more" ) if $too_many; $self_key = $pri; } @@ -35,9 +35,9 @@ sub has_many { $f_key = lc $1 if $f_class->_columns->{lc $1}; } - die "Unable to resolve foreign key for has_many from ${class} to ${f_class}" + $class->throw( "Unable to resolve foreign key for has_many from ${class} to ${f_class}" ) unless $f_key; - die "No such column ${f_key} on foreign class ${f_class}" + $class->throw( "No such column ${f_key} on foreign class ${f_class}" ) unless $f_class->_columns->{$f_key}; $class->add_relationship($rel, $f_class, { "foreign.${f_key}" => "self.${self_key}" }, diff --git a/lib/DBIx/Class/CDBICompat/ImaDBI.pm b/lib/DBIx/Class/CDBICompat/ImaDBI.pm index d0f16f2..22b7eff 100644 --- a/lib/DBIx/Class/CDBICompat/ImaDBI.pm +++ b/lib/DBIx/Class/CDBICompat/ImaDBI.pm @@ -39,7 +39,7 @@ __PACKAGE__->mk_classdata('_transform_sql_handlers' => ($rel_obj) = grep { $_->{class} && $_->{class} eq $to_class } values %{ $from_class->_relationships }; } - die "No relationship to JOIN from ${from_class} to ${to_class}" + $self->throw( "No relationship to JOIN from ${from_class} to ${to_class}" ) unless $rel_obj; my $attrs = { _aliases => { self => $from, foreign => $to }, diff --git a/lib/DBIx/Class/Core.pm b/lib/DBIx/Class/Core.pm index 4a3cf36..b250e8a 100644 --- a/lib/DBIx/Class/Core.pm +++ b/lib/DBIx/Class/Core.pm @@ -10,6 +10,7 @@ use base qw/DBIx::Class::Relationship DBIx::Class::Table DBIx::Class::SQL DBIx::Class::DB + DBIx::Class::Exception DBIx::Class::AccessorGroup/; 1; diff --git a/lib/DBIx/Class/Exception.pm b/lib/DBIx/Class/Exception.pm new file mode 100644 index 0000000..cfa7887 --- /dev/null +++ b/lib/DBIx/Class/Exception.pm @@ -0,0 +1,75 @@ +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 + +=over 4 + +=item throw( $message ) + +=item throw( message => $message ) + +=item 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 = 1; + + Carp::croak($message); +} + +=back + +=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/PK.pm b/lib/DBIx/Class/PK.pm index 1ae5331..487aa94 100644 --- a/lib/DBIx/Class/PK.pm +++ b/lib/DBIx/Class/PK.pm @@ -48,7 +48,8 @@ sub retrieve { my ($class, @vals) = @_; my $attrs = (@vals > 1 && ref $vals[$#vals] eq 'HASH' ? pop(@vals) : {}); my @pk = keys %{$class->_primaries}; - die "Can't retrieve unless primary columns are defined" unless @pk; + $class->throw( "Can't retrieve unless primary columns are defined" ) + unless @pk; my $query; if (ref $vals[0] eq 'HASH') { $query = $vals[0]; @@ -59,7 +60,7 @@ sub retrieve { } else { $query = {@vals}; } - die "Can't retrieve unless all primary keys are specified" + $class->throw( "Can't retrieve 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 my $ret = ($class->search($query))[0]; @@ -83,7 +84,7 @@ sub discard_changes { sub id { my ($self) = @_; - die "Can't call id() as a class method" unless ref $self; + $self->throw( "Can't call id() as a class method" ) unless ref $self; my @pk = $self->_ident_values; return (wantarray ? @pk : $pk[0]); } diff --git a/lib/DBIx/Class/PK/Auto.pm b/lib/DBIx/Class/PK/Auto.pm index 2436120..ff4ed69 100644 --- a/lib/DBIx/Class/PK/Auto.pm +++ b/lib/DBIx/Class/PK/Auto.pm @@ -32,13 +32,13 @@ sub insert { (grep { $self->_primaries->{$_}{'auto_increment'} } keys %{ $self->_primaries }) || (keys %{ $self->_primaries }); - die "More than one possible key found for auto-inc on ".ref $self + $self->throw( "More than one possible key found for auto-inc on ".ref $self ) if $too_many; unless (defined $self->get_column($pri)) { - die "Can't auto-inc for $pri on ".ref $self.": no _last_insert_id method" + $self->throw( "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; - die "Can't get last insert id" unless $id; + $self->throw( "Can't get last insert id" ) unless $id; $self->store_column($pri => $id); } return $ret; diff --git a/lib/DBIx/Class/Relationship.pm b/lib/DBIx/Class/Relationship.pm index 3843251..1106f28 100644 --- a/lib/DBIx/Class/Relationship.pm +++ b/lib/DBIx/Class/Relationship.pm @@ -39,7 +39,7 @@ sub _cond_key { my $action = $attrs->{_action} || ''; if ($action eq 'convert') { unless ($key =~ s/^foreign\.//) { - die "Unable to convert relationship to WHERE clause: invalid key ${key}"; + $self->throw("Unable to convert relationship to WHERE clause: invalid key ${key}"); } return $key; } elsif ($action eq 'join') { @@ -47,8 +47,8 @@ sub _cond_key { if ($attrs->{_aliases}{$type}) { return join('.', $attrs->{_aliases}{$type}, $field); } else { - die "Unable to resolve type ${type}: only have aliases for ". - join(', ', keys %{$attrs->{_aliases}{$type} || {}}); + $self->throw( "Unable to resolve type ${type}: only have aliases for ". + join(', ', keys %{$attrs->{_aliases}{$type} || {}}) ); } } return $self->NEXT::ACTUAL::_cond_key($attrs, $key); @@ -59,10 +59,10 @@ sub _cond_value { my $action = $attrs->{_action} || ''; if ($action eq 'convert') { unless ($value =~ s/^self\.//) { - die "Unable to convert relationship to WHERE clause: invalid value ${value}"; + $self->throw( "Unable to convert relationship to WHERE clause: invalid value ${value}" ); } unless ($self->_columns->{$value}) { - die "Unable to convert relationship to WHERE clause: no such accessor ${value}"; + $self->throw( "Unable to convert relationship to WHERE clause: no such accessor ${value}" ); } push(@{$attrs->{bind}}, $self->get_column($value)); return '?'; @@ -71,8 +71,8 @@ sub _cond_value { if ($attrs->{_aliases}{$type}) { return join('.', $attrs->{_aliases}{$type}, $field); } else { - die "Unable to resolve type ${type}: only have aliases for ". - join(', ', keys %{$attrs->{_aliases}{$type} || {}}); + $self->throw( "Unable to resolve type ${type}: only have aliases for ". + join(', ', keys %{$attrs->{_aliases}{$type} || {}}) ); } } @@ -87,11 +87,11 @@ sub search_related { $attrs = { %{ pop(@_) } }; } my $rel_obj = $self->_relationships->{$rel}; - die "No such relationship ${rel}" unless $rel; + $self->throw( "No such relationship ${rel}" ) unless $rel; $attrs = { %{$rel_obj->{attrs} || {}}, %{$attrs || {}} }; my $s_cond; if (@_) { - die "Invalid query: @_" if (@_ > 1 && (@_ % 2 == 1)); + $self->throw( "Invalid query: @_" ) if (@_ > 1 && (@_ % 2 == 1)); my $query = ((@_ > 1) ? {@_} : shift); $s_cond = $self->_cond_resolve($query, $attrs); } @@ -104,11 +104,13 @@ sub search_related { sub create_related { my ($self, $rel, $values, $attrs) = @_; - die "Can't call create_related as class method" unless ref $self; - die "create_related needs a hash" unless (ref $values eq 'HASH'); + $self->throw( "Can't call create_related as class method" ) + unless ref $self; + $self->throw( "create_related needs a hash" ) + unless (ref $values eq 'HASH'); my $rel_obj = $self->_relationships->{$rel}; - die "No such relationship ${rel}" unless $rel; - die "Can't abstract implicit create for ${rel}, condition not a hash" + $self->throw( "No such relationship ${rel}" ) unless $rel; + $self->throw( "Can't abstract implicit create for ${rel}, condition not a hash" ) unless ref $rel_obj->{cond} eq 'HASH'; $attrs = { %{$rel_obj->{attrs}}, %{$attrs || {}}, _action => 'convert' }; my %fields = %$values; diff --git a/lib/DBIx/Class/SQL/Abstract.pm b/lib/DBIx/Class/SQL/Abstract.pm index 44b3efa..8a45a2a 100644 --- a/lib/DBIx/Class/SQL/Abstract.pm +++ b/lib/DBIx/Class/SQL/Abstract.pm @@ -69,7 +69,7 @@ sub _cond_resolve { my $u = uc($1); if ($u =~ /BETWEEN/) { # SQL sucks - die "BETWEEN must have exactly two arguments" unless @$x == 2; + $self->throw( "BETWEEN must have exactly two arguments" ) unless @$x == 2; push @sqlf, join ' ', $self->_cond_key($attrs => $k), $u, $self->_cond_value($attrs => $k => $x->[0]), diff --git a/lib/DBIx/Class/Table.pm b/lib/DBIx/Class/Table.pm index 6caae42..ed2e86e 100644 --- a/lib/DBIx/Class/Table.pm +++ b/lib/DBIx/Class/Table.pm @@ -37,7 +37,7 @@ sub new { $class = ref $class if ref $class; my $new = bless({ _column_data => { } }, $class); if ($attrs) { - die "attrs must be a hashref" unless ref($attrs) eq 'HASH'; + $new->throw("attrs must be a hashref" ) unless ref($attrs) eq 'HASH'; while (my ($k, $v) = each %{$attrs}) { $new->store_column($k => $v); } @@ -66,13 +66,13 @@ sub in_database { sub create { my ($class, $attrs) = @_; - die "create needs a hashref" unless ref $attrs eq 'HASH'; + $class->throw( "create needs a hashref" ) unless ref $attrs eq 'HASH'; return $class->new($attrs)->insert; } sub update { my ($self) = @_; - die "Not in database" unless $self->in_database; + $self->throw( "Not in database" ) unless $self->in_database; my @to_update = keys %{$self->{_dirty_columns} || {}}; return -1 unless @to_update; my $sth = $self->_get_sth('update', \@to_update, @@ -81,9 +81,9 @@ sub update { $self->_ident_values ); $sth->finish; if ($rows == 0) { - die "Can't update $self: row not found"; + $self->throw( "Can't update $self: row not found" ); } elsif ($rows > 1) { - die "Can't update $self: updated more than one row"; + $self->throw("Can't update $self: updated more than one row"); } $self->{_dirty_columns} = {}; return $self; @@ -92,7 +92,7 @@ sub update { sub delete { my $self = shift; if (ref $self) { - die "Not in database" unless $self->in_database; + $self->throw( "Not in database" ) unless $self->in_database; #warn $self->_ident_cond.' '.join(', ', $self->_ident_values); my $sth = $self->_get_sth('delete', undef, $self->_table_name, $self->_ident_cond); @@ -115,8 +115,8 @@ sub delete { sub get_column { my ($self, $column) = @_; - die "Can't fetch data as class method" unless ref $self; - die "No such column '${column}'" unless $self->_columns->{$column}; + $self->throw( "Can't fetch data as class method" ) unless ref $self; + $self->throw( "No such column '${column}'" ) unless $self->_columns->{$column}; return $self->{_column_data}{$column} if exists $self->{_column_data}{$column}; return undef; @@ -132,8 +132,10 @@ sub set_column { sub store_column { my ($self, $column, $value) = @_; - die "No such column '${column}'" unless $self->_columns->{$column}; - die "set_column called for ${column} without value" if @_ < 3; + $self->throw( "No such column '${column}'" ) + unless $self->_columns->{$column}; + $self->throw( "set_column called for ${column} without value" ) + if @_ < 3; return $self->{_column_data}{$column} = $value; }