LXR perl/perl_keyword.pl

   1
   2# How to generate the logic of the lookup table Perl_keyword() in toke.c
   3
   4use Devel::Tokenizer::C 0.05;
   5use strict;
   6use warnings;
   7
   8my @pos = qw(__DATA__ __END__ AUTOLOAD BEGIN CHECK DESTROY default defined
   9            delete do END else eval elsif exists for format foreach given grep
  10            goto glob INIT if last local m my map next no our pos print printf
  11            package prototype q qr qq qw qx redo return require s say scalar sort
  12            split state study sub tr tie tied use undef UNITCHECK until untie
  13            unless when while y);
  14
  15my @neg = qw(__FILE__ __LINE__ __PACKAGE__ and abs alarm atan2 accept bless
  16            break bind binmode CORE cmp chr cos chop close chdir chomp chmod
  17            chown crypt chroot caller connect closedir continue die dump
  18            dbmopen dbmclose eq eof err exp exit exec each endgrent endpwent
  19            endnetent endhostent endservent endprotoent fork fcntl flock fileno
  20            formline getppid getpgrp getpwent getpwnam getpwuid getpeername
  21            getprotoent getpriority getprotobyname getprotobynumber
  22            gethostbyname gethostbyaddr gethostent getnetbyname getnetbyaddr
  23            getnetent getservbyname getservbyport getservent getsockname
  24            getsockopt getgrent getgrnam getgrgid getlogin getc gt ge gmtime
  25            hex int index ioctl join keys kill lt le lc log link lock lstat
  26            length listen lcfirst localtime mkdir msgctl msgget msgrcv msgsnd
  27            ne not or ord oct open opendir pop push pack pipe quotemeta ref
  28            read rand recv rmdir reset rename rindex reverse readdir readlink
  29            readline readpipe rewinddir seek send semop select semctl semget
  30            setpgrp seekdir setpwent setgrent setnetent setsockopt sethostent
  31            setservent setpriority setprotoent shift shmctl shmget shmread
  32            shmwrite shutdown sin sleep socket socketpair sprintf splice sqrt
  33            srand stat substr system symlink syscall sysopen sysread sysseek
  34            syswrite tell time times telldir truncate uc utime umask unpack
  35            unlink unshift ucfirst values vec warn wait write waitpid wantarray
  36            x xor);
  37
  38my %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        err     => 'err',
  48
  49        state   => 'state',
  50        );
  51
  52my %pos = map { ($_ => 1) } @pos;
  53
  54my $t = Devel::Tokenizer::C->new( TokenFunc     => \&perl_keyword
  55                                , TokenString   => 'name'
  56                                , StringLength  => 'len'
  57                                , MergeSwitches => 1
  58                                );
  59
  60$t->add_tokens(@pos, @neg, 'elseif');
  61
  62my $switch = $t->generate(Indent => '  ');
  63
  64print <<END;
  65/*
  66 *  The following code was generated by $0.
  67 */
  68
  69I32
  70Perl_keyword (pTHX_ const char *name, I32 len, bool all_keywords)
  71{
  72    dVAR;
  73$switch
  74unknown:
  75  return 0;
  76}
  77END
  78
  79sub perl_keyword
  80{
  81  my $k = shift;
  82  my $sign = $pos{$k} ? '' : '-';
  83
  84  if ($k eq 'elseif') {
  85    return <<END;
  86if(ckWARN_d(WARN_SYNTAX))
  87  Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "elseif should be elsif");
  88END
  89  }
  90  elsif (my $feature = $feature_kw{$k}) {
  91    $feature =~ s/([\\"])/\\$1/g;
  92    return <<END;
  93return (all_keywords || FEATURE_IS_ENABLED("$feature") ? ${sign}KEY_$k : 0);
  94END
  95  }
  96  return <<END;
  97return ${sign}KEY_$k;
  98END
  99}
 100