X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FCarp.pm;fp=lib%2FDBIx%2FClass%2FCarp.pm;h=e2af539e5b92895f0e5947bf19374ae5a0bab37b;hb=70c288086248e5a4008490df22a56632341f2473;hp=0000000000000000000000000000000000000000;hpb=a1249d49dffc7703374d3ea8aa3637609f21843e;p=dbsrgits%2FDBIx-Class.git

diff --git a/lib/DBIx/Class/Carp.pm b/lib/DBIx/Class/Carp.pm
new file mode 100644
index 0000000..e2af539
--- /dev/null
+++ b/lib/DBIx/Class/Carp.pm
@@ -0,0 +1,154 @@
+package DBIx::Class::Carp;
+
+use strict;
+use warnings;
+
+use Carp ();
+use namespace::clean ();
+
+sub __find_caller {
+  my ($skip_pattern, $class) = @_;
+
+  my $skip_class_data = $class->_skip_namespace_frames
+    if ($class and $class->can('_skip_namespace_frames'));
+
+  $skip_pattern = qr/$skip_pattern|$skip_class_data/
+    if $skip_class_data;
+
+  my $fr_num = 1; # skip us and the calling carp*
+  my @f;
+  while (@f = caller($fr_num++)) {
+    last unless $f[0] =~ $skip_pattern;
+  }
+
+  my ($ln, $calling) = @f # if empty - nothing matched - full stack
+    ? ( "at $f[1] line $f[2]", $f[3] )
+    : ( Carp::longmess(), '{UNKNOWN}' )
+  ;
+
+  return (
+    $ln,
+    $calling =~ /::/ ? "$calling(): " : "$calling: ", # cargo-cult from Carp::Clan
+  );
+};
+
+my $warn = sub {
+  my ($ln, @warn) = @_;
+  @warn = "Warning: something's wrong" unless @warn;
+
+  # back-compat with Carp::Clan - a warning ending with \n does
+  # not include caller info
+  warn (
+    @warn,
+    $warn[-1] =~ /\n$/ ? '' : " $ln\n"
+  );
+};
+
+sub import {
+  my (undef, $skip_pattern) = @_;
+  my $into = caller;
+
+  $skip_pattern = $skip_pattern
+    ? qr/ ^ $into $ | $skip_pattern /xo
+    : qr/ ^ $into $ /xo
+  ;
+
+  no strict 'refs';
+
+  *{"${into}::carp"} = sub {
+    $warn->(
+      __find_caller($skip_pattern, $into),
+      @_
+    );
+  };
+
+  my $fired;
+  *{"${into}::carp_once"} = sub {
+    return if $fired;
+    $fired = 1;
+
+    $warn->(
+      __find_caller($skip_pattern, $into),
+      @_,
+    );
+  };
+
+  my $seen;
+  *{"${into}::carp_unique"} = sub {
+    my ($ln, $calling) = __find_caller($skip_pattern, $into);
+    my $msg = join ('', $calling, @_);
+
+    # unique carping with a hidden caller makes no sense
+    $msg =~ s/\n+$//;
+
+    return if $seen->{$ln}{$msg};
+    $seen->{$ln}{$msg} = 1;
+
+    $warn->(
+      $ln,
+      $msg,
+    );
+  };
+
+  # cleanup after ourselves
+  namespace::clean->import(-cleanee => $into, qw/carp carp_once carp_unique/);
+}
+
+sub unimport {
+  die (__PACKAGE__ . " does not implement unimport yet\n");
+}
+
+1;
+
+=head1 NAME
+
+DBIx::Class::Carp - Provides advanced Carp::Clan-like warning functions for DBIx::Class internals
+
+=head1 DESCRIPTION
+
+Documentation is lacking on purpose - this an experiment not yet fit for
+mass consumption. If you use this do not count on any kind of stability,
+in fact don't even count on this module's continuing existence (it has
+been noindexed for a reason).
+
+In addition to the classic interface:
+
+  use DBIx::Class::Carp '^DBIx::Class'
+
+this module also supports a class-data based way to specify the exclusion
+regex. A message is only carped from a callsite that matches neither the
+closed over string, nor the value of L</_skip_namespace_frames> as declared
+on the B<first> callframe origin.
+
+=head1 CLASS ATTRIBUTES
+
+=head2 _skip_namespace_frames
+
+A classdata attribute holding the stringified regex matching callsites that
+should be skipped by the carp methods below. An empty string C<q{}> is treated
+like no setting/C<undef> (the distinction is necessary due to semantics of the
+class data accessors provided by L<Class::Accessor::Grouped>)
+
+=head1 EXPORTED FUNCTIONS
+
+This module export the following 3 functions. Only warning related C<carp*>
+is being handled here, for C<croak>-ing you must use
+L<DBIx::Class::Schema/throw_exception> or L<DBIx::Class::Exception>.
+
+=head2 carp
+
+Carps message with the file/line of the first callsite not matching
+L</_skip_namespace_frames> nor the closed-over arguments to
+C<use DBIx::Class::Carp>.
+
+=head2 carp_unique
+
+Like L</carp> but warns once for every distinct callsite (subject to the
+same ruleset as L</carp>).
+
+=head2 carp_once
+
+Like L</carp> but warns only once for the life of the perl interpreter
+(regardless of callsite).
+
+=cut