lib/Devel/Declare.pm

   1 package Devel::Declare;
   2
   3 use strict;
   4 use warnings;
   5 use 5.008001;
   6
   7 our $VERSION = '0.006008';
   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
 475 =head3 C<skipspace>
 476
 477 This parser skips whitsepace.
 478
 479     sub skipspace {
 480       $Offset += Devel::Declare::toke_skipspace($Offset);
 481     }
 482
 483 =head4 C<toke_skipspace>
 484
 485 This builtin parser, given an offset into the source document,
 486 skips over any whitespace, and returns the number of characters
 487 skipped.
 488
 489 =head3 C<strip_proto>
 490
 491 This is a more complex parser that checks if it's found something that
 492 starts with C<'('> and returns everything till the matching C<')'>.
 493
 494     sub strip_proto {
 495       skipspace;
 496
 497       my $linestr = Devel::Declare::get_linestr();
 498       if (substr($linestr, $Offset, 1) eq '(') {
 499         my $length = Devel::Declare::toke_scan_str($Offset);
 500         my $proto = Devel::Declare::get_lex_stuff();
 501         Devel::Declare::clear_lex_stuff();
 502         $linestr = Devel::Declare::get_linestr();
 503         substr($linestr, $Offset, $length) = '';
 504         Devel::Declare::set_linestr($linestr);
 505         return $proto;
 506       }
 507       return;
 508     }
 509
 510 =head4 C<toke_scan_str>
 511
 512 This builtin parser uses Perl's own parsing routines to match a "stringlike"
 513 expression.  Handily, this includes bracketed expressions (just think about
 514 things like C<q(this is a quote)>).
 515
 516 Also it Does The Right Thing with nested delimiters (like C<q(this (is (a) quote))>).
 517
 518 It returns the effective length of the expression matched.  Really, what
 519 it returns is the difference in position between where the string started,
 520 within the buffer, and where it finished.  If the string extended across
 521 multiple lines then the contents of the buffer may have been completely
 522 replaced by the new lines, so this position difference is not the same
 523 thing as the actual length of the expression matched.  However, because
 524 moving backward in the buffer causes problems, the function arranges
 525 for the effective length to always be positive, padding the start of
 526 the buffer if necessary.
 527
 528 Use C<get_lex_stuff> to get the actual matched text, the content of
 529 the string.  Because of the behaviour around multiline strings, you
 530 can't reliably get this from the buffer.  In fact, after the function
 531 returns, you can't rely on any content of the buffer preceding the end
 532 of the string.
 533
 534 If the string being scanned is not well formed (has no closing delimiter),
 535 C<toke_scan_str> returns C<undef>.  In this case you cannot rely on the
 536 contents of the buffer.
 537
 538 =head4 C<get_lex_stuff>
 539
 540 This builtin returns what was matched by C<toke_scan_str>.  To avoid segfaults,
 541 you should call C<clear_lex_stuff> immediately afterwards.
 542
 543 =head2 Munging the subroutine
 544
 545 Let's look at what we need to do in detail.
 546
 547 =head3 C<make_proto_unwrap>
 548
 549 We may have defined our method in different ways, which will result
 550 in a different value for our prototype, as parsed above.  For example:
 551
 552     method foo         {  # undefined
 553     method foo ()      {  # ''
 554     method foo ($arg1) {  # '$arg1'
 555
 556 We deal with them as follows, and return the appropriate C<my ($self, ...) = @_;>
 557 string.
 558
 559     sub make_proto_unwrap {
 560       my ($proto) = @_;
 561       my $inject = 'my ($self';
 562       if (defined $proto) {
 563         $inject .= ", $proto" if length($proto);
 564         $inject .= ') = @_; ';
 565       } else {
 566         $inject .= ') = shift;';
 567       }
 568       return $inject;
 569     }
 570
 571 =head3 C<inject_if_block>
 572
 573 Now we need to inject it after the opening C<'{'> of the method body.
 574 We can do this with the building blocks we defined above like C<skipspace>
 575 and C<get_linestr>.
 576
 577     sub inject_if_block {
 578       my $inject = shift;
 579       skipspace;
 580       my $linestr = Devel::Declare::get_linestr;
 581       if (substr($linestr, $Offset, 1) eq '{') {
 582         substr($linestr, $Offset+1, 0) = $inject;
 583         Devel::Declare::set_linestr($linestr);
 584       }
 585     }
 586
 587 =head3 C<scope_injector_call>
 588
 589 We want to be able to handle both named and anonymous methods.  i.e.
 590
 591     method foo () { ... }
 592     my $meth = method () { ... };
 593
 594 These will then get rewritten as
 595
 596     method { ... }
 597     my $meth = method { ... };
 598
 599 where 'method' is a subroutine that takes a code block.  Spot the problem?
 600 The first one doesn't have a semicolon at the end of it!  Unlike 'sub' which
 601 is a builtin, this is just a normal statement, so we need to terminate it.
 602 Luckily, using C<B::Hooks::EndOfScope>, we can do this!
 603
 604   use B::Hooks::EndOfScope;
 605
 606 We'll add this to what gets 'injected' at the beginning of the method source.
 607
 608   sub scope_injector_call {
 609     return ' BEGIN { MethodHandlers::inject_scope }; ';
 610   }
 611
 612 So at the beginning of every method, we are passing a callback that will get invoked
 613 at the I<end> of the method's compilation... i.e. exactly then the closing C<'}'>
 614 is compiled.
 615
 616   sub inject_scope {
 617     on_scope_end {
 618       my $linestr = Devel::Declare::get_linestr;
 619       my $offset = Devel::Declare::get_linestr_offset;
 620       substr($linestr, $offset, 0) = ';';
 621       Devel::Declare::set_linestr($linestr);
 622     };
 623   }
 624
 625 =head2 Shadowing each method.
 626
 627 =head3 C<shadow>
 628
 629 We override the current definition of 'method' using C<shadow>.
 630
 631     sub shadow {
 632       my $pack = Devel::Declare::get_curstash_name;
 633       Devel::Declare::shadow_sub("${pack}::${Declarator}", $_[0]);
 634     }
 635
 636 For a named method we invoked like this:
 637
 638     shadow(sub (&) { no strict 'refs'; *{$name} = shift; });
 639
 640 So in the case of a C<method foo { ... }>, this call would redefine C<method>
 641 to be a subroutine that exports 'sub foo' as the (munged) contents of C<{...}>.
 642
 643 The case of an anonymous method is also cute:
 644
 645     shadow(sub (&) { shift });
 646
 647 This means that
 648
 649     my $meth = method () { ... };
 650
 651 is rewritten with C<method> taking the codeblock, and returning it as is to become
 652 the value of C<$meth>.
 653
 654 =head4 C<get_curstash_name>
 655
 656 This returns the package name I<currently being compiled>.
 657
 658 =head4 C<shadow_sub>
 659
 660 Handles the details of redefining the subroutine.
 661
 662 =head1 SEE ALSO
 663
 664 One of the best ways to learn C<Devel::Declare> is still to look at
 665 modules that use it:
 666
 667 L<http://cpants.perl.org/dist/used_by/Devel-Declare>.
 668
 669 =head1 AUTHORS
 670
 671 Matt S Trout - E<lt>mst@shadowcat.co.ukE<gt> - original author
 672
 673 Company: http://www.shadowcat.co.uk/
 674 Blog: http://chainsawblues.vox.com/
 675
 676 Florian Ragwitz E<lt>rafl@debian.orgE<gt> - maintainer
 677
 678 osfameron E<lt>osfameron@cpan.orgE<gt> - first draft of documentation
 679
 680 =head1 COPYRIGHT AND LICENSE
 681
 682 This library is free software under the same terms as perl itself
 683
 684 Copyright (c) 2007, 2008, 2009  Matt S Trout
 685
 686 Copyright (c) 2008, 2009  Florian Ragwitz
 687
 688 stolen_chunk_of_toke.c based on toke.c from the perl core, which is
 689
 690 Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
 691 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
 692
 693 =cut
 694
 695 1;