File Coverage

blib/lib/Perl6/Tokener.pm
Criterion Covered Total %
statement 68 206 33.0
branch 26 86 30.2
condition 6 27 22.2
subroutine 11 27 40.7
pod 0 26 0.0
total 111 372 29.8


line stmt bran cond sub pod time code
1             package Perl6::Tokener;
2 1     1   20471 use Text::Balanced qw(extract_quotelike);
  1         51391  
  1         18688  
3             my %keywords = map {$_=>1} (qw(
4             given when CATCH break try POST class
5             __FILE__ __LINE__ __PACKAGE__ __DATA__ __END__ AUTOLOAD BEGIN CORE
6             DESTROY END INIT CHECK abs accept alarm and atan2 bind binmode bless
7             caller chdir chmod chomp chop chown chr chroot close closedir cmp
8             connect continue cos crypt dbmclose dbmopen defined delete die do
9             each else elsif endgrent endhostent endnetent endprotoent endpwent
10             endservent eof eq eval exec exists exit exp fcntl fileno flock for
11             foreach fork format formline ge getc glob gmtime goto grep gt hex if
12             index int ioctl join keys kill last lc lcfirst le length link listen
13             local localtime lock log lstat lt m map mkdir my ne next no not oct
14             open opendir or ord our pack package pipe pop pos print printf prototype
15             push q qq qr quotemeta qw qx rand read readdir readline readlink readpipe
16             recv redo ref rename require reset return reverse rewinddir rindex rmdir
17             s scalar seek seekdir select shift sin sleep sort splice split sprintf
18             sqrt srand stat study sub substr tell telldir tie tied time tr truncate
19             uc ucfirst umask undef unless unlink unpack unshift untie until use
20             values vec wait waitpid wantarray warn while write x xor y
21             ));
22              
23             my %tokener = (
24             '$' => \&dollar,
25             '@' => \&at,
26             '%' => \&hash,
27             '+' => sub {operator(shift, type => "addop")},
28             '+=' => sub {operator(shift, type => "assignop", length => 2)},
29             '*' => sub {operator(shift, type => "mulop")},
30             '**' => sub {operator(shift, type => "powop", length => 2)},
31             '*=' => sub {operator(shift, type => "assignop", length => 2)},
32             '-' => sub {operator(shift, type => "addop")},
33             '-=' => sub {operator(shift, type => "assignop", length => 2)},
34             '++' => \&inc,
35             '--' => \&dec,
36             '/' => \&slash,
37              
38             '>=' => sub {operator(shift, type => "comparison", length => 2)},
39             '>' => sub {operator(shift, type => "comparison")},
40             '>>' => sub {operator(shift, type => "shiftop", length => 2)},
41              
42             '==' => sub {operator(shift, type => "comparison", length => 2)},
43             '=>' => sub {operator(shift, type => "pair", length => 2)},
44             '=~' => sub {operator(shift, type => "match", length => 2)},
45             '=' => sub {operator(shift, type => "assignop") },
46             '#' => \&comment,
47              
48             '<' => \&less_or_readln,
49             '<=' => sub {operator(shift, type => "comparison", length => 2)},
50             '<=>' => sub {operator(shift, type => "comparison", length => 3)},
51             '<<' => \&shift_or_heredoc,
52              
53             ' ' => \&space, "\t" => \&space, "\n" => \&space,
54             ';' => \&operator,
55             '.' => \&dot,
56             '..' => sub {operator(shift, type => "range", length => 2)},
57             '...' => \&tripledot,
58             ',' => \&operator,
59             '[' => \&operator,
60             ']' => \&term,
61             '!' => sub {operator(shift, type=> "unop") },
62             '\\' => sub {operator(shift, type=> "refgen") },
63             '(' => sub {operator(shift, type=> "token", check => "no") },
64             ')' => sub {term(shift, check=>"no") },
65             '{' => sub {operator(shift, type=> "blockstart") },
66             '}' => sub {operator(shift, type=> "blockend", check => "no", state => "ANY") },
67             #'{' => \&block_or_subscript,
68             #'}' => \&end_curly,
69             '_' => sub {operator(shift, type=>"addop")},
70             '|' => sub {operator(shift, type=>"logop")},
71             '||' => sub {operator(shift, length=>2, type=>"logop")},
72             '||=' => sub {operator(shift, length=>3, type=>"assignop")},
73              
74             '^' => \&hyper,
75             '"' => \"e, "'" => \"e,
76             '`' => \"e, # Of sorts
77              
78             );
79              
80             $tokener{$_} = \&number for 0 .. 9;
81             $tokener{$_} = \&bareword for "a".."z","A".."Z", "_";
82              
83             $tokener{"-$_"} = \&filetest
84             for split //, "rwxoRWXOezsfdlpSugkbctTBMAC";
85              
86             my %keyword_tokens = (
87             '__FILE__' => sub {$_[0]->{type}="constant"; $_[0]->{token}=$_[0]->file },
88             '__LINE__' => sub {$_[0]->{type}="constant"; $_[0]->{token}=$_[0]->{line} },
89             '__PACKAGE__' => sub {$_[0]->{type}="constant"; $_[0]->{token}=$_[0]->{package} },
90             'AUTOLOAD' => \&block_or_sub,
91             'BEGIN' => \&block_or_sub,
92             'CATCH' => \&block_or_sub,
93             'CHECK' => \&block_or_sub,
94             'DESTROY' => \&block_or_sub,
95             'END' => \&block_or_sub,
96             'INIT' => \&block_or_sub,
97             'POST' => \&block_or_sub,
98             # I don't care about CORE:: any more. Do you?
99             'abs' => \&uni,
100             'alarm' => \&uni,
101             'and' => sub { my $t=shift; $t->{state}="TERM"; $t->{type}="andop" },
102             'atan2' => \&uni,
103             'binmode' => \&lop,
104             'bless' => \&lop,
105             'chop' => \&uni,
106             'continue' => \&preblock,
107             'chdir' => \&uni,
108             'close' => \&uni,
109             'closedir' => \&uni,
110             'cmp' => sub { my $t=shift; $t->{state}="TERM"; $t->{type}="comparison" },
111             'caller' => \&uni,
112             'crypt' => \&lop,
113             'chmod' => \&lop,
114             'chown' => \&lop,
115             'class' => sub { my $t=shift; $t->{state}="TERM"; $t->{type}="operator" }, #also need to set $t->{package}
116             'connect' => \&lop,
117             'chr' => \&uni,
118             'cos' => \&uni,
119             'die' => \&lop,
120             'defined' => \&uni,
121             'delete' => \&uni,
122             'else' => \&preblock,
123             'elsif' => sub { my $t=shift; $t->{state}="TERM"; $t->{type}="operator" },
124             'eq' => sub { my $t=shift; $t->{state}="TERM"; $t->{type}="comparison" },
125             'eval' => \&preblock, # A Perl 6ism.
126             'exists' => \&uni,
127             'exit' => \&uni,
128             'eof' => \&uni,
129             'exp' => \&uni,
130             'each' => \&uni,
131             'exec' => \&lop,
132             'fcntl' => \&lop,
133             'fileno' => \&uni,
134             'flock' => \&lop,
135             #'for' => \&do_for, # This is going to suck
136             #'foreach' => \&do_for, # really quite nastily
137             'fork' => sub { my $t=shift; $t->{type}="func0" },
138             'ge' => sub { my $t=shift; $t->{state}="TERM"; $t->{type}="comparison" },
139             'getc' => \&uni,
140             'given' => sub { my $t=shift; $t->{state}="TERM"; $t->{type}="operator" },
141             'glob' => \&lop,
142             'gmtime' => \&uni,
143             'goto' => sub { my $t=shift; $t->{state}="TERM"; $t->{type}="loopx"; $t->{next}->{type} = "bareword" },
144             'grep' => sub { lop(shift, "REF") },
145             'gt' => sub { my $t=shift; $t->{state}="TERM"; $t->{type}="comparison" },
146             'hex' => \&uni,
147             'if' => sub { my $t=shift; $t->{state}="TERM"; $t->{type}="operator" },
148             'index' => \&lop,
149             'int' => \&uni,
150             'ioctl' => \&lop,
151             'join' => \&lop,
152             'keys' => \&uni,
153             'kill' => \&lop,
154             'last' => sub { my $t=shift; $t->{state}="TERM"; $t->{type}="loopx"; $t->{next}->{type} = "bareword" },
155             'lc' => \&uni,
156             'lcfirst' => \&uni,
157             'le' => sub { my $t=shift; $t->{state}="TERM"; $t->{type}="comparison" },
158             'length' => \&uni,
159             'local' => sub { my $t=shift; $t->{state}="TERM"; $t->{type}="operator" },
160             'localtime' => \&uni,
161             'log' => \&uni,
162             'link' => \&lop,
163             'listen' => \&lop,
164             'lock' => \&uni,
165             'lstat' => \&uni,
166             'lt' => sub { my $t=shift; $t->{state}="TERM"; $t->{type}="comparison" },
167             'map' => sub { lop(shift, "REF") },
168             'mkdir' => \&lop,
169             'my' => sub { my $t=shift; $t->{state}="TERM"; $t->{type}="operator" },
170             'ne' => sub { my $t=shift; $t->{state}="TERM"; $t->{type}="comparison" },
171             'next' => sub { my $t=shift; $t->{state}="TERM"; $t->{type}="loopx"; $t->{next}->{type} = "bareword" },
172             #'no' => \&use_no,
173             #'not' => \&do_not,
174             'open' => \&lop,
175             'or' => sub { my $t=shift; $t->{state}="TERM"; $t->{type}="operator" },
176             'ord' => \&uni,
177             'oct' => \&uni,
178             'open' => \&lop,
179             'opendir' => \&lop,
180             'our' => sub { my $t=shift; $t->{state}="TERM"; $t->{type}="operator" },
181             'package' => sub { my $t=shift; $t->{state}="TERM"; $t->{type}="operator" }, #also need to set $t->{package}
182             'print' => sub { lop(shift, "REF") },
183             'printf' => sub { lop(shift, "REF") },
184             'prototype' => \&uni,
185             'push' => \&lop,
186             'pop' => \&uni,
187             'pos' => \&uni,
188             'pack' => \&lop,
189             'pipe_op' => \&lop,
190             'quotemeta' => \&uni,
191             'redo' => sub { my $t=shift; $t->{state}="TERM"; $t->{type}="loopx"; $t->{next}->{type} = "bareword" },
192             'return' => \&lop, # XXX
193             'require' => \&uni,
194             'reset' => \&uni,
195             'rename' => \&lop,
196             'rand' => \&uni,
197             'rmdir' => \&uni,
198             'rindex' => \&lop,
199             'read' => \&lop,
200             'readdir' => \&uni,
201             'readline' => \&uni,
202             'rewinddir' => \&uni,
203             'recv' => \&lop,
204             'reverse' => \&lop,
205             'readlink' => \&uni,
206             'ref' => \&uni,
207             'chomp' => \&uni,
208             'scalar' => \&uni,
209             'select' => \&lop,
210             'seek' => \&lop,
211             'shift' => \&uni,
212             'sin' => \&uni,
213             'sleep' => \&uni,
214             'socket' => \&lop,
215             'sort' => sub { lop(shift, "REF") },
216             'split' => \&lop,
217             'sprintf' => \&lop,
218             'splice' => \&lop,
219             'sqrt' => \&uni,
220             'srand' => \&uni,
221             'stat' => \&uni,
222             'study' => \&uni,
223             #'sub' => \&do_sub,
224             'substr' => \&lop,
225             'system' => \&lop,
226             'symlink' => \&lop,
227             'syscall' => \&lop,
228             'sysopen' => \&lop,
229             'sysseek' => \&lop,
230             'sysread' => \&lop,
231             'syswrite' => \&lop,
232             'tell' => \&uni,
233             'telldir' => \&uni,
234             'tie' => \&lop,
235             'tied' => \&uni,
236             'time' => sub { my $t=shift; $t->{type}="func0" },
237             'truncate' => \&lop,
238             'uc' => \&uni,
239             'ucfirst' => \&uni,
240             'untie' => \&uni,
241             'until' => sub { my $t=shift; $t->{state}="TERM"; $t->{type}="operator" },
242             'unless' => sub { my $t=shift; $t->{state}="TERM"; $t->{type}="operator" },
243             'unlink' => \&lop,
244             'undef' => \&uni,
245             'unpack' => \&lop,
246             'utime' => \&lop,
247             'umask' => \&uni,
248             'unshift' => \&lop,
249             #'use' => \&use_no,
250             'values' => \&uni,
251             'vec' => \&lop,
252             'warn' => \&lop,
253             'wait' => sub { my $t=shift; $t->{type}="func0" },
254             'waitpid' => \&lop,
255             'when' => sub { my $t=shift; $t->{state}="TERM"; $t->{type}="operator" },
256             'while' => sub { my $t=shift; $t->{state}="TERM"; $t->{type}="operator" },
257             'write' => \&uni,
258             'x' => \&do_repeat,
259             'xor' => sub { my $t=shift; $t->{state}="TERM"; $t->{type}="operator" },
260             );
261              
262             $Perl6::Tokener::VERSION = '0.01';
263              
264             =head1 NAME
265              
266             Perl6::Tokener - It's a Perl 6 tokener. It tokenises Perl 6.
267              
268             =head1 SYNOPSIS
269              
270             use Perl6::Tokener;
271             my $t = new Perl6::Tokener(file=>"foo.pl", buffer => $code);
272             while ($t->{buffer}) {
273             my ($type, $token) = $t->toke();
274             ...
275             }
276              
277             =head1 DESCRIPTION
278              
279             I don't think there's really much I need to say about this. It isn't
280             perfect, but I'm working on it. The synopsis pretty much gives you all
281             you need to know to drive the thing, and, bluntly, if you're futzing
282             with tokenising Perl 6, you're already beyond the need for most kinds of
283             documentation. So have fun.
284              
285             Oh, one thing - when you're parsing, you probably want to discard the
286             type of everything called C or C and just use the token
287             value. Oh, and white space will return C for token and type, so
288             don't try using this in a C loop.
289              
290             =head1 BUGS
291              
292             =over 3
293              
294             =item *
295              
296             C<{> doesn't do what it ought. This is going to suck.
297              
298             =item *
299              
300             Some of the important keyword subs aren't implemented.
301              
302             =head1 AUTHOR
303              
304             Simon Cozens, C
305              
306             =cut
307              
308             sub new {
309 1     1 0 105 my $class = shift;
310 1         7 my $t = bless {
311             state => "STATE",
312             line => 1,
313             char => 1,
314             @_
315             }, $class;
316 1         12 return $class;
317              
318             }
319              
320             sub toke {
321 12     12 0 27 my $t = shift;
322 12         58 my $thistoke = { line => $t->{line}, char => $t->{char} };
323 12 50       34 if (not $t->prime()) {
324 12         252 for (sort { length $b <=> length $a } keys %tokener) {
  6468         7162  
325 736 100       7092 if ($t->{buffer} =~ /^\Q$_/) {
326             #print "Matched |$_|\n";
327 12         78 $tokener{$_}->($t);
328 12         80 goto done;
329             }
330             }
331 0         0 die "Can't find a callback for \"$t->{buffer}\"\n";
332             }
333             done:
334 12 50       184 die $t->{error} if $t->{error};
335 12 50       36 if ($t->{hyper}) {
336 0         0 $t->{token} = "^".$t->{token};
337             }
338 12         96 return ($t->{type}, $t->{token}); # Convenience
339             }
340             # Utility functions
341              
342             sub prime {
343 12     12 0 19 my $t = shift;
344 12         42 $t->{hyper} = $t->{next}->{hyper};
345 12 50       40 $t->{state} = $t->{next}->{state} if $t->{next}->{state};
346 12 50 33     42 if ($t->{next}->{type} and $t->{next}->{token}) {
347 0         0 $t->{type} = $t->{next}->{type};
348 0         0 $t->{token} = $t->{next}->{token};
349 0         0 delete $t->{next};
350 0         0 return 1;
351             }
352 12         29 delete $t->{next};
353 12         37 return 0;
354             }
355              
356 0     0 0 0 sub no_op { return "$_[0] found where operator expected" }
357 0     0 0 0 sub not_op { return "$_[0] found where term expected" }
358              
359             sub read_ident {
360 3     3 0 9 $_[0] =~ s/^\s+//;
361 3 50       12 $_[0] =~ s/^(\d+)// and return $1;
362 3 50       18 $_[0] =~ s/^((\w+|::)+)// and return $1;
363 3 50       28 $_[0] =~ s/^([\$@%](\w+|::)+)// and return $1;
364 0 0       0 $_[0] =~ s/^(\$)$// and return $1;
365 0 0       0 $_[0] =~ s/^(\$[?!\$])// and return $1;
366 0         0 die "tricky identifier encountered: $_[0]";
367             }
368              
369              
370             # Individual characters
371              
372             sub dollar {
373 3     3 0 6 my ($t) = shift;
374 3         14 my $first = substr($t->{buffer}, 1, 1);
375 3 50       13 if ($t->{state} eq "OPERATOR") {
376 0         0 $t->{error} = no_op('$');
377 0         0 return;
378             }
379 3 50       10 if ($first eq "#") {
380 0         0 $t->{buffer} =~ s/../@/;
381 0         0 my $ident = read_ident($t->{buffer});
382 0         0 $_[0] = $buffer;
383 0         0 $t->{type} = "term";
384 0         0 $t->{token} = "\$#$ident";
385 0         0 $t->{char}+= length $t->{token};
386 0         0 $t->{state} = "OPERATOR";
387 0         0 return ;
388             }
389 3         13 my $ident = read_ident($t->{buffer});
390 3 50       11 if (length $ident ==1) {
391 0 0       0 $t->{error} = 'Final $ should be \\$ or $name' if not $t->{buffer};
392 0         0 $t->{type} = "preref";
393 0         0 $t->{token} = '$';
394 0         0 $t->{char}+= length $t->{token};
395 0         0 $t->{state} = "REF";
396 0         0 return;
397             }
398 3         12 $t->{type} = "term";
399 3         7 $t->{token} = $ident;
400 3         10 $t->{char}+= length $t->{token};
401 3         9 $t->{state} = "OPERATOR";
402             }
403              
404             sub hash {
405 0     0 0 0 my $t = shift;
406 0 0       0 if ($t->{state} eq "OPERATOR") {
407 0         0 operator($t, type=>"mulop");
408             return
409 0         0 }
410 0         0 $t->{token} = read_ident($t->{buffer});
411 0         0 $t->{type} = "term";
412 0         0 $t->{char}+= length $t->{token};
413 0         0 $t->{state} = "OPERATOR";
414              
415             }
416              
417              
418             sub at {
419 0     0 0 0 my $t = shift;
420 0         0 $t->{token} = read_ident($t->{buffer});
421 0         0 $t->{type} = "term";
422 0         0 $t->{char}+= length $t->{token};
423 0         0 $t->{state} = "OPERATOR";
424             }
425              
426             sub space {
427 4     4 0 7 my $t = shift;
428 4 50       19 $t->{char}=1, $t->{line}++ if $t->{buffer}=~ s/^\n//;
429 4         18 $t->{buffer} =~ s/^([\t ]+)//s; $t->{char} += length $1;
  4         16  
430 4         18 delete $t->{type}; delete $t->{token};
  4         12  
431             }
432              
433             sub inc {
434 0     0 0 0 my $t = shift;
435 0         0 $t->{buffer} =~ s/..//;
436 0         0 $t->{char}+=2;
437 0         0 $t->{token}="++";
438 0 0       0 $t->{type} = $t->{state} eq "OPERATOR" ? "postinc" : "preinc";
439             }
440              
441             sub dec {
442 0     0 0 0 my $t = shift;
443 0         0 $t->{buffer} =~ s/..//;
444 0         0 $t->{char}+=2;
445 0         0 $t->{token}="--";
446 0 0       0 $t->{type} = $t->{state} eq "OPERATOR" ? "postdec" : "predec";
447             }
448              
449             sub operator {
450 4     4 0 7 my $t = shift;
451 4         16 my %options = @_;
452 4 50 66     25 if ($t->{state} eq "TERM" and not $options{check} eq "no") {
453 0   0     0 $t->{error} = not_op($options{token} || "operator");
454 0         0 return;
455             }
456 4 100       13 $options{length} = 1 if not defined $options{length};
457 4         17 my $was = substr($t->{buffer},0,$options{length},"");
458 4         10 $t->{char} += $options{length};
459 4   33     30 $t->{token} = $options{token} || $was;
460 4   50     15 $t->{type} = $options{type} || "operator";
461 4   50     25 $t->{state} = $options{state} || "TERM";
462             }
463              
464             sub term {
465 0     0 0 0 my $t = shift;
466 0         0 my %options = @_;
467 0 0 0     0 if ($t->{state} eq "OPERATOR" and not $options{check} eq "no") {
468 0   0     0 $t->{error} = no_op($options{token} || "term");
469 0         0 return;
470             }
471 0 0       0 $options{length} = 1 if not defined $options{length};
472 0         0 my $was = substr($t->{buffer},0,$options{length},"");
473 0         0 $t->{char} += $options{length};
474 0   0     0 $t->{token} = $options{token} || $was;
475 0   0     0 $t->{type} = $options{type} || "term";
476 0   0     0 $t->{state} = $options{state} || "OPERATOR";
477             }
478              
479             sub number {
480 0     0 0 0 $t = shift;
481 0 0       0 $t->{buffer} =~ s/^
482             (
483             0x[0-9A-Fa-f](_?[0-9A-Fa-f])*
484             | 0[0-7](_?[0-7])*
485             | 0b[01](_?[01])*
486             | \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*)
487             | \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*)
488             | [\d_]+(\.[\d_]+)?
489             )//x or die "Didn't match $t->{buffer}!";
490 0         0 $t->{type} = "const",
491             $t->{char} += length $1;
492 0         0 $t->{token} = eval $1;
493 0         0 $t->{state} = "OPERATOR";
494             }
495              
496             sub bareword {
497 1     1 0 3 $t = shift;
498 1         6 $t->{buffer} =~ s/^(\w+)//;
499 1         29 my $what = $1;
500 1         3 $t->{token} = $what;
501 1 50       6 if ($t->{token} =~ /^(s|tr|y|m|qr)$/) {
502 0         0 ($t->{token}, $t->{buffer}) = extract_quotelike($t->{token}.$t->{buffer});
503 0         0 $t->{type} = "regex";
504 0         0 $t->{state} = "OPERATOR";
505 0         0 $t->{char}+= length $t->{token}; # XXX NEWLINES.
506 0         0 return;
507             }
508 1 50       6 if ($t->{token} =~ /^(q|qq|qw|qx)$/) {
509 0         0 ($t->{token}, $t->{buffer}) = extract_quotelike($t->{token}.$t->{buffer});
510 0         0 $t->{type} = "const";
511 0         0 $t->{state} = "OPERATOR";
512 0         0 $t->{char}+= length $t->{token}; # XXX NEWLINES.
513 0         0 return;
514             }
515              
516 1         4 $t->{char} += length $what;
517 1 50       16 if ($t->{buffer} =~ s/^((::\w+)+)//) {
    50          
    50          
    50          
    50          
518 0         0 $t->{token} .= $1;
519 0         0 $t->{type} = "class";
520             } elsif ($t->{buffer} =~ s/^://) {
521 0         0 $t->{type} = "label";
522             } elsif ($t->{buffer} =~ /^\s*=>/) {
523 0         0 $t->{type} = "const";
524             } elsif (exists $keywords{$what}) {
525 0         0 $t->{type} = "key_$what";
526 0 0       0 $keyword_tokens{$t->{token}}->($t)
527             if exists $keyword_tokens{$t->{token}};
528             } elsif ($t->{buffer} =~ /^\s*\(/) {
529             # It's a subroutine, so fake up a subroutine call
530 0         0 $t->{next}->{token} = $t->{token};
531 0         0 $t->{next}->{type} = "bareword";
532 0         0 $t->{token} = "&";
533 0         0 $t->{type} = "token";
534             } else {
535 1         10 $t->{type} = "bareword";
536             }
537 1         4 $t->{state} = "ANY"; # Hack
538             }
539              
540             sub hyper {
541 0     0 0 0 $t=shift;
542 0         0 $t->{buffer} =~ s/.//;
543 0 0       0 if ($t->{state} ne "OPERATOR") {
544 0         0 $t->{error} = no_op("hyperoperation");
545 0         0 return;
546             }
547 0 0       0 if ($t->{hyper}) {
548 0         0 $t->{error} = "Can't multiply hyperoperate";
549 0         0 return;
550             }
551 0         0 $t->{next}->{hyper}=1;
552             }
553              
554             sub quote {
555 0     0 0 0 $t = shift;
556             # Cheat
557 0         0 ($t->{token}, $t->{buffer}) = extract_quotelike($t->{buffer});
558 0         0 $t->{type} = "const";
559 0         0 for (split //, $t->{token}) {
560 0         0 $t->{char}++;
561 0 0       0 $t->{line}++, $t->{char} = 1 if $_ eq "\n";
562             }
563 0         0 $t->{state} = "OPERATOR";
564             }
565              
566             sub comment {
567 0     0 0 0 $t = shift;
568 0         0 $t->{buffer} =~ s/.*//;
569 0         0 $t->{line}++; $t->{char}=1;
  0         0  
570             }
571              
572             sub slash {
573 0     0 0 0 my $t= shift;
574 0 0       0 if ($t->{state} eq "OPERATOR") {
575 0         0 return operator($t, type =>"mulop");
576             }
577 0         0 ($t->{token}, $t->{buffer}) = extract_quotelike($t->{buffer});
578 0         0 $t->{type} = "regex";
579 0         0 $t->{state} = "OPERATOR";
580             }
581              
582             sub tripledot {
583 0     0 0 0 my $t = shift;
584 0 0       0 if ($t->{state} eq "OPERATOR") {
585 0         0 return operator($t, type=>"range", length => 3);
586             } else {
587 0         0 return operator($t, type=>"notyet", check=> "no", state=>"ANY", length => 3);
588             }
589             }
590              
591             sub dot {
592 1     1 0 3 my $t = shift;
593 1 50       7 if ($t->{state} eq "OPERATOR") {
594 1         5 return operator($t, type=>"method");
595             } else {
596             # Dirty hack
597 0         0 $t->{buffer} = '$_'. $t->{buffer};
598 0         0 $t->{char} -= 2;
599 0         0 delete $t->{token}; delete $t->{type};
  0         0  
600             }
601             }
602              
603             sub filetest {
604 1     1 0 4 my $t = shift;
605 1 50       10 if ($t->{buffer}=~/-\w\w+/) {
606             # I'm not really a filetest
607 0         0 return operator($t, type=>"addop"); # Just return the -, try again
608             }
609 1         4 return operator($t, type=>"filetest", length=>2, check=>"no");
610             }
611              
612             # Keywords, and what we do with them
613              
614             sub block_or_sub {
615 0     0 0   my $t= shift;
616 0 0         if ($t->{state} eq "STATE") { # XXX
617 0           do_sub($t);
618             } else {
619 0           $t->{type}="bareword";
620             }
621             }
622              
623             sub uni {
624 0     0 0   my $t = shift;
625 0           $t->{state} = "TERM";
626 0 0         if ($t->{buffer}=~/^s*\(/) {
627 0           $t->{type} = "func1";
628             } else {
629 0           $t->{type} = "unop";
630             }
631             }
632              
633             sub lop {
634 0     0 0   my $t = shift;
635 0           $t->{state} = "TERM";
636 0 0         if ($t->{next}->{type}) {
    0          
637 0           $t->{type} = "listop";
638             } elsif ($t->{buffer}=~/^s*\(/) {
639 0           $t->{type} = "func";
640             } else {
641 0           $t->{type} = "listop";
642             }
643             }
644              
645             __END__