DBIO-SQLite

 view release on metacpan or  search on metacpan

t/52leaks.t  view on Meta::CPAN

  };
  *CORE::GLOBAL::bless = sub { goto $bless_override };
}

use strict;
use warnings;
use Test::More;

use DBIO::Test;
use DBIO::Test::Util::LeakTracer qw(populate_weakregistry assert_empty_weakregistry visit_refs);
use Scalar::Util qw(weaken blessed reftype);
use DBIO::Util qw(hrefaddr peepeeness sigwarn_silencer modver_gt_or_eq modver_gt_or_eq_and_lt);
BEGIN {
  plan skip_all => "Your perl version $] appears to leak like a sieve - skipping test"
    if peepeeness;
}


my $TB = Test::More->builder;
if ($ENV{DBIO_TEST_IN_PERSISTENT_ENV}) {
  # without this explicit close TB warns in END after a ->reset

t/52leaks.t  view on Meta::CPAN

  if ( modver_gt_or_eq( 'Test::More', '1.200' ) ) {
    open ($TB->$_, '>&', *STDERR)
      for qw( failure_output todo_output );
    open ($TB->output, '>&', *STDOUT);
  }

  # so done_testing can work on every persistent pass
  $TB->reset;
}

# this is what holds all weakened refs to be checked for leakage
my $weak_registry = {};

# whether or to invoke IC::DT
my $has_dt;

# Skip the heavy-duty leak tracing when just doing an install
unless (DBIO::Test->is_plain) {

  # redefine the bless override so that we can catch each and every object created
  no warnings qw/redefine once/;

t/52leaks.t  view on Meta::CPAN

      or push @circreffed, $r;
  }

  if (@circreffed) {
    is (scalar @circreffed, 1, 'One resultset expected to leak');

    # this is useless on its own, it is to showcase the circref-diag
    # and eventually test it when it is operational
    local $TODO = 'Needs Data::Entangled or somesuch - see RT#82942';
    while (@circreffed) {
      weaken (my $r = shift @circreffed);

      populate_weakregistry( (my $mini_registry = {}), $r );
      assert_empty_weakregistry( $mini_registry );

      $r->result_source(undef);
    }
  }
}

assert_empty_weakregistry ($weak_registry);

t/99dbic_sqlt_parser.t  view on Meta::CPAN

    package
  )) {
    warnings_exist {
      push @schemas, create_schema({
        args => { parser_args => { $parser_args_key => $s } }
      });
    } qr/\Qparser_args => {\E.+?is deprecated.+\Q@{[__FILE__]}/,
    "deprecated crazy parser_arg '$parser_args_key' warned";
  }

  Scalar::Util::weaken ($s);

  ok (!$s, 'Schema not leaked');

  isa_ok ($_, 'SQL::Translator::Schema', "SQLT schema object $_ produced")
    for @schemas;
}

# make sure classname-style works
lives_ok { isa_ok (create_schema ({ schema => 'DBIO::Test::Schema' }), 'SQL::Translator::Schema', 'SQLT schema object produced') };

t/storage/savepoints.t  view on Meta::CPAN

use strict;
use warnings;

use Test::More;
use Test::Exception;
use DBIO::Optional::Dependencies;
use DBIO::Util qw(sigwarn_silencer scope_guard);
use Scalar::Util 'weaken';

use DBIO::SQLite::Test;
{
  package # moar hide
    DBIO::Test::SVPTracerObj;

  use base 'DBIO::Storage::Statistics';

  sub query_start { 'do notning'}
  sub callback { 'dummy '}

t/storage/savepoints.t  view on Meta::CPAN

    'commit from inner transaction');
  is $ars->search({ name => 'in_inner_transaction_rolling_back' })->first,
    undef,
    'rollback from inner transaction';

  # make sure a fresh txn will work after above
  $schema->storage->txn_do(sub { ok "noop" } );

### Make sure non-existend savepoint release doesn't infloop itself
  {
    weaken( my $s = $schema );

    throws_ok {
      $s->storage->txn_do(sub { $s->svp_release('wibble') })
    } qr/Savepoint 'wibble' does not exist/,
      "Calling svp_release on a non-existant savepoint throws expected error"
    ;
  }

### cleanupz
  $schema->storage->dbh->do ("DROP TABLE artist");