lib/with.pm

   1 package with;
   2
   3 use 5.009004;
   4
   5 use strict;
   6 use warnings;
   7
   8 use Carp qw/croak/;
   9 use Filter::Util::Call;
  10 use Text::Balanced qw/extract_variable extract_quotelike extract_multiple/;
  11 use Scalar::Util qw/refaddr set_prototype/;
  12
  13 use Sub::Prototype::Util qw/flatten recall wrap/;
  14
  15 =head1 NAME
  16
  17 with - Lexically call methods with a default object.
  18
  19 =head1 VERSION
  20
  21 Version 0.01
  22
  23 =cut
  24
  25 our $VERSION = '0.01';
  26
  27 =head1 SYNOPSIS
  28
  29     package Deuce;
  30
  31     sub new { my $class = shift; bless { id = > shift }, $class }
  32
  33     sub hlagh { my $self = shift; print "Deuce::hlagh $self->{id}\n" }
  34
  35
  36     package Pants;
  37
  38     sub hlagh { print "Pants::hlagh\n" }
  39
  40     our @ISA;
  41     push @ISA, 'Deuce';
  42     my $deuce = new Deuce 1;
  43
  44     hlagh;         # Pants::hlagh
  45
  46     {
  47      use with \$deuce;
  48      hlagh;        # Deuce::hlagh 1
  49      Pants::hlagh; # Pants::hlagh
  50
  51      {
  52       use with \Deuce->new(2);
  53       hlagh;       # Deuce::hlagh 2
  54      }
  55
  56      hlagh;        # Deuce::hlagh 1
  57
  58      no with;
  59      hlagh;        # Pants::hlagh
  60     }
  61
  62     hlagh;         # Pants::hlagh
  63
  64 =head1 DESCRIPTION
  65
  66 This pragma lets you define a default object against with methods will be called in the current scope when possible. It is enabled by the C<use with \$obj> idiom (note that you must pass a reference to the object). If you C<use with> several times in the current scope, the default object will be the last specified one.
  67
  68 =cut
  69
  70 my $EOP = qr/\n+|\Z/;
  71 my $CUT = qr/\n=cut.*$EOP/;
  72 my $pod_or_DATA = qr/
  73               ^=(?:head[1-4]|item) .*? $CUT
  74             | ^=pod .*? $CUT
  75             | ^=for .*? $EOP
  76             | ^=begin \s* (\S+) .*? \n=end \s* \1 .*? $EOP
  77             | ^__(DATA|END)__\r?\n.*
  78             /smx;
  79
  80 my $extractor = [
  81  { 'with::COMMENT'    => qr/(?<![\$\@%])#.*/ },
  82  { 'with::PODDATA'    => $pod_or_DATA },
  83  { 'with::QUOTELIKE'  => sub {
  84       extract_quotelike $_[0], qr/(?=(?:['"]|\bq.|<<\w+))/
  85  } },
  86  { 'with::VARIABLE'   => sub {
  87       extract_variable $_[0], qr/(?=\\?[\$\@\%\&\*])/
  88  } },
  89  { 'with::HASHKEY'    => qr/\w+\s*=>/ },
  90  { 'with::QUALIFIED'  => qr/\w+(?:::\w+)+(?:::)?/ },
  91  { 'with::SUB'        => qr/sub\s+\w+(?:::\w+)*/ },
  92  { 'with::FILEHANDLE' => qr/<[\$\*]?[^\W>]*>/ },
  93  { 'with::USE'        => qr/(?:use|no)\s+\S+/ },
  94 ];
  95
  96 my %skip;
  97 $skip{$_} = 1 for qw/my our local sub do eval goto return
  98                      if else elsif unless given when or and
  99                      while until for foreach next redo last continue
 100                      eq ne lt gt le ge
 101                      map grep system exec sort print say
 102                      new
 103                      STDIN STDOUT STDERR/;
 104
 105 my @core = qw/abs accept alarm atan2 bind binmode bless caller chdir chmod
 106               chop chown chr chroot close closedir connect cos crypt dbmclose
 107               defined delete die do dump each endgrent endhostent endnetent
 108               endpwent endservent eof eval exec exists exit exp fcntl fileno
 109               fork format formline getc getgrent getgrgid getgrnam
 110               gethostbyname gethostent getlogin getnetbyaddr getnetbyname
 111               getpeername getpgrp getppid getpriority getprotobyname
 112               getprotoent getpwent getpwnam getpwuid getservbyname
 113               getservent getsockname getsockopt glob gmtime goto grep hex
 114               int ioctl join keys kill last lc lcfirst length link listen
 115               localtime lock log lstat map mkdir msgctl msgget msgrcv msgsnd
 116               next no oct open opendir ord our pack package pipe pop pos print
 117               prototype push quotemeta rand read readdir readline readlink
 118               redo ref rename require reset return reverse rewinddir rindex
 119               scalar seek seekdir select semctl semget semop send setgrent
 120               setnetent setpgrp setpriority setprotoent setpwent setservent
 121               shift shmctl shmget shmread shmwrite shutdown sin sleep socket
 122               sort splice split sprintf sqrt srand stat study sub substr
 123               syscall sysopen sysread sysseek system syswrite tell telldir tie
 124               time times truncate uc ucfirst umask undef unlink unpack unshift
 125               use utime values vec wait waitpid wantarray warn write/;
 126 my %core;
 127 $core{$_} = prototype "CORE::$_" for @core;
 128 undef @core;
 129 # Fake prototypes
 130 $core{'not'}        = '$';
 131 $core{'defined'}    = '_';
 132 $core{'undef'}      = ';\[$@%&*]';
 133
 134 my %hints;
 135
 136 sub code {
 137  no strict 'refs';
 138  my $name = @_ > 1 ? join '::', @_
 139                    : $_[0];
 140  return *{$name}{CODE};
 141 }
 142
 143 sub corewrap {
 144  my ($name, $par) = @_;
 145  return '' unless $name;
 146  my $wrap = 'with::core::' . $name;
 147  if (not code $wrap) {
 148   my $proto = $core{$name};
 149   my $func = wrap { 'CORE::' . $name => $proto }, compile => 1;
 150   my $code = set_prototype sub {
 151    my ($caller, $H) = (caller 0)[0, 10];
 152    my $id = ($H || {})->{with};
 153    my $obj;
 154    # Try method call.
 155    if ($id and $obj = $hints{$id}) {
 156     if (my $meth = $$obj->can($name)) {
 157      @_ = flatten $proto, @_ if defined $proto;
 158      unshift @_, $$obj;
 159      goto &$meth;
 160     }
 161    }
 162    # Try function call in caller namescape.
 163    $name = $caller . '::' . $name;
 164    if (code $name) {
 165     @_ = flatten $proto, @_ if defined $proto;
 166     goto &$name;
 167    }
 168    # Try core function call.
 169    my @ret = eval { $func->(@_) };
 170    if ($@) {
 171     # Produce a correct error in regard of the caller.
 172     my $msg = $@;
 173     $msg =~ s/(called)\s+at.*/$1/s;
 174     croak $msg;
 175    }
 176    return wantarray ? @ret : $ret[0];
 177   }, $proto;
 178   {
 179    no strict 'refs';
 180    *$wrap = $code;
 181   }
 182  }
 183  return $wrap . ' ' . $par;
 184 }
 185
 186 sub subwrap {
 187  my ($name, $par, $proto) = @_;
 188  return '' unless $name;
 189  return "with::defer $par'$name'," unless defined $proto;
 190  my $wrap = 'with::sub::' . $name;
 191  if (not code $wrap) {
 192   my $code = set_prototype sub {
 193    my ($caller, $H) = (caller 0)[0, 10];
 194    my $id = ($H || {})->{with};
 195    my $obj;
 196    # Try method call.
 197    if ($id and $obj = $hints{$id}) {
 198     if (my $meth = $$obj->can($name)) {
 199      @_ = flatten $proto, @_;
 200      unshift @_, $$obj;
 201      goto &$meth;
 202     }
 203    }
 204    # Try function call in caller namescape.
 205    $name = $caller . '::' . $name;
 206    goto &$name if code $name;
 207    # This call won't succeed, but it'll throw an exception we should propagate.
 208    eval { $name->(@_) };
 209    if ($@) {
 210     # Produce a correct 'Undefined subroutine' error in regard of the caller.
 211     my $msg = $@;
 212     $msg =~ s/(called)\s+at.*/$1/s;
 213     croak $msg;
 214    }
 215    croak "$name didn't exist and yet the call succeeded\n";
 216   }, $proto;
 217   {
 218    no strict 'refs';
 219    *$wrap = $code;
 220   }
 221  }
 222  return $wrap . ' '. $par;
 223 }
 224
 225 sub defer {
 226  my $name = shift;
 227  my ($caller, $H) = (caller 0)[0, 10];
 228  my $id = ($H || {})->{with};
 229  my $obj;
 230  # Try method call.
 231  if ($id and $obj = $hints{$id}) {
 232   if (my $meth = $$obj->can($name)) {
 233    unshift @_, $$obj;
 234    goto &$meth;
 235   }
 236  }
 237  # Try function call in caller namescape.
 238  $name = $caller . '::' . $name;
 239  goto &$name if code $name;
 240  # This call won't succeed, but it'll throw an exception we should propagate.
 241  eval { $name->(@_) };
 242  if ($@) {
 243   # Produce a correct 'Undefined subroutine' error in regard of the caller.
 244   my $msg = $@;
 245   $msg =~ s/(called)\s+at.*/$1/s;
 246   croak $msg;
 247  }
 248  croak "$name didn't exist and yet the call succeeded\n";
 249 }
 250
 251 sub import {
 252  return unless defined $_[1] and ref $_[1];
 253  my $caller = (caller 0)[0];
 254  my $id = refaddr $_[1];
 255  $hints{$^H{with} = $id} = $_[1];
 256  filter_add sub {
 257   my ($status, $lastline);
 258   my ($data, $count) = ('', 0);
 259   while ($status = filter_read) {
 260    return $status if $status < 0;
 261    return $status unless defined $^H{with} && $^H{with} == $id;
 262    if (/^__(?:DATA)__\r?$/ || /\b(?:use|no)\s+with\b/) {
 263     $lastline = $_;
 264     last;
 265    }
 266    $data .= $_;
 267    ++$count;
 268    $_ = '';
 269   }
 270   return $count if not $count;
 271   my $instr;
 272   my @components;
 273   for (extract_multiple($data, $extractor)) {
 274    if (ref)       { push @components, $_; $instr = 0 }
 275    elsif ($instr) { $components[-1] .= $_ }
 276    else           { push @components, $_; $instr = 1 }
 277   }
 278   my $i = 0;
 279   $_ = join '',
 280         map { (ref) ? $; . pack('N', $i++) . $; : $_ }
 281          @components;
 282   @components = grep ref, @components;
 283   s/
 284     \b &? ([^\W\d]\w+) \s* (?!=>) (\(?)
 285    /
 286     $skip{$1} ? "$1 $2"
 287               : exists $core{$1} ? corewrap $1, $2
 288                                  : subwrap $1, $2, prototype($caller.'::'.$1)
 289    /sexg;
 290   s/\Q$;\E(\C{4})\Q$;\E/${$components[unpack('N',$1)]}/g;
 291   $_ .= $lastline if defined $lastline;
 292   return $count;
 293  }
 294 }
 295
 296 sub unimport {
 297  $^H{with} = undef;
 298  filter_del;
 299 }
 300
 301 =head1 HOW DOES IT WORK
 302
 303 The main problem to address is that lexical scope and source modifications can only occur at compile time, while object creation and method resolution happen at run-time.
 304
 305 The C<use with \$obj> statement stores an address to the variable C<$obj> in the C<with> field of the hints hash C<%^H>. It also starts a source filter that replaces function calls with calls to C<with::defer>, passing the name of the original function as the first argument. When the replaced function is part of Perl core, the call is deferred to a corresponding wrapper generated in the C<with> namespace. Some keywords that couldn't possibly be replaced are also completely skipped. C<no with> undefines the hint and deletes the source filter, stopping any subsequent modification in the current scope.
 306
 307 When the script is executed, deferred calls first fetch the default object back from the address stored into the hint. If the object C<< ->can >> the original function name, a method call is issued. If not, the calling namespace is inspected for a subroutine with the proper name, and if it's present the program C<goto>s into it. If that fails too, the core function with the same name is recalled if possible, or an "Undefined subroutine" warning is thrown.
 308
 309 =head1 IGNORED KEYWORDS
 310
 311 A call will never dispatch to methods whose name is part of :
 312
 313     my our local sub do eval goto return
 314     if else elsif unless given when or and
 315     while until for foreach next redo last continue
 316     eq ne lt gt le ge
 317     map grep system exec sort print say
 318     new
 319     STDIN STDOUT STDERR
 320
 321 =head1 EXPORT
 322
 323 No function or constant is exported by this pragma.
 324
 325 =head1 CAVEATS
 326
 327 Most likely slow. Almost surely non thread-safe. Contains source filters, hence brittle. Messes with the dreadful prototypes. Crazy. Will have bugs.
 328
 329 Don't put anything on the same line of C<use with \$obj> or C<no with>.
 330
 331 =head1 DEPENDENCIES
 332
 333 L<perl> 5.9.4.
 334
 335 L<Carp> (core module since perl 5).
 336
 337 L<Filter::Util::Call>, L<Scalar::Util> and L<Text::Balanced> (core since 5.7.3).
 338
 339 L<Sub::Prototype::Util> 0.08.
 340
 341 =head1 AUTHOR
 342
 343 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 344
 345 You can contact me by mail or on #perl @ FreeNode (vincent or Prof_Vince).
 346
 347 =head1 BUGS
 348
 349 Please report any bugs or feature requests to C<bug-with at rt.cpan.org>, or through the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=with>. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
 350
 351 =head1 SUPPORT
 352
 353 You can find documentation for this module with the perldoc command.
 354
 355     perldoc with
 356
 357 =head1 ACKNOWLEDGEMENTS
 358
 359 A fair part of this module is widely inspired from L<Filter::Simple> (especially C<FILTER_ONLY>), but a complete integration was needed in order to add hints support and more placeholder patterns.
 360
 361 =head1 COPYRIGHT & LICENSE
 362
 363 Copyright 2008 Vincent Pit, all rights reserved.
 364
 365 This program is free software; you can redistribute it and/or modify it
 366 under the same terms as Perl itself.
 367
 368 =cut
 369
 370 1; # End of with