File Coverage

lib/Strict/Perl.pm
Criterion Covered Total %
statement 24 138 17.3
branch 2 58 3.4
condition 0 3 0.0
subroutine 11 20 55.0
pod 0 1 0.0
total 37 220 16.8


line stmt bran cond sub pod time code
1             package Strict::Perl;
2             ######################################################################
3             #
4             # Strict::Perl - Perl module to restrict old/unsafe constructs
5             #
6             # http://search.cpan.org/dist/Strict-Perl/
7             #
8             # Copyright (c) 2014, 2015, 2017, 2018, 2019 INABA Hitoshi in a CPAN
9             ######################################################################
10              
11             $VERSION = '2019.07';
12             $VERSION = $VERSION;
13              
14 1     1   3387 use 5.00503;
  1         3  
15 1     1   4 use strict;
  1         2  
  1         39  
16 1 50   1   23 BEGIN { $INC{'warnings.pm'} = '' if $] < 5.006 }; use warnings; $^W=1;
  1     1   5  
  1         2  
  1         713  
17              
18             # use strict;
19             sub _strict {
20 0     0   0 require strict;
21 0 0       0 if (exists $INC{'Fake/Our.pm'}) {
22             # no strict qw(vars); on Fake::Our used
23             }
24             else {
25 0         0 strict::->import(qw(vars));
26             }
27 0         0 strict::->import(qw(refs subs));
28             }
29              
30             # use warnings;
31             sub _warnings {
32 1     1   6 require warnings;
33 1         1028 warnings::->import;
34             }
35              
36             # install Fatal CORE::* functions
37             sub _Fatal {
38 0     0   0 my $package = (caller(1))[0];
39              
40 0         0 for my $function (
41             qw(seek sysseek), # :io (excluded: read sysread syswrite)
42             qw(dbmclose dbmopen), # :dbm
43             qw(binmode close chmod chown fcntl flock ioctl truncate), # :file (excluded: fileno)
44             qw(chdir closedir link mkdir readlink rename rmdir symlink), # :filesys (excluded: unlink)
45             qw(msgctl msgget msgrcv msgsnd), # :msg
46             qw(semctl semget semop), # :semaphore
47             qw(shmctl shmget shmread), # :shm
48             qw(bind connect getsockopt listen recv send setsockopt shutdown socketpair), # :socket
49             qw(fork), # :threads
50             ) {
51 0         0 _install_fatal_function($function, $package);
52             }
53              
54             # not on Modern::Open
55 0 0       0 if (not exists $INC{'Modern/Open.pm'}) {
56 0         0 for my $function (qw(open opendir sysopen pipe accept)) {
57 0         0 _install_fatal_function($function, $package);
58             }
59             }
60             }
61              
62             # make fatal invocation
63             sub _fatal_invocation {
64 0     0   0 my($function, $proto) = @_;
65              
66 0         0 my $n = -1;
67 0         0 local @_ = ();
68 0         0 my @prototype = ();
69 0         0 my $seen_semicolon = 0;
70              
71 0         0 $proto =~ s/_$/;\$/;
72 0         0 $proto =~ s/_;/;\$/;
73 0         0 while ($proto =~ /\S/) {
74 0         0 $n++;
75 0 0       0 if ($seen_semicolon) {
76 0         0 push @prototype, [$n, @_];
77             }
78 0 0       0 if ($proto =~ s/^\s*\\([\@%\$\&])//) {
79 0         0 push @_, $1 . "{\$_[$n]}";
80 0         0 next;
81             }
82 0 0       0 if ($proto =~ s/^\s*([*\$&])//) {
83 0         0 push @_, "\$_[$n]";
84 0         0 next;
85             }
86 0 0       0 if ($proto =~ s/^\s*(;\s*)?\@//) {
87 0         0 push @_, "\@_[$n..\$#_]";
88 0         0 last;
89             }
90 0 0       0 if ($proto =~ s/^\s*;//) {
91 0         0 $seen_semicolon = 1;
92 0         0 $n--;
93 0         0 next;
94             }
95 0         0 die "Unknown prototype letters: \"$proto\"";
96             }
97 0         0 push @prototype, [$n+1, @_];
98              
99 0 0       0 if (@prototype == 1) {
100 0         0 my @argv = @{$prototype[0]};
  0         0  
101 0         0 shift @argv;
102 0         0 local $" = ', ';
103 0         0 return qq{\tCORE::$function(@argv) || croak "Can't $function(\@_): \$!";};
104             }
105             else {
106 0         0 local @_ = <
107             \tif (0) {
108             \t}
109             END
110 0         0 while (@prototype) {
111 0         0 my @argv = @{shift @prototype};
  0         0  
112 0         0 my $n = shift @argv;
113 0         0 local $" = ', ';
114 0         0 push @_, <
115             \telsif (\@_ == $n) {
116             \t\treturn CORE::$function(@argv) || croak "Can't $function(\@_): \$!";
117             \t}
118             END
119             }
120 0         0 push @_, qq{\tdie "$function(\@_): Do not expect to get ", scalar \@_, " arguments";};
121 0         0 return join '', @_;
122             }
123             }
124              
125             # install Fatal function to package
126             sub _install_fatal_function {
127 0     0   0 my($function, $package) = @_;
128              
129 0         0 my $proto = eval { prototype "CORE::$function" };
  0         0  
130 0 0       0 if ($@) {
131 0         0 die "$function is not a builtin";
132             }
133 0 0       0 if (not defined $proto) {
134 0         0 die "Cannot install a fatal function since non-overridable builtin";
135             }
136              
137 0         0 my $code = <
138             sub ($proto) {
139             \tlocal \$" = ', ';
140             \tlocal \$! = 0;
141 0         0 @{[_fatal_invocation($function,$proto)]}
142             }
143              
144             END
145             {
146 1     1   6 no strict 'refs';
  1         2  
  1         594  
  0         0  
147 0         0 $code = eval "package $package; use Carp; $code";
148 0 0       0 die if $@;
149 0         0 local $^W = 0;
150 0         0 *{"${package}::$function"} = $code;
  0         0  
151             }
152             }
153              
154             # use autodie qw(...);
155             sub _autodie {
156 0     0   0 require autodie;
157             package main;
158 0         0 autodie::->import(
159             qw(read sysread syswrite), # :io
160             qw(fileno), # :file
161             # nothing # :filesys (excluded: unlink)
162             );
163             }
164              
165             # $SIG{__WARN__}, $SIG{__DIE__}
166             sub _SIG {
167              
168             # use warnings qw(FATAL all);
169             $SIG{__WARN__} = sub {
170              
171             # avoid: Use of reserved word "our" is deprecated
172 0 0 0 0   0 if (($_[0] =~ /^Use of reserved word "our" is deprecated at /) and exists $INC{'Fake/Our.pm'}) {
    0          
173             # ignore message
174             }
175              
176             # ignore wrong warning: Name "main::BAREWORD" used only once
177             elsif ($_[0] =~ /Name "main::[A-Za-z_][A-Za-z_0-9]*" used only once:/) {
178 0 0       0 if ($] < 5.012) {
179             # ignore message
180             }
181             else {
182 0         0 $SIG{__DIE__}->(@_);
183             }
184             }
185             else {
186 0         0 $SIG{__DIE__}->(@_);
187             }
188 1     1   6 };
189              
190             # HACK #55 Show Source Code on Errors in Chapter 6: Debugging of PERL HACKS
191             $SIG{__DIE__} = sub {
192 0     0     print STDERR __PACKAGE__, ': ';
193 0 0         print STDERR "$^E\n" if defined($^E);
194 0           print STDERR "$_[0]\n";
195              
196 0           my $i = 0;
197 0           my @confess = ();
198 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
199 0           push @confess, [$i,$package,$filename,$line,$subroutine];
200 0           $i++;
201             }
202 0           for my $confess (reverse @confess) {
203 0           my($i,$package,$filename,$line,$subroutine) = @{$confess};
  0            
204 0 0         next if $package eq __PACKAGE__;
205 0 0         next if $package eq 'Carp';
206              
207 0           print STDERR "[$i] $subroutine in $filename\n";
208 0 0         if (open(SCRIPT,$filename)) {
209 0           my @script = (undef,