installing $dbh->{HandleError} so that error messages go through Carp…

…::Clan
damil · Jan 27, 2024 · 76a9fc0 · 76a9fc0
1 parent 9bd8524
commit 76a9fc0
Show file tree

Hide file tree

Showing 5 changed files with 178 additions and 50 deletions.
diff --git a/MANIFEST b/MANIFEST
@@ -79,5 +79,6 @@ t/v2_multischema.t
 t/v2_Oracle.t
 t/v2_result_as.t
 t/v3_Oracle12c.t
+t/v3_error_handler.t
 t/v3_with_recursive.t
 xt/pod.t
diff --git a/lib/DBIx/DataModel/Doc/Reference.pod b/lib/DBIx/DataModel/Doc/Reference.pod
@@ -1120,6 +1120,9 @@ allowed at any time, except when a transaction is in course.  However,
 a nested transaction may temporarily change the database handle by
 supplying it as argument to the L</"do_transaction()"> method.
 
+While setting the schema to a new C<$dbh>, the C<HandleError> attribute of that C<$dbh> may
+be modified -- see L</handleError_policy()>.
+
 To unset the database handle, call C<< $schema->dbh(undef) >>.
 
 =head3 debug()
@@ -1270,6 +1273,43 @@ schema, as opposed to the C<db_schema()> method above that performs a
 permanent change.
 
 
+=head3 handleError_policy()
+
+  $schema->handleError_policy('none'); # default is 'combine'
+
+Decides which policy will be applied regarding C<< $dbh->{HandleError} >> handlers.
+Whenever a schema receives a handle to a dbh through the C<< $schema->dbh($new_dbh, ..) >>
+method, C<DBIx::DataModel> may add or modify the C<< $dbh->{HandleError} >> handler,
+so that SQL errrors are signaled at the client's level instead of being signaled
+as errors within L<DBIx::DataModel::Statement>. Allowed policies are :
+
+=over
+
+=item combine
+
+A new C<< $dbh->{HandleError} >> handler will be installed. If a previous handler
+was already present, that handler will be called, and then the C<DBIx::DataModel>
+handler runs on top of the previous one. If the previous handler was already installed
+by C<DBIx::DataModel>, this handler remains in place without any new installation.
+
+This is the default policy.
+
+=item none
+
+C<DBIx::DataModel> leaves the previous  C<< $dbh->{HandleError} >> handler in place without any interference.
+
+=item override
+
+C<DBIx::DataModel> forces installation of a new   C<< $dbh->{HandleError} >>, ignoring the previous handler.
+
+=item if_absent
+
+C<DBIx::DataModel> installs a new  C<< $dbh->{HandleError} >> handler only if there was no previous handler.
+
+=back
+
+
+
 =head3 localize_state()
 
   {

diff --git a/lib/DBIx/DataModel/Schema.pm b/lib/DBIx/DataModel/Schema.pm
@@ -25,42 +25,41 @@ use mro                            qw/c3/;
 use namespace::clean;
 
 
-my $spec = {
-  dbh                   => {type => OBJECT|ARRAYREF, optional => 1},
-  debug                 => {type => OBJECT|SCALAR,   optional => 1},
-  sql_abstract          => {type => OBJECT,
-                            isa  => 'SQL::Abstract::More',
-                            optional => 1},
-  dbi_prepare_method    => {type => SCALAR,   default  => 'prepare'},
-  placeholder_prefix    => {type => SCALAR,   default  => '?:'},
-  select_implicitly_for => {type => SCALAR,   default  => ''},
-  autolimit_firstrow    => {type => BOOLEAN,  optional => 1},
-  db_schema             => {type => SCALAR,   optional => 1},
-  resultAs_classes      => {type => ARRAYREF, optional => 1},
+my $schema_attributes_spec = {
+  dbh                   => {type => OBJECT|ARRAYREF, optional => 1                                        },
+  debug                 => {type => OBJECT|SCALAR,   optional => 1                                        },
+  sql_abstract          => {type => OBJECT,          optional => 1,         isa   => 'SQL::Abstract::More'},
+  dbi_prepare_method    => {type => SCALAR,          default  => 'prepare'                                },
+  placeholder_prefix    => {type => SCALAR,          default  => '?:'                                     },
+  select_implicitly_for => {type => SCALAR,          default  => ''                                       },
+  autolimit_firstrow    => {type => BOOLEAN,         optional => 1                                        },
+  db_schema             => {type => SCALAR,          optional => 1                                        },
+  resultAs_classes      => {type => ARRAYREF,        optional => 1                                        },
+  handleError_policy    => {type => SCALAR,          default  => 'combine', regex => qr(^(if_absent
+                                                                                         |combine
+                                                                                         |override
+                                                                                         |none)$)x        },
 };
 
 
-
 sub new {
   my $class = shift;
 
-  my $metadm = $class->metadm;
+  my %args = @_;
+  my $dbh = delete $args{dbh}; # this arg needs special treatment
 
+  # setup metaclass
+  my $metadm = $class->metadm;
   not $metadm->{singleton}
     or croak "$class is already used in single-schema mode, can't call new()";
 
-  # validate params
-  my %params = validate_with(
-    params      => \@_,
-    spec        => $spec,
+  # validate params and create $self
+  my $self = validate_with(
+    params      => [%args],
+    spec        => $schema_attributes_spec,
     allow_extra => 0,
    );
-
-  # instantiate and call 'setter' methods for %params
-  my $self = bless {}, $class;
-  while (my ($method, $arg) = each %params) {
-    $self->$method($arg);
-  }
+  bless $self, $class;
 
   # default SQLA
   $self->{sql_abstract} ||= $metadm->sql_abstract_class->new($metadm->sql_abstract_args);
@@ -71,10 +70,35 @@ sub new {
   # from now on, singleton mode will be forbidden
   $metadm->{singleton} = undef;
 
+  # initial dbh if it was passed within %args;
+  $self->dbh($dbh) if $dbh;
+
   return $self;
 }
 
 
+# install simple-minded rw accessors for schema attributes
+foreach my $accessor (grep {$_ ne 'dbh'} keys %$schema_attributes_spec) {
+  no strict 'refs';
+  *$accessor = sub {
+    my $self = shift;
+    ref $self or $self = $self->singleton;
+
+    if (@_) {
+      my ($new_val) = validate_with(params      => \@_,
+                                    spec        => [ $schema_attributes_spec->{$accessor} ],
+                                    allow_extra => 0);
+      $self->{$accessor} = $new_val;
+    }
+    return $self->{$accessor};
+  };
+}
+
+
+
+
+
+
 # proxy methods, forwarded to the meta-schema
 foreach my $method (qw/Table View Association Composition Type/) {
   no strict 'refs';
@@ -135,6 +159,22 @@ sub dbh {
       $dbh->{RaiseError} 
         or croak "arg to dbh(..) must have RaiseError=1";
 
+      # install a HandleError attribute so that error reporting goes through Carp::Clan
+      my $HE_policy = $self->handleError_policy;
+      if ($HE_policy ne 'none') {
+        my $prev_handler   = $dbh->{HandleError}; # see L<DBI/HandleError>
+
+        my $should_install = !$prev_handler || ($HE_policy eq 'combine' || $HE_policy eq 'override');
+        $should_install  &&= 0 if ($prev_handler || -1) == ($dbh->{private_dbix_datamodel_handle_error} || -2);
+        if ($should_install) {
+          my $new_handler = $prev_handler && $HE_policy eq 'combine'   ? sub {my $was_handled = $prev_handler->(@_);
+                                                                              croak shift unless $was_handled}
+                                                                       : sub {croak shift};
+          $dbh->{HandleError} = $new_handler;
+          $dbh->{private_dbix_datamodel_handle_error} = $new_handler;
+        }
+      }
+
       # default values for $dbh_options{returning_through}
       if (not exists $dbh_options{returning_through}) {
         for ($dbh->{Driver}{Name}) {
@@ -158,24 +198,6 @@ sub dbh {
 
 
 
-# some rw setters/getters
-my @accessors = qw/debug select_implicitly_for dbi_prepare_method 
-                   sql_abstract placeholder_prefix autolimit_firstrow
-                   db_schema resultAs_classes/;
-foreach my $accessor (@accessors) {
-  no strict 'refs';
-  *$accessor = sub {
-    my $self = shift;
-    ref $self or $self = $self->singleton;
-
-    if (@_) {
-      $self->{$accessor} = shift;
-    }
-    return $self->{$accessor};
-  };
-}
-
-
 sub with_db_schema {
   my ($self, $db_schema) = @_;
   ref $self or $self = $self->singleton;
@@ -386,12 +408,12 @@ sub DESTROY { # called when the guard goes out of scope
   my ($schema, $previous_state) = @$self;
 
   # must cleanup dbh so that ->dbh(..) does not complain if in a transaction
-  if (exists $previous_state->{dbh}) {
-    delete $schema->{dbh};
-  }
-
+  delete $schema->{dbh} if exists $previous_state->{dbh};
+
   # invoke "setter" method on each state component
-  $schema->$_($previous_state->{$_}) foreach keys %$previous_state;
+  while (my ($k, $v) = each %$previous_state) {
+    $schema->$k($v) if $v;
+  }
 }
 
 

diff --git a/lib/DBIx/DataModel/Statement.pm b/lib/DBIx/DataModel/Statement.pm
@@ -346,14 +346,15 @@ sub prepare {
   # log the statement and bind values
   $self->schema->_debug("PREPARE $self->{sql} / @{$self->{bound_params}}");
 
-  # call the database
+  # assemble stuff for calling the database
   my $dbh          = $self->schema->dbh or croak "Schema has no dbh";
-  my $method       = $self->{args}{-dbi_prepare_method}
-                  || $self->schema->dbi_prepare_method;
+  my $method       = $self->{args}{-dbi_prepare_method}  || $self->schema->dbi_prepare_method;
   my @prepare_args = ($self->{sql});
   if (my $prepare_attrs = $self->{args}{-prepare_attrs}) {
     push @prepare_args, $prepare_attrs;
   }
+
+  # call the database
   $self->{sth}  = $dbh->$method(@prepare_args);
 
   # new status and return
@@ -362,6 +363,7 @@ sub prepare {
 }
 
 
+
 sub sth {
   my ($self) = @_;
 

diff --git a/t/v3_error_handler.t b/t/v3_error_handler.t
@@ -0,0 +1,63 @@
+use strict;
+use warnings;
+use SQL::Abstract::Test import => [qw/is_same_sql_bind/];
+use DBI;
+use DBIx::DataModel;
+use Test::More;
+
+my $schema = DBIx::DataModel->Schema('SCH')->Table(Foo => foo => qw/foo_id/);
+
+# default policy : 'if_absent' without previous handler
+refresh_dbh();
+like error_msg(), qr/\bat\b.*?v3_error_handler.t/,          "'if_absent' (default) without previous handler";
+
+# 'if_absent' policy with previous handler
+refresh_dbh(sub {die "Previous handler"});
+like error_msg(), qr/Previous/,                             "'if_absent' (default) with previous handler";
+
+# 'none' policy
+$schema->handleError_policy('none');
+refresh_dbh();
+like error_msg(), qr/\bat\b.*?Statement.pm/,                "'none' : no handler installed";
+
+# 'override' policy
+$schema->handleError_policy('override');
+refresh_dbh(sub {die "Previous handler"});
+my $msg = error_msg();
+unlike $msg, qr/Previous/,                                  "'override' with previous handler - previous handler not called";
+like   $msg, qr/\bat\b.*?v3_error_handler.t/,               "'override' with previous handler - new handler installed";
+refresh_dbh();
+like error_msg(), qr/\bat\b.*?v3_error_handler.t/,          "'override' without previous handler";
+
+# 'combine' policy
+$schema->handleError_policy('combine');
+refresh_dbh();
+like error_msg(), qr/\bat\b.*?v3_error_handler.t/,          "'combine', no previous handler";
+refresh_dbh(sub {die "Previous handler"});
+like error_msg(), qr/Previous.*\bat\b.*v3_error_handler.t/, "'combine' with previous handler";
+
+# repeated calls to 'combine'
+my $previous_dbh     = $schema->dbh;
+my $previous_handler = $previous_dbh->{HandleError};
+refresh_dbh();
+$schema->dbh($previous_dbh);
+is $schema->dbh->{HandleError}, $previous_handler,          "'combine' with previous handler already installed by DBIDM";
+
+
+done_testing;
+
+
+sub refresh_dbh  {
+  my ($handler) = @_;
+  my $dbh = DBI->connect('dbi:SQLite:dbname=:memory:', '', '', {RaiseError => 1, AutoCommit => 1});
+  $dbh->{HandleError} = $handler if $handler;
+  $schema->dbh($dbh);
+}
+
+sub error_msg {
+  eval {$schema->table('Foo')->select(-columns => [qw/Foo Bar/]) };
+  my $err = $@;
+  # note $err;
+  return $err;
+}
+