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