File Coverage

blib/lib/Test/Without/Shm.pm
Criterion Covered Total %
statement 23 43 53.4
branch 7 22 31.8
condition n/a
subroutine 6 10 60.0
pod 1 5 20.0
total 37 80 46.2


line stmt bran cond sub pod time code
1             # Copyright 2011, 2012, 2013, 2015 Kevin Ryde
2              
3             # This file is part of Test-VariousBits.
4             #
5             # Test-VariousBits is free software; you can redistribute it and/or
6             # modify it under the terms of the GNU General Public License as published
7             # by the Free Software Foundation; either version 3, or (at your option) any
8             # later version.
9             #
10             # Test-VariousBits is distributed in the hope that it will be useful,
11             # but WITHOUT ANY WARRANTY; without even the implied warranty of
12             # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General
13             # Public License for more details.
14             #
15             # You should have received a copy of the GNU General Public License along
16             # with Test-VariousBits. If not, see .
17              
18              
19             # cf doio.c
20             # Perl_do_ipcget() for shmget
21             # Perl_do_shmio() for shmread,shmwrite
22             # Perl_do_ipcctl() for shmget
23             #
24              
25             package Test::Without::Shm;
26             require 5;
27 3     3   1579 use strict;
  3         6  
  3         138  
28              
29 3     3   19 use vars '$VERSION';
  3         5  
  3         2311  
30             $VERSION = 5;
31              
32             # uncomment this to run the ### lines
33             #use Devel::Comments;
34              
35             ### Test-Without-Shm loads ...
36              
37             my %modes = (notimp => 1,
38             nomem => 1,
39             normal => 1);
40             my $current_mode = 'normal'; # default
41              
42             sub _croak {
43 1     1   5 require Carp;
44 1         191 Carp::croak(@_);
45             }
46              
47             sub mode {
48 8     8 1 5495 my ($class, $mode) = @_;
49             ### Test-Without-Shm mode(): @_
50              
51 8 100       31 if (@_ > 1) {
52 4 50       22 $modes{$mode} or _croak "No such $class mode: ",$mode;
53 4         8 $current_mode = $mode;
54             }
55 8         34 return $current_mode;
56             }
57              
58             sub import {
59 2     2   17 my $class = shift;
60             ### Test-Without-Shm import(): @_
61              
62 2 50       11 if (! @_) {
63             # default
64 2         61 $current_mode = 'notimp';
65             } else {
66 0         0 foreach (@_) {
67 0 0       0 if ($_ eq '-notimp') {
    0          
    0          
68 0         0 $current_mode = 'notimp';
69             } elsif ($_ eq '-nomem') {
70 0         0 $current_mode = 'nomem';
71             } elsif ($_ eq '-normal') {
72 0         0 $current_mode = 'normal';
73             } else {
74 0         0 _croak 'Test::Without::Shm unrecognised import option: ',$_;
75             }
76             }
77             }
78             }
79              
80             sub unimport {
81 0     0   0 $current_mode = 'normal';
82             }
83              
84              
85             *CORE::GLOBAL::shmget = \&Test_Without_Shm_shmget;
86             sub Test_Without_Shm_shmget ($$$) {
87 2     2 0 3246 my ($key, $size, $flags) = @_;
88             ### Test-Without-Shm shmget() ...
89              
90 2 100       7 if ($current_mode eq 'notimp') {
91             # this message string per doio.c Perl_do_ipcget()
92 1         6 _croak "shmget not implemented";
93             }
94 1 50       5 if ($current_mode eq 'nomem') {
95 1         470 require POSIX;
96 1         5701 $! = POSIX::ENOMEM();
97 1         5 return undef;
98             }
99 0           return CORE::shmget ($key, $size, $flags);
100             }
101              
102             *CORE::GLOBAL::shmread = \&Test_Without_Shm_shmread;
103             sub Test_Without_Shm_shmread ($$$$) {
104 0     0 0   my ($id,$var,$pos,$size) = @_;
105 0 0         if ($current_mode eq 'notimp') {
106             # this message string per doio.c Perl_do_shmio()
107 0           _croak "shm I/O not implemented";
108             }
109 0           return CORE::shmread($id,$var,$pos,$size);
110             }
111              
112             *CORE::GLOBAL::shmwrite = \&Test_Without_Shm_shmwrite;
113             sub Test_Without_Shm_shmwrite ($$$$) {
114 0     0 0   my ($id,$str,$pos,$size) = @_;
115 0 0         if ($current_mode eq 'notimp') {
116             # this message per doio.c Perl_do_shmio()
117 0           _croak "shm I/O not implemented";
118             }
119 0           return CORE::shmwrite($id,$str,$pos,$size);
120             }
121              
122             *CORE::GLOBAL::shmctl = \&Test_Without_Shm_shmctl;
123             sub Test_Without_Shm_shmctl ($$$) {
124 0     0 0   my ($id,$cmd,$arg) = @_;
125 0 0         if ($current_mode eq 'notimp') {
126             # this message string per doio.c Perl_do_ipcctl()
127 0           _croak "shmctl not implemented";
128             }
129 0           return CORE::shmctl($id,$cmd,$arg);
130             }
131              
132             1;
133             __END__