t/03torture.t

   1 use strict;
   2 use warnings;
   3
   4 # T::M appears to leak, emit the TAP by hand
   5 #use Test::More 'no_plan';
   6
   7 sub is {
   8   my $str = $_[0] eq $_[1] ? 'ok' : 'not ok';
   9
  10   {
  11     lock($::TEST_COUNT);
  12     $::TEST_COUNT++;
  13     printf STDOUT ("%s %u - %s\n",
  14       $str,
  15       $::TEST_COUNT,
  16       $_[2] || '',
  17     );
  18     if ($str ne 'ok') {
  19       printf STDERR ("# Failed test #%d at %s line %d
  20 # %s
  21 #   ne
  22 # %s
  23 "       , $::TEST_COUNT, (caller(0))[1,2],
  24         , (map { unpack 'H*', $_ } @_[0,1])
  25       );
  26     }
  27
  28   }
  29   threads->yield if $INC{'threads.pm'};
  30 }
  31
  32 use Devel::PeekPoke qw/peek poke/;
  33 use Devel::PeekPoke::Constants qw/PTR_SIZE PTR_PACK_TYPE/;
  34
  35 my $str = 'for mutilation and mayhem';
  36 my $len = length($str);
  37 my $str_pv_addr = unpack(PTR_PACK_TYPE, pack('p', $str) );
  38
  39 is( peek($str_pv_addr, $len + 1), $str . "\0", 'peek as expected (with NUL termination)' );
  40
  41 for (1 .. ($ENV{AUTOMATED_TESTING} ? 200 : 5 ) ) {
  42   for my $poke_size (2 .. $len) {
  43     my $replace_chunk = 'a' . ( '0' x ($poke_size-1) );
  44     for my $poke_start ( 0 .. ($len - $poke_size) ) {
  45       $replace_chunk++;
  46
  47       my $expecting = $str;
  48       substr($expecting, $poke_start, $poke_size, $replace_chunk);
  49
  50       poke($str_pv_addr+$poke_start, $replace_chunk);
  51       is($str, $expecting, 'String matches expectation after poke');
  52     }
  53   }
  54 }
  55
  56 if ($ENV{AUTOMATED_TESTING} and ! $INC{'threads.pm'}) {
  57   my $vsz;
  58   if (-f "/proc/$$/stat") {
  59     my $proc_stat = do { local (@ARGV, $/) = "/proc/$$/stat"; <> };
  60     ($vsz) = map { $_ / 1024 }
  61       (split (/\s+/, $proc_stat))[-22];  # go backwards because the %s of the procname can contain anything
  62   }
  63
  64   printf STDERR "#\n# VSIZE:%dKiB\n", $vsz
  65     if $vsz;
  66 }
  67
  68 print "1..$::TEST_COUNT\n" unless $INC{'threads.pm'};