v3.11 replace Carp::Clan by Carp::Object

Build.PL

@@ -11,7 +11,7 @@ my $builder = Module::Build->new(
     requires => {
         'perl'                   => 5.010,
         'version'                => 0,
-        'Carp::Clan'             => 0,
+        'Carp::Object'           => 0,
         'Clone'                  => 0,
         'DBI'                    => 0,
         'SQL::Abstract::Classic' => 1.91,

Changes

@@ -1,5 +1,14 @@
 Revision history for Perl extension DBIx::DataModel.
 
+v3.11 28.04.2024
+  - Carp::Clan replaced by Carp::Object
+  - new Schema attribute: 'frame_filter' (to be transmitted to Devel::StackTrace)
+  - new Schema attribute: 'auto_show_error_statement'
+  - $dbh->{ShowErrorStatement} is automatically turned on by default
+  - more precise multiplicity rules for Compositions
+      - the composite multiplicity must be 1..1     (previously 0..1 was incorrectly allowed)
+      - the component multiplicity must not be 1..1 (previously 0..1 was incorrectly forbidden)
+
 v3.10 11.03.2024
   - bug fix : schema attribute setters must accept undef (for erasing the attribute)
   - added tests for the debug() method

lib/DBIx/DataModel.pm

@@ -9,9 +9,8 @@ use strict;
 use version;
 use MRO::Compat;
 use DBIx::DataModel::Meta::Utils qw/does/;
-use Carp::Clan qw[^(DBIx::DataModel::|SQL::Abstract)];
 
-our $VERSION = '3.10';
+our $VERSION = '3.11';
 
 # compatibility setting : see import()
 our $COMPATIBILITY = $VERSION; # from 2.20, no longer automatic compatibility

lib/DBIx/DataModel/Compatibility/V1.pm

@@ -147,7 +147,7 @@ package DBIx::DataModel::Schema;
 use strict;
 use warnings;
 no warnings 'redefine';
-use Carp;
+use DBIx::DataModel::Carp;
 
 
 *_createPackage  = \&DBIx::DataModel::Meta::Utils::define_class;
@@ -236,7 +236,7 @@ package DBIx::DataModel::Source;
 use strict;
 use warnings;
 no warnings 'redefine';
-use Carp;
+use DBIx::DataModel::Carp;
 
 *primKey        = \&primary_key;
 
@@ -376,7 +376,7 @@ package DBIx::DataModel::Statement;
 use strict;
 use warnings;
 no warnings 'redefine';
-use Carp;
+use DBIx::DataModel::Carp;
 use Scalar::Util qw/reftype/;
 
 my $orig_refine = \&refine;
@@ -429,7 +429,7 @@ package DBIx::DataModel::Statement::JDBC;
 use strict;
 use warnings;
 no warnings 'redefine';
-use Carp;
+use DBIx::DataModel::Carp;
 
 *{rowCount}       = \&row_count;
 

lib/DBIx/DataModel/Doc/Reference.pod

@@ -1278,6 +1278,25 @@ For a I<temporary> change of database schema,
 see method L<with_db_schema()> below.
 
 
+=head3 auto_show_error_statement()
+
+Boolean flag to decide if the schema should automatically turn on the C<ShowErrorStatement>
+attribute in C<$dbh> handles supplied through the dbh() method. Some drivers (for example
+Oracle) already turn it on automatically, others do not. Having the flag on is generally useful
+for understanding errors generated by the DBI layer, therefore its default value is true.
+It can be avoided by explicitly setting C<auto_show_error_statement> to a false value.
+
+=head3 frame_filter()
+
+Optional coderef to be passed to L<Devel::StackTrace> for filtering out some stack
+frames while reporting errors. Packages in DBIx::Datamodel::* and SQL::Abstract::* namespaces
+are already filtered out, but client applications may have additional layers to filter, like
+for example L<DBI::RetryOverDisconnects> or L<DBIx::Connector>.
+
+The filtering coderef will receive as single argument a hashref with keys C<caller> and C<args> --
+see L<Devel::StrackTrace/Devel::StackTrace->new(%named_params)>.
+
+
 =head3 handleError_policy()
 
   $schema->handleError_policy('none'); # default is 'combine'

lib/DBIx/DataModel/Meta/Association.pm

@@ -4,8 +4,11 @@ use warnings;
 use parent "DBIx::DataModel::Meta";
 use DBIx::DataModel;
 use DBIx::DataModel::Meta::Utils qw/define_method define_readonly_accessors/;
+use DBIx::DataModel::Carp;
+# use Carp::Clan qw(^(DBIx::DataModel|SQL::Abstract));
+
+
 
-use Carp::Clan       qw[^(DBIx::DataModel::|SQL::Abstract)];
 use Params::Validate qw/validate_with SCALAR ARRAYREF HASHREF OBJECT UNDEF/;
 use List::MoreUtils  qw/pairwise/;
 use Scalar::Util     qw/weaken dualvar looks_like_number/;
@@ -225,10 +228,11 @@ sub _check_composition {
   my $self = shift;
 
   # multiplicities must be 1-to-n
-  $self->{A}{multiplicity}[1] == 1
-    or croak "max multiplicity of first class in a composition must be 1";
-  $self->{B}{multiplicity}[0] == 0
-    or croak "min multiplicity of second class in a composition must be 0";
+  my $msg = "Composition([$self->{A}{table}{name} ..], [$self->{B}{table}{name} ..])";
+  $self->_multiplicity_is_exactly_1('A')
+    or croak "$msg: $self->{A}{table}{name} must have multiplicity 1..1";
+  ! $self->_multiplicity_is_exactly_1('B')
+    or croak "$msg: $self->{B}{table}{name} must not have multiplicity 1..1";
 
   # check for conflicting compositions
   while (my ($name, $path) = each %{$self->{B}{table}{path} || {}}) {
@@ -241,6 +245,14 @@ sub _check_composition {
   }
 }
 
+sub _multiplicity_is_exactly_1 {
+  my ($self, $end) = @_;
+  my $mult = $self->{$end}{multiplicity};
+
+  return $mult->[0] == 1 && $mult->[1] == 1;
+}
+
+
 
 1;
 

lib/DBIx/DataModel/Meta/Path.pm

@@ -4,10 +4,10 @@ use warnings;
 use parent "DBIx::DataModel::Meta";
 use DBIx::DataModel;
 use DBIx::DataModel::Meta::Utils qw/define_readonly_accessors/;
+use DBIx::DataModel::Carp;
 
 use Scalar::Util                 qw/looks_like_number weaken/;
 use Params::Validate             qw/validate_with SCALAR HASHREF ARRAYREF OBJECT/;
-use Carp::Clan                   qw[^(DBIx::DataModel::|SQL::Abstract)];
 use namespace::clean;
 
 {no strict 'refs'; *CARP_NOT = \@DBIx::DataModel::CARP_NOT;}
@@ -43,7 +43,7 @@ sub new {
 
   # if this is a composition path, remember it in the 'components' array
   push @{$self->{from}{components}}, $path
-    if $self->{association}{kind} eq 'Composition' && $self->{multiplicity}[0] == 0;
+    if $self->{association}{kind} eq 'Composition' && $self->{direction} eq 'AB';
 
   # install a navigation method into the 'from' table class
   my @navigation_args = ($self->{name},  # method name

lib/DBIx/DataModel/Meta/Schema.pm

@@ -6,13 +6,13 @@ use DBIx::DataModel;
 use DBIx::DataModel::Meta::Utils qw/define_class define_readonly_accessors/;
 use DBIx::DataModel::Source::Join;
 use DBIx::DataModel::Meta::Source::Join;
+use DBIx::DataModel::Carp;
 
 use Params::Validate     qw/validate_with SCALAR ARRAYREF CODEREF UNDEF BOOLEAN
                                           OBJECT HASHREF/;
 use List::MoreUtils      qw/any firstval lastval uniq/;
 use Hash::Util           qw/lock_keys/;
 use Module::Load         qw/load/;
-use Carp::Clan           qw[^(DBIx::DataModel::|SQL::Abstract)];
 use Try::Tiny;
 use mro                  qw/c3/;
 use namespace::clean;

lib/DBIx/DataModel/Meta/Source.pm

@@ -5,11 +5,11 @@ use parent "DBIx::DataModel::Meta";
 use DBIx::DataModel;
 use DBIx::DataModel::Meta::Utils qw/define_class define_readonly_accessors
                                     define_abstract_methods/;
+use DBIx::DataModel::Carp;
 
 use Params::Validate qw/validate_with SCALAR ARRAYREF HASHREF OBJECT/;
 use Scalar::Util     qw/weaken/;
 use List::MoreUtils  qw/any/;
-use Carp::Clan       qw[^(DBIx::DataModel::|SQL::Abstract)];
 
 use namespace::clean;
 

lib/DBIx/DataModel/Meta/Source/Table.pm

@@ -4,9 +4,9 @@ use warnings;
 use parent "DBIx::DataModel::Meta::Source";
 use DBIx::DataModel;
 use DBIx::DataModel::Meta::Utils qw/define_method does/;
+use DBIx::DataModel::Carp;
 use Params::Validate             qw/HASHREF ARRAYREF SCALAR/;
 use List::MoreUtils              qw/any/;
-use Carp::Clan                   qw[^(DBIx::DataModel::|SQL::Abstract)];
 
 use namespace::clean;
 

lib/DBIx/DataModel/Meta/Type.pm

@@ -4,10 +4,10 @@ use warnings;
 use parent "DBIx::DataModel::Meta";
 use DBIx::DataModel;
 use DBIx::DataModel::Meta::Utils qw/define_readonly_accessors does/;
+use DBIx::DataModel::Carp;
 
 use Scalar::Util         qw/weaken/;
 use Params::Validate     qw/validate_with OBJECT SCALAR HASHREF/;
-use Carp::Clan           qw[^(DBIx::DataModel::|SQL::Abstract)];
 use namespace::clean;
 
 {no strict 'refs'; *CARP_NOT = \@DBIx::DataModel::CARP_NOT;}

lib/DBIx/DataModel/Meta/Utils.pm

@@ -5,14 +5,13 @@ use warnings;
 use strict;
 use warnings;
 
-use Carp;
+use DBIx::DataModel::Carp;
 use Module::Load               qw/load/;
 use Params::Validate           qw/validate_with SCALAR ARRAYREF CODEREF
                                                 BOOLEAN OBJECT HASHREF/;
 use List::MoreUtils            qw/any/;
 use mro                        qw/c3/;
 use SQL::Abstract::More 1.39;
-use Carp::Clan                 qw[^(DBIx::DataModel::|SQL::Abstract)];
 
 # utility function 'does' imported by hand because not really meant
 # to be publicly exportable from SQL::Abstract::More

lib/DBIx/DataModel/Schema.pm

@@ -9,35 +9,35 @@ use warnings;
 use strict;
 use DBIx::DataModel::Meta::Utils   qw/does/;
 use DBIx::DataModel::Source::Table;
+use DBIx::DataModel::Carp;
 
 use Scalar::Util                   qw/blessed/;
 use Data::Structure::Util;           # for calling unbless(), fully qualified
 use Module::Load                   qw/load/;
 use Params::Validate               qw/validate_with SCALAR ARRAYREF CODEREF UNDEF
                                                     OBJECT BOOLEAN/;
-
-use Carp::Clan                     qw[^(DBIx::DataModel::|SQL::Abstract)];
-
 use SQL::Abstract::More 1.41;
 use Try::Tiny;
+use Devel::StackTrace;
 use mro                            qw/c3/;
 
 use namespace::clean;
 
-
 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                                        },
-  handleError_policy    => {type => SCALAR,          default  => 'combine', regex => qr(^(if_absent
-                                                                                         |combine
-                                                                                         |override
-                                                                                         |none)$)x        },
+  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                                        },
+  auto_show_error_statement => {type => BOOLEAN,         default  => 1                                        },
+  frame_filter              => {type => CODEREF,         optional => 1                                        },
+  handleError_policy        => {type => SCALAR,          default  => 'combine', regex => qr(^(if_absent
+                                                                                             |combine
+                                                                                             |override
+                                                                                             |none)$)x        },
 };
 
 
@@ -162,20 +162,30 @@ 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;
-        }
+      # set ShowErrorStatement if necessary
+      $dbh->{ShowErrorStatement} or !$self->auto_show_error_statement
+        or $dbh->{ShowErrorStatement} = 1;
+
+      # decide if we should install a HandleError attribute so that error reporting goes through Carp::Object
+      my $HE_policy      = $self->handleError_policy;
+      my $prev_handler   = $dbh->{HandleError};
+      my $should_install = $HE_policy eq 'none'      ? 0
+                         : $HE_policy eq 'if_absent' ? !$prev_handler
+                         : $HE_policy eq 'combine'   ? 1
+                         : $HE_policy eq 'override'  ? 1
+                         : die "unexpected value for 'handleError_policy': $HE_policy";
+
+      # actually, no need to re8install if the previous handler on this $dbh was already installed by the present module
+      $should_install  &&= 0 if ($prev_handler || -1) == ($dbh->{private_dbix_datamodel_handle_error} || -2);      
+
+      # install the handler
+      if ($should_install) {
+        my $must_combine    = $prev_handler && $HE_policy eq 'combine';
+        my $new_handler     = $must_combine ? sub {my $was_handled = $prev_handler->(@_);
+                                                   die $self->_handle_SQL_error(@_) if !$was_handled; }
+                                            : sub {die $self->_handle_SQL_error(@_)};
+        $dbh->{HandleError} = $new_handler;
+        $dbh->{private_dbix_datamodel_handle_error} = $new_handler;
       }
 
       # default values for $dbh_options{returning_through}
@@ -200,6 +210,26 @@ sub dbh {
 }
 
 
+sub _handle_SQL_error {
+  my ($self, $dbi_errstr, $dbh, $unused) = @_;
+
+  # skip intermediate ORM stack frames so that errors are reported from the caller's perspective
+  local %DBIx::DataModel::Carp::CARP_OBJECT_CONSTRUCTOR = (frame_filter => sub {
+    my ($frame_ref) = @_; 
+    my $pkg = $frame_ref->{caller}[0];
+    return 0  if $pkg =~ /^DBIx::DataModel/ or $pkg =~ /^SQL::Abstract/;   # skip packages used by DBIx::DataModel
+    return $self->{frame_filter}->($frame_ref) if $self->{frame_filter};   # skip packages specified by client
+    return 1;                                                              # otherwise, don't skip
+   });
+
+  # clear the DBI error, to make sure that upper levels like DBIx::RetryOverDisconnects will use
+  # our $dbi_errstr and not DBI->errstr
+  $dbh->set_err(undef, "");
+
+  croak $dbi_errstr;
+}
+
+
 
 sub with_db_schema {
   my ($self, $db_schema) = @_;
@@ -433,7 +463,7 @@ use overload '""' => sub {
   my $self = shift;
   my $err             = $self->initial_error;
   my @rollback_errs   = $self->rollback_errors;
-  my $rollback_status = @rollback_errs ? join(", ", @rollback_errs) : "OK";
+  my $rollback_status = @rollback_errs ? CORE::join(", ", @rollback_errs) : "OK";
   return "FAILED TRANSACTION: $err (rollback: $rollback_status)";
 };
 
@@ -529,6 +559,14 @@ Methods implemented in this module :
 
 =item L<autolimit_firstrow|DBIx::DataModel::Doc::Reference/autolimit_firstrow>
 
+=item L<db_schema|DBIx::DataModel::Doc::Reference/db_schema>
+
+=item L<auto_show_error_statement|DBIx::DataModel::Doc::Reference/auto_show_error_statement>
+
+=item L<frame_filter|DBIx::DataModel::Doc::Reference/frame_filter>
+
+=item L<handleError_policy|DBIx::DataModel::Doc::Reference/handleError_policy>
+
 =item L<localize_state|DBIx::DataModel::Doc::Reference/localize_state>
 
 =item L<do_transaction|DBIx::DataModel::Doc::Reference/do_transaction>

lib/DBIx/DataModel/Schema/Generator.pm

@@ -8,13 +8,12 @@ package DBIx::DataModel::Schema::Generator;
 use strict;
 use warnings;
 no warnings 'uninitialized';
-use Carp;
+use DBIx::DataModel::Carp;
 use List::Util   qw/max/;
 use Exporter     qw/import/;
 use DBI;
 use Try::Tiny;
 use Module::Load ();
-use Carp::Clan   qw[^(DBIx::DataModel::|SQL::Abstract)];
 
 
 our @EXPORT = qw/fromDBIxClass fromDBI/;