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


line stmt bran cond sub pod time code
1             # Copyright 2011, 2012, 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             package Test::Without::GD;
20 2     2   1161 use 5.004; # for ->can()
  2         7  
  2         96  
21 2     2   13 use strict;
  2         4  
  2         91  
22              
23 2     2   11 use vars '$VERSION';
  2         2  
  2         1620  
24             $VERSION = 5;
25              
26             # uncomment this to run the ### lines
27             #use Smart::Comments;
28              
29              
30             sub _croak {
31 0     0   0 require Carp;
32 0         0 Carp::croak(@_);
33             }
34              
35             sub import {
36 2     2   15 my $class = shift;
37 2         47 foreach (@_) {
38 0 0         if (/^-/) {
39 0           my $method = 'without_' . substr($_,1);
40 0 0         if ($class->can($method)) {
41 0           $class->$method();
42 0           next;
43             }
44             }
45 0           _croak 'Unrecognised without option: ',$_;
46             }
47             }
48              
49             my %replaced;
50              
51             sub unimport {
52 0     0     foreach my $name (keys %replaced) {
53 0           local $^W = 0;
54 0           *$name = delete $replaced{$name};
55             }
56             }
57              
58             #------------------------------------------------------------------------------
59             sub without_jpeg {
60 0     0 1   _without_func('GD::Image::_newFromJpeg');
61 0           _without_func('GD::Image::newFromJpegData');
62 0           _without_func('GD::Image::jpeg');
63 0 0         if (my $coderef = GD::Image->can('jpeg')) {
64 0           die "Oops, GD::Image->can('jpeg') still true: $coderef";
65             }
66             }
67              
68             #------------------------------------------------------------------------------
69             sub without_png {
70 0     0 1   _without_func('GD::Image::_newFromPng');
71 0           _without_func('GD::Image::newFromPngData');
72 0           _without_func('GD::Image::png');
73 0 0         if (my $coderef = GD::Image->can('png')) {
74 0           die "Oops, GD::Image->can('png') still true: $coderef";
75             }
76             }
77              
78             #------------------------------------------------------------------------------
79             sub without_gif {
80 0     0 1   _without_func('GD::Image::_newFromGif');
81 0           _without_func('GD::Image::newFromGifData');
82 0           _without_func('GD::Image::gif');
83 0 0         if (my $coderef = GD::Image->can('gif')) {
84 0           die "Oops, GD::Image->can('gif') still true: $coderef";
85             }
86             }
87              
88             #------------------------------------------------------------------------------
89              
90             sub without_gifanim {
91 0     0 1   _change_func('GD::Image::gifanimbegin', \&_Test_Without_GD__gifanimbegin);
92 0           _change_func('GD::Image::gifanimadd', \&_Test_Without_GD__gifanimadd);
93 0           _change_func('GD::Image::gifanimend', \&_Test_Without_GD__gifanimend);
94 0 0         if (eval { GD::Image->gifanim; 1 }) {
  0            
  0            
95 0           die "Oops, GD::Image->gifanim() still works";
96             }
97             }
98             # prototypes here per GD.xs, but presumably have no effect since they're
99             # supposed to be called as methods
100             sub _Test_Without_GD__gifanimbegin ($$$) {
101             # die per gdgifanimbegin() in GD.xs when HAVE_ANIMGIF false
102 0     0     die "libgd 2.0.33 or higher required for animated GIF support";
103             }
104             sub _Test_Without_GD__gifanimadd ($$$$$$$) {
105             # die per gdgifanimadd() in GD.xs when HAVE_ANIMGIF false
106 0     0     die "libgd 2.0.33 or higher required for animated GIF support";
107             }
108             sub _Test_Without_GD__gifanimend ($) {
109             # die per gdgifanimbegin() in GD.xs when HAVE_ANIMGIF false
110 0     0     die "libgd 2.0.33 or higher required for animated GIF support";
111             }
112              
113             #------------------------------------------------------------------------------
114              
115             sub without_xpm {
116 0     0 1   _change_func('GD::Image::newFromXpm', \&_Test_Without_GD__newFromXpm);
117             }
118             # prototype here per GD.xs, but presumably has no effect since it's supposed
119             # to be called as a method
120             sub _Test_Without_GD__newFromXpm ($$) {
121             ### _Test_Without_GD__newFromXpm() ...
122             # empty return and $@ per gdnewFromXpm() in GD.xs when HAVE_XPM false
123 0     0     $@ = "libgd was not built with xpm support\n";
124 0           return;
125             }
126              
127             #------------------------------------------------------------------------------
128              
129             sub _without_func {
130 0     0     my ($name) = @_;
131 0           require GD;
132 0 0         unless ($replaced{$name}) {
133             ### remove: $name
134 0           $replaced{$name} = \&$name;
135 0           require Sub::Delete;
136 0           Sub::Delete::delete_sub($name);
137             }
138             }
139             sub _change_func {
140 0     0     my ($name, $new_coderef) = @_;
141             ### _change_func(): $name
142             ### $new_coderef
143             ### name prototype: prototype $name
144             ### new prototype : prototype $new_coderef
145              
146 0           require GD;
147 0 0         unless ($replaced{$name}) {
148 0           $replaced{$name} = \&$name;
149 2     2   13 no strict 'refs';
  2         3  
  2         113  
150 0           local $^W = 0;
151 0           *$name = $new_coderef;
152             }
153             }
154              
155             1;
156             __END__