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