File Coverage

blib/lib/Test/Without/GD.pm

Criterion	Covered	Total	%
statement	14	65	21.5
branch	0	16	0.0
condition			n/a
subroutine	5	18	27.7
pod	5	5	100.0
total	24	104	23.0

# Copyright 2011, 2012, 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 .


package Test::Without::GD;
use 5.004;  # for ->can()
use strict;

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

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


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

sub import {
  my $class = shift;
  foreach (@_) {
    if (/^-/) {
      my $method = 'without_' . substr($_,1);
      if ($class->can($method)) {
        $class->$method();
        next;
      }
    }
    _croak 'Unrecognised without option: ',$_;
  }
}

my %replaced;

sub unimport {
  foreach my $name (keys %replaced) {
    local $^W = 0;
    *$name = delete $replaced{$name};
  }
}

#------------------------------------------------------------------------------
sub without_jpeg {
  _without_func('GD::Image::_newFromJpeg');
  _without_func('GD::Image::newFromJpegData');
  _without_func('GD::Image::jpeg');
  if (my $coderef = GD::Image->can('jpeg')) {
    die "Oops, GD::Image->can('jpeg') still true: $coderef";
  }
}

#------------------------------------------------------------------------------
sub without_png {
  _without_func('GD::Image::_newFromPng');
  _without_func('GD::Image::newFromPngData');
  _without_func('GD::Image::png');
  if (my $coderef = GD::Image->can('png')) {
    die "Oops, GD::Image->can('png') still true: $coderef";
  }
}

#------------------------------------------------------------------------------
sub without_gif {
  _without_func('GD::Image::_newFromGif');
  _without_func('GD::Image::newFromGifData');
  _without_func('GD::Image::gif');
  if (my $coderef = GD::Image->can('gif')) {
    die "Oops, GD::Image->can('gif') still true: $coderef";
  }
}

#------------------------------------------------------------------------------

sub without_gifanim {
  _change_func('GD::Image::gifanimbegin', \&_Test_Without_GD__gifanimbegin);
  _change_func('GD::Image::gifanimadd',   \&_Test_Without_GD__gifanimadd);
  _change_func('GD::Image::gifanimend',   \&_Test_Without_GD__gifanimend);
  if (eval { GD::Image->gifanim; 1 }) {
    die "Oops, GD::Image->gifanim() still works";
  }
}
# prototypes here per GD.xs, but presumably have no effect since they're
# supposed to be called as methods
sub _Test_Without_GD__gifanimbegin ($$$) {
  # die per gdgifanimbegin() in GD.xs when HAVE_ANIMGIF false
  die "libgd 2.0.33 or higher required for animated GIF support";
}
sub _Test_Without_GD__gifanimadd ($$$$$$$) {
  # die per gdgifanimadd() in GD.xs when HAVE_ANIMGIF false
  die "libgd 2.0.33 or higher required for animated GIF support";
}
sub _Test_Without_GD__gifanimend ($) {
  # die per gdgifanimbegin() in GD.xs when HAVE_ANIMGIF false
  die "libgd 2.0.33 or higher required for animated GIF support";
}

#------------------------------------------------------------------------------

sub without_xpm {
  _change_func('GD::Image::newFromXpm', \&_Test_Without_GD__newFromXpm);
}
# prototype here per GD.xs, but presumably has no effect since it's supposed
# to be called as a method
sub _Test_Without_GD__newFromXpm ($$) {
  ### _Test_Without_GD__newFromXpm() ...
  # empty return and $@ per gdnewFromXpm() in GD.xs when HAVE_XPM false
  $@ = "libgd was not built with xpm support\n";
  return;
}

#------------------------------------------------------------------------------

sub _without_func {
  my ($name) = @_;
  require GD;
  unless ($replaced{$name}) {
    ### remove: $name
    $replaced{$name} = \&$name;
    require Sub::Delete;
    Sub::Delete::delete_sub($name);
  }
}
sub _change_func {
  my ($name, $new_coderef) = @_;
  ### _change_func(): $name
  ### $new_coderef
  ### name prototype: prototype $name
  ### new prototype : prototype $new_coderef

  require GD;
  unless ($replaced{$name}) {
    $replaced{$name} = \&$name;
    no strict 'refs';
    local $^W = 0;
    *$name = $new_coderef;
  }
}

1;
__END__