From: Marcus Ramberg <mramberg@cpan.org>
Date: Sun, 31 Jul 2005 23:41:50 +0000 (+0000)
Subject: Add ::Exception, and use throw instead of die.
X-Git-Tag: v0.03001~113
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=78bab9cad621ac5e3d1d12b02c41d662dec7a22a;p=dbsrgits%2FDBIx-Class.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<DBIx::Class>.
+
+=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 <mramberg@cpan.org>
+
+=head1 THANKS
+
+Thanks to the L<Catalyst> 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;
 }