lib/Devel/Declare.pm

   1 package Devel::Declare;
   2
   3 use strict;
   4 use warnings;
   5 use 5.008001;
   6
   7 our $VERSION = '0.006009';
   8
   9 use constant DECLARE_NAME => 1;
  10 use constant DECLARE_PROTO => 2;
  11 use constant DECLARE_NONE => 4;
  12 use constant DECLARE_PACKAGE => 8+1; # name implicit
  13
  14 use vars qw(%declarators %declarator_handlers @ISA);
  15 use base qw(DynaLoader);
  16 use Scalar::Util 'set_prototype';
  17 use B::Hooks::OP::Check 0.19;
  18
  19 bootstrap Devel::Declare;
  20
  21 @ISA = ();
  22
  23 initialize();
  24
  25 sub import {
  26   my ($class, %args) = @_;
  27   my $target = caller;
  28   if (@_ == 1) { # "use Devel::Declare;"
  29     no strict 'refs';
  30     foreach my $name (qw(NAME PROTO NONE PACKAGE)) {
  31       *{"${target}::DECLARE_${name}"} = *{"DECLARE_${name}"};
  32     }
  33   } else {
  34     $class->setup_for($target => \%args);
  35   }
  36 }
  37
  38 sub unimport {
  39   my ($class) = @_;
  40   my $target = caller;
  41   $class->teardown_for($target);
  42 }
  43
  44 sub setup_for {
  45   my ($class, $target, $args) = @_;
  46   setup();
  47   foreach my $key (keys %$args) {
  48     my $info = $args->{$key};
  49     my ($flags, $sub);
  50     if (ref($info) eq 'ARRAY') {
  51       ($flags, $sub) = @$info;
  52     } elsif (ref($info) eq 'CODE') {
  53       $flags = DECLARE_NAME;
  54       $sub = $info;
  55     } elsif (ref($info) eq 'HASH') {
  56       $flags = 1;
  57       $sub = $info;
  58     } else {
  59       die "Info for sub ${key} must be [ \$flags, \$sub ] or \$sub or handler hashref";
  60     }
  61     $declarators{$target}{$key} = $flags;
  62     $declarator_handlers{$target}{$key} = $sub;
  63   }
  64 }
  65
  66 sub teardown_for {
  67   my ($class, $target) = @_;
  68   delete $declarators{$target};
  69   delete $declarator_handlers{$target};
  70 }
  71
  72 my $temp_name;
  73 my $temp_save;
  74
  75 sub init_declare {
  76   my ($usepack, $use, $inpack, $name, $proto, $traits) = @_;
  77   my ($name_h, $XX_h, $extra_code)
  78        = $declarator_handlers{$usepack}{$use}->(
  79            $usepack, $use, $inpack, $name, $proto, defined(wantarray), $traits
  80          );
  81   ($temp_name, $temp_save) = ([], []);
  82   if ($name) {
  83     $name = "${inpack}::${name}" unless $name =~ /::/;
  84     shadow_sub($name, $name_h);
  85   }
  86   if ($XX_h) {
  87     shadow_sub("${inpack}::X", $XX_h);
  88   }
  89   if (defined wantarray) {
  90     return $extra_code || '0;';
  91   } else {
  92     return;
  93   }
  94 }
  95
  96 sub shadow_sub {
  97   my ($name, $cr) = @_;
  98   push(@$temp_name, $name);
  99   no strict 'refs';
 100   my ($pack, $pname) = ($name =~ m/(.+)::([^:]+)/);
 101   push(@$temp_save, $pack->can($pname));
 102   no warnings 'redefine';
 103   no warnings 'prototype';
 104   *{$name} = $cr;
 105   set_in_declare(~~@{$temp_name||[]});
 106 }
 107
 108 sub done_declare {
 109   no strict 'refs';
 110   my $name = shift(@{$temp_name||[]});
 111   die "done_declare called with no temp_name stack" unless defined($name);
 112   my $saved = shift(@$temp_save);
 113   $name =~ s/(.*):://;
 114   my $temp_pack = $1;
 115   delete ${"${temp_pack}::"}{$name};
 116   if ($saved) {
 117     no warnings 'prototype';
 118     *{"${temp_pack}::${name}"} = $saved;
 119   }
 120   set_in_declare(~~@{$temp_name||[]});
 121 }
 122
 123 sub build_sub_installer {
 124   my ($class, $pack, $name, $proto) = @_;
 125   return eval "
 126     package ${pack};
 127     my \$body;
 128     sub ${name} (${proto}) :lvalue {\n"
 129     .'  if (wantarray) {
 130         goto &$body;
 131       }
 132       my $ret = $body->(@_);
 133       return $ret;
 134     };
 135     sub { ($body) = @_; };';
 136 }
 137
 138 sub setup_declarators {
 139   my ($class, $pack, $to_setup) = @_;
 140   die "${class}->setup_declarators(\$pack, \\\%to_setup)"
 141     unless defined($pack) && ref($to_setup) eq 'HASH';
 142   my %setup_for_args;
 143   foreach my $name (keys %$to_setup) {
 144     my $info = $to_setup->{$name};
 145     my $flags = $info->{flags} || DECLARE_NAME;
 146     my $run = $info->{run};
 147     my $compile = $info->{compile};
 148     my $proto = $info->{proto} || '&';
 149     my $sub_proto = $proto;
 150     # make all args optional to enable lvalue for DECLARE_NONE
 151     $sub_proto =~ s/;//; $sub_proto = ';'.$sub_proto;
 152     #my $installer = $class->build_sub_installer($pack, $name, $proto);
 153     my $installer = $class->build_sub_installer($pack, $name, '@');
 154     $installer->(sub :lvalue {
 155 #{ no warnings 'uninitialized'; warn 'INST: '.join(', ', @_)."\n"; }
 156       if (@_) {
 157         if (ref $_[0] eq 'HASH') {
 158           shift;
 159           if (wantarray) {
 160             my @ret = $run->(undef, undef, @_);
 161             return @ret;
 162           }
 163           my $r = $run->(undef, undef, @_);
 164           return $r;
 165         } else {
 166           return @_[1..$#_];
 167         }
 168       }
 169       return my $sv;
 170     });
 171     $setup_for_args{$name} = [
 172       $flags,
 173       sub {
 174         my ($usepack, $use, $inpack, $name, $proto, $shift_hashref, $traits) = @_;
 175         my $extra_code = $compile->($name, $proto, $traits);
 176         my $main_handler = sub { shift if $shift_hashref;
 177           ("DONE", $run->($name, $proto, @_));
 178         };
 179         my ($name_h, $XX);
 180         if (defined $proto) {
 181           $name_h = sub :lvalue { return my $sv; };
 182           $XX = $main_handler;
 183         } elsif (defined $name && length $name) {
 184           $name_h = $main_handler;
 185         }
 186         $extra_code ||= '';
 187         $extra_code = '}, sub {'.$extra_code;
 188         return ($name_h, $XX, $extra_code);
 189       }
 190     ];
 191   }
 192   $class->setup_for($pack, \%setup_for_args);
 193 }
 194
 195 sub install_declarator {
 196   my ($class, $target_pack, $target_name, $flags, $filter, $handler) = @_;
 197   $class->setup_declarators($target_pack, {
 198     $target_name => {
 199       flags => $flags,
 200       compile => $filter,
 201       run => $handler,
 202    }
 203   });
 204 }
 205
 206 sub linestr_callback_rv2cv {
 207   my ($name, $offset) = @_;
 208   $offset += toke_move_past_token($offset);
 209   my $pack = get_curstash_name();
 210   my $flags = $declarators{$pack}{$name};
 211   my ($found_name, $found_proto);
 212   if ($flags & DECLARE_NAME) {
 213     $offset += toke_skipspace($offset);
 214     my $linestr = get_linestr();
 215     if (substr($linestr, $offset, 2) eq '::') {
 216       substr($linestr, $offset, 2) = '';
 217       set_linestr($linestr);
 218     }
 219     if (my $len = toke_scan_word($offset, $flags & DECLARE_PACKAGE)) {
 220       $found_name = substr($linestr, $offset, $len);
 221       $offset += $len;
 222     }
 223   }
 224   if ($flags & DECLARE_PROTO) {
 225     $offset += toke_skipspace($offset);
 226     my $linestr = get_linestr();
 227     if (substr($linestr, $offset, 1) eq '(') {
 228       my $length = toke_scan_str($offset);
 229       $found_proto = get_lex_stuff();
 230       clear_lex_stuff();
 231       my $replace =
 232         ($found_name ? ' ' : '=')
 233         .'X'.(' ' x length($found_proto));
 234       $linestr = get_linestr();
 235       substr($linestr, $offset, $length) = $replace;
 236       set_linestr($linestr);
 237       $offset += $length;
 238     }
 239   }
 240   my @args = ($pack, $name, $pack, $found_name, $found_proto);
 241   $offset += toke_skipspace($offset);
 242   my $linestr = get_linestr();
 243   if (substr($linestr, $offset, 1) eq '{') {
 244     my $ret = init_declare(@args);
 245     $offset++;
 246     if (defined $ret && length $ret) {
 247       substr($linestr, $offset, 0) = $ret;
 248       set_linestr($linestr);
 249     }
 250   } else {
 251     init_declare(@args);
 252   }
 253   #warn "linestr now ${linestr}";
 254 }
 255
 256 sub linestr_callback_const {
 257   my ($name, $offset) = @_;
 258   my $pack = get_curstash_name();
 259   my $flags = $declarators{$pack}{$name};
 260   if ($flags & DECLARE_NAME) {
 261     $offset += toke_move_past_token($offset);
 262     $offset += toke_skipspace($offset);
 263     if (toke_scan_word($offset, $flags & DECLARE_PACKAGE)) {
 264       my $linestr = get_linestr();
 265       substr($linestr, $offset, 0) = '::';
 266       set_linestr($linestr);
 267     }
 268   }
 269 }
 270
 271 sub linestr_callback {
 272   my $type = shift;
 273   my $name = $_[0];
 274   my $pack = get_curstash_name();
 275   my $handlers = $declarator_handlers{$pack}{$name};
 276   if (ref $handlers eq 'CODE') {
 277     my $meth = "linestr_callback_${type}";
 278     __PACKAGE__->can($meth)->(@_);
 279   } elsif (ref $handlers eq 'HASH') {
 280     if ($handlers->{$type}) {
 281       $handlers->{$type}->(@_);
 282     }
 283   } else {
 284     die "PANIC: unknown thing in handlers for $pack $name: $handlers";
 285   }
 286 }
 287
 288 =head1 NAME
 289
 290 Devel::Declare - Adding keywords to perl, in perl
 291
 292 =head1 SYNOPSIS
 293
 294   use Method::Signatures;
 295   # or ...
 296   use MooseX::Declare;
 297   # etc.
 298
 299   # Use some new and exciting syntax like:
 300   method hello (Str :$who, Int :$age where { $_ > 0 }) {
 301     $self->say("Hello ${who}, I am ${age} years old!");
 302   }
 303
 304 =head1 DESCRIPTION
 305
 306 L<Devel::Declare> can install subroutines called declarators which locally take
 307 over Perl's parser, allowing the creation of new syntax.
 308
 309 This document describes how to create a simple declarator.
 310
 311 =head1 USAGE
 312
 313 We'll demonstrate the usage of C<Devel::Declare> with a motivating example: a new
 314 C<method> keyword, which acts like the builtin C<sub>, but automatically unpacks
 315 C<$self> and the other arguments.
 316
 317   package My::Methods;
 318   use Devel::Declare;
 319
 320 =head2 Creating a declarator with C<setup_for>
 321
 322 You will typically create
 323
 324   sub import {
 325     my $class = shift;
 326     my $caller = caller;
 327
 328     Devel::Declare->setup_for(
 329         $caller,
 330         { method => { const => \&parser } }
 331     );
 332     no strict 'refs';
 333     *{$caller.'::method'} = sub (&) {};
 334   }
 335
 336 Starting from the end of this import routine, you'll see that we're creating a
 337 subroutine called C<method> in the caller's namespace.  Yes, that's just a normal
 338 subroutine, and it does nothing at all (yet!)  Note the prototype C<(&)> which means
 339 that the caller would call it like so:
 340
 341     method {
 342         my ($self, $arg1, $arg2) = @_;
 343         ...
 344     }
 345
 346 However we want to be able to call it like this
 347
 348     method foo ($arg1, $arg2) {
 349         ...
 350     }
 351
 352 That's why we call C<setup_for> above, to register the declarator 'method' with a custom
 353 parser, as per the next section.  It acts on an optype, usually C<'const'> as above.
 354 (Other valid values are C<'check'> and C<'rv2cv'>).
 355
 356 For a simpler way to install new methods, see also L<Devel::Declare::MethodInstaller::Simple>
 357
 358 =head2 Writing a parser subroutine
 359
 360 This subroutine is called at I<compilation> time, and allows you to read the custom
 361 syntaxes that we want (in a syntax that may or may not be valid core Perl 5) and
 362 munge it so that the result will be parsed by the C<perl> compiler.
 363
 364 For this example, we're defining some globals for convenience:
 365
 366     our ($Declarator, $Offset);
 367
 368 Then we define a parser subroutine to handle our declarator.  We'll look at this in
 369 a few chunks.
 370
 371     sub parser {
 372       local ($Declarator, $Offset) = @_;
 373
 374 C<Devel::Declare> provides some very low level utility methods to parse character
 375 strings.  We'll define some useful higher level routines below for convenience,
 376 and we can use these to parse the various elements in our new syntax.
 377
 378 Notice how our parser subroutine is invoked at compile time,
 379 when the C<perl> parser is pointed just I<before> the declarator name.
 380
 381       skip_declarator;          # step past 'method'
 382       my $name = strip_name;    # strip out the name 'foo', if present
 383       my $proto = strip_proto;  # strip out the prototype '($arg1, $arg2)', if present
 384
 385 Now we can prepare some code to 'inject' into the new subroutine.  For example we
 386 might want the method as above to have C<my ($self, $arg1, $arg2) = @_> injected at
 387 the beginning of it.  We also do some clever stuff with scopes that we'll look
 388 at shortly.
 389
 390       my $inject = make_proto_unwrap($proto);
 391       if (defined $name) {
 392         $inject = scope_injector_call().$inject;
 393       }
 394       inject_if_block($inject);
 395
 396 We've now managed to change C<method ($arg1, $arg2) { ... }> into C<method {
 397 injected_code; ... }>.  This will compile...  but we've lost the name of the
 398 method!
 399
 400 In a cute (or horrifying, depending on your perspective) trick, we temporarily
 401 change the definition of the subroutine C<method> itself, to specialise it with
 402 the C<$name> we stripped, so that it assigns the code block to that name.
 403
 404 Even though the I<next> time C<method> is compiled, it will be
 405 redefined again, C<perl> caches these definitions in its parse
 406 tree, so we'll always get the right one!
 407
 408 Note that we also handle the case where there was no name, allowing
 409 an anonymous method analogous to an anonymous subroutine.
 410
 411       if (defined $name) {
 412         $name = join('::', Devel::Declare::get_curstash_name(), $name)
 413           unless ($name =~ /::/);
 414         shadow(sub (&) { no strict 'refs'; *{$name} = shift; });
 415       } else {
 416         shadow(sub (&) { shift });
 417       }
 418     }
 419
 420
 421 =head2 Parser utilities in detail
 422
 423 For simplicity, we're using global variables like C<$Offset> in these examples.
 424 You may prefer to look at L<Devel::Declare::Context::Simple>, which
 425 encapsulates the context much more cleanly.
 426
 427 =head3 C<skip_declarator>
 428
 429 This simple parser just moves across a 'token'.  The common case is
 430 to skip the declarator, i.e.  to move to the end of the string
 431 'method' and before the prototype and code block.
 432
 433     sub skip_declarator {
 434       $Offset += Devel::Declare::toke_move_past_token($Offset);
 435     }
 436
 437 =head4 C<toke_move_past_token>
 438
 439 This builtin parser simply moves past a 'token' (matching C</[a-zA-Z_]\w*/>)
 440 It takes an offset into the source document, and skips past the token.
 441 It returns the number of characters skipped.
 442
 443 =head3 C<strip_name>
 444
 445 This parser skips any whitespace, then scans the next word (again matching a
 446 'token').  We can then analyse the current line, and manipulate it (using pure
 447 Perl).  In this case we take the name of the method out, and return it.
 448
 449     sub strip_name {
 450       skipspace;
 451       if (my $len = Devel::Declare::toke_scan_word($Offset, 1)) {
 452         my $linestr = Devel::Declare::get_linestr();
 453         my $name = substr($linestr, $Offset, $len);
 454         substr($linestr, $Offset, $len) = '';
 455         Devel::Declare::set_linestr($linestr);
 456         return $name;
 457       }
 458       return;
 459     }
 460
 461 =head4 C<toke_scan_word>
 462
 463 This builtin parser, given an offset into the source document,
 464 matches a 'token' as above but does not skip.  It returns the
 465 length of the token matched, if any.
 466
 467 =head4 C<get_linestr>
 468
 469 This builtin returns the full text of the current line of the source document.
 470
 471 =head4 C<set_linestr>
 472
 473 This builtin sets the full text of the current line of the source document.
 474 Beware that injecting a newline into the middle of the line is likely
 475 to fail in surprising ways.  Generally, Perl's parser can rely on the
 476 `current line' actually being only a single line.  Use other kinds of
 477 whitespace instead, in the code that you inject.
 478
 479 =head3 C<skipspace>
 480
 481 This parser skips whitsepace.
 482
 483     sub skipspace {
 484       $Offset += Devel::Declare::toke_skipspace($Offset);
 485     }
 486
 487 =head4 C<toke_skipspace>
 488
 489 This builtin parser, given an offset into the source document,
 490 skips over any whitespace, and returns the number of characters
 491 skipped.
 492
 493 =head3 C<strip_proto>
 494
 495 This is a more complex parser that checks if it's found something that
 496 starts with C<'('> and returns everything till the matching C<')'>.
 497
 498     sub strip_proto {
 499       skipspace;
 500
 501       my $linestr = Devel::Declare::get_linestr();
 502       if (substr($linestr, $Offset, 1) eq '(') {
 503         my $length = Devel::Declare::toke_scan_str($Offset);
 504         my $proto = Devel::Declare::get_lex_stuff();
 505         Devel::Declare::clear_lex_stuff();
 506         $linestr = Devel::Declare::get_linestr();
 507         substr($linestr, $Offset, $length) = '';
 508         Devel::Declare::set_linestr($linestr);
 509         return $proto;
 510       }
 511       return;
 512     }
 513
 514 =head4 C<toke_scan_str>
 515
 516 This builtin parser uses Perl's own parsing routines to match a "stringlike"
 517 expression.  Handily, this includes bracketed expressions (just think about
 518 things like C<q(this is a quote)>).
 519
 520 Also it Does The Right Thing with nested delimiters (like C<q(this (is (a) quote))>).
 521
 522 It returns the effective length of the expression matched.  Really, what
 523 it returns is the difference in position between where the string started,
 524 within the buffer, and where it finished.  If the string extended across
 525 multiple lines then the contents of the buffer may have been completely
 526 replaced by the new lines, so this position difference is not the same
 527 thing as the actual length of the expression matched.  However, because
 528 moving backward in the buffer causes problems, the function arranges
 529 for the effective length to always be positive, padding the start of
 530 the buffer if necessary.
 531
 532 Use C<get_lex_stuff> to get the actual matched text, the content of
 533 the string.  Because of the behaviour around multiline strings, you
 534 can't reliably get this from the buffer.  In fact, after the function
 535 returns, you can't rely on any content of the buffer preceding the end
 536 of the string.
 537
 538 If the string being scanned is not well formed (has no closing delimiter),
 539 C<toke_scan_str> returns C<undef>.  In this case you cannot rely on the
 540 contents of the buffer.
 541
 542 =head4 C<get_lex_stuff>
 543
 544 This builtin returns what was matched by C<toke_scan_str>.  To avoid segfaults,
 545 you should call C<clear_lex_stuff> immediately afterwards.
 546
 547 =head2 Munging the subroutine
 548
 549 Let's look at what we need to do in detail.
 550
 551 =head3 C<make_proto_unwrap>
 552
 553 We may have defined our method in different ways, which will result
 554 in a different value for our prototype, as parsed above.  For example:
 555
 556     method foo         {  # undefined
 557     method foo ()      {  # ''
 558     method foo ($arg1) {  # '$arg1'
 559
 560 We deal with them as follows, and return the appropriate C<my ($self, ...) = @_;>
 561 string.
 562
 563     sub make_proto_unwrap {
 564       my ($proto) = @_;
 565       my $inject = 'my ($self';
 566       if (defined $proto) {
 567         $inject .= ", $proto" if length($proto);
 568         $inject .= ') = @_; ';
 569       } else {
 570         $inject .= ') = shift;';
 571       }
 572       return $inject;
 573     }
 574
 575 =head3 C<inject_if_block>
 576
 577 Now we need to inject it after the opening C<'{'> of the method body.
 578 We can do this with the building blocks we defined above like C<skipspace>
 579 and C<get_linestr>.
 580
 581     sub inject_if_block {
 582       my $inject = shift;
 583       skipspace;
 584       my $linestr = Devel::Declare::get_linestr;
 585       if (substr($linestr, $Offset, 1) eq '{') {
 586         substr($linestr, $Offset+1, 0) = $inject;
 587         Devel::Declare::set_linestr($linestr);
 588       }
 589     }
 590
 591 =head3 C<scope_injector_call>
 592
 593 We want to be able to handle both named and anonymous methods.  i.e.
 594
 595     method foo () { ... }
 596     my $meth = method () { ... };
 597
 598 These will then get rewritten as
 599
 600     method { ... }
 601     my $meth = method { ... };
 602
 603 where 'method' is a subroutine that takes a code block.  Spot the problem?
 604 The first one doesn't have a semicolon at the end of it!  Unlike 'sub' which
 605 is a builtin, this is just a normal statement, so we need to terminate it.
 606 Luckily, using C<B::Hooks::EndOfScope>, we can do this!
 607
 608   use B::Hooks::EndOfScope;
 609
 610 We'll add this to what gets 'injected' at the beginning of the method source.
 611
 612   sub scope_injector_call {
 613     return ' BEGIN { MethodHandlers::inject_scope }; ';
 614   }
 615
 616 So at the beginning of every method, we are passing a callback that will get invoked
 617 at the I<end> of the method's compilation... i.e. exactly then the closing C<'}'>
 618 is compiled.
 619
 620   sub inject_scope {
 621     on_scope_end {
 622       my $linestr = Devel::Declare::get_linestr;
 623       my $offset = Devel::Declare::get_linestr_offset;
 624       substr($linestr, $offset, 0) = ';';
 625       Devel::Declare::set_linestr($linestr);
 626     };
 627   }
 628
 629 =head2 Shadowing each method.
 630
 631 =head3 C<shadow>
 632
 633 We override the current definition of 'method' using C<shadow>.
 634
 635     sub shadow {
 636       my $pack = Devel::Declare::get_curstash_name;
 637       Devel::Declare::shadow_sub("${pack}::${Declarator}", $_[0]);
 638     }
 639
 640 For a named method we invoked like this:
 641
 642     shadow(sub (&) { no strict 'refs'; *{$name} = shift; });
 643
 644 So in the case of a C<method foo { ... }>, this call would redefine C<method>
 645 to be a subroutine that exports 'sub foo' as the (munged) contents of C<{...}>.
 646
 647 The case of an anonymous method is also cute:
 648
 649     shadow(sub (&) { shift });
 650
 651 This means that
 652
 653     my $meth = method () { ... };
 654
 655 is rewritten with C<method> taking the codeblock, and returning it as is to become
 656 the value of C<$meth>.
 657
 658 =head4 C<get_curstash_name>
 659
 660 This returns the package name I<currently being compiled>.
 661
 662 =head4 C<shadow_sub>
 663
 664 Handles the details of redefining the subroutine.
 665
 666 =head1 SEE ALSO
 667
 668 One of the best ways to learn C<Devel::Declare> is still to look at
 669 modules that use it:
 670
 671 L<http://cpants.perl.org/dist/used_by/Devel-Declare>.
 672
 673 =head1 AUTHORS
 674
 675 Matt S Trout - E<lt>mst@shadowcat.co.ukE<gt> - original author
 676
 677 Company: http://www.shadowcat.co.uk/
 678 Blog: http://chainsawblues.vox.com/
 679
 680 Florian Ragwitz E<lt>rafl@debian.orgE<gt> - maintainer
 681
 682 osfameron E<lt>osfameron@cpan.orgE<gt> - first draft of documentation
 683
 684 =head1 COPYRIGHT AND LICENSE
 685
 686 This library is free software under the same terms as perl itself
 687
 688 Copyright (c) 2007, 2008, 2009  Matt S Trout
 689
 690 Copyright (c) 2008, 2009  Florian Ragwitz
 691
 692 stolen_chunk_of_toke.c based on toke.c from the perl core, which is
 693
 694 Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
 695 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
 696
 697 =cut
 698
 699 1;