of SQL::Abstract >= 1.73
* Misc
+ - Rewire all warnings to a new Carp-like implementation internal
+ to DBIx::Class, and remove the Carp::Clan dependency
- Only load Class::C3 and friends if necessary ($] < 5.010)
- Greatly reduced loading of non-essential modules to aid startup
time (mainly benefiting CGI users)
};
my $runtime_requires = {
- 'Carp::Clan' => '6.0',
'Class::Accessor::Grouped' => '0.10002',
'Class::C3::Componentised' => '1.0009',
'Class::Inspector' => '1.24',
|);
no_index package => $_ for (qw/
DBIx::Class::Storage::DBIHacks
+ DBIx::Class::Carp
/);
WriteAll();
use base qw/DBIx::Class::Componentised DBIx::Class::AccessorGroup/;
use DBIx::Class::StartupCheck;
+__PACKAGE__->mk_group_accessors(inherited => '_skip_namespace_frames');
+__PACKAGE__->_skip_namespace_frames('^DBIx::Class|^SQL::Abstract|^Try::Tiny');
+
sub mk_classdata {
shift->mk_classaccessor(@_);
}
# check deps
BEGIN {
- use Carp::Clan qw/^DBIx::Class/;
use DBIx::Class;
- croak('The following modules are required for DBIx::Class::Admin ' . DBIx::Class::Optional::Dependencies->req_missing_for ('admin') )
+ die('The following modules are required for DBIx::Class::Admin ' . DBIx::Class::Optional::Dependencies->req_missing_for ('admin') )
unless DBIx::Class::Optional::Dependencies->req_ok_for ('admin');
}
print "return is $ret\n" if (!$self->quiet);
}
elsif ($schema->get_db_version() and $self->force ) {
- carp "Forcing install may not be a good idea";
+ warn "Forcing install may not be a good idea\n";
if($self->_confirm() ) {
$self->schema->_set_db_version({ version => $version});
}
use strict;
use warnings;
use base qw/DBIx::Class::Core DBIx::Class::DB/;
-use Carp::Clan qw/^DBIx::Class/;
# Modules CDBICompat needs that DBIx::Class does not.
my @Extra_Modules = qw(
for my $module (@Extra_Modules) {
push @didnt_load, $module unless eval qq{require $module};
}
-croak("@{[ join ', ', @didnt_load ]} are missing and are required for CDBICompat")
+__PACKAGE__->throw_exception("@{[ join ', ', @didnt_load ]} are missing and are required for CDBICompat")
if @didnt_load;
--- /dev/null
+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
use base 'Class::C3::Componentised';
use mro 'c3';
-use Carp::Clan qw/^DBIx::Class|^Class::C3::Componentised/;
-use namespace::clean;
-
-
-my $warned;
+use DBIx::Class::Carp '^DBIx::Class|^Class::C3::Componentised';
# this warns of subtle bugs introduced by UTF8Columns hacky handling of store_column
# if and only if it is placed before something overriding store_column
for (qw/DBIx::Class::UTF8Columns DBIx::Class::ForceUTF8/) {
if ($comp->isa ($_) ) {
$keep_checking = 0; # no use to check from this point on
- carp "Use of $_ is strongly discouraged. See documentation of DBIx::Class::UTF8Columns for more info\n"
- unless ($warned->{UTF8Columns}++ || $ENV{DBIC_UTF8COLUMNS_OK});
+ carp_once "Use of $_ is strongly discouraged. See documentation of DBIx::Class::UTF8Columns for more info\n"
+ unless $ENV{DBIC_UTF8COLUMNS_OK};
last;
}
}
use strict;
use warnings;
-use Carp::Clan qw/^DBIx::Class|^Try::Tiny/;
-use Try::Tiny;
-use namespace::clean;
+use DBIx::Class::Carp ();
use overload
'""' => sub { shift->{msg} },
Exception objects of this class are used internally by
the default error handling of L<DBIx::Class::Schema/throw_exception>
-to prevent confusing and/or redundant re-application of L<Carp>'s
-stack trace information.
+and derivatives.
These objects stringify to the contained error message, and use
overload fallback to give natural boolean/numeric values.
code, and shouldn't be used directly elsewhere.
Expects a scalar exception message. The optional argument
-C<$stacktrace> tells it to use L<Carp/longmess> instead of
-L<Carp::Clan/croak>.
+C<$stacktrace> tells it to output a full trace similar to L<Carp/confess>.
DBIx::Class::Exception->throw('Foo');
try { ... } catch { DBIx::Class::Exception->throw(shift) }
# Don't re-encapsulate exception objects of any kind
die $msg if ref($msg);
- # use Carp::Clan's croak if we're not stack tracing
+ # all exceptions include a caller
+ $msg =~ s/\n$//;
+
if(!$stacktrace) {
- try { croak $msg } catch { $msg = shift };
+ # skip all frames that match the original caller, or any of
+ # the dbic-wide classdata patterns
+ my ($ln, $calling) = DBIx::Class::Carp::__find_caller(
+ '^' . caller() . '$',
+ 'DBIx::Class',
+ );
+
+ $msg = "${calling}${msg} ${ln}\n";
}
else {
$msg = Carp::longmess($msg);
use strict;
use warnings;
use base qw/DBIx::Class/;
-use Carp::Clan qw/^DBIx::Class/;
+use DBIx::Class::Carp;
use Try::Tiny;
use namespace::clean;
use File::Path;
use File::Copy;
use Path::Class;
-use Carp::Clan qw/^DBIx::Class/;
+use DBIx::Class::Carp;
use namespace::clean;
carp 'InflateColumn::File has entered a deprecation cycle. This component '
if (keys %errors) {
my $missing = join (', ', map { $deps->{$_} ? "$_ >= $deps->{$_}" : $_ } (sort keys %errors) );
$missing .= " (see $class for details)" if $reqs->{$group}{pod};
+ $missing .= "\n";
$res = {
status => 0,
errorlist => \%errors,
use strict;
use warnings;
-use Carp::Clan qw/^DBIx::Class|^Try::Tiny/;
-use namespace::clean;
+use DBIx::Class::Carp;
our %_pod_inherit_config =
(
use strict;
use warnings;
-use Carp::Clan qw/^DBIx::Class/;
+use DBIx::Class::Carp;
use Try::Tiny;
use namespace::clean;
use strict;
use warnings;
-use Carp::Clan qw/^DBIx::Class/;
+use DBIx::Class::Carp;
use Sub::Name qw/subname/;
use Scalar::Util qw/blessed/;
use strict;
use warnings;
use base qw/DBIx::Class/;
-use Carp::Clan qw/^DBIx::Class/;
+use DBIx::Class::Carp;
use DBIx::Class::Exception;
use DBIx::Class::ResultSetColumn;
use Scalar::Util qw/blessed weaken/;
=cut
-my $callsites_warned;
sub search_rs {
my $self = shift;
} if @_;
if( @_ > 1 and ! $rsrc->result_class->isa('DBIx::Class::CDBICompat') ) {
- # determine callsite obeying Carp::Clan rules (fucking ugly but don't have better ideas)
- my $callsite = do {
- my $w;
- local $SIG{__WARN__} = sub { $w = shift };
- carp;
- $w
- };
- carp 'search( %condition ) is deprecated, use search( \%condition ) instead'
- unless $callsites_warned->{$callsite}++;
+ carp_unique 'search( %condition ) is deprecated, use search( \%condition ) instead';
}
for ($old_where, $call_cond) {
return \%aliased;
}
-my $callsites_warned_ucond;
sub _build_unique_cond {
my ($self, $constraint_name, $extra_cond, $croak_on_null) = @_;
and
my @undefs = grep { ! defined $final_cond->{$_} } (keys %$final_cond)
) {
- my $callsite = do {
- my $w;
- local $SIG{__WARN__} = sub { $w = shift };
- carp;
- $w
- };
-
- carp ( sprintf (
+ carp_unique ( sprintf (
"NULL/undef values supplied for requested unique constraint '%s' (NULL "
. 'values in column(s): %s). This is almost certainly not what you wanted, '
. 'though you can set DBIC_NULLABLE_KEY_NOWARN to disable this warning.',
$constraint_name,
join (', ', map { "'$_'" } @undefs),
- )) unless $callsites_warned_ucond->{$callsite}++;
+ ));
}
return $final_cond;
sub search_like {
my $class = shift;
- carp (
+ carp_unique (
'search_like() is deprecated and will be removed in DBIC version 0.09.'
.' Instead use ->search({ x => { -like => "y%" } })'
.' (note the outer pair of {}s - they are important!)'
# subquery (since a group_by is present)
if (delete $attrs->{distinct}) {
if ($attrs->{group_by}) {
- carp ("Useless use of distinct on a grouped resultset ('distinct' is ignored when a 'group_by' is present)");
+ carp_unique ("Useless use of distinct on a grouped resultset ('distinct' is ignored when a 'group_by' is present)");
}
else {
# distinct affects only the main selection part, not what prefetch may
use warnings;
use base 'DBIx::Class';
-
+use DBIx::Class::Carp;
use DBIx::Class::Exception;
-use Carp::Clan qw/^DBIx::Class/;
-use namespace::clean;
# not importing first() as it will clash with our own method
use List::Util ();
use DBIx::Class::ResultSourceHandle;
use DBIx::Class::Exception;
-use Carp::Clan qw/^DBIx::Class/;
+use DBIx::Class::Carp;
use Try::Tiny;
use List::Util 'first';
use Scalar::Util qw/weaken isweak/;
use base qw/
DBIx::Class::SQLMaker::LimitDialects
SQL::Abstract
- Class::Accessor::Grouped
+ DBIx::Class
/;
use mro 'c3';
use strict;
use warnings;
use Sub::Name 'subname';
-use Carp::Clan qw/^DBIx::Class|^SQL::Abstract|^Try::Tiny/;
+use DBIx::Class::Carp;
+use DBIx::Class::Exception;
use namespace::clean;
__PACKAGE__->mk_group_accessors (simple => qw/quote_char name_sep limit_dialect/);
;
}
+# FIXME when we bring in the storage weaklink, check its schema
+# weaklink and channel through $schema->throw_exception
+sub throw_exception { DBIx::Class::Exception->throw($_[1]) }
+
BEGIN {
# reinstall the belch()/puke() functions of SQL::Abstract with custom versions
- # that use Carp::Clan instead of plain Carp (they do not like each other much)
+ # that use DBIx::Class::Carp/DBIx::Class::Exception instead of plain Carp
no warnings qw/redefine/;
*SQL::Abstract::belch = subname 'SQL::Abstract::belch' => sub (@) {
*SQL::Abstract::puke = subname 'SQL::Abstract::puke' => sub (@) {
my($func) = (caller(1))[3];
- croak "[$func] Fatal: ", @_;
+ __PACKAGE__->throw_exception("[$func] Fatal: " . join ('', @_));
};
# Current SQLA pollutes its namespace - clean for the time being
my $self = shift;
my ($op, $rhs) = splice @_, -2;
if (ref $rhs) {
- croak "-$op takes a single scalar argument (a quotable identifier)";
+ $self->throw_exception("-$op takes a single scalar argument (a quotable identifier)");
}
# in case we are called as a top level special op (no '=')
my $lhs = shift;
my @bind = [
- ($lhs || $self->{_nested_func_lhs} || croak "Unable to find bindtype for -value $rhs"),
+ ($lhs || $self->{_nested_func_lhs} || $self->throw_exception("Unable to find bindtype for -value $rhs") ),
$rhs
];
;
}
-my $callsites_warned;
sub _where_op_NEST {
- # determine callsite obeying Carp::Clan rules (fucking ugly but don't have better ideas)
- my $callsite = do {
- my $w;
- local $SIG{__WARN__} = sub { $w = shift };
- carp;
- $w
- };
-
- carp ("-nest in search conditions is deprecated, you most probably wanted:\n"
+ carp_unique ("-nest in search conditions is deprecated, you most probably wanted:\n"
.q|{..., -and => [ \%cond0, \@cond1, \'cond2', \[ 'cond3', [ col => bind ] ], etc. ], ... }|
- ) unless $callsites_warned->{$callsite}++;
+ );
shift->next::method(@_);
}
$fields = $self->_recurse_fields($fields);
if (defined $offset) {
- croak ('A supplied offset must be a non-negative integer')
+ $self->throw_exception('A supplied offset must be a non-negative integer')
if ( $offset =~ /\D/ or $offset < 0 );
}
$offset ||= 0;
if (defined $limit) {
- croak ('A supplied limit must be a positive integer')
+ $self->throw_exception('A supplied limit must be a positive integer')
if ( $limit =~ /\D/ or $limit <= 0 );
}
elsif ($offset) {
||
do {
my $dialect = $self->limit_dialect
- or croak "Unable to generate SQL-limit - no limit dialect specified on $self, and no emulate_limit method found";
+ or $self->throw_exception( "Unable to generate SQL-limit - no limit dialect specified on $self, and no emulate_limit method found" );
$self->can ("_$dialect")
- or croak (__PACKAGE__ . " does not implement the requested dialect '$dialect'");
+ or $self->throw_exception(__PACKAGE__ . " does not implement the requested dialect '$dialect'");
}
;
};
sub _lock_select {
my ($self, $type) = @_;
- my $sql = $for_syntax->{$type} || croak "Unknown SELECT .. FOR type '$type' requested";
+ my $sql = $for_syntax->{$type} || $self->throw_exception( "Unknown SELECT .. FOR type '$type' requested" );
return " $sql";
}
# there should be only one pair
if (@toomany) {
- croak "Malformed select argument - too many keys in hash: " . join (',', keys %$fields );
+ $self->throw_exception( "Malformed select argument - too many keys in hash: " . join (',', keys %$fields ) );
}
if (lc ($func) eq 'distinct' && ref $args eq 'ARRAY' && @$args > 1) {
- croak (
+ $self->throw_exception (
'The select => { distinct => ... } syntax is not supported for multiple columns.'
.' Instead please use { group_by => [ qw/' . (join ' ', @$args) . '/ ] }'
.' or { select => [ qw/' . (join ' ', @$args) . '/ ], distinct => 1 }'
return $$fields->[0];
}
else {
- croak($ref . qq{ unexpected in _recurse_fields()})
+ $self->throw_exception( $ref . qq{ unexpected in _recurse_fields()} );
}
}
( grep { $_ !~ /^\-/ } keys %$fromspec )
);
- croak "Only one table/as pair expected in from-spec but an exra '$toomuch' key present"
+ $self->throw_exception( "Only one table/as pair expected in from-spec but an exra '$toomuch' key present" )
if defined $toomuch;
($self->_from_chunk_to_sql($table), $self->_quote($as) );
for (keys %$cond) {
my $v = $cond->{$_};
if (ref $v) {
- croak (ref($v) . qq{ reference arguments are not supported in JOINS - try using \"..." instead'})
+ $self->throw_exception (ref($v) . qq{ reference arguments are not supported in JOINS - try using \"..." instead'})
if ref($v) ne 'SCALAR';
$j{$_} = $v;
}
} elsif (ref $cond eq 'ARRAY') {
return join(' OR ', map { $self->_join_condition($_) } @$cond);
} else {
- croak "Can't handle this yet!";
+ die "Can't handle this yet!";
}
}
use warnings;
use strict;
-use Carp::Clan qw/^DBIx::Class|^SQL::Abstract|^Try::Tiny/;
use List::Util 'first';
use namespace::clean;
@order = @$order, last CASE if $ref eq 'ARRAY';
@order = ( $order ), last CASE unless $ref;
@order = ( $$order ), last CASE if $ref eq 'SCALAR';
- croak __PACKAGE__ . ": Unsupported data struct $ref for ORDER BY";
+ $self->throw_exception(__PACKAGE__ . ": Unsupported data struct $ref for ORDER BY");
}
my ( $order_by_up, $order_by_down );
foreach my $spec ( @order )
{
my @spec = split ' ', $spec;
- croak( "bad column order spec: $spec" ) if @spec > 2;
+ $self->throw_exception("bad column order spec: $spec") if @spec > 2;
push( @spec, 'ASC' ) unless @spec == 2;
my ( $col, $up ) = @spec; # or maybe down
$up = uc( $up );
- croak( "bad direction: $up" ) unless $up =~ /^(?:ASC|DESC)$/;
+ $self->throw_exception("bad direction: $up") unless $up =~ /^(?:ASC|DESC)$/;
$order_by_up .= ", $col $up";
my $down = $up eq 'ASC' ? 'DESC' : 'ASC';
$order_by_down .= ", $col $down";
# mangle the input sql as we will be replacing the selector
$sql =~ s/^ \s* SELECT \s+ .+? \s+ (?= \b FROM \b )//ix
- or croak "Unrecognizable SELECT: $sql";
+ or $self->throw_exception("Unrecognizable SELECT: $sql");
# get selectors, and scan the order_by (if any)
my ($in_sel, $out_sel, $alias_map, $extra_order_sel)
my ($self, $sql, $rs_attrs, $rows, $offset) = @_;
$sql =~ s/^ \s* SELECT \s+ //ix
- or croak "Unrecognizable SELECT: $sql";
+ or $self->throw_exception("Unrecognizable SELECT: $sql");
return sprintf ('SELECT %s%s%s%s',
$offset
my ($self, $sql, $rs_attrs, $rows, $offset) = @_;
$sql =~ s/^ \s* SELECT \s+ //ix
- or croak "Unrecognizable SELECT: $sql";
+ or $self->throw_exception("Unrecognizable SELECT: $sql");
return sprintf ('SELECT %s%s%s%s',
sprintf ('FIRST %u ', $rows),
# mangle the input sql as we will be replacing the selector
$sql =~ s/^ \s* SELECT \s+ .+? \s+ (?= \b FROM \b )//ix
- or croak "Unrecognizable SELECT: $sql";
+ or $self->throw_exception("Unrecognizable SELECT: $sql");
my ($insel, $outsel) = $self->_subqueried_limit_attrs ($rs_attrs);
# mangle the input sql as we will be replacing the selector
$sql =~ s/^ \s* SELECT \s+ .+? \s+ (?= \b FROM \b )//ix
- or croak "Unrecognizable SELECT: $sql";
+ or $self->throw_exception("Unrecognizable SELECT: $sql");
# get selectors
my ($in_sel, $out_sel, $alias_map, $extra_order_sel)
# mangle the input sql as we will be replacing the selector
$sql =~ s/^ \s* SELECT \s+ .+? \s+ (?= \b FROM \b )//ix
- or croak "Unrecognizable SELECT: $sql";
+ or $self->throw_exception("Unrecognizable SELECT: $sql");
my ($order_by, @rest) = do {
local $self->{quote_char};
( ref $order_by eq 'ARRAY' and @$order_by == 1 )
)
) {
- croak (
+ $self->throw_exception (
'Generic Subquery Limit does not work on resultsets without an order, or resultsets '
. 'with complex order criteria (multicolumn and/or functions). Provide a single, '
. 'unique-column order criteria.'
$rs_attrs->{from}, [$order_by, $unq_sort_col]
);
- my $ord_colinfo = $inf->{$order_by} || croak "Unable to determine source of order-criteria '$order_by'";
+ my $ord_colinfo = $inf->{$order_by} || $self->throw_exception("Unable to determine source of order-criteria '$order_by'");
if ($ord_colinfo->{-result_source}->name ne $root_tbl_name) {
- croak "Generic Subquery Limit order criteria can be only based on the root-source '"
- . $root_rsrc->source_name . "' (aliased as '$rs_attrs->{alias}')";
+ $self->throw_exception(sprintf
+ "Generic Subquery Limit order criteria can be only based on the root-source '%s'"
+ . " (aliased as '%s')", $root_rsrc->source_name, $rs_attrs->{alias},
+ );
}
# make sure order column is qualified
last;
}
}
- croak "Generic Subquery Limit order criteria column '$order_by' must be unique (no unique constraint found)"
- unless $is_u;
+ $self->throw_exception(
+ "Generic Subquery Limit order criteria column '$order_by' must be unique (no unique constraint found)"
+ ) unless $is_u;
my ($in_sel, $out_sel, $alias_map, $extra_order_sel)
= $self->_subqueried_limit_attrs ($rs_attrs);
sub _subqueried_limit_attrs {
my ($self, $rs_attrs) = @_;
- croak 'Limit dialect implementation usable only in the context of DBIC (missing $rs_attrs)'
- unless ref ($rs_attrs) eq 'HASH';
+ $self->throw_exception(
+ 'Limit dialect implementation usable only in the context of DBIC (missing $rs_attrs)'
+ ) unless ref ($rs_attrs) eq 'HASH';
my ($re_sep, $re_alias) = map { quotemeta $_ } ( $self->{name_sep}, $rs_attrs->{alias} );
||
$rs_attrs->{as}[$i]
||
- croak "Select argument $i ($s) without corresponding 'as'"
+ $self->throw_exception("Select argument $i ($s) without corresponding 'as'")
,
};
DBIx::Class::SQLMaker::MySQL;
use base qw( DBIx::Class::SQLMaker );
-use Carp::Clan qw/^DBIx::Class|^SQL::Abstract/;
-use namespace::clean;
#
# MySQL does not understand the standard INSERT INTO $table DEFAULT VALUES
sub _lock_select {
my ($self, $type) = @_;
- my $sql = $for_syntax->{$type} || croak "Unknown SELECT .. FOR type '$type' requested";
+ my $sql = $for_syntax->{$type}
+ || $self->throw_exception("Unknown SELECT .. FOR type '$type' requested");
return " $sql";
}
use strict;
use base qw( DBIx::Class::SQLMaker );
-use Carp::Clan qw/^DBIx::Class|^SQL::Abstract/;
-use namespace::clean;
BEGIN {
use DBIx::Class::Optional::Dependencies;
- croak('The following extra modules are required for Oracle-based Storages ' . DBIx::Class::Optional::Dependencies->req_missing_for ('id_shortener') )
+ die('The following extra modules are required for Oracle-based Storages ' . DBIx::Class::Optional::Dependencies->req_missing_for ('id_shortener') . "\n" )
unless DBIx::Class::Optional::Dependencies->req_ok_for ('id_shortener');
}
return $to_shorten
if length($to_shorten) <= $max_len;
- croak 'keywords needs to be an arrayref'
+ $self->throw_exception("'keywords' needs to be an arrayref")
if defined $keywords && ref $keywords ne 'ARRAY';
# if no keywords are passed use the identifier as one
});
my $rc_ref = $options->{returning_container}
- or croak ('No returning container supplied for IR values');
+ or $self->throw_exception('No returning container supplied for IR values');
@$rc_ref = (undef) x @f_names;
DBIx::Class::SQLMaker::OracleJoins;
use base qw( DBIx::Class::SQLMaker::Oracle );
-use Carp::Clan qw/^DBIx::Class|^SQL::Abstract/;
-use namespace::clean;
sub select {
my ($self, $table, $fields, $where, $rs_attrs, @rest) = @_;
#TODO: Support full outer joins -- this would happen much earlier in
#the sequence since oracle 8's full outer join syntax is best
#described as INSANE.
- croak "Can't handle full outer joins in Oracle 8 yet!\n"
+ $self->throw_exception("Can't handle full outer joins in Oracle 8 yet!\n")
if $to_jt->{-join_type} =~ /full/i;
$left_join = q{(+)} if $to_jt->{-join_type} =~ /left/i
use warnings;
use DBIx::Class::Exception;
-use Carp::Clan qw/^DBIx::Class|^Try::Tiny/;
+use DBIx::Class::Carp;
use Try::Tiny;
use Scalar::Util 'weaken';
use Sub::Name 'subname';
=back
-Throws an exception. Defaults to using L<Carp::Clan> to report errors from
-user's perspective. See L</exception_action> for details on overriding
+Throws an exception. Obeys the exemption rules of L<DBIx::Class::Carp> to report
+errors from outer-user's perspective. See L</exception_action> for details on overriding
this method's behavior. If L</stacktrace> is turned on, C<throw_exception>'s
default behavior will provide a detailed stack trace.
use warnings;
use base 'DBIx::Class::Schema';
-use Carp::Clan qw/^DBIx::Class/;
+use DBIx::Class::Carp;
use Time::HiRes qw/gettimeofday/;
use Try::Tiny;
use namespace::clean;
# db and schema at same version. do nothing
if ( $db_version eq $self->schema_version ) {
- carp "Upgrade not necessary\n";
+ carp 'Upgrade not necessary';
return;
}
# db and schema at same version. do nothing
if ($db_version eq $target_version) {
- carp "Upgrade not necessary\n";
+ carp 'Upgrade not necessary';
return;
}
$self->create_upgrade_path({ upgrade_file => $upgrade_file });
unless (-f $upgrade_file) {
- carp "Upgrade not possible, no upgrade file found ($upgrade_file), please create one\n";
+ carp "Upgrade not possible, no upgrade file found ($upgrade_file), please create one";
return;
}
if($pversion eq $self->schema_version)
{
-# carp "This version is already installed\n";
+ #carp "This version is already installed";
return 1;
}
if(!$pversion)
{
- carp "Your DB is currently unversioned. Please call upgrade on your schema to sync the DB.\n";
+ carp "Your DB is currently unversioned. Please call upgrade on your schema to sync the DB.";
return 1;
}
carp "Versions out of sync. This is " . $self->schema_version .
- ", your database contains version $pversion, please call upgrade on your Schema.\n";
+ ", your database contains version $pversion, please call upgrade on your Schema.";
}
# is this just a waste of time? if not then merge with DBI.pm
print $file $diff;
close($file);
- carp "WARNING: There may be differences between your DB and your DBIC schema. Please review and if necessary run the SQL in $filename to sync your DB.\n";
+ carp "WARNING: There may be differences between your DB and your DBIC schema. Please review and if necessary run the SQL in $filename to sync your DB.";
}
package DBIx::Class::Serialize::Storable;
use strict;
use warnings;
-use Storable;
-use Carp::Clan qw/^DBIx::Class/;
-use namespace::clean;
+use Storable();
+use DBIx::Class::Carp;
carp 'The Serialize::Storable component is now *DEPRECATED*. It has not '
.'been providing any useful functionality for quite a while, and in fact '
use base qw/DBIx::Class::Storage::DBIHacks DBIx::Class::Storage/;
use mro 'c3';
-use Carp::Clan qw/^DBIx::Class|^Try::Tiny/;
-use DBI;
-use DBIx::Class::Storage::DBI::Cursor;
+use DBIx::Class::Carp;
+use DBIx::Class::Exception;
use Scalar::Util qw/refaddr weaken reftype blessed/;
use List::Util qw/first/;
use Sub::Name 'subname';
try {
if(ref $info[0] eq 'CODE') {
- $dbh = $info[0]->();
+ $dbh = $info[0]->();
}
else {
- $dbh = DBI->connect(@info);
+ require DBI;
+ $dbh = DBI->connect(@info);
}
if (!$dbh) {
else {
# the handler may be invoked by something totally out of
# the scope of DBIC
- croak ("DBI Exception (unhandled by DBIC, ::Schema GCed): $_[0]");
+ DBIx::Class::Exception->throw("DBI Exception (unhandled by DBIC, ::Schema GCed): $_[0]");
}
}, '__DBIC__DBH__ERROR__HANDLER__';
}->($self, $dbh);
use mro 'c3';
use Scalar::Util 'reftype';
use Try::Tiny;
-use Carp::Clan qw/^DBIx::Class/;
+use DBIx::Class::Carp;
use namespace::clean;
__PACKAGE__->mk_group_accessors(simple => qw/
package DBIx::Class::Storage::DBI::Replicated;
BEGIN {
- use Carp::Clan qw/^DBIx::Class/;
use DBIx::Class;
- croak('The following modules are required for Replication ' . DBIx::Class::Optional::Dependencies->req_missing_for ('replicated') )
+ die('The following modules are required for Replication ' . DBIx::Class::Optional::Dependencies->req_missing_for ('replicated') . "\n" )
unless DBIx::Class::Optional::Dependencies->req_ok_for ('replicated');
}
for my $method (@{$method_dispatch->{unimplemented}}) {
__PACKAGE__->meta->add_method($method, sub {
- croak "$method must not be called on ".(blessed shift).' objects';
+ my $self = shift;
+ $self->throw_exception("$method must not be called on ".(blessed $self).' objects');
});
}
use List::Util 'sum';
use Scalar::Util 'reftype';
use DBI ();
-use Carp::Clan qw/^DBIx::Class/;
use MooseX::Types::Moose qw/Num Int ClassName HashRef/;
use DBIx::Class::Storage::DBI::Replicated::Types 'DBICStorageDBI';
use Try::Tiny;
DBIx::Class::Storage::DBI::AutoCast
/;
use mro 'c3';
-use Carp::Clan qw/^DBIx::Class/;
+use DBIx::Class::Carp;
use Scalar::Util 'blessed';
use List::Util 'first';
use Sub::Name();
=cut
-{
- my $old_dbd_warned = 0;
+sub connect_call_datetime_setup {
+ my $self = shift;
+ my $dbh = $self->_get_dbh;
- sub connect_call_datetime_setup {
- my $self = shift;
- my $dbh = $self->_get_dbh;
-
- if ($dbh->can('syb_date_fmt')) {
- # amazingly, this works with FreeTDS
- $dbh->syb_date_fmt('ISO_strict');
- } elsif (not $old_dbd_warned) {
- carp "Your DBD::Sybase is too old to support ".
- "DBIx::Class::InflateColumn::DateTime, please upgrade!";
- $old_dbd_warned = 1;
- }
+ if ($dbh->can('syb_date_fmt')) {
+ # amazingly, this works with FreeTDS
+ $dbh->syb_date_fmt('ISO_strict');
+ }
+ else {
+ carp_once
+ 'Your DBD::Sybase is too old to support '
+ .'DBIx::Class::InflateColumn::DateTime, please upgrade!';
$dbh->do('SET DATEFORMAT mdy');
-
1;
}
}
use strict;
use warnings;
-use Carp::Clan qw/^DBIx::Class/;
-use namespace::clean;
+use DBIx::Class::Carp;
carp 'Setting of storage_type is redundant as connections through DBD::Sybase'
.' are now properly recognized and reblessed into the appropriate subclass'
/;
use mro 'c3';
-use Carp::Clan qw/^DBIx::Class/;
-use namespace::clean;
+use DBIx::Class::Carp;
__PACKAGE__->datetime_parser_type(
'DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server::DateTime::Format'
=cut
-{
- my $old_dbd_warned = 0;
-
- sub connect_call_datetime_setup {
- my $self = shift;
- my $dbh = $self->_get_dbh;
-
- if ($dbh->can('syb_date_fmt')) {
- # amazingly, this works with FreeTDS
- $dbh->syb_date_fmt('ISO_strict');
- } elsif (not $old_dbd_warned) {
- carp "Your DBD::Sybase is too old to support ".
- "DBIx::Class::InflateColumn::DateTime, please upgrade!";
- $old_dbd_warned = 1;
- }
+sub connect_call_datetime_setup {
+ my $self = shift;
+ my $dbh = $self->_get_dbh;
+
+ if ($dbh->can('syb_date_fmt')) {
+ # amazingly, this works with FreeTDS
+ $dbh->syb_date_fmt('ISO_strict');
+ }
+ else{
+ carp_once
+ 'Your DBD::Sybase is too old to support '
+ . 'DBIx::Class::InflateColumn::DateTime, please upgrade!';
}
}
use base 'DBIx::Class::Storage';
use mro 'c3';
-use Carp::Clan qw/^DBIx::Class/;
use List::Util 'first';
use Scalar::Util 'blessed';
use namespace::clean;
use strict;
use warnings;
-use Carp::Clan qw/^DBIx::Class/;
use Try::Tiny;
use Scalar::Util qw/weaken blessed/;
use DBIx::Class::Exception;
+use DBIx::Class::Carp;
# temporary until we fix the $@ issue in core
# we also need a real appendable, stackable exception object
use Exporter;
use SQL::Translator::Utils qw(debug normalize_name);
-use Carp::Clan qw/^SQL::Translator|^DBIx::Class|^Try::Tiny/;
+use DBIx::Class::Carp qw/^SQL::Translator|^DBIx::Class|^Try::Tiny/;
+use DBIx::Class::Exception;
use Scalar::Util qw/weaken blessed/;
use Try::Tiny;
use namespace::clean;
$dbicschema ||= $args->{'package'};
my $limit_sources = $args->{'sources'};
- croak 'No DBIx::Class::Schema' unless ($dbicschema);
+ DBIx::Class::Exception->throw('No DBIx::Class::Schema') unless ($dbicschema);
if (!ref $dbicschema) {
eval "require $dbicschema"
- or croak "Can't load $dbicschema: $@";
+ or DBIx::Class::Exception->throw("Can't load $dbicschema: $@");
}
my $schema = $tr->schema;
Hash::Merge
DBI
+ SQL::Abstract
Carp
- Carp::Clan
Class::Accessor::Grouped
Class::C3::Componentised
-
- SQL::Abstract
/, $] < 5.010 ? 'MRO::Compat' : () };
$test_hook = sub {
my $gv = svref_2object($all_method_like{$name})->GV;
my $origin = $gv->STASH->NAME;
- next if $seen->{"${origin}:${name}"}++;
-
TODO: {
local $TODO = 'CAG does not clean its BEGIN constants' if $name =~ /^__CAG_/;
- is ($gv->NAME, $name, "Properly named $name method at $origin");
+ is ($gv->NAME, $name, "Properly named $name method at $origin" . ($origin eq $mod
+ ? ''
+ : " (inherited by $mod)"
+ ));
}
+ next if $seen->{"${origin}:${name}"}++;
+
if ($origin eq $mod) {
pass ("$name is a native $mod method");
}
);
}
}
+
+ # some common import names (these should never ever be methods)
+ for my $f (qw/carp carp_once carp_unique croak confess cluck try catch finally/) {
+ if ($mod->can($f)) {
+ my $via;
+ for (reverse @{mro::get_linear_isa($mod)} ) {
+ if ( ($_->can($f)||'') eq $all_method_like{$f} ) {
+ $via = $_;
+ last;
+ }
+ }
+ fail ("Import $f leaked into method list of ${mod}, appears to have entered inheritance chain at "
+ . ($via || 'UNKNOWN')
+ );
+ }
+ else {
+ pass ("Import $f not leaked into method list of $mod");
+ }
+ }
}
}
'no spurious warnings issued',
);
+warnings_like (
+ sub {
+ package A::Test1Loud;
+ use base 'DBIx::Class::Core';
+ __PACKAGE__->load_components(qw(Core +A::Comp Ordered UTF8Columns));
+ __PACKAGE__->load_components(qw(Ordered +A::SubComp Row UTF8Columns Core));
+ sub store_column { shift->next::method (@_) };
+ 1;
+ },
+ [qr/Use of DBIx::Class::UTF8Columns is strongly discouraged/],
+ 'issued deprecation warning',
+);
+
+
my $test1_mro;
my $idx = 0;
for (@{mro::get_linear_isa ('A::Test1')} ) {
# attempt v1 -> v3 upgrade
{
- local $SIG{__WARN__} = sub { warn if $_[0] !~ /Attempting upgrade\.$/ };
+ local $SIG{__WARN__} = sub { warn $_[0] if $_[0] !~ /Attempting upgrade\.$/ };
$schema_v3->upgrade();
is($schema_v3->get_db_version(), '3.0', 'db version number upgraded');
}
# Then attempt v1 -> v3 upgrade
{
- local $SIG{__WARN__} = sub { warn if $_[0] !~ /Attempting upgrade\.$/ };
+ local $SIG{__WARN__} = sub { warn $_[0] if $_[0] !~ /Attempting upgrade\.$/ };
$schema_v3->upgrade();
is($schema_v3->get_db_version(), '3.0', 'db version number upgraded to 3.0');
$schema_v2->deploy;
}
- local $SIG{__WARN__} = sub { warn if $_[0] !~ /Attempting upgrade\.$/ };
+ local $SIG{__WARN__} = sub { warn $_[0] if $_[0] !~ /Attempting upgrade\.$/ };
$schema_v2->upgrade();
is($schema_v2->get_db_version(), '3.0', 'Fast deploy/upgrade');
for ($db_file, "${db_file}-journal") {
next unless -e $_;
unlink ($_) or carp (
- "Unable to unlink existing test database file $_ ($!), creation of fresh database / further tests may fail!\n"
+ "Unable to unlink existing test database file $_ ($!), creation of fresh database / further tests may fail!"
);
}
}
use lib qw(t/lib);
-use DBIx::Class::SQLMaker::OracleJoins;
use DBICTest;
+use DBIx::Class::SQLMaker::OracleJoins;
use DBIC::SqlMakerTest;
my $sa = DBIx::Class::SQLMaker::OracleJoins->new;
mk_classaccessor
/]
},
+ 'DBIx::Class::Carp' => {
+ ignore => [qw/
+ unimport
+ /]
+ },
'DBIx::Class::Row' => {
ignore => [qw/
MULTICREATE_DEBUG
projects / dbsrgits/DBIx-Class.git / commitdiff