t/io/shm.t

   1 ################################################################################
   2 #
   3 #  $Revision: 6 $
   4 #  $Author: mhx $
   5 #  $Date: 2010/03/07 16:01:42 +0100 $
   6 #
   7 ################################################################################
   8 #
   9 #  Version 2.x, Copyright (C) 2007-2010, Marcus Holland-Moritz <mhx@cpan.org>.
  10 #  Version 1.x, Copyright (C) 1999, Graham Barr <gbarr@pobox.com>.
  11 #
  12 #  This program is free software; you can redistribute it and/or
  13 #  modify it under the same terms as Perl itself.
  14 #
  15 ################################################################################
  16
  17 BEGIN {
  18   chdir 't' if -d 't' && $ENV{'PERL_CORE'};
  19   require "./test.pl";
  20   set_up_inc('../lib') if $ENV{'PERL_CORE'} && -d '../lib' && -d '../ext';
  21
  22   require Config; import Config;
  23
  24   if ($ENV{'PERL_CORE'} && $Config{'extensions'} !~ m[\bIPC/SysV\b]) {
  25     skip_all('-- IPC::SysV was not built');
  26   }
  27   skip_all_if_miniperl();
  28   if ($Config{'d_shm'} ne 'define') {
  29     skip_all('-- $Config{d_shm} undefined');
  30   }
  31 }
  32
  33
  34 use sigtrap qw/die normal-signals error-signals/;
  35 use IPC::SysV qw/ IPC_PRIVATE S_IRWXU IPC_RMID /;
  36
  37 my $key;
  38 END { shmctl $key, IPC_RMID, 0 if defined $key }
  39
  40 {
  41         local $SIG{SYS} = sub { skip_all("SIGSYS caught") } if exists $SIG{SYS};
  42         $key = shmget IPC_PRIVATE, 8, S_IRWXU;
  43 }
  44
  45 if (not defined $key) {
  46   my $info = "IPC::SharedMem->new failed: $!";
  47   if ($! == &IPC::SysV::ENOSPC || $! == &IPC::SysV::ENOSYS ||
  48       $! == &IPC::SysV::ENOMEM || $! == &IPC::SysV::EACCES) {
  49     skip_all($info);
  50   }
  51   else {
  52     die $info;
  53   }
  54 }
  55 else {
  56         plan(tests => 21);
  57         pass('acquired shared mem');
  58 }
  59
  60 ok(shmwrite($key, pack("N", 4711), 0, 4), 'write(offs=0)');
  61 ok(shmwrite($key, pack("N", 210577), 4, 4), 'write(offs=4)');
  62
  63 my $var;
  64 ok(shmread($key, $var, 0, 4), 'read(offs=0) returned ok');
  65 is($var, pack("N", 4711), 'read(offs=0) correct');
  66 ok(shmread($key, $var, 4, 4), 'read(offs=4) returned ok');
  67 is($var, pack("N", 210577), 'read(offs=4) correct');
  68
  69 ok(shmwrite($key, "Shared", 1, 6), 'write(offs=1)');
  70
  71 ok(shmread($key, $var, 1, 6), 'read(offs=1) returned ok');
  72 is($var, 'Shared', 'read(offs=1) correct');
  73 ok(shmwrite($key,"Memory", 0, 6), 'write(offs=0)');
  74
  75 my $number = 1;
  76 my $int = 2;
  77 shmwrite $key, $int, 0, 1;
  78 shmread $key, $number, 0, 1;
  79 is("$number", $int, qq{"\$id" eq "$int"});
  80 cmp_ok($number + 0, '==', $int, "\$id + 0 == $int");
  81
  82 my ($fetch, $store) = (0, 0);
  83 { package Counted;
  84   sub TIESCALAR { bless [undef] }
  85   sub FETCH     { ++$fetch; $_[0][0] }
  86   sub STORE     { ++$store; $_[0][0] = $_[1] } }
  87 tie $ct, 'Counted';
  88 shmread $key, $ct, 0, 1;
  89 is($fetch, 1, "shmread FETCH once");
  90 is($store, 1, "shmread STORE once");
  91
  92 {
  93     # check reading into an upgraded buffer is sane
  94     my $text = "\xC0\F0AB";
  95     ok(shmwrite($key, $text, 0, 4), "setup text");
  96     my $rdbuf = "\x{101}";
  97     ok(shmread($key, $rdbuf, 0, 4), "read it back");
  98     is($rdbuf, $text, "check we got back the expected");
  99
 100     # check writing from an upgraded buffer
 101     utf8::upgrade(my $utext = $text);
 102     ok(shmwrite($key, $utext, 0, 4), "setup text (upgraded source)");
 103     $rdbuf = "";
 104     ok(shmread($key, $rdbuf, 0, 4), "read it back (upgraded source)");
 105     is($rdbuf, $text, "check we got back the expected (upgraded source)");
 106 }