view release on metacpan or  search on metacpan

Tokener.pm  view on Meta::CPAN

package Perl6::Tokener;
use Text::Balanced qw(extract_quotelike);
my %keywords = map {$_=>1} (qw(
given when CATCH break try POST class
__FILE__ __LINE__ __PACKAGE__ __DATA__ __END__ AUTOLOAD BEGIN CORE 
DESTROY END INIT CHECK abs accept alarm and atan2 bind binmode bless 
caller chdir chmod chomp chop chown chr chroot close closedir cmp 
connect continue cos crypt dbmclose dbmopen defined delete die do 
each else elsif endgrent endhostent endnetent endprotoent endpwent 
endservent eof eq eval exec exists exit exp fcntl fileno flock for 
foreach fork format formline ge getc glob gmtime goto grep gt hex if 
index int ioctl join keys kill last lc lcfirst le length link listen 
local localtime lock log lstat lt m map mkdir my ne next no not oct 
open opendir or ord our pack package pipe pop pos print printf prototype 
push q qq qr quotemeta qw qx rand read readdir readline readlink readpipe 
recv redo ref rename require reset return reverse rewinddir rindex rmdir 
s scalar seek seekdir select shift sin sleep sort splice split sprintf 
sqrt srand stat study sub substr tell telldir tie tied time tr truncate 
uc ucfirst umask undef unless unlink unpack unshift untie until use 
values vec wait waitpid wantarray warn while write x xor y 
));

my %tokener = (
    '$'  => \&dollar,
    '@'  => \&at,
    '%'  => \&hash,
    '+'  => sub {operator(shift, type => "addop")}, 
    '+=' => sub {operator(shift, type => "assignop", length => 2)},
    '*'  => sub {operator(shift, type => "mulop")}, 
    '**' => sub {operator(shift, type => "powop",    length => 2)},
    '*=' => sub {operator(shift, type => "assignop", length => 2)},
    '-'  => sub {operator(shift, type => "addop")}, 
    '-=' => sub {operator(shift, type => "assignop", length => 2)},
    '++' => \&inc,
    '--' => \&dec,
    '/' => \&slash,

    '>=' => sub {operator(shift, type => "comparison", length => 2)},
    '>' => sub {operator(shift, type => "comparison")},
    '>>' => sub {operator(shift, type => "shiftop", length => 2)},

    '==' => sub {operator(shift, type => "comparison", length => 2)},
    '=>' => sub {operator(shift, type => "pair", length => 2)},
    '=~' => sub {operator(shift, type => "match", length => 2)},
    '=' => sub {operator(shift, type => "assignop") },
    '#' => \&comment,

    '<' => \&less_or_readln,
    '<=' => sub {operator(shift, type => "comparison", length => 2)},
    '<=>' => sub {operator(shift, type => "comparison", length => 3)},
    '<<' => \&shift_or_heredoc,

    ' '   => \&space, "\t" => \&space, "\n" => \&space, 
    ';'   => \&operator, 
    '.'   => \&dot,
    '..' => sub {operator(shift, type => "range", length => 2)},
    '...' => \&tripledot,
    ','   => \&operator, 
    '['   => \&operator,
    ']'  =>  \&term,
    '!'   =>  sub {operator(shift, type=> "unop") },
    '\\'   =>  sub {operator(shift, type=> "refgen") },
    '('  => sub {operator(shift, type=> "token", check => "no") },
    ')'  => sub {term(shift, check=>"no") },
    '{'  => sub {operator(shift, type=> "blockstart") },
    '}'  => sub {operator(shift, type=> "blockend", check => "no", state => "ANY") },
    #'{'  => \&block_or_subscript,
    #'}'  => \&end_curly,
    '_' => sub {operator(shift, type=>"addop")},
    '|' => sub {operator(shift, type=>"logop")},
    '||' => sub {operator(shift, length=>2, type=>"logop")},
    '||=' => sub {operator(shift, length=>3, type=>"assignop")},

    '^'  => \&hyper, 
    '"'  => \&quote, "'" => \&quote,
    '`'  => \&quote, # Of sorts

);

$tokener{$_} = \&number for 0 .. 9;
$tokener{$_} = \&bareword for "a".."z","A".."Z", "_";

$tokener{"-$_"} = \&filetest
    for split //, "rwxoRWXOezsfdlpSugkbctTBMAC";

my %keyword_tokens = ( 
    '__FILE__' => sub {$_[0]->{type}="constant"; $_[0]->{token}=$_[0]->file },
    '__LINE__' => sub {$_[0]->{type}="constant"; $_[0]->{token}=$_[0]->{line} },
    '__PACKAGE__' => sub {$_[0]->{type}="constant"; $_[0]->{token}=$_[0]->{package} },
    'AUTOLOAD' => \&block_or_sub,
    'BEGIN' => \&block_or_sub,
    'CATCH' => \&block_or_sub,
    'CHECK' => \&block_or_sub,
    'DESTROY' => \&block_or_sub,
    'END' => \&block_or_sub,
    'INIT' => \&block_or_sub,
    'POST' => \&block_or_sub,
    # I don't care about CORE:: any more. Do you?
    'abs' => \&uni,
    'alarm' => \&uni,
    'and' => sub { my $t=shift; $t->{state}="TERM"; $t->{type}="andop" },
    'atan2' => \&uni,
    'binmode' => \&lop,
    'bless' => \&lop,
    'chop' => \&uni,
    'continue' => \&preblock,
    'chdir' => \&uni,
    'close' => \&uni,
    'closedir' => \&uni,
    'cmp' => sub { my $t=shift; $t->{state}="TERM"; $t->{type}="comparison" },
    'caller' => \&uni,
    'crypt' => \&lop,
    'chmod' => \&lop,
    'chown' => \&lop,
    'class' => sub { my $t=shift; $t->{state}="TERM"; $t->{type}="operator" }, #also need to set $t->{package}
    'connect' => \&lop,
    'chr' => \&uni,
    'cos' => \&uni,
    'die' => \&lop,
    'defined' => \&uni,
    'delete' => \&uni,
    'else' => \&preblock,
    'elsif' => sub { my $t=shift; $t->{state}="TERM"; $t->{type}="operator" },
    'eq' => sub { my $t=shift; $t->{state}="TERM"; $t->{type}="comparison" },
    'eval' => \&preblock, # A Perl 6ism.
    'exists' => \&uni,
    'exit' => \&uni,
    'eof' => \&uni,
    'exp' => \&uni,
    'each' => \&uni,
    'exec' => \&lop,
    'fcntl' => \&lop,
    'fileno' => \&uni,
    'flock' => \&lop,
    #'for' => \&do_for,     # This is going to suck
    #'foreach' => \&do_for, # really quite nastily
    'fork' => sub { my $t=shift; $t->{type}="func0" },
    'ge' => sub { my $t=shift; $t->{state}="TERM"; $t->{type}="comparison" },
    'getc' => \&uni,
    'given' => sub { my $t=shift; $t->{state}="TERM"; $t->{type}="operator" },
    'glob' => \&lop,
    'gmtime' => \&uni,
    'goto' => sub { my $t=shift; $t->{state}="TERM"; $t->{type}="loopx"; $t->{next}->{type} = "bareword" },
    'grep' => sub { lop(shift, "REF") },
    'gt' => sub { my $t=shift; $t->{state}="TERM"; $t->{type}="comparison" },
    'hex' => \&uni,
    'if' => sub { my $t=shift; $t->{state}="TERM"; $t->{type}="operator" },
    'index' => \&lop,
    'int' => \&uni,
    'ioctl' => \&lop,
    'join' => \&lop,
    'keys' => \&uni,
    'kill' => \&lop,
    'last' => sub { my $t=shift; $t->{state}="TERM"; $t->{type}="loopx"; $t->{next}->{type} = "bareword" },
    'lc' => \&uni,
    'lcfirst' => \&uni,
    'le' => sub { my $t=shift; $t->{state}="TERM"; $t->{type}="comparison" },
    'length' => \&uni,
    'local' => sub { my $t=shift; $t->{state}="TERM"; $t->{type}="operator" },
    'localtime' => \&uni,
    'log' => \&uni,
    'link' => \&lop,
    'listen' => \&lop,
    'lock' => \&uni,
    'lstat' => \&uni,
    'lt' => sub { my $t=shift; $t->{state}="TERM"; $t->{type}="comparison" },
    'map' => sub { lop(shift, "REF") },
    'mkdir' => \&lop,
    'my' => sub { my $t=shift; $t->{state}="TERM"; $t->{type}="operator" },
    'ne' => sub { my $t=shift; $t->{state}="TERM"; $t->{type}="comparison" },
    'next' => sub { my $t=shift; $t->{state}="TERM"; $t->{type}="loopx"; $t->{next}->{type} = "bareword" },
    #'no' => \&use_no,
    #'not' => \&do_not,
    'open' => \&lop,