view release on metacpan or  search on metacpan

t/lib/DBICTest/BaseSchema.pm  view on Meta::CPAN

package #hide from pause
  DBICTest::BaseSchema;

use strict;
use warnings;
use base qw(DBICTest::Base DBIx::Class::Schema);

use Fcntl qw(:DEFAULT :seek :flock);
use Scalar::Util 'weaken';
use Time::HiRes 'sleep';
use DBICTest::Util::LeakTracer qw(populate_weakregistry assert_empty_weakregistry);
use DBICTest::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';

  require DBICTest::SQLTracerObj;

  # hack around stupid, stupid API
  no warnings 'redefine';
  local *DBIx::Class::Storage::DBI::_format_for_trace = sub { $_[1] };
  Class::C3->reinitialize if DBIx::Class::_ENV_::OLD_MRO;


  local $self->storage->{debugcb};
  local $self->storage->{debugobj} = my $tracer_obj = DBICTest::SQLTracerObj->new;
  local $self->storage->{debug} = 1;

  local $Test::Builder::Level = $Test::Builder::Level + 2;
  $cref->();

  return $tracer_obj->{sqlbinds} || [];
}

sub is_executed_querycount {
  my ($self, $cref, $exp_counts, $msg) = @_;

  local $Test::Builder::Level = $Test::Builder::Level + 1;

  $self->throw_exception("Expecting an hashref of counts or an integer representing total query count")
    unless ref $exp_counts eq 'HASH' or (defined $exp_counts and ! ref $exp_counts);

  my @got = map { $_->[0] } @{ $self->capture_executed_sql_bind($cref) };

  return Test::More::is( @got, $exp_counts, $msg )
    unless ref $exp_counts;

  my $got_counts = { map { $_ => 0 } keys %$exp_counts };
  $got_counts->{$_}++ for @got;

  return Test::More::is_deeply(
    $got_counts,
    $exp_counts,
    $msg,
  );
}

sub is_executed_sql_bind {
  my ($self, $cref, $sqlbinds, $msg) = @_;

  local $Test::Builder::Level = $Test::Builder::Level + 1;

  $self->throw_exception("Expecting an arrayref of SQL/Bind pairs") unless ref $sqlbinds eq 'ARRAY';

  my @expected = @$sqlbinds;

t/lib/DBICTest/BaseSchema.pm  view on Meta::CPAN

      undef $locker;

      my $lockpath = DBICTest::RunMode->tmpdir->file("_dbictest_$locktype.lock");

      DEBUG_TEST_CONCURRENCY_LOCKS
        and dbg "Waiting for $locktype LOCK: $lockpath...";

      my $lock_fh;
      {
        my $u = local_umask(0); # so that the file opens as 666, and any user can lock
        sysopen ($lock_fh, $lockpath, O_RDWR|O_CREAT) or die "Unable to open $lockpath: $!";
      }

      await_flock ($lock_fh, LOCK_EX) or die "Unable to lock $lockpath: $!";

      DEBUG_TEST_CONCURRENCY_LOCKS
        and dbg "Got $locktype LOCK: $lockpath";

      # see if anyone was holding a lock before us, and wait up to 5 seconds for them to terminate
      # if we do not do this we may end up trampling over some long-running END or somesuch
      seek ($lock_fh, 0, SEEK_SET) or die "seek failed $!";
      my $old_pid;
      if (
        read ($lock_fh, $old_pid, 100)
          and
        ($old_pid) = $old_pid =~ /^(\d+)$/
      ) {
        DEBUG_TEST_CONCURRENCY_LOCKS
          and dbg "Post-grab WAIT for $old_pid START: $lockpath";

        for (1..50) {
          kill (0, $old_pid) or last;
          sleep 0.1;
        }

        DEBUG_TEST_CONCURRENCY_LOCKS
          and dbg "Post-grab WAIT for $old_pid FINISHED: $lockpath";
      }

      truncate $lock_fh, 0;
      seek ($lock_fh, 0, SEEK_SET) or die "seek failed $!";
      $lock_fh->autoflush(1);
      print $lock_fh $$;

      $ENV{DBICTEST_LOCK_HOLDER} ||= $$;

      $locker = {
        type => $locktype,
        fh => $lock_fh,
        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
        [ sub { ($wlocker||{})->{rdbms_connection_diag} = Data::Dumper::Concise::Dumper( $_[0]->_describe_connection() ) } ],
      )),
    ]);
  }

  return $self;
}

sub clone {
  my $self = shift->next::method(@_);
  populate_weakregistry ( $weak_registry, $self )
    if $INC{'Test/Builder.pm'};
  $self;
}

END {
  assert_empty_weakregistry($weak_registry, 'quiet');
}

1;