1=head1 NAME 2 3Lexical::Persistence - Persistent lexical variable values for arbitrary calls. 4 5=head1 VERSION 6 7version 1.023 8 9=head1 SYNOPSIS 10 11 #!/usr/bin/perl 12 13 use Lexical::Persistence; 14 15 my $persistence = Lexical::Persistence->new(); 16 foreach my $number (qw(one two three four five)) { 17 $persistence->call(\&target, number => $number); 18 } 19 20 exit; 21 22 sub target { 23 my $arg_number; # Argument. 24 my $narf_x++; # Persistent. 25 my $_i++; # Dynamic. 26 my $j++; # Persistent. 27 28 print "arg_number = $arg_number\n"; 29 print "\tnarf_x = $narf_x\n"; 30 print "\t_i = $_i\n"; 31 print "\tj = $j\n"; 32 } 33 34=head1 DESCRIPTION 35 36Lexical::Persistence does a few things, all related. Note that all 37the behaviors listed here are the defaults. Subclasses can override 38nearly every aspect of Lexical::Persistence's behavior. 39 40Lexical::Persistence lets your code access persistent data through 41lexical variables. This example prints "some value" because the value 42of $x persists in the $lp object between setter() and getter(). 43 44 use Lexical::Persistence; 45 46 my $lp = Lexical::Persistence->new(); 47 $lp->call(\&setter); 48 $lp->call(\&getter); 49 50 sub setter { my $x = "some value" } 51 sub getter { print my $x, "\n" } 52 53Lexicals with leading underscores are not persistent. 54 55By default, Lexical::Persistence supports accessing data from multiple 56sources through the use of variable prefixes. The set_context() 57member sets each data source. It takes a prefix name and a hash of 58key/value pairs. By default, the keys must have sigils representing 59their variable types. 60 61 use Lexical::Persistence; 62 63 my $lp = Lexical::Persistence->new(); 64 $lp->set_context( pi => { '$member' => 3.141 } ); 65 $lp->set_context( e => { '@member' => [ 2, '.', 7, 1, 8 ] } ); 66 $lp->set_context( 67 animal => { 68 '%member' => { cat => "meow", dog => "woof" } 69 } 70 ); 71 72 $lp->call(\&display); 73 74 sub display { 75 my ($pi_member, @e_member, %animal_member); 76 77 print "pi = $pi_member\n"; 78 print "e = @e_member\n"; 79 while (my ($animal, $sound) = each %animal_member) { 80 print "The $animal goes... $sound!\n"; 81 } 82 } 83 84And the corresponding output: 85 86 pi = 3.141 87 e = 2 . 7 1 8 88 The cat goes... meow! 89 The dog goes... woof! 90 91By default, call() takes a single subroutine reference and an optional 92list of named arguments. The arguments will be passed directly to the 93called subroutine, but Lexical::Persistence also makes the values 94available from the "arg" prefix. 95 96 use Lexical::Persistence; 97 98 my %animals = ( 99 snake => "hiss", 100 plane => "I'm Cartesian", 101 ); 102 103 my $lp = Lexical::Persistence->new(); 104 while (my ($animal, $sound) = each %animals) { 105 $lp->call(\&display, animal => $animal, sound => $sound); 106 } 107 108 sub display { 109 my ($arg_animal, $arg_sound); 110 print "The $arg_animal goes... $arg_sound!\n"; 111 } 112 113And the corresponding output: 114 115 The plane goes... I'm Cartesian! 116 The snake goes... hiss! 117 118Sometimes you want to call functions normally. The wrap() method will 119wrap your function in a small thunk that does the call() for you, 120returning a coderef. 121 122 use Lexical::Persistence; 123 124 my $lp = Lexical::Persistence->new(); 125 my $thunk = $lp->wrap(\&display); 126 127 $thunk->(animal => "squirrel", sound => "nuts"); 128 129 sub display { 130 my ($arg_animal, $arg_sound); 131 print "The $arg_animal goes... $arg_sound!\n"; 132 } 133 134And the corresponding output: 135 136 The squirrel goes... nuts! 137 138Prefixes are the characters leading up to the first underscore in a 139lexical variable's name. However, there's also a default context 140named underscore. It's literally "_" because the underscore is not 141legal in a context name by default. Variables without prefixes, or 142with prefixes that have not been previously defined by set_context(), 143are stored in that context. 144 145The get_context() member returns a hash for a named context. This 146allows your code to manipulate the values within a persistent context. 147 148 use Lexical::Persistence; 149 150 my $lp = Lexical::Persistence->new(); 151 $lp->set_context( 152 _ => { 153 '@mind' => [qw(My mind is going. I can feel it.)] 154 } 155 ); 156 157 while (1) { 158 $lp->call(\&display); 159 my $mind = $lp->get_context("_")->{'@mind'}; 160 splice @$mind, rand(@$mind), 1; 161 last unless @$mind; 162 } 163 164 sub display { 165 my @mind; 166 print "@mind\n"; 167 } 168 169Displays something like: 170 171 My mind is going. I can feel it. 172 My is going. I can feel it. 173 My is going. I feel it. 174 My going. I feel it. 175 My going. I feel 176 My I feel 177 My I 178 My 179 180It's possible to create multiple Lexical::Persistence objects, each 181with a unique state. 182 183 use Lexical::Persistence; 184 185 my $lp_1 = Lexical::Persistence->new(); 186 $lp_1->set_context( _ => { '$foo' => "context 1's foo" } ); 187 188 my $lp_2 = Lexical::Persistence->new(); 189 $lp_2->set_context( _ => { '$foo' => "the foo in context 2" } ); 190 191 $lp_1->call(\&display); 192 $lp_2->call(\&display); 193 194 sub display { 195 print my $foo, "\n"; 196 } 197 198Gets you this output: 199 200 context 1's foo 201 the foo in context 2 202 203You can also compile and execute perl code contained in plain strings in a 204a lexical environment that already contains the persisted variables. 205 206 use Lexical::Persistence; 207 208 my $lp = Lexical::Persistence->new(); 209 210 $lp->do( 'my $message = "Hello, world" ); 211 212 $lp->do( 'print "$message\n"' ); 213 214Which gives the output: 215 216 Hello, world 217 218If you come up with other fun uses, let us know. 219 220=cut 221 222package Lexical::Persistence; 223 224use warnings; 225use strict; 226 227our $VERSION = '1.020'; 228 229use Devel::LexAlias qw(lexalias); 230use PadWalker qw(peek_sub); 231 232=head2 new 233 234Create a new lexical persistence object. This object will store one 235or more persistent contexts. When called by this object, lexical 236variables will take on the values kept in this object. 237 238=cut 239 240sub new { 241 my $class = shift; 242 243 my $self = bless { 244 context => { }, 245 }, $class; 246 247 $self->initialize_contexts(); 248 249 return $self; 250} 251 252=head2 initialize_contexts 253 254This method is called by new() to declare the initial contexts for a 255new Lexical::Persistence object. The default implementation declares 256the default "_" context. 257 258Override or extend it to create others as needed. 259 260=cut 261 262sub initialize_contexts { 263 my $self = shift; 264 $self->set_context( _ => { } ); 265} 266 267=head2 set_context NAME, HASH 268 269Store a context HASH within the persistence object, keyed on a NAME. 270Members of the context HASH are unprefixed versions of the lexicals 271they'll persist, including the sigil. For example, this set_context() 272call declares a "request" context with predefined values for three 273variables: $request_foo, @request_foo, and %request_foo: 274 275 $lp->set_context( 276 request => { 277 '$foo' => 'value of $request_foo', 278 '@foo' => [qw( value of @request_foo )], 279 '%foo' => { key => 'value of $request_foo{key}' } 280 } 281 ); 282 283See parse_variable() for information about how Lexical::Persistence 284decides which context a lexical belongs to and how you can change 285that. 286 287=cut 288 289sub set_context { 290 my ($self, $context_name, $context_hash) = @_; 291 $self->{context}{$context_name} = $context_hash; 292} 293 294=head2 get_context NAME 295 296Returns a context hash associated with a particular context name. 297Autovivifies the context if it doesn't already exist, so be careful 298there. 299 300=cut 301 302sub get_context { 303 my ($self, $context_name) = @_; 304 $self->{context}{$context_name} ||= { }; 305} 306 307=head2 call CODEREF, ARGUMENT_LIST 308 309Call CODEREF with lexical persistence and an optional ARGUMENT_LIST, 310consisting of name => value pairs. Unlike with set_context(), 311however, argument names do not need sigils. This may change in the 312future, however, as it's easy to access an argument with the wrong 313variable type. 314 315The ARGUMENT_LIST is passed to the called CODEREF through @_ in the 316usual way. They're also available as $arg_name variables for 317convenience. 318 319See push_arg_context() for information about how $arg_name works, and 320what you can do to change that behavior. 321 322=cut 323 324sub call { 325 my ($self, $sub, @args) = @_; 326 327 my $old_arg_context = $self->push_arg_context(@args); 328 329 my $pad = peek_sub($sub); 330 while (my ($var, $ref) = each %$pad) { 331 next unless my ($sigil, $context, $member) = $self->parse_variable($var); 332 lexalias( 333 $sub, $var, $self->get_member_ref($sigil, $context, $member) 334 ); 335 } 336 337 unless (defined wantarray) { 338 $sub->(@args); 339 $self->pop_arg_context($old_arg_context); 340 return; 341 } 342 343 if (wantarray) { 344 my @return = $sub->(@args); 345 $self->pop_arg_context($old_arg_context); 346 return @return; 347 } 348 349 my $return = $sub->(@args); 350 $self->pop_arg_context($old_arg_context); 351 return $return; 352} 353 354=head2 invoke OBJECT, METHOD, ARGUMENT_LIST 355 356Invoke OBJECT->METHOD(ARGUMENT_LIST) while maintaining state for the 357METHOD's lexical variables. Written in terms of call(), except that 358it takes OBJECT and METHOD rather than CODEREF. See call() for more 359details. 360 361May have issues with methods invoked via AUTOLOAD, as invoke() uses 362can() to find the method's CODEREF for call(). 363 364=cut 365 366sub invoke { 367 my ($self, $object, $method, @args) = @_; 368 return unless defined( my $sub = $object->can($method) ); 369 $self->call($sub, @args); 370} 371 372=head2 wrap CODEREF 373 374Wrap a function or anonymous CODEREF so that it's transparently called 375via call(). Returns a coderef which can be called directly. Named 376arguments to the call will automatically become available as $arg_name 377lexicals within the called CODEREF. 378 379See call() and push_arg_context() for more details. 380 381=cut 382 383sub wrap { 384 my ($self, $invocant, $method) = @_; 385 386 if (ref($invocant) eq 'CODE') { 387 return sub { 388 $self->call($invocant, @_); 389 }; 390 } 391 392 # FIXME - Experimental method wrapper. 393 # TODO - Make it resolve the method at call time. 394 # TODO - Possibly make it generate dynamic facade classes. 395 396 return sub { 397 $self->invoke($invocant, $method, @_); 398 }; 399} 400 401=head2 prepare CODE 402 403Wrap a CODE string in a subroutine definition, and prepend 404declarations for all the variables stored in the Lexical::Persistence 405default context. This avoids having to declare variables explicitly 406in the code using 'my'. Returns a new code string ready for Perl's 407built-in eval(). From there, a program may $lp->call() the code or 408$lp->wrap() it. 409 410Also see L</compile()>, which is a convenient wrapper for prepare() 411and Perl's built-in eval(). 412 413Also see L</do()>, which is a convenient way to prepare(), eval() and 414call() in one step. 415 416=cut 417 418sub prepare { 419 my ($self, $code) = @_; 420 421 # Don't worry about values because $self->call() will deal with them 422 my $vars = join( 423 " ", map { "my $_;" } 424 keys %{ $self->get_context('_') } 425 ); 426 427 # Declare the variables OUTSIDE the actual sub. The compiler will 428 # pull any into the sub that are actually used. Any that aren't will 429 # just get dropped at this point 430 return "$vars sub { $code }"; 431} 432 433=head2 compile CODE 434 435compile() is a convenience method to prepare() a CODE string, eval() 436it, and then return the resulting coderef. If it fails, it returns 437false, and $@ will explain why. 438 439=cut 440 441sub compile { 442 my ($self, $code) = @_; 443 return eval($self->prepare($code)); 444} 445 446=head2 do CODE 447 448do() is a convenience method to compile() a CODE string and execute 449it. It returns the result of CODE's execution, or it throws an 450exception on failure. 451 452This example prints the numbers 1 through 10. Note, however, that 453do() compiles the same code each time. 454 455 use Lexical::Persistence; 456 457 my $lp = Lexical::Persistence->new(); 458 $lp->do('my $count = 0'); 459 $lp->do('print ++$count, "\\n"') for 1..10; 460 461Lexical declarations are preserved across do() invocations, such as 462with $count in the surrounding examples. This behavior is part of 463prepare(), which do() uses via compile(). 464 465The previous example may be rewritten in terms of compile() and call() 466to avoid recompiling code every iteration. Lexical declarations are 467preserved between do() and compile() as well: 468 469 use Lexical::Persistence; 470 471 my $lp = Lexical::Persistence->new(); 472 $lp->do('my $count = 0'); 473 my $coderef = $lp->compile('print ++$count, "\\n"'); 474 $lp->call($coderef) for 1..10; 475 476do() inherits some limitations from PadWalker's peek_sub(). For 477instance, it cannot alias lexicals within sub() definitions in the 478supplied CODE string. However, Lexical::Persistence can do this with 479careful use of eval() and some custom CODE preparation. 480 481=cut 482 483sub do { 484 my ($self, $code) = @_; 485 486 my $sub = $self->compile( $code ) or die $@; 487 $self->call( $sub ); 488} 489 490=head2 parse_variable VARIABLE_NAME 491 492This method determines whether VARIABLE_NAME should be persistent. If 493it should, parse_variable() will return three values: the variable's 494sigil ('$', '@' or '%'), the context name in which the variable 495persists (see set_context()), and the name of the member within that 496context where the value is stored. parse_variable() returns nothing 497if VARIABLE_NAME should not be persistent. 498 499parse_variable() also determines whether the member name includes its 500sigil. By default, the "arg" context is the only one with members 501that have no sigils. This is done to support the unadorned argument 502names used by call(). 503 504This method implements a default behavior. It's intended to be 505overridden or extended by subclasses. 506 507=cut 508 509sub parse_variable { 510 my ($self, $var) = @_; 511 512 return unless ( 513 my ($sigil, $context, $member) = ( 514 $var =~ /^([\$\@\%])(?!_)(?:([^_]*)_)?(\S+)/ 515 ) 516 ); 517 518 if (defined $context) { 519 if (exists $self->{context}{$context}) { 520 return $sigil, $context, $member if $context eq "arg"; 521 return $sigil, $context, "$sigil$member"; 522 } 523 return $sigil, "_", "$sigil$context\_$member"; 524 } 525 526 return $sigil, "_", "$sigil$member"; 527} 528 529=head2 get_member_ref SIGIL, CONTEXT, MEMBER 530 531This method fetches a reference to the named MEMBER of a particular 532named CONTEXT. The returned value type will be governed by the given 533SIGIL. 534 535Scalar values are stored internally as scalars to be consistent with 536how most people store scalars. 537 538The persistent value is created if it doesn't exist. The initial 539value is undef or empty, depending on its type. 540 541This method implements a default behavior. It's intended to be 542overridden or extended by subclasses. 543 544=cut 545 546sub get_member_ref { 547 my ($self, $sigil, $context, $member) = @_; 548 549 my $hash = $self->{context}{$context}; 550 551 if ($sigil eq '$') { 552 $hash->{$member} = undef unless exists $hash->{$member}; 553 return \$hash->{$member}; 554 } 555 556 if ($sigil eq '@') { 557 $hash->{$member} = [ ] unless exists $hash->{$member}; 558 } 559 elsif ($sigil eq '%') { 560 $hash->{$member} = { } unless exists $hash->{$member}; 561 } 562 563 return $hash->{$member}; 564} 565 566=head2 push_arg_context ARGUMENT_LIST 567 568Convert a named ARGUMENT_LIST into members of an argument context, and 569call set_context() to declare that context. This is how $arg_foo 570variables are supported. This method returns the previous context, 571fetched by get_context() before the new context is set. 572 573This method implements a default behavior. It's intended to be 574overridden or extended by subclasses. For example, to redefine the 575parameters as $param_foo. 576 577See pop_arg_context() for the other side of this coin. 578 579=cut 580 581sub push_arg_context { 582 my $self = shift; 583 my $old_arg_context = $self->get_context("arg"); 584 $self->set_context( arg => { @_ } ); 585 return $old_arg_context; 586} 587 588=head2 pop_arg_context OLD_ARG_CONTEXT 589 590Restores OLD_ARG_CONTEXT after a target function has returned. The 591OLD_ARG_CONTEXT is the return value from the push_arg_context() call 592just prior to the target function's call. 593 594This method implements a default behavior. It's intended to be 595overridden or extended by subclasses. 596 597=cut 598 599sub pop_arg_context { 600 my ($self, $old_context) = @_; 601 $self->set_context( arg => $old_context ); 602} 603 604=head1 SEE ALSO 605 606L<POE::Stage>, L<Devel::LexAlias>, L<PadWalker>, 607L<Catalyst::Controller::BindLex>. 608 609=head2 BUG TRACKER 610 611https://rt.cpan.org/Dist/Display.html?Status=Active&Queue=Lexical-Persistence 612 613=head2 REPOSITORY 614 615http://github.com/rcaputo/lexical-persistence 616http://gitorious.org/lexical-persistence 617 618=head2 OTHER RESOURCES 619 620http://search.cpan.org/dist/Lexical-Persistence/ 621 622=head1 COPYRIGHT 623 624Lexical::Persistence in copyright 2006-2013 by Rocco Caputo. All 625rights reserved. Lexical::Persistence is free software. It is 626released under the same terms as Perl itself. 627 628=head1 ACKNOWLEDGEMENTS 629 630Thanks to Matt Trout and Yuval Kogman for lots of inspiration. They 631were the demon and the other demon sitting on my shoulders. 632 633Nick Perez convinced me to make this a class rather than persist with 634the original, functional design. While Higher Order Perl is fun for 635development, I have to say the move to OO was a good one. 636 637Paul "LeoNerd" Evans contributed the compile() and eval() methods. 638 639The South Florida Perl Mongers, especially Jeff Bisbee and Marlon 640Bailey, for documentation feedback. 641 642irc://irc.perl.org/poe for support and feedback. 643 644=cut 645 6461; 647