Login
Further work on RequireLocalizedPunctuationVars.run.PL
[gknop/Perl-Critic.git] / t / Variables / RequireLocalizedPunctuationVars.run.PL
1 #!perl
2 ##############################################################################
3 #      $URL$
4 #     $Date$
5 #   $Author$
6 # $Revision$
7 ##############################################################################
8 use warnings;
9 use strict;
10 use B::Keywords qw();
11 use Carp qw(confess);
12 use English qw(-no_match_vars);
13
14 my $this_program = __FILE__;
15 (my $test_file_name = $this_program) =~ s/ \.PL \z //xms;
16 if ($this_program eq $test_file_name) {
17     confess
18         'Was not able to figure out the name of the file to generate.'
19         . "This program: $this_program.";
20 }
21
22 print "\n\nGenerating $test_file_name.\n";
23
24
25
26 open my $test_file, '>', $test_file_name
27     or die "Could not open $test_file_name: $ERRNO";
28
29 my @globals = (
30     @B::Keywords::Arrays,
31     @B::Keywords::Hashes,
32     @B::Keywords::Scalars,
33 );
34 my %exceptions = map {$_ => 1} qw(
35     $_
36     $ARG
37     @_
38 );
39
40 ## PPI bug.  Remove this later when we depend on a PPI version where these are recognized as magic
41 use PPI;
42 my $is_broken_ppi = PPI->VERSION lt '1.119_04';
43 my %bugs = $is_broken_ppi ? map {$_ => 1} qw( %! %^H ) : ();
44
45 %exceptions = (%exceptions, %bugs);
46
47 my $carat_re = qr/\A [\$%]\^\w+ /xms;
48
49 my $numvars = @globals - keys %exceptions;
50 my $numcarats = grep {!$exceptions{$_} && m/ $carat_re /xms} @globals;
51
52 print {$test_file} <<"EOF";
53 ##### This file auto-generated by $0 #####
54 # Skipping the following magic variables which PPI can't parse: @{[sort keys %bugs]}
55 EOF
56
57 print {$test_file} <<'EOF';
58
59 ## name Named magic variables, special case passes
60 ## failures 0
61 ## cut
62
63 local ($_, $RS) = ();
64 local $SIG{__DIE__} = sub { print "AAAAAAARRRRRGGGGHHHHH....\n"; };
65 $_ = 1;
66 $ARG = 1;
67 @_ = (1, 2, 3);
68
69 #-----------------------------------------------------------------------------
70
71 ## name Named magic variables, special case failures
72 ## failures 1
73 ## TODO we are not handling dereferences yet...
74 ## cut
75
76 $SIG{__DIE__} = sub { print "AAAAAAARRRRRGGGGHHHHH....\n"; };
77
78 #-----------------------------------------------------------------------------
79
80 ## name Named magic variables, pass local
81 ## failures 0
82 ## cut
83
84 EOF
85
86 for my $varname (@globals) {
87     print {$test_file} "local $varname = ();\n";
88 }
89
90 print {$test_file} <<"EOF";
91
92 #-----------------------------------------------------------------------------
93
94 ## name Named magic variables, pass local()
95 ## failures 0
96 ## cut
97
98 EOF
99
100 for my $varname (@globals) {
101     print {$test_file} "local ($varname) = ();\n";
102 }
103
104 print {$test_file} <<"EOF";
105
106 #-----------------------------------------------------------------------------
107
108 ## name Named magic variables, pass (local)
109 ## failures 0
110 ## cut
111
112 EOF
113
114 for my $varname (@globals) {
115     print {$test_file} "(local $varname) = ();\n";
116 }
117
118 print {$test_file} <<"EOF";
119
120 #-----------------------------------------------------------------------------
121
122 ## name Named magic variables, pass = (local) =
123 ## failures 0
124 ## cut
125
126 EOF
127
128 for my $varname (@globals) {
129     print {$test_file} "\@foo = (local $varname) = ();\n";
130 }
131
132 print {$test_file} <<"EOF";
133
134 #-----------------------------------------------------------------------------
135
136 ## name Named magic variables, fail non-local, non-carats
137 ## failures @{[$numvars - $numcarats]}
138 ## cut
139
140 EOF
141
142 for my $varname (@globals) {
143     next if $exceptions{$varname};
144     next if $varname =~ m/ $carat_re /xms;
145     print {$test_file} "$varname = ();\n";
146 }
147
148 print {$test_file} <<"EOF";
149
150 #-----------------------------------------------------------------------------
151
152 ## name Named magic variables, fail non-local, carats
153 ## failures $numcarats
154 ### TODO PPI bug parsing vars like \$^X, fixed in PPI v1.119_04+
155 ## cut
156
157 EOF
158
159 for my $varname (@globals) {
160     next if $exceptions{$varname};
161     next if $varname !~ m/ $carat_re /xms;
162     print {$test_file} "$varname = ();\n";
163 }
164
165 print {$test_file} <<"EOF";
166
167 #-----------------------------------------------------------------------------
168
169 ## name Named magic variables, fail non-local, carats, no space
170 ## failures $numcarats
171 ## cut
172
173 EOF
174
175 for my $varname (@globals) {
176     next if $exceptions{$varname};
177     next if $varname !~ m/ $carat_re /xms;
178     print {$test_file} "$varname= ();\n";
179 }
180
181 print {$test_file} <<"EOF";
182
183 #-----------------------------------------------------------------------------
184
185 ## name Named magic variables, fail = (non-local) =
186 ## failures $numvars
187 ## cut
188
189 EOF
190
191 for my $varname (@globals) {
192     next if $exceptions{$varname};
193     print {$test_file} "\@foo = ($varname) = ();\n";
194 }
195
196 print {$test_file} <<"EOF";
197
198 #-----------------------------------------------------------------------------
199
200 ## name Named magic variables, fail (non-local)
201 ## failures $numvars
202 ## cut
203
204 EOF
205
206 for my $varname (@globals) {
207     next if $exceptions{$varname};
208     print {$test_file} "($varname) = ();\n";
209 }
210
211
212 print {$test_file} <<'EOF';
213
214 #-----------------------------------------------------------------------------
215
216 ##############################################################################
217 #      $\URL$
218 #     $\Date$
219 #   $\Author$
220 # $\Revision$
221 ##############################################################################
222
223 # Local Variables:
224 #   mode: cperl
225 #   cperl-indent-level: 4
226 #   fill-column: 78
227 #   indent-tabs-mode: nil
228 #   c-indentation-style: bsd
229 # End:
230 # ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab :
231 EOF
232
233 close $test_file;
234 print "Done.\n\n";