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

# Copyright 2011, 2012, 2013, 2015 Kevin Ryde

# This file is part of Test-VariousBits.
#
# Test-VariousBits is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License as published
# by the Free Software Foundation; either version 3, or (at your option) any
# later version.
#
# Test-VariousBits is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General
# Public License for more details.
#
# You should have received a copy of the GNU General Public License along
# with Test-VariousBits.  If not, see .


# cf doio.c
#   Perl_do_ipcget() for shmget
#   Perl_do_shmio() for shmread,shmwrite
#   Perl_do_ipcctl() for shmget
#

package Test::Without::Shm;
require 5;
use strict;

use vars '$VERSION';
$VERSION = 5;

# uncomment this to run the ### lines
#use Devel::Comments;

### Test-Without-Shm loads ...

my %modes = (notimp => 1,
             nomem  => 1,
             normal => 1);
my $current_mode = 'normal';  # default

sub _croak {
  require Carp;
  Carp::croak(@_);
}

sub mode {
  my ($class, $mode) = @_;
  ### Test-Without-Shm mode(): @_

  if (@_ > 1) {
    $modes{$mode} or _croak "No such $class mode: ",$mode;
    $current_mode = $mode;
  }
  return $current_mode;
}

sub import {
  my $class = shift;
  ### Test-Without-Shm import(): @_

  if (! @_) {
    # default
    $current_mode = 'notimp';
  } else {
    foreach (@_) {
      if ($_ eq '-notimp') {
        $current_mode = 'notimp';
      } elsif ($_ eq '-nomem') {
        $current_mode = 'nomem';
      } elsif ($_ eq '-normal') {
        $current_mode = 'normal';
      } else {
        _croak 'Test::Without::Shm unrecognised import option: ',$_;
      }
    }
  }
}

sub unimport {
  $current_mode = 'normal';
}


*CORE::GLOBAL::shmget = \&Test_Without_Shm_shmget;
sub Test_Without_Shm_shmget ($$$) {
  my ($key, $size, $flags) = @_;
  ### Test-Without-Shm shmget() ...

  if ($current_mode eq 'notimp') {
    # this message string per doio.c Perl_do_ipcget()
    _croak "shmget not implemented";
  }
  if ($current_mode eq 'nomem') {
    require POSIX;
    $! = POSIX::ENOMEM();
    return undef;
  }
  return CORE::shmget ($key, $size, $flags);
}

*CORE::GLOBAL::shmread = \&Test_Without_Shm_shmread;
sub Test_Without_Shm_shmread ($$$$) {
  my ($id,$var,$pos,$size) = @_;
  if ($current_mode eq 'notimp') {
    # this message string per doio.c Perl_do_shmio()
    _croak "shm I/O not implemented";
  }
  return CORE::shmread($id,$var,$pos,$size);
}

*CORE::GLOBAL::shmwrite = \&Test_Without_Shm_shmwrite;
sub Test_Without_Shm_shmwrite ($$$$) {
  my ($id,$str,$pos,$size) = @_;
  if ($current_mode eq 'notimp') {
    # this message per doio.c Perl_do_shmio()
    _croak "shm I/O not implemented";
  }
  return CORE::shmwrite($id,$str,$pos,$size);
}

*CORE::GLOBAL::shmctl = \&Test_Without_Shm_shmctl;
sub Test_Without_Shm_shmctl ($$$) {
  my ($id,$cmd,$arg) = @_;
  if ($current_mode eq 'notimp') {
    # this message string per doio.c Perl_do_ipcctl()
    _croak "shmctl not implemented";
  }
  return CORE::shmctl($id,$cmd,$arg);
}

1;
__END__