File Coverage

Strict/Perl.pm
Criterion Covered Total %
statement 42 156 26.9
branch 10 72 13.8
condition 0 9 0.0
subroutine 9 17 52.9
pod 0 1 0.0
total 61 255 23.9


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