DBIO
view release on metacpan or search on metacpan
- added the ability to set on_connect_do and the various sql_maker
options as part of Storage::DBI's connect_info.
0.06003 2006-05-19 15:37:30
- make find_or_create_related check defined() instead of truth
- don't unnecessarily fetch rels for cascade_update
- don't set_columns explicitly in update_or_create; instead use
update($hashref) so InflateColumn works
- fix for has_many prefetch with 0 related rows
- make limit error if rows => 0
- added memory cycle tests and a long-needed weaken call
0.06002 2006-04-20 00:42:41
- fix set_from_related to accept undef
- fix to Dumper-induced hash iteration bug
- fix to copy() with non-composed resultsource
- fix to ->search without args to clone rs but maintain cache
- grab $self->dbh once per function in Storage::DBI
- nuke ResultSource caching of ->resultset for consistency reasons
- fix for -and conditions when updating or deleting on a ResultSet
- Fix exception text for nonexistent key in ResultSet::find()
0.05999_04 2006-03-18 19:20:49
- Fix for delete on full-table resultsets
- Removed caching on count() and added _count for pager()
- ->connection does nothing if ->storage defined and no args
(and hence ->connect acts like ->clone under the same conditions)
- Storage::DBI throws better exception if no connect info
- columns_info_for made more robust / informative
- ithreads compat added, fork compat improved
- weaken result_source in all resultsets
- Make pg seq extractor less sensitive.
0.05999_03 2006-03-14 01:58:10
- has_many prefetch fixes
- deploy now adds drop statements before creates
- deploy outputs debugging statements if DBIX_CLASS_STORAGE_DBI_DEBUG
is set
0.05999_02 2006-03-10 13:31:37
- remove test dep on YAML
docs/adr/0033-update-or-create-dwim-splits-unresolvable-relation-subhash.md view on Meta::CPAN
FK-scoped heuristics.
5. **When any relation is split out, the whole operation runs inside a
transaction** (`schema->txn_scope_guard`), so a partially-built graph never
survives a failure — the same guarantee `DBIO::Row::insert` gives multi-create.
The common no-relation case opens no transaction.
## Rationale
The safe-but-unhelpful exception is replaced by the behaviour the caller
actually meant, without weakening `find()`: the complex-condition guard still
fires for a *direct* `find()` with a genuinely crosstable relation sub-hash.
This is an **extension**, not a behaviour break — the exception only disappears
for the mixed-condition `update_or_create` shape, where it was never useful.
Callers relying on the exception from a direct `find()` are unaffected.
Sharing one resolution seam between the guard and the split is the load-bearing
design point: the question "does this relation reduce to plain FK columns on the
main table?" is asked in exactly one place, so `update_or_create`'s DWIM and
`find()`'s guard interpret the *same* resolution result. Each caller interprets
it for itself — the guard rejects, the split peels — but neither re-derives it.
lib/DBIO/Base.pm view on Meta::CPAN
return $class if Scalar::Util::blessed($class);
if (defined $class and ! $successfully_loaded_components->{$class} ) {
$_[0]->ensure_class_loaded($class);
no strict 'refs';
$successfully_loaded_components->{$class}
= ${"${class}::__LOADED__BY__DBIO__CAG__COMPONENT_CLASS__"}
= do { \(my $anon = 'loaded') };
Scalar::Util::weaken($successfully_loaded_components->{$class});
}
$class;
}
sub set_component_class {
shift->set_inherited(@_);
}
__PACKAGE__->mk_group_accessors(inherited => '_skip_namespace_frames');
lib/DBIO/Generate/Relationships.pm view on Meta::CPAN
package DBIO::Generate::Relationships;
# ABSTRACT: Relationship inference for DBIO::Generate
use strict;
use warnings;
use base qw/Class::Accessor::Grouped/;
use mro 'c3';
use Carp::Clan qw/^DBIO/;
use Scalar::Util 'weaken';
use List::Util qw/all any first/;
use Try::Tiny;
use Lingua::EN::Inflect::Phrase ();
use Lingua::EN::Tagger ();
use String::ToIdentifier::EN ();
use String::ToIdentifier::EN::Unicode ();
use namespace::clean;
__PACKAGE__->mk_group_accessors(simple => qw/
inflect_plural
lib/DBIO/PopulateMore.pm view on Meta::CPAN
package DBIO::PopulateMore;
# ABSTRACT: Enhanced populate with cross-source references
use strict;
use warnings;
use Scalar::Util qw(refaddr weaken);
use namespace::clean;
my $MATCH_CONDITION = qr/^!(\w+:.+)$/;
sub populate_more {
my ($self, $arg, @rest) = @_;
$self->throw_exception("Argument is required.")
lib/DBIO/PopulateMore.pm view on Meta::CPAN
if (ref $next && ref $next eq 'HASH') {
push @definitions, $next;
} else {
my $value = shift @args;
push @definitions, { $next => $value };
}
}
my %rs_index;
my %seen;
weaken(my $weak_self = $self);
my $visit;
my $dispatch;
# Visitor: recursively walk data structures, inflating !-prefixed values
$visit = sub {
my ($target) = @_;
if (ref $target eq 'ARRAY') {
my $addr = refaddr $target;
return $seen{$addr} if defined $seen{$addr};
lib/DBIO/Relationship/Base.pm view on Meta::CPAN
package DBIO::Relationship::Base;
# ABSTRACT: Inter-table relationships
use strict;
use warnings;
use base qw/DBIO::Base/;
use Scalar::Util qw/weaken blessed/;
use Try::Tiny;
use DBIO::Util 'UNRESOLVABLE_CONDITION';
use namespace::clean;
sub register_relationship { }
sub related_resultset {
my $self = shift;
lib/DBIO/Relationship/Base.pm view on Meta::CPAN
)->search_related('me', $query, $attrs)
}
else {
# FIXME - this conditional doesn't seem correct - got to figure out
# at some point what it does. Also the entire UNRESOLVABLE_CONDITION
# business seems shady - we could simply not query *at all*
if ($cond eq UNRESOLVABLE_CONDITION) {
my $reverse = $rsrc->reverse_relationship_info($rel);
foreach my $rev_rel (keys %$reverse) {
if ($reverse->{$rev_rel}{attrs}{accessor} && $reverse->{$rev_rel}{attrs}{accessor} eq 'multi') {
weaken($attrs->{related_objects}{$rev_rel}[0] = $self);
} else {
weaken($attrs->{related_objects}{$rev_rel} = $self);
}
}
}
elsif (ref $cond eq 'ARRAY') {
$cond = [ map {
if (ref $_ eq 'HASH') {
my $hash;
foreach my $key (keys %$_) {
my $newkey = $key !~ /\./ ? "me.$key" : $key;
$hash->{$newkey} = $_->{$key};
lib/DBIO/Replicated/Backend.pm view on Meta::CPAN
package DBIO::Replicated::Backend;
# ABSTRACT: Wrapper base class for replicated backends
use strict;
use warnings;
use base 'DBIO::Base';
use Scalar::Util 'weaken';
use namespace::clean;
our $AUTOLOAD;
__PACKAGE__->mk_group_accessors(simple => qw/
storage
dsn
id
active
kind
lib/DBIO/Replicated/Backend.pm view on Meta::CPAN
$self->master($args{master}) if exists $args{master};
return $self;
}
sub master {
my $self = shift;
if (@_) {
$self->{master} = $_[0];
weaken $self->{master} if ref $self->{master};
}
return $self->{master};
}
sub install_debug_proxy {
my ($self, $target) = @_;
require DBIO::Replicated::DebugProxy;
if (eval { $target->isa('DBIO::Replicated::DebugProxy') }) {
$target = $target->target;
lib/DBIO/Replicated/Storage.pm view on Meta::CPAN
package DBIO::Replicated::Storage;
# ABSTRACT: Replicated DBI storage coordinator
use strict;
use warnings;
use base 'DBIO::Storage::DBI';
use Scalar::Util qw/blessed reftype weaken/;
use List::Util ();
use Sub::Util 'set_subname';
use DBIO::Util ();
use namespace::clean;
__PACKAGE__->mk_group_accessors(simple => qw/
pool_type
pool_args
balancer_type
balancer_args
lib/DBIO/Replicated/Storage.pm view on Meta::CPAN
sub new {
my ($class, $schema, $args) = @_;
$args ||= {};
my $self = bless {
transaction_depth => 0,
savepoints => [],
}, $class;
$self->schema($schema);
weaken $self->{schema} if ref $self->{schema};
$self->{debug} = 1
if $ENV{DBIO_TRACE};
$self->pool_type($args->{pool_type} || 'DBIO::Replicated::Pool');
$self->pool_args($args->{pool_args} || {});
$self->balancer_type($class->_normalize_balancer_type($args->{balancer_type} || 'DBIO::Replicated::Balancer::First'));
$self->balancer_args($args->{balancer_args} || {});
$self->backend_storage_class($args->{backend_storage_class} || 'DBIO::Storage::DBI');
$self->_master_connect_info_opts({});
lib/DBIO/ResultSet.pm view on Meta::CPAN
package DBIO::ResultSet;
# ABSTRACT: Lazy query object for fetching and manipulating DBIO rows
use strict;
use warnings;
use base qw/DBIO::Base/;
use DBIO::Carp;
use DBIO::ResultSetColumn;
use Scalar::Util qw/blessed weaken reftype/;
use DBIO::Util qw(
fail_on_internal_wantarray fail_on_internal_call UNRESOLVABLE_CONDITION
assert_no_internal_wantarray assert_no_internal_indirect_calls
help_url stresstest_utf8_upgrade_generated_collapser_source
);
use Try::Tiny;
BEGIN {
# De-duplication in _merge_attr() is disabled, but left in for reference
# (the merger is used for other things that ought not to be de-duped)
lib/DBIO/ResultSource.pm view on Meta::CPAN
use base qw/DBIO::ResultSource::RowParser DBIO::Base/;
use DBIO::ResultSet;
use DBIO::ResultSourceHandle;
use DBIO::Carp;
use DBIO::Util 'UNRESOLVABLE_CONDITION';
use DBIO::Util qw(is_literal_value);
use Devel::GlobalDestruction;
use Try::Tiny;
use Scalar::Util qw/blessed weaken isweak/;
use namespace::clean;
__PACKAGE__->mk_group_accessors(simple => qw/
source_name name source_info
_ordered_columns _columns _primaries _unique_constraints
_relationships resultset_attributes
column_info_from_storage
/);
lib/DBIO/ResultSource.pm view on Meta::CPAN
# we are trying to save to reattach back to the source we are destroying.
# The relevant code checking refcounts is in ::Schema::DESTROY()
# if we are not a schema instance holder - we don't matter
return if(
! ref $_[0]->{schema}
or
isweak $_[0]->{schema}
);
# weaken our schema hold forcing the schema to find somewhere else to live
# during global destruction (if we have not yet bailed out) this will throw
# which will serve as a signal to not try doing anything else
# however beware - on older perls the exception seems randomly untrappable
# due to some weird race condition during thread joining :(((
local $@;
eval {
weaken $_[0]->{schema};
# if schema is still there reintroduce ourselves with strong refs back to us
if ($_[0]->{schema}) {
my $srcregs = $_[0]->{schema}->source_registrations;
for (keys %$srcregs) {
next unless $srcregs->{$_};
$srcregs->{$_} = $_[0] if $srcregs->{$_} == $_[0];
}
}
lib/DBIO/Schema.pm view on Meta::CPAN
package DBIO::Schema;
# ABSTRACT: Schema class and connection container for DBIO applications
use strict;
use warnings;
use base 'DBIO::Base';
use DBIO::Carp;
use Try::Tiny;
use Scalar::Util qw/weaken blessed/;
use DBIO::Util qw(refcount quote_sub is_exception scope_guard old_mro file_path);
use DBIO::Skills;
use DBIO::Storage::Composed;
use Devel::GlobalDestruction;
use namespace::clean;
__PACKAGE__->mk_classdata('class_mappings' => {});
__PACKAGE__->mk_classdata('source_registrations' => {});
__PACKAGE__->mk_classdata('storage_type' => '::DBI');
__PACKAGE__->mk_classdata('storage');
lib/DBIO/Schema.pm view on Meta::CPAN
sub register_extra_source { shift->_register_source(@_, { extra => 1 }) }
sub _register_source {
my ($self, $source_name, $source, $params) = @_;
$source = $source->new({ %$source, source_name => $source_name });
$source->schema($self);
weaken $source->{schema} if ref($self);
my %reg = %{$self->source_registrations};
$reg{$source_name} = $source;
$self->source_registrations(\%reg);
return $source if $params->{extra};
my $rs_class = $source->result_class;
if ($rs_class and my $rsrc = try { $rs_class->result_source_instance } ) {
my %map = %{$self->class_mappings};
lib/DBIO/Schema.pm view on Meta::CPAN
### NO detected_reinvoked_destructor check
### This code very much relies on being called multuple times
return if $global_phase_destroy ||= in_global_destruction;
my $self = shift;
my $srcs = $self->source_registrations;
for my $source_name (keys %$srcs) {
# find first source that is not about to be GCed (someone other than $self
# holds a reference to it) and reattach to it, weakening our own link
#
# during global destruction (if we have not yet bailed out) this should throw
# which will serve as a signal to not try doing anything else
# however beware - on older perls the exception seems randomly untrappable
# due to some weird race condition during thread joining :(((
if (length ref $srcs->{$source_name} and refcount($srcs->{$source_name}) > 1) {
local $@;
eval {
$srcs->{$source_name}->schema($self);
weaken $srcs->{$source_name};
1;
} or do {
$global_phase_destroy = 1;
};
last;
}
}
}
lib/DBIO/Storage.pm view on Meta::CPAN
use mro 'c3';
{
package # Hide from PAUSE
DBIO::Storage::NESTED_ROLLBACK_EXCEPTION;
use base 'DBIO::Exception';
}
use DBIO::Carp;
use DBIO::Storage::BlockRunner;
use Scalar::Util qw/blessed weaken/;
use DBIO::Storage::TxnScopeGuard;
use Try::Tiny;
use namespace::clean;
__PACKAGE__->mk_group_accessors(simple => qw/
debug schema transaction_depth deferred_rollback auto_savepoint savepoints
access_broker access_broker_mode
/);
__PACKAGE__->mk_group_accessors(component_class => 'cursor_class');
lib/DBIO/Storage.pm view on Meta::CPAN
if $ENV{DBIO_TRACE};
$new;
}
sub set_schema {
my ($self, $schema) = @_;
$self->schema($schema);
weaken $self->{schema} if ref $self->{schema};
}
sub set_access_broker {
my ($self, $broker, $mode) = @_;
$self->throw_exception('set_access_broker() requires a broker object')
unless blessed($broker);
$self->throw_exception(
lib/DBIO/Storage/Async.pm view on Meta::CPAN
package DBIO::Storage::Async;
# ABSTRACT: Base class for async storage implementations
use strict;
use warnings;
use base 'DBIO::Storage';
use Carp 'croak';
use Scalar::Util qw(blessed weaken);
use DBIO::Storage::Async::TransactionContext;
use DBIO::SQL::Util ();
use namespace::clean;
sub new {
my ($class, $schema, $args) = @_;
my $self = bless {
schema => $schema,
pool => undef,
connect_info => undef,
sql_maker => undef,
_conninfo_provider => undef,
debug => $ENV{DBIO_TRACE} || 0,
debugobj => undef,
}, $class;
weaken($self->{schema}) if ref $self->{schema};
return $self;
}
sub future_class {
croak 'Subclass must override future_class';
}
sub pool {
lib/DBIO/Storage/Async.pm view on Meta::CPAN
$self->{_storage_options} = \%storage_options;
return \@args;
}
sub _owner_storage {
my $self = shift;
if (@_) {
$self->{_owner_storage} = $_[0];
weaken($self->{_owner_storage}) if ref $self->{_owner_storage};
}
return $self->{_owner_storage};
}
sub _setup_pool_connection {
my ($self, $conn) = @_;
my $owner = $self->_owner_storage or return;
return unless $owner->can('_run_pool_connect_actions');
lib/DBIO/Storage/BlockRunner.pm view on Meta::CPAN
package DBIO::Storage::BlockRunner;
# ABSTRACT: Execute code blocks with transaction wrapping and retry logic
use warnings;
use strict;
use DBIO::Exception;
use DBIO::Carp;
use Context::Preserve 'preserve_context';
use DBIO::Util qw(is_exception qsub);
use Scalar::Util qw(weaken blessed reftype);
use Try::Tiny;
use namespace::clean;
sub new {
my $class = shift;
my %args = @_ == 1 && ref $_[0] eq 'HASH' ? %{$_[0]} : @_;
for my $required (qw(storage wrap_txn retry_handler)) {
DBIO::Exception->throw("Missing required attribute '$required'")
lib/DBIO/Storage/BlockRunner.pm view on Meta::CPAN
);
local $storage->{_in_do_block} = 1 unless $storage->{_in_do_block};
return $self->_run($cref, @_);
}
# this is the actual recursing worker
sub _run {
# internal method - we know that both refs are strong-held by the
# calling scope of run(), hence safe to weaken everything
weaken( my $self = shift );
weaken( my $cref = shift );
my $args = @_ ? \@_ : [];
# from this point on (defined $txn_init_depth) is an indicator for wrap_txn
# save a bit on method calls
my $txn_init_depth = $self->wrap_txn ? $self->storage->transaction_depth : undef;
my $txn_begin_ok;
my $run_err = '';
lib/DBIO/Storage/DBI.pm view on Meta::CPAN
# ABSTRACT: DBI storage handler
# -*- mode: cperl; cperl-indent-level: 2 -*-
use strict;
use warnings;
use base qw/DBIO::Storage::QueryRewrite DBIO::Storage::DBI::Capabilities DBIO::Storage::DBI::DataTypeClassifier DBIO::Storage::DBI::AccessBroker DBIO::Storage/;
use mro 'c3';
use DBIO::Carp;
use Scalar::Util qw/refaddr weaken reftype blessed/;
use Context::Preserve 'preserve_context';
use Try::Tiny;
use DBIO::Util qw(is_plain_value is_literal_value);
use DBIO::Util qw(quote_sub perlstring serialize dump_value sigwarn_silencer is_windows is_dev_release old_mro help_url);
use DBIO::Skills;
use DBIO::Storage::Composed;
use namespace::clean;
# default cursor class, overridable in connect_info attributes
__PACKAGE__->cursor_class('DBIO::Storage::DBI::Cursor');
lib/DBIO/Storage/DBI.pm view on Meta::CPAN
{
my %seek_and_destroy;
sub _arm_global_destructor {
# quick "garbage collection" pass - prevents the registry
# from slowly growing with a bunch of undef-valued keys
defined $seek_and_destroy{$_} or delete $seek_and_destroy{$_}
for keys %seek_and_destroy;
weaken (
$seek_and_destroy{ refaddr($_[0]) } = $_[0]
);
}
END {
local $?; # just in case the DBI destructor changes it somehow
# destroy just the object if not native to this process
$_->_verify_pid for (grep
{ defined $_ }
lib/DBIO/Storage/DBI.pm view on Meta::CPAN
# counterpart and compose them over the transport, so an extension's async
# behaviour rides every transport just as its sync behaviour rides every
# driver (one behaviour, one transport). Per sync layer L, in registration
# order:
# * L->async_layer_class($mode) if L defines it -- a package (must load, or
# croak) or undef (fall back to convention);
# * otherwise the convention sibling "${L}::Async" via load_optional_class;
# * absent -> skip L silently (a sync-only extension, e.g. PostGIS).
# This does NOT touch the transport resolution above (ADR 0030: the mode
# stays explicit; only the layer CLASSES are added by composition).
# A storage with no live schema (weakened ref already gone) can carry no
# registered layers, so there is nothing to mirror.
my $schema = $self->schema;
my @async_layers;
for my $sync_layer ($schema ? @{ $schema->storage_layers } : ()) {
my $async_layer;
if ($sync_layer->can('async_layer_class')) {
$async_layer = $sync_layer->async_layer_class($mode);
if (defined $async_layer) {
# An explicitly declared class MUST load: genuinely absent -> the
lib/DBIO/Storage/DBI.pm view on Meta::CPAN
local $DBI::connect_via = 'connect' if $INC{'Apache/DBI.pm'} && $ENV{MOD_PERL};
# this odd anonymous coderef dereference is in fact really
# necessary to avoid the unwanted effect described in perl5
# RT#75792
#
# in addition the coderef itself can't reside inside the try{} block below
# as it somehow triggers a leak under perl -d
my $dbh_error_handler_installer = sub {
weaken (my $weak_self = $_[0]);
# the coderef is blessed so we can distinguish it from externally
# supplied handles (which must be preserved)
$_[1]->{HandleError} = bless sub {
if ($weak_self) {
$weak_self->throw_exception("DBI Exception: $_[0]");
}
else {
# the handler may be invoked by something totally out of
# the scope of DBIO
lib/DBIO/Storage/DBI/Cursor.pm view on Meta::CPAN
package DBIO::Storage::DBI::Cursor;
# ABSTRACT: Object representing a query cursor on a resultset.
use strict;
use warnings;
use base 'DBIO::Cursor';
use Try::Tiny;
use Scalar::Util qw(refaddr weaken);
use DBIO::Util qw(has_ithreads is_windows shuffle_unordered_resultsets);
use namespace::clean;
__PACKAGE__->mk_group_accessors('simple' =>
qw/storage args attrs/
);
{
my %cursor_registry;
lib/DBIO/Storage/DBI/Cursor.pm view on Meta::CPAN
attrs => $attrs,
}, ref $class || $class;
if (has_ithreads) {
# quick "garbage collection" pass - prevents the registry
# from slowly growing with a bunch of undef-valued keys
defined $cursor_registry{$_} or delete $cursor_registry{$_}
for keys %cursor_registry;
weaken( $cursor_registry{ refaddr($self) } = $self )
}
return $self;
}
sub CLONE {
for (keys %cursor_registry) {
# once marked we no longer care about them, hence no
# need to keep in the registry, left alone renumber the
# keys (all addresses are now different)
lib/DBIO/Storage/PoolBase.pm view on Meta::CPAN
# karr #68: optional back-reference to the owning DBIO::Storage::Async, held
# weakly (the storage owns the pool, not the other way round). When present,
# the pool replays the storage's configured on_connect / on_disconnect actions
# against every freshly-spawned / torn-down connection -- see the connect-action
# hooks in L</_spawn_connection> and L</shutdown>. A pool used standalone, or an
# async pool whose owner does not wire it, simply carries no {storage} and skips
# the hooks entirely.
if (defined $args{storage}) {
$self->{storage} = $args{storage};
Scalar::Util::weaken($self->{storage}) if ref $self->{storage};
}
return $self;
}
sub future_class { $_[0]->{future_class} || 'Future' }
sub acquire {
lib/DBIO/Storage/TxnScopeGuard.pm view on Meta::CPAN
package DBIO::Storage::TxnScopeGuard;
# ABSTRACT: Scope-based transaction handling
use strict;
use warnings;
use Try::Tiny;
use Scalar::Util qw(weaken blessed refaddr);
use DBIO;
use DBIO::Util qw(is_exception is_windows);
use DBIO::Carp;
use namespace::clean;
sub new {
my ($class, $storage) = @_;
my $guard = {
lib/DBIO/Storage/TxnScopeGuard.pm view on Meta::CPAN
};
# we are starting with an already set $@ - in order for things to work we need to
# be able to recognize it upon destruction - store its weakref
# recording it before doing the txn_begin stuff
#
# FIXME FRAGILE - any eval that fails but *does not* rethrow between here
# and the unwind will trample over $@ and invalidate the entire mechanism
# There got to be a saner way of doing this...
if (is_exception $@) {
weaken(
$guard->{existing_exception_ref} = (ref($@) eq '') ? \$@ : $@
);
}
$storage->txn_begin;
weaken( $guard->{dbh} = $storage->_dbh );
bless $guard, ref $class || $class;
$guard;
}
sub commit {
my $self = shift;
lib/DBIO/Test/Util/LeakTracer.pm view on Meta::CPAN
package DBIO::Test::Util::LeakTracer;
# ABSTRACT: Memory leak detection and tracing for DBIO tests
use warnings;
use strict;
use Carp;
use Scalar::Util qw(isweak weaken blessed reftype);
use DBIO::Util qw(refcount hrefaddr refdesc);
use DBIO::Optional::Dependencies;
use Data::Dumper 'Dumper';
use DBIO::Test::Util qw( stacktrace visit_namespaces );
use namespace::clean;
use constant {
CV_TRACING => (
!( !$ENV{AUTOMATED_TESTING} && !$ENV{RELEASE_TESTING} )
&&
DBIO::Optional::Dependencies->req_ok_for('test_leaks_heavy')
lib/DBIO/Test/Util/LeakTracer.pm view on Meta::CPAN
croak 'Expecting a registry hashref' unless ref $weak_registry eq 'HASH';
croak 'Target is not a reference' unless length ref $target;
my $refaddr = hrefaddr $target;
# a registry could be fed to itself or another registry via recursive sweeps
return $target if $reg_of_regs{$refaddr};
return $target if SKIP_SCALAR_REFS and reftype($target) eq 'SCALAR';
weaken( $reg_of_regs{ hrefaddr($weak_registry) } = $weak_registry )
unless( $reg_of_regs{ hrefaddr($weak_registry) } );
# an explicit "garbage collection" pass every time we store a ref
# if we do not do this the registry will keep growing appearing
# as if the traced program is continuously slowly leaking memory
for my $reg (values %reg_of_regs) {
(defined $reg->{$_}{weakref}) or delete $reg->{$_}
for keys %$reg;
}
if (! defined $weak_registry->{$refaddr}{weakref}) {
$weak_registry->{$refaddr} = {
stacktrace => stacktrace(1),
weakref => $target,
};
weaken( $weak_registry->{$refaddr}{weakref} );
$refs_traced++;
}
my $desc = refdesc $target;
$weak_registry->{$refaddr}{slot_names}{$desc} = 1;
if ($note) {
$note =~ s/\s*\Q$desc\E\s*//g;
$weak_registry->{$refaddr}{slot_names}{$note} = 1;
}
lib/DBIO/Test/Util/LeakTracer.pm view on Meta::CPAN
# Regenerate the slots names on a thread spawn
sub CLONE {
my @individual_regs = grep { scalar keys %{$_||{}} } values %reg_of_regs;
%reg_of_regs = ();
for my $reg (@individual_regs) {
my @live_slots = grep { defined $_->{weakref} } values %$reg
or next;
$reg = {}; # get a fresh hashref in the new thread ctx
weaken( $reg_of_regs{hrefaddr($reg)} = $reg );
for my $slot_info (@live_slots) {
my $new_addr = hrefaddr $slot_info->{weakref};
# replace all slot names
$slot_info->{slot_names} = { map {
my $name = $_;
$name =~ s/\(0x[0-9A-F]+\)/sprintf ('(%s)', $new_addr)/ieg;
($name => 1);
} keys %{$slot_info->{slot_names}} };
lib/DBIO/Util.pm view on Meta::CPAN
}
}
# FIXME - this is not supposed to be here
# Carp::Skip to the rescue soon
use DBIO::Carp '^DBIO';
use B ();
use Carp 'croak';
use Storable 'nfreeze';
use Scalar::Util qw(weaken blessed reftype refaddr);
use Sub::Quote qw(qsub quote_sub);
use base 'Exporter';
our @EXPORT_OK = qw(
sigwarn_silencer modver_gt_or_eq modver_gt_or_eq_and_lt
fail_on_internal_wantarray fail_on_internal_call
refdesc refcount hrefaddr
scope_guard is_exception emit_loud_diag
quote_sub qsub perlstring serialize dump_value
UNRESOLVABLE_CONDITION
lib/DBIO/Util.pm view on Meta::CPAN
if (
$want and $fr->[0] =~ /^(?:DBIO|DBICx::)/
) {
DBIO::Exception->throw( sprintf (
"Improper use of %s instance in list context at %s line %d\n\n Stacktrace starts",
$argdesc, @{$fr}[1,2]
), 'with_stacktrace');
}
my $mark = [];
weaken ( $list_ctx_ok_stack_marker = $mark );
$mark;
}
}
# --- Path helpers (replace Path::Class with core modules) ---
require File::Spec;
require File::Basename;
sub dir_path { File::Spec->catdir(@_) }
t/composed/async_mirror.t view on Meta::CPAN
sub _transform_sql { $_[1] } # identity: wire speaks '?'
sub _post_insert_sql { '' }
sub _query_async { push @RECORDED, $_[1]; return Future->done }
sub pool { $_[0]->{pool} ||= bless {}, 'T::AM::NoPool' }
}
# Build a fresh sync storage for one scenario. $mode is the async mode string;
# the transport is registered against it on the sync storage class so
# _async_storage resolves it from the registry (explicit mode -- ADR 0030),
# except the one future_io scenario which resolves it by convention. Returns
# ($storage, $schema); the caller MUST hold $schema in scope -- storage weakens
# its schema back-reference, so a dropped schema would undef $self->schema
# inside _async_storage.
sub build_storage {
my (%arg) = @_;
my $schema = DBIO::Test->init_schema;
$schema->register_storage_layer($_) for @{ $arg{layers} || [] };
my $storage_class = $arg{storage_class};
my $storage = $storage_class->new($schema);
$storage->connect_info([ 'dbi:AMMock:', '', '', { async => $arg{mode} } ]);
t/lib/MigrationsTest/BaseSchema.pm view on Meta::CPAN
package #hide from pause
MigrationsTest::BaseSchema;
use strict;
use warnings;
use base qw(MigrationsTest::Base DBIO::Schema);
use Fcntl qw(:DEFAULT :seek :flock);
use Scalar::Util 'weaken';
use Time::HiRes 'sleep';
use MigrationsTest::Util::LeakTracer qw(populate_weakregistry assert_empty_weakregistry);
use MigrationsTest::Util qw( local_umask await_flock dbg DEBUG_TEST_CONCURRENCY_LOCKS );
use namespace::clean;
sub capture_executed_sql_bind {
my ($self, $cref) = @_;
$self->throw_exception("Expecting a coderef to run") unless ref $cref eq 'CODE';
t/lib/MigrationsTest/BaseSchema.pm view on Meta::CPAN
lock_name => "$lockpath",
};
}
}
if ($INC{'Test/Builder.pm'}) {
populate_weakregistry ( $weak_registry, $self->storage );
my $cur_connect_call = $self->storage->on_connect_call;
# without this weaken() the sub added below *sometimes* leaks
# ( can't reproduce locally :/ )
weaken( my $wlocker = $locker );
$self->storage->on_connect_call([
(ref $cur_connect_call eq 'ARRAY'
? @$cur_connect_call
: ($cur_connect_call || ())
),
[ sub { populate_weakregistry( $weak_registry, $_[0]->_dbh ) } ],
( !$wlocker ? () : (
require Data::Dumper::Concise
and
t/lib/MigrationsTest/Util/LeakTracer.pm view on Meta::CPAN
package MigrationsTest::Util::LeakTracer;
use warnings;
use strict;
use Carp;
use Scalar::Util qw(isweak weaken blessed reftype);
use DBIO::Util qw(refcount hrefaddr refdesc);
use DBIO::Optional::Dependencies;
use Data::Dumper::Concise;
use MigrationsTest::Util qw( stacktrace visit_namespaces );
use constant {
CV_TRACING => !MigrationsTest::RunMode->is_plain && DBIO::Optional::Dependencies->req_ok_for ('test_leaks_heavy'),
SKIP_SCALAR_REFS => ( "$]" < 5.008004 ),
};
use base 'Exporter';
t/lib/MigrationsTest/Util/LeakTracer.pm view on Meta::CPAN
croak 'Expecting a registry hashref' unless ref $weak_registry eq 'HASH';
croak 'Target is not a reference' unless length ref $target;
my $refaddr = hrefaddr $target;
# a registry could be fed to itself or another registry via recursive sweeps
return $target if $reg_of_regs{$refaddr};
return $target if SKIP_SCALAR_REFS and reftype($target) eq 'SCALAR';
weaken( $reg_of_regs{ hrefaddr($weak_registry) } = $weak_registry )
unless( $reg_of_regs{ hrefaddr($weak_registry) } );
# an explicit "garbage collection" pass every time we store a ref
# if we do not do this the registry will keep growing appearing
# as if the traced program is continuously slowly leaking memory
for my $reg (values %reg_of_regs) {
(defined $reg->{$_}{weakref}) or delete $reg->{$_}
for keys %$reg;
}
if (! defined $weak_registry->{$refaddr}{weakref}) {
$weak_registry->{$refaddr} = {
stacktrace => stacktrace(1),
weakref => $target,
};
weaken( $weak_registry->{$refaddr}{weakref} );
$refs_traced++;
}
my $desc = refdesc $target;
$weak_registry->{$refaddr}{slot_names}{$desc} = 1;
if ($note) {
$note =~ s/\s*\Q$desc\E\s*//g;
$weak_registry->{$refaddr}{slot_names}{$note} = 1;
}
t/lib/MigrationsTest/Util/LeakTracer.pm view on Meta::CPAN
# Regenerate the slots names on a thread spawn
sub CLONE {
my @individual_regs = grep { scalar keys %{$_||{}} } values %reg_of_regs;
%reg_of_regs = ();
for my $reg (@individual_regs) {
my @live_slots = grep { defined $_->{weakref} } values %$reg
or next;
$reg = {}; # get a fresh hashref in the new thread ctx
weaken( $reg_of_regs{hrefaddr($reg)} = $reg );
for my $slot_info (@live_slots) {
my $new_addr = hrefaddr $slot_info->{weakref};
# replace all slot names
$slot_info->{slot_names} = { map {
my $name = $_;
$name =~ s/\(0x[0-9A-F]+\)/sprintf ('(%s)', $new_addr)/ieg;
($name => 1);
} keys %{$slot_info->{slot_names}} };
t/storage/pool_connect_actions.t view on Meta::CPAN
# method that emits a known SQL via _do_query -- the exact convention real
# drivers use (connect_call_load_age, connect_call_use_foreign_keys, ...).
{
package RecOwner;
use base 'DBIO::Storage::DBI';
sub connect_call_test_setup { $_[0]->_do_query('SETUP CALL') }
sub disconnect_call_test_teardown { $_[0]->_do_query('TEARDOWN CALL') }
}
my $schema = DBIO::Test->init_schema; # kept alive: storages weaken their ref
sub wired_backend {
my %config = @_;
my $backend = RecBackend->new($schema);
my $owner = RecOwner->new($schema);
$owner->on_connect_do($config{on_connect_do}) if exists $config{on_connect_do};
$owner->on_connect_call($config{on_connect_call}) if exists $config{on_connect_call};
$owner->on_disconnect_do($config{on_disconnect_do}) if exists $config{on_disconnect_do};
$owner->on_disconnect_call($config{on_disconnect_call}) if exists $config{on_disconnect_call};
t/storage/txn_scope_guard.t view on Meta::CPAN
# connection that isn't there. DBIO::Test::Storage's _dbh is undef, so to
# exercise the rollback path at all we give the fake storage a stand-in dbh
# (a real driver always has one here). Everything else -- txn_begin/commit/
# rollback capture -- is the genuine mock machinery.
{
package DBIO::Test::Storage::WithFakeDbh;
use base 'DBIO::Test::Storage';
use mro 'c3';
# A single, program-lifetime fake handle so the guard's weakened dbh ref
# stays live for the guard's whole scope.
my $FAKE_DBH = bless {}, 'DBIO::Test::Storage::WithFakeDbh::FakeDbh';
sub _dbh { $FAKE_DBH }
# txn_commit consults ->FETCH('AutoCommit') only at depth 0; harmless stub.
sub DBIO::Test::Storage::WithFakeDbh::FakeDbh::FETCH { 1 }
}
my $schema = DBIO::Test->init_schema(no_deploy => 1);
bless $schema->storage, 'DBIO::Test::Storage::WithFakeDbh';
t/test/15_async_orchestration.t view on Meta::CPAN
sub _pipeline_enter { push @{ $_[0]->{captured} }, { sql => 'PIPELINE_ENTER' }; 1 }
sub _pipeline_exit { push @{ $_[0]->{captured} }, { sql => 'PIPELINE_EXIT' }; 1 }
sub _pipeline_sync { push @{ $_[0]->{captured} }, { sql => 'PIPELINE_SYNC' }; $_[0]->future_class->done }
# test helper
sub _last_sql { $_[0]->{captured}[-1]{sql} }
}
sub new_backend {
my $schema = DBIO::Test->init_schema;
# keep the schema alive for the caller (backend weakens its ref)
my $backend = Test::SyncBackend->new($schema);
return ($backend, $schema);
}
# ---------------------------------------------------------------------------
# connect_info normalization
# ---------------------------------------------------------------------------
{
my ($backend) = new_backend();
t/test/16_async_future_io_convention.t view on Meta::CPAN
use mro 'c3';
}
{
package AsyncConv::BaseReg::Storage; # NO ::Async sibling; used with a base-class reg
use base 'DBIO::Test::Storage';
use mro 'c3';
}
# Build a driver storage of $class in future_io mode, bound to a live schema.
# Returns ($storage, $schema) -- the caller must keep $schema alive (the async
# backend weakens its schema ref).
sub driver_storage {
my ($class) = @_;
my $schema = DBIO::Test->init_schema;
my $storage = $class->new($schema);
$storage->_async_mode('future_io'); # Test::Storage defaults to 'immediate'
delete $storage->{_async_storage_obj};
$storage->_connect_info([ { host => 'localhost' } ]);
return ($storage, $schema);
}
t/test/20_async_future_io_unloadable_adapter.t view on Meta::CPAN
use mro 'c3';
}
{
package T::Unl::Absent::Storage; # no ::Async anywhere in its MRO
use base 'DBIO::Test::Storage';
use mro 'c3';
}
# Build a driver storage of $class in future_io mode bound to a live schema,
# matching t/test/17's helper. Returns ($storage, $schema); keep $schema in
# scope (storage weakens its schema back-reference).
sub driver_storage {
my ($class) = @_;
my $schema = DBIO::Test->init_schema;
my $storage = $class->new($schema);
$storage->_async_mode('future_io');
delete $storage->{_async_storage_obj};
$storage->_connect_info([ { host => 'localhost' } ]);
return ($storage, $schema);
}
xbin/benchmark_row_destroy.pl view on Meta::CPAN
my $schema = DBIO::Test->init_schema(no_populate => 1);
my $storage = $schema->storage;
my $old_destroy_sub = do {
my $registry = {};
sub {
my $self = $_[0];
defined $registry->{$_} or delete $registry->{$_}
for keys %$registry;
my $addr = Scalar::Util::refaddr($self);
Scalar::Util::weaken($registry->{$addr} = $self)
if !defined $registry->{$addr};
};
};
for my $n (10, 100, 500, 2000, 10_000) {
printf "\n--- %d Artist rows inflated from mock storage ---\n", $n;
my @mock_rows = map { [$_, "Artist $_", 13, undef] } 1..$n;
cmpthese(-2, {
( run in 2.414 seconds using v1.01-cache-2.11-cpan-600a1bdf6e4 )