skip appropriately when XS::APItest isn't available
[perl.git] / regen / keywords.pl
1 #!/usr/bin/perl -w
2 #
3 # Regenerate (overwriting only if changed):
4 #
5 #    keywords.h keywords.c
6 #
7 # from information stored in the DATA section of this file.
8 #
9 # Accepts the standard regen_lib -q and -v args.
10
11 use strict;
12 use Devel::Tokenizer::C 0.05;
13
14 require 'regen/regen_lib.pl';
15
16 my $h = open_new('keywords.h', '>',
17                  { by => 'regen/keywords.pl', from => 'its data',
18                    file => 'keywords.h', style => '*',
19                    copyright => [1994 .. 1997, 1999 .. 2002, 2005 .. 2007]});
20 my $c = open_new('keywords.c', '>',
21                  { by => 'regen/keywords.pl', from => 'its data', style => '*'});
22
23 my %by_strength;
24
25 my $keynum = 0;
26 while (<DATA>) {
27     chop;
28     next unless $_;
29     next if /^#/;
30     my ($strength, $keyword) = /^([- +])([A-Z_a-z2]+)/;
31     die "Bad line '$_'" unless defined $strength;
32     print $h tab(5, "#define KEY_$keyword"), $keynum++, "\n";
33     push @{$by_strength{$strength}}, $keyword;
34 }
35
36 # If this hash changes, make sure the equivalent hash in
37 # dist/B-Deparse/Deparse.pm is also updated.
38 my %feature_kw = (
39         given   => 'switch',
40         when    => 'switch',
41         default => 'switch',
42         # continue is already a keyword
43         break   => 'switch',
44
45         say     => 'say',
46
47         state   => 'state',
48
49         evalbytes=>'evalbytes',
50
51         __SUB__ => '__SUB__',
52
53         fc      => 'fc',
54         );
55
56 my %pos = map { ($_ => 1) } @{$by_strength{'+'}};
57
58 my $t = Devel::Tokenizer::C->new(TokenFunc     => \&perl_keyword,
59                                  TokenString   => 'name',
60                                  StringLength  => 'len',
61                                  MergeSwitches => 1,
62                                 );
63
64 $t->add_tokens(@{$by_strength{'+'}}, @{$by_strength{'-'}}, 'elseif');
65
66 my $switch = $t->generate(Indent => '  ');
67
68 print $c <<"END";
69 #include "EXTERN.h"
70 #define PERL_IN_KEYWORDS_C
71 #include "perl.h"
72 #include "keywords.h"
73 #include "feature.h"
74
75 I32
76 Perl_keyword (pTHX_ const char *name, I32 len, bool all_keywords)
77 {
78   dVAR;
79
80   PERL_ARGS_ASSERT_KEYWORD;
81
82 $switch
83 unknown:
84   return 0;
85 }
86 END
87
88 sub perl_keyword
89 {
90   my $k = shift;
91   my $sign = $pos{$k} ? '' : '-';
92
93   if ($k eq 'elseif') {
94     return <<END;
95 Perl_ck_warner_d(aTHX_ packWARN(WARN_SYNTAX), "elseif should be elsif");
96 END
97   }
98   elsif (my $feature = $feature_kw{$k}) {
99     $feature =~ s/([\\"])/\\$1/g;
100     return <<END;
101 return (all_keywords || FEATURE_\U$feature\E_IS_ENABLED ? ${sign}KEY_$k : 0);
102 END
103   }
104   return <<END;
105 return ${sign}KEY_$k;
106 END
107 }
108
109 read_only_bottom_close_and_rename($_, [$0]) foreach $c, $h;
110
111
112 # coresub_op in op.c expects __FILE__, __LINE__ and __PACKAGE__ to be the
113 # first three.
114
115 __END__
116
117  NULL
118 -__FILE__
119 -__LINE__
120 -__PACKAGE__
121 +__DATA__
122 +__END__
123 -__SUB__
124 +AUTOLOAD
125 +BEGIN
126 +UNITCHECK
127 -CORE
128 +DESTROY
129 +END
130 +INIT
131 +CHECK
132 -abs
133 -accept
134 -alarm
135 -and
136 -atan2
137 -bind
138 -binmode
139 -bless
140 -break
141 -caller
142 -chdir
143 -chmod
144 -chomp
145 -chop
146 -chown
147 -chr
148 -chroot
149 -close
150 -closedir
151 -cmp
152 -connect
153 -continue
154 -cos
155 -crypt
156 -dbmclose
157 -dbmopen
158 +default
159 +defined
160 +delete
161 -die
162 +do
163 -dump
164 -each
165 +else
166 +elsif
167 -endgrent
168 -endhostent
169 -endnetent
170 -endprotoent
171 -endpwent
172 -endservent
173 -eof
174 -eq
175 +eval
176 -evalbytes
177 -exec
178 +exists
179 -exit
180 -exp
181 -fc
182 -fcntl
183 -fileno
184 -flock
185 +for
186 +foreach
187 -fork
188 +format
189 -formline
190 -ge
191 -getc
192 -getgrent
193 -getgrgid
194 -getgrnam
195 -gethostbyaddr
196 -gethostbyname
197 -gethostent
198 -getlogin
199 -getnetbyaddr
200 -getnetbyname
201 -getnetent
202 -getpeername
203 -getpgrp
204 -getppid
205 -getpriority
206 -getprotobyname
207 -getprotobynumber
208 -getprotoent
209 -getpwent
210 -getpwnam
211 -getpwuid
212 -getservbyname
213 -getservbyport
214 -getservent
215 -getsockname
216 -getsockopt
217 +given
218 +glob
219 -gmtime
220 +goto
221 +grep
222 -gt
223 -hex
224 +if
225 -index
226 -int
227 -ioctl
228 -join
229 -keys
230 -kill
231 +last
232 -lc
233 -lcfirst
234 -le
235 -length
236 -link
237 -listen
238 +local
239 -localtime
240 -lock
241 -log
242 -lstat
243 -lt
244 +m
245 +map
246 -mkdir
247 -msgctl
248 -msgget
249 -msgrcv
250 -msgsnd
251 +my
252 -ne
253 +next
254 +no
255 -not
256 -oct
257 -open
258 -opendir
259 -or
260 -ord
261 +our
262 -pack
263 +package
264 -pipe
265 -pop
266 +pos
267 +print
268 +printf
269 +prototype
270 -push
271 +q
272 +qq
273 +qr
274 -quotemeta
275 +qw
276 +qx
277 -rand
278 -read
279 -readdir
280 -readline
281 -readlink
282 -readpipe
283 -recv
284 +redo
285 -ref
286 -rename
287 +require
288 -reset
289 +return
290 -reverse
291 -rewinddir
292 -rindex
293 -rmdir
294 +s
295 +say
296 +scalar
297 -seek
298 -seekdir
299 -select
300 -semctl
301 -semget
302 -semop
303 -send
304 -setgrent
305 -sethostent
306 -setnetent
307 -setpgrp
308 -setpriority
309 -setprotoent
310 -setpwent
311 -setservent
312 -setsockopt
313 -shift
314 -shmctl
315 -shmget
316 -shmread
317 -shmwrite
318 -shutdown
319 -sin
320 -sleep
321 -socket
322 -socketpair
323 +sort
324 -splice
325 +split
326 -sprintf
327 -sqrt
328 -srand
329 -stat
330 +state
331 +study
332 +sub
333 -substr
334 -symlink
335 -syscall
336 -sysopen
337 -sysread
338 -sysseek
339 -system
340 -syswrite
341 -tell
342 -telldir
343 -tie
344 -tied
345 -time
346 -times
347 +tr
348 -truncate
349 -uc
350 -ucfirst
351 -umask
352 +undef
353 +unless
354 -unlink
355 -unpack
356 -unshift
357 -untie
358 +until
359 +use
360 -utime
361 -values
362 -vec
363 -wait
364 -waitpid
365 -wantarray
366 -warn
367 +when
368 +while
369 -write
370 -x
371 -xor
372 +y