lib/with.pm

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