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 wrap/;
  14
  15 =head1 NAME
  16
  17 with - Lexically call methods with a default object.
  18
  19 =head1 VERSION
  20
  21 Version 0.02
  22
  23 =cut
  24
  25 our $VERSION = '0.02';
  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 cmp
 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               chomp chop chown chr chroot close closedir connect cos crypt
 107               dbmclose dbmopen defined delete die do dump each endgrent
 108               endhostent endnetent endprotoent endpwent endservent eof eval
 109               exec exists exit exp fcntl fileno flock fork format formline
 110               getc getgrent getgrgid getgrnam gethostbyaddr gethostbyname
 111               gethostent getlogin getnetbyaddr getnetbyname getnetent
 112               getpeername getpgrp getppid getpriority getprotobyname
 113               getprotobynumber getprotoent getpwent getpwnam getpwuid
 114               getservbyname getservbyport getservent getsockname getsockopt
 115               glob gmtime goto grep hex index int ioctl join keys kill last lc
 116               lcfirst length link listen local localtime lock log lstat map
 117               mkdir msgctl msgget msgrcv msgsnd my next no oct open opendir
 118               ord our pack package pipe pop pos print printf prototype push
 119               quotemeta rand read readdir readline readlink recv redo ref
 120               rename require reset return reverse rewinddir rindex rmdir
 121               scalar seek seekdir select semctl semget semop send setgrent
 122               sethostent setnetent setpgrp setpriority setprotoent setpwent
 123               setservent setsockopt shift shmctl shmget shmread shmwrite
 124               shutdown sin sleep socket socketpair sort splice split sprintf
 125               sqrt srand stat study sub substr symlink syscall sysopen sysread
 126               sysseek system syswrite tell telldir tie tied time times
 127               truncate uc ucfirst umask undef unlink unpack unshift untie use
 128               utime values vec wait waitpid wantarray warn write/;
 129
 130 my %core;
 131 $core{$_} = prototype "CORE::$_" for @core;
 132 undef @core;
 133 # Fake prototypes
 134 $core{'not'}        = '$';
 135 $core{'defined'}    = '_';
 136 $core{'undef'}      = ';\[$@%&*]';
 137
 138 my %hints;
 139
 140 sub code {
 141  no strict 'refs';
 142  my $name = @_ > 1 ? join '::', @_
 143                    : $_[0];
 144  return *{$name}{CODE};
 145 }
 146
 147 sub corewrap {
 148  my ($name, $par) = @_;
 149  return '' unless $name;
 150  my $wrap = 'with::core::' . $name;
 151  if (not code $wrap) {
 152   my $proto = $core{$name};
 153   my $func = wrap { 'CORE::' . $name => $proto }, compile => 1;
 154   my $code = set_prototype sub {
 155    my ($caller, $H) = (caller 0)[0, 10];
 156    my $id = ($H || {})->{with};
 157    my $obj;
 158    # Try method call.
 159    if ($id and $obj = $hints{$id}) {
 160     if (my $meth = $$obj->can($name)) {
 161      @_ = flatten $proto, @_ if defined $proto;
 162      unshift @_, $$obj;
 163      goto &$meth;
 164     }
 165    }
 166    # Try function call in caller namescape.
 167    my $qname = $caller . '::' . $name;
 168    if (code $qname) {
 169     @_ = flatten $proto, @_ if defined $proto;
 170     goto &$qname;
 171    }
 172    # Try core function call.
 173    my @ret = eval { $func->(@_) };
 174    if ($@) {
 175     # Produce a correct error in regard of the caller.
 176     my $msg = $@;
 177     $msg =~ s/(called)\s+at.*/$1/s;
 178     croak $msg;
 179    }
 180    return wantarray ? @ret : $ret[0];
 181   }, $proto;
 182   {
 183    no strict 'refs';
 184    *$wrap = $code;
 185   }
 186  }
 187  return $wrap . ' ' . $par;
 188 }
 189
 190 sub subwrap {
 191  my ($name, $par, $proto) = @_;
 192  return '' unless $name;
 193  return "with::defer $par'$name'," unless defined $proto;
 194  my $wrap = 'with::sub::' . $name;
 195  if (not code $wrap) {
 196   my $code = set_prototype sub {
 197    my ($caller, $H) = (caller 0)[0, 10];
 198    my $id = ($H || {})->{with};
 199    my $obj;
 200    # Try method call.
 201    if ($id and $obj = $hints{$id}) {
 202     if (my $meth = $$obj->can($name)) {
 203      @_ = flatten $proto, @_;
 204      unshift @_, $$obj;
 205      goto &$meth;
 206     }
 207    }
 208    # Try function call in caller namescape.
 209    my $qname = $caller . '::' . $name;
 210    goto &$qname if code $qname;
 211    # This call won't succeed, but it'll throw an exception we should propagate.
 212    eval { no strict 'refs'; $qname->(@_) };
 213    if ($@) {
 214     # Produce a correct 'Undefined subroutine' error in regard of the caller.
 215     my $msg = $@;
 216     $msg =~ s/(called)\s+at.*/$1/s;
 217     croak $msg;
 218    }
 219    croak "$qname didn't exist and yet the call succeeded\n";
 220   }, $proto;
 221   {
 222    no strict 'refs';
 223    *$wrap = $code;
 224   }
 225  }
 226  return $wrap . ' '. $par;
 227 }
 228
 229 sub defer {
 230  my $name = shift;
 231  my ($caller, $H) = (caller 0)[0, 10];
 232  my $id = ($H || {})->{with};
 233  my $obj;
 234  # Try method call.
 235  if ($id and $obj = $hints{$id}) {
 236   if (my $meth = $$obj->can($name)) {
 237    unshift @_, $$obj;
 238    goto &$meth;
 239   }
 240  }
 241  # Try function call in caller namescape.
 242  $name = $caller . '::' . $name;
 243  goto &$name if code $name;
 244  # This call won't succeed, but it'll throw an exception we should propagate.
 245  eval { no strict 'refs'; $name->(@_) };
 246  if ($@) {
 247   # Produce a correct 'Undefined subroutine' error in regard of the caller.
 248   my $msg = $@;
 249   $msg =~ s/(called)\s+at.*/$1/s;
 250   croak $msg;
 251  }
 252  croak "$name didn't exist and yet the call succeeded\n";
 253 }
 254
 255 sub import {
 256  return unless defined $_[1] and ref $_[1];
 257  my $caller = (caller 0)[0];
 258  my $id = refaddr $_[1];
 259  $hints{$^H{with} = $id} = $_[1];
 260  filter_add sub {
 261   my ($status, $lastline);
 262   my ($data, $count) = ('', 0);
 263   while ($status = filter_read) {
 264    return $status if $status < 0;
 265    return $status unless defined $^H{with} && $^H{with} == $id;
 266    if (/^__(?:DATA)__\r?$/ || /\b(?:use|no)\s+with\b/) {
 267     $lastline = $_;
 268     last;
 269    }
 270    $data .= $_;
 271    ++$count;
 272    $_ = '';
 273   }
 274   return $count if not $count;
 275   my $instr;
 276   my @components;
 277   for (extract_multiple($data, $extractor)) {
 278    if (ref)       { push @components, $_; $instr = 0 }
 279    elsif ($instr) { $components[-1] .= $_ }
 280    else           { push @components, $_; $instr = 1 }
 281   }
 282   my $i = 0;
 283   $_ = join '',
 284         map { (ref) ? $; . pack('N', $i++) . $; : $_ }
 285          @components;
 286   @components = grep ref, @components;
 287   s/
 288     \b &? ([^\W\d]\w+) \s* (?!=>) (\(?)
 289    /
 290     $skip{$1} ? "$1 $2"
 291               : exists $core{$1} ? corewrap $1, $2
 292                                  : subwrap $1, $2, prototype($caller.'::'.$1)
 293    /sexg;
 294   s/\Q$;\E(\C{4})\Q$;\E/${$components[unpack('N',$1)]}/g;
 295   $_ .= $lastline if defined $lastline;
 296   return $count;
 297  }
 298 }
 299
 300 sub unimport {
 301  $^H{with} = undef;
 302  filter_del;
 303 }
 304
 305 =head1 HOW DOES IT WORK
 306
 307 The main problem to address is that lexical scoping and source modification can only occur at compile time, while object creation and method resolution happen at run-time.
 308
 309 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 has a prototype or is part of the 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.
 310
 311 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" error is thrown.
 312
 313 =head1 IGNORED KEYWORDS
 314
 315 A call will never be dispatched to a method whose name is one of :
 316
 317     my our local sub do eval goto return
 318     if else elsif unless given when or and
 319     while until for foreach next redo last continue
 320     eq ne lt gt le ge cmp
 321     map grep system exec sort print say
 322     new
 323     STDIN STDOUT STDERR
 324
 325 =head1 EXPORT
 326
 327 No function or constant is exported by this pragma.
 328
 329 =head1 CAVEATS
 330
 331 Most likely slow. Almost surely non thread-safe. Contains source filters, hence brittle. Messes with the dreadful prototypes. Crazy. Will have bugs.
 332
 333 Don't put anything on the same line of C<use with \$obj> or C<no with>.
 334
 335 When there's a function in the caller namespace that has a core function name, and when no method with the same name is present, the ambiguity is resolved in favor of the caller namespace. That's different from the usual perl semantics where C<sub push; push @a, 1> gets resolved to CORE::push.
 336
 337 If a method has the same name as a prototyped function in the caller namespace, and if a called is deferred to the method, it will have its arguments passed by value.
 338
 339 =head1 DEPENDENCIES
 340
 341 L<perl> 5.9.4.
 342
 343 L<Carp> (core module since perl 5).
 344
 345 L<Filter::Util::Call>, L<Scalar::Util> and L<Text::Balanced> (core since 5.7.3).
 346
 347 L<Sub::Prototype::Util> 0.08.
 348
 349 =head1 AUTHOR
 350
 351 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 352
 353 You can contact me by mail or on C<irc.perl.org> (vincent).
 354
 355 =head1 BUGS
 356
 357 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.
 358
 359 =head1 SUPPORT
 360
 361 You can find documentation for this module with the perldoc command.
 362
 363     perldoc with
 364
 365 =head1 ACKNOWLEDGEMENTS
 366
 367 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.
 368
 369 =head1 COPYRIGHT & LICENSE
 370
 371 Copyright 2008 Vincent Pit, all rights reserved.
 372
 373 This program is free software; you can redistribute it and/or modify it
 374 under the same terms as Perl itself.
 375
 376 =cut
 377
 378 1; # End of with