Want-0.26/000755 000765 000120 00000000000 12517670066 012622 5ustar00robinadmin000000 000000 Want-0.26/Changes000644 000765 000120 00000013544 12517670002 014112 0ustar00robinadmin000000 000000 Revision history for Perl extension Want. 0.01 Sun Jul 1 18:04:58 2001 - original version; created by h2xs 1.1.1.4 with options -A Want - Published to CPAN on 2001-07-15 0.02 Mon Jul 16 10:06:15 2001 - Give correct expectation count for constructs like my ($x, $y, $z) = (23, foo()); # foo's expectation count is 2 - want(2) should be true in C<@x = foo()> etc; i.e. infinity > N for any finite N :-) - Support '!' negative requests - correct expectation count for slices 0.03 Wed Jul 25 12:03:01 BST 2001 - Fix documentation snafus - add want('COUNT') as a synonym for C and want('REF') for C - BOOLEAN context - now compiles & passes tests under ithreads - SCALARREF and OBJECT reference contexts (want('REF') eq 'SCALAR' || want('REF') eq 'OBJECT') - Reorganised test suite 0.04 Sat Aug 4 09:44:34 BST 2001 - 'want' is now exported by default - BOOL is a euphemism for BOOLEAN (Perl 6 compatibility) - ARGUMENTS section added to documentation - excised C++-style comments from the source - fixed the expectation count issue from the BUGS section of 0.03 - ASSIGN context. Yeah, baby! - don't throw an error if RVALUE/LVALUE are used from a non-lvalue sub - specifiers can also now be space-separated, e.g.: want('LVALUE ASSIGN'); 0.05 Tue Aug 28 22:14:48 BST 2001 - tests pass on 5.6.1 and above - added 'rreturn' and 'lnoreturn' functions 0.06 Fri Jul 25 11:42:13 BST 2003 - pass thread context to Perl_pop_return - remove v-string 0.07 Mon Aug 18 10:27:27 BST 2003 - do not try to call pop_return (it's private) - update copyright year(s) and fix doc glitches - remove spurious || $n eq 'gelem' from _wantref - change i to I32 (rather than U32) to avoid compiler warning on Win32 0.08 Mon Dec 13 01:23:28 GMT 2004 - Accommodate the changed internals of perl 5.9.2 (the retstack is no more: see change #23156). 0.09 Thu Jun 30 15:02:37 BST 2005 - Fix a bug reported by Damian: want doesn't work (crashes) if it's called from within the guard of a loop. See the comment above upcontext_plus in Want.xs. - Runs under the debugger! - Give an error message (rather than segfaulting) if called from a tie handler. 0.10 Sat Mar 25 15:00:41 GMT 2006 - Make context propagate through subroutine return - Fix bug whereby want('LVALUE') sometimes gave false positives (see test 58 in t/all.t) - Fix bug whereby want_boolean often gave false positives 0.11 Sat Aug 26 22:36:27 BST 2006 - (Jerry D. Hedden) Fix bug whereby 'lnoreturn' failed to decrement the CvDEPTH, which causes an error with 'use threads' 0.12 Tue Aug 29 21:06:40 BST 2006 - (Jerry D. Hedden) Force the threads test to be skipped if oldstyle threads (as opposed to ithreads) are in use. 0.13 Tue May 1 21:39:19 BST 2007 - Address bug #26847, and add t/methcall.t 0.14 Fri May 4 12:00:20 BST 2007 - Fix bug #26928 0.15 Sun Jul 15 14:39:15 BST 2007 - Fix compiler warning (#26961) -- from Jerry D. Hedden - Fix memory leak in want_assign (#28224) 0.16 Thu Dec 6 11:15:39 GMT 2007 - Make sure there are no ._ files in the tarball - Refuse to run Makefile.PL with Perl < 5.006 0.17 Sun Feb 3 22:30:30 GMT 2008 - Be compatible with internals changes post-5.10 (new loop contexts & CxLVAL) 0.18 Mon Feb 4 09:35:56 GMT 2008 - Code identical to 0.17; eliminate ._files by using gnutar. 0.19 Sat 30 Jul 2011 17:07:16 BST - Change tests to avoid the new warning 'Useless assignment to a temporary' added in 5.15. 0.20 Sun 5 Feb 2012 17:43:22 GMT - Remove a test that was testing the behaviour of perl, rather than of this module, and was testing an aspect of perl’s behaviour that has changed (bf8fb5ebd) in in such a way that the test was failing with bleadperl. 0.21 Wed 29 Feb 2012 16:47:58 GMT - Avoid leaking the RHS of an lnoreturn lvalue sub, thanks to Father Chrysostomos https://rt.cpan.org/Public/Bug/Display.html?id=72083 0.22 Sun 15 Dec 2013 17:08:35 GMT - Prevent return from being optimised away by newer (>= 5.19.7) Perls. This is a patch supplied by @wolfsage: see https://github.com/robinhouston/Want/pull/1 0.23 Mon 24 Mar 2014 00:28:36 GMT - Accommodate a bleadperl change to the optree, made in 7d3c8a6837b55fff0e6294ebf8c94a1601367c76. This is bug #94086 for Want, and bug #121342 for perl5. 0.24 Tue 2 Dec 2014 10:22:39 GMT - Accommodate another bleadperl change. Patch provided by Father Chrysostomos at https://rt.cpan.org/Public/Bug/Display.html?id=100626 0.25 Wed 10 Dec 2014 19:31:03 GMT - Add support for the new OP_MULTIDEREF Perl has a new op, added as a performance optimisation in fedf30e1c349130b23648c022f5f3cb4ad7928f3, to represent a sequence of array/hash dereferences. This patch adds support for the new op. 0.26 Tue 28 Apr 2015 12:31:17 BST - There is a new experimental option in bleadperl under which one ought not to use the op_sibling field directly. Quoting from perlguts.pod: “ Starting in version 5.21.2, perls built with the experimental define C<-DPERL_OP_PARENT> add an extra boolean flag for each op, C. When not set, this indicates that this is the last op in an C chain. This frees up the C field on the last sibling to point back to the parent op. Under this build, that field is also renamed C to reflect its joint role. The macro C wraps this special behaviour, and always returns NULL on the last sibling. With this build the C function can be used to find the parent of any op. Thus for forward compatibility, you should always use the C macro rather than accessing C directly. ” Thanks to Reini Urban for the patch. Want-0.26/Makefile.PL000644 000765 000120 00000000653 12253361370 014570 0ustar00robinadmin000000 000000 use ExtUtils::MakeMaker; require 5.006; # See lib/ExtUtils/MakeMaker.pm for details of how to influence # the contents of the Makefile that is written. WriteMakefile( 'NAME' => 'Want', 'VERSION_FROM' => 'Want.pm', # finds $VERSION 'PREREQ_PM' => {}, # e.g., Module::Name => 1.1 'LIBS' => [''], # e.g., '-lm' 'DEFINE' => '', # e.g., '-DHAVE_SOMETHING' 'INC' => '', # e.g., '-I/usr/include/other' ); Want-0.26/MANIFEST000644 000765 000120 00000000476 12517670066 013762 0ustar00robinadmin000000 000000 Changes MANIFEST Makefile.PL README TODO Want.pm Want.xs t/all.t t/assign.t t/boolean.t t/damian.t t/err.t t/methcall.t t/object.t t/threads.p t/threads.t META.yml Module meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) Want-0.26/META.json000644 000765 000120 00000001416 12517670066 014245 0ustar00robinadmin000000 000000 { "abstract" : "unknown", "author" : [ "unknown" ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 6.66, CPAN::Meta::Converter version 2.120921", "license" : [ "unknown" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Want", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : {} } }, "release_status" : "stable", "version" : "0.26" } Want-0.26/META.yml000644 000765 000120 00000000644 12517670066 014077 0ustar00robinadmin000000 000000 --- abstract: unknown author: - unknown build_requires: ExtUtils::MakeMaker: 0 configure_requires: ExtUtils::MakeMaker: 0 dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 6.66, CPAN::Meta::Converter version 2.120921' license: unknown meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: Want no_index: directory: - t - inc requires: {} version: 0.26 Want-0.26/README000644 000765 000120 00000005525 12517667464 013521 0ustar00robinadmin000000 000000 ----------------------------------------------------------------------------- | Want v0.26 - Robin Houston, 2015-04-28 ----------------------------------------------------------------------------- For full documentation, see the POD included with the module. Below is a brief extract of the documentation, to give you an idea of what this module does. It requires Perl version 5.6 or later. NAME Want - Implement the `want' command SYNOPSIS use Want; sub foo :lvalue { if (want(qw'LVALUE ASSIGN')) { print "We have been assigned ", want('ASSIGN'); lnoreturn; } elsif (want('LIST')) { rreturn (1, 2, 3); } elsif (want('BOOL')) { rreturn 0; } elsif (want(qw'SCALAR !REF')) { rreturn 23; } elsif (want('HASH')) { rreturn { foo => 17, bar => 23 }; } return } DESCRIPTION This module generalises the mechanism of the wantarray function, allowing a function to determine in some detail how its return value is going to be immediately used. ... EXAMPLES use Carp 'croak'; use Want 'howmany'; sub numbers { my $count = howmany(); croak("Can't make an infinite list") if !defined($count); return (1..$count); } my ($one, $two, $three) = numbers(); use Want 'want'; sub pi () { if (want('ARRAY')) { return [3, 1, 4, 1, 5, 9]; } elsif (want('LIST')) { return (3, 1, 4, 1, 5, 9); } else { return 3; } } print pi->[2]; # prints 4 print ((pi)[3]); # prints 1 use Want; use strict; sub backstr :lvalue { if (want(qw'LVALUE ASSIGN')) { my ($a) = want('ASSIGN'); $_[0] = reverse $a; lnoreturn; } elsif (want('RVALUE')) { rreturn scalar reverse $_[0]; } else { carp("Not in ASSIGN context"); } return } print "foo -> ", backstr("foo"), "\n"; # foo -> oof backstr(my $robin) = "nibor"; print "\$robin is now $robin\n"; # $robin is now robin AUTHOR Robin Houston, Thanks to Damian Conway for encouragement and good suggestions, and to Father Chrysostomos and Matthew Horsfall for patches. SEE ALSO o the wantarray entry in the perlfunc manpage o Perl6 RFC 21, by Damian Conway. http://dev.perl.org/rfc/21.html COPYRIGHT Copyright (c) 2001-2012, Robin Houston. All Rights Reserved. This module is free software. It may be used, redistributed and/or modified under the same terms as Perl itself. Want-0.26/t/000755 000765 000120 00000000000 12517670066 013065 5ustar00robinadmin000000 000000 Want-0.26/TODO000644 000765 000120 00000000727 07720116316 013311 0ustar00robinadmin000000 000000 Note: I'm not sure these first two items are necessary - Improve the error handling (only warn once per call, anyway). - Benchmark & optimise if necessary (i.e. don't get the cx multiple times) But these two are definitely worth looking into: - See what happens from FETCH/STORE routines (eek!) - NUMBER, INTEGER (and STRING?) contexts. This will involve constructing a large and tedious table of ops indicating which args are treated as which sort of value. Want-0.26/Want.pm000644 000765 000120 00000043246 12517667467 014115 0ustar00robinadmin000000 000000 package Want; require 5.006; use Carp 'croak'; use strict; use warnings; require Exporter; require DynaLoader; our @ISA = qw(Exporter DynaLoader); our @EXPORT = qw(want rreturn lnoreturn); our @EXPORT_OK = qw(howmany wantref); our $VERSION = '0.26'; bootstrap Want $VERSION; my %reftype = ( ARRAY => 1, HASH => 1, CODE => 1, GLOB => 1, OBJECT => 1, ); sub _wantone { my ($uplevel, $arg) = @_; my $wantref = wantref($uplevel + 1); if ($arg =~ /^\d+$/) { my $want_count = want_count($uplevel); return ($want_count == -1 || $want_count >= $arg); } elsif (lc($arg) eq 'infinity') { return (want_count($uplevel) == -1); } elsif ($arg eq 'REF') { return $wantref; } elsif ($reftype{$arg}) { return ($wantref eq $arg); } elsif ($arg eq 'REFSCALAR') { return ($wantref eq 'SCALAR'); } elsif ($arg eq 'LVALUE') { return want_lvalue($uplevel); } elsif ($arg eq 'RVALUE') { return !want_lvalue($uplevel); } elsif ($arg eq 'VOID') { return !defined(wantarray_up($uplevel)); } elsif ($arg eq 'SCALAR') { my $gimme = wantarray_up($uplevel); return (defined($gimme) && 0 == $gimme); } elsif ($arg eq 'BOOL' || $arg eq 'BOOLEAN') { return want_boolean(bump_level($uplevel)); } elsif ($arg eq 'LIST') { return wantarray_up($uplevel); } elsif ($arg eq 'COUNT') { croak("want: COUNT must be the *only* parameter"); } elsif ($arg eq 'ASSIGN') { return !!wantassign($uplevel + 1); } else { croak ("want: Unrecognised specifier $arg"); } } sub want { if (@_ == 1 && $_[0] eq 'ASSIGN') { @_ = (1); goto &wantassign; } want_uplevel(1, @_); } # Simulate the propagation of context through a return value. sub bump_level { my ($level) = @_; for(;;) { my ($p, $r) = parent_op_name($level+1); if ($p eq "return" or $p eq "(none)" && $r =~ /^leavesub(lv)?$/) { ++$level } else { return $level } } } sub want_uplevel { my ($level, @args) = @_; # Deal with special cases (for RFC21-consistency): if (1 == @args) { @_ = (1 + $level); goto &wantref if $args[0] eq 'REF'; goto &howmany if $args[0] eq 'COUNT'; goto &wantassign if $args[0] eq 'ASSIGN'; } for my $arg (map split, @args) { if ($arg =~ /^!(.*)/) { return 0 unless !_wantone(2 + $level, $1); } else { return 0 unless _wantone(2 + $level, $arg); } } return 1; } sub howmany () { my $level = bump_level(@_, 1); my $count = want_count($level); return ($count < 0 ? undef : $count); } sub wantref { my $level = bump_level(@_, 1); my $n = parent_op_name($level); if ($n eq 'rv2av') { return "ARRAY"; } elsif ($n eq 'rv2hv') { return "HASH"; } elsif ($n eq 'rv2cv' || $n eq 'entersub') { return "CODE"; } elsif ($n eq 'rv2gv' || $n eq 'gelem') { return "GLOB"; } elsif ($n eq 'rv2sv') { return "SCALAR"; } elsif ($n eq 'method_call') { return 'OBJECT'; } elsif ($n eq 'multideref') { return first_multideref_type($level); } else { return ""; } } sub wantassign { my $uplevel = shift(); return unless want_lvalue($uplevel); my $r = want_assign(bump_level($uplevel)); if (want('BOOL')) { return (defined($r) && 0 != $r); } else { return $r ? (want('SCALAR') ? $r->[$#$r] : @$r) : (); } } sub rreturn (@) { if (want_lvalue(1)) { croak "Can't rreturn in lvalue context"; } double_return(); # Extra scope needed to work with perl-5.19.7 or greater. # Prevents the return being optimised out, which is needed # since it's actually going to be used a stack level above # this sub. { return wantarray ? @_ : $_[$#_]; } } sub lnoreturn () { if (!want_lvalue(1) || !want_assign(1)) { croak "Can't lnoreturn except in ASSIGN context"; } double_return(); # Extra scope needed to work with perl-5.19.7 or greater. # Prevents the return being optimised out, which is needed # since it's actually going to be used a stack level above # this sub. { return disarm_temp(my $undef); } } # Some naughty people were relying on these internal methods. *_wantref = \&wantref; *_wantassign = \&wantassign; 1; __END__ =head1 NAME Want - A generalisation of C =head1 SYNOPSIS use Want; sub foo :lvalue { if (want(qw'LVALUE ASSIGN')) { print "We have been assigned ", want('ASSIGN'); lnoreturn; } elsif (want('LIST')) { rreturn (1, 2, 3); } elsif (want('BOOL')) { rreturn 0; } elsif (want(qw'SCALAR !REF')) { rreturn 23; } elsif (want('HASH')) { rreturn { foo => 17, bar => 23 }; } return; # You have to put this at the end to keep the compiler happy } =head1 DESCRIPTION This module generalises the mechanism of the B function, allowing a function to determine in some detail how its return value is going to be immediately used. =head2 Top-level contexts: The three kinds of top-level context are well known: =over 4 =item B The return value is not being used in any way. It could be an entire statement like C, or the last component of a compound statement which is itself in void context, such as C<$test || foo();>n. Be warned that the last statement of a subroutine will be in whatever context the subroutine was called in, because the result is implicitly returned. =item B The return value is being treated as a scalar value of some sort: my $x = foo(); $y += foo(); print "123" x foo(); print scalar foo(); warn foo()->{23}; ...etc... =item B The return value is treated as a list of values: my @x = foo(); my ($x) = foo(); () = foo(); # even though the results are discarded print foo(); bar(foo()); # unless the bar subroutine has a prototype print @hash{foo()}; # (hash slice) ...etc... =back =head2 Lvalue subroutines: The introduction of B in Perl 5.6 has created a new type of contextual information, which is independent of those listed above. When an lvalue subroutine is called, it can either be called in the ordinary way (so that its result is treated as an ordinary value, an B); or else it can be called so that its result is considered updatable, an B. These rather arcane terms (lvalue and rvalue) are easier to remember if you know why they are so called. If you consider a simple assignment statement C, then the Beft-hand side is an Bvalue and the Bight-hand side is an Bvalue. So (for lvalue subroutines only) there are two new types of context: =over 4 =item B The caller is definitely not trying to assign to the result: foo(); my $x = foo(); ...etc... If the sub is declared without the C<:lvalue> attribute, then it will I be in RVALUE context. If you need to return values from an lvalue subroutine in RVALUE context, you should use the C function rather than an ordinary C. Otherwise you'll probably get a compile-time error in perl 5.6.1 and later. =item B Either the caller is directly assigning to the result of the sub call: foo() = $x; foo() = (1, 1, 2, 3, 5, 8); or the caller is making a reference to the result, which might be assigned to later: my $ref = \(foo()); # Could now have: $$ref = 99; # Note that this example imposes LIST context on the sub call. # So we're taking a reference to the first element to be # returned _in list context_. # If we want to call the function in scalar context, we can # do it like this: my $ref = \(scalar foo()); or else the result of the function call is being used as part of the argument list for I function call: bar(foo()); # Will *always* call foo in lvalue context, # (provided that foo is an C<:lvalue> sub) # regardless of what bar actually does. The reason for this last case is that bar might be a sub which modifies its arguments. They're rare in contemporary Perl code, but perfectly possible: sub bar { $_[0] = 23; } (This is really a throwback to Perl 4, which didn't support explicit references.) =back =head2 Assignment context: The commonest use of lvalue subroutines is with the assignment statement: size() = 12; (list()) = (1..10); A useful motto to remember when thinking about assignment statements is I. Consider code like this: my ($x, $y, $z); sub list () :lvalue { ($x, $y, $z) } list = (1, 2, 3); print "\$x = $x; \$y = $y; \$z = $z\n"; This prints C<$x = ; $y = ; $z = 3>, which may not be what you were expecting. The reason is that the assignment is in scalar context, so the comma operator is in scalar context too, and discards all values but the last. You can fix it by writing C<(list) = (1,2,3);> instead. If your lvalue subroutine is used on the left of an assignment statement, it's in B context. If ASSIGN is the only argument to C, then it returns a reference to an array of the value(s) of the right-hand side. In this case, you should return with the C function, rather than an ordinary C. This makes it very easy to write lvalue subroutines which do clever things: use Want; use strict; sub backstr :lvalue { if (want(qw'LVALUE ASSIGN')) { my ($a) = want('ASSIGN'); $_[0] = reverse $a; lnoreturn; } elsif (want('RVALUE')) { rreturn scalar reverse $_[0]; } else { carp("Not in ASSIGN context"); } return } print "foo -> ", backstr("foo"), "\n"; # foo -> oof backstr(my $robin) = "nibor"; print "\$robin is now $robin\n"; # $robin is now robin Notice that you need to put a (meaningless) return statement at the end of the function, otherwise you will get the error I. The only way to write that C function without using Want is to return a tied variable which is tied to a custom class. =head2 Reference context: Sometimes in scalar context the caller is expecting a reference of some sort to be returned: print foo()->(); # CODE reference expected print foo()->{bar}; # HASH reference expected print foo()->[23]; # ARRAY reference expected print ${foo()}; # SCALAR reference expected print foo()->bar(); # OBJECT reference expected my $format = *{foo()}{FORMAT} # GLOB reference expected You can check this using conditionals like C. There is also a function C which returns one of the strings "CODE", "HASH", "ARRAY", "GLOB", "SCALAR" or "OBJECT"; or the empty string if a reference is not expected. Because C is already used to select ordinary scalar context, you have to use C to find out if a SCALAR reference is expected. Or you could use C of course. Be warned that C is a B different thing from C. =head2 Item count Sometimes in list context the caller is expecting a particular number of items to be returned: my ($x, $y) = foo(); # foo is expected to return two items If you pass a number to the C function, then it will return true or false according to whether at least that many items are wanted. So if we are in the definition of a sub which is being called as above, then: want(1) returns true want(2) returns true want(3) returns false Sometimes there is no limit to the number of items that might be used: my @x = foo(); do_something_with( foo() ); In this case, C, C, C and so on will all return true; and so will C. The C function can be used to find out how many items are wanted. If the context is scalar, then C returns true and C returns 1. If you want to check whether your result is being assigned to a singleton list, you can say C. =head2 Boolean context Sometimes the caller is only interested in the truth or falsity of a function's return value: if (everything_is_okay()) { # Carry on } print (foo() ? "ok\n" : "not ok\n"); In the following example, all subroutine calls are in BOOL context: my $x = ( (foo() && !bar()) xor (baz() || quux()) ); Boolean context, like the reference contexts above, is considered to be a subcontext of SCALAR. =head1 FUNCTIONS =over 4 =item want(SPECIFIERS) This is the primary interface to this module, and should suffice for most purposes. You pass it a list of context specifiers, and the return value is true whenever all of the specifiers hold. want('LVALUE', 'SCALAR'); # Are we in scalar lvalue context? want('RVALUE', 3); # Are at least three rvalues wanted? want('ARRAY'); # Is the return value used as an array ref? You can also prefix a specifier with an exclamation mark to indicate that you B want it to be true want(2, '!3'); # Caller wants exactly two items. want(qw'REF !CODE !GLOB'); # Expecting a reference that # isn't a CODE or GLOB ref. want(100, '!Infinity'); # Expecting at least 100 items, # but there is a limit. If the I keyword is the only parameter passed, then the type of reference will be returned. This is just a synonym for the C function: it's included because you might find it useful if you don't want to pollute your namespace by importing several functions, and to conform to Damian Conway's suggestion in RFC 21. Finally, the keyword I can be used, provided that it's the only keyword you pass. Mixing COUNT with other keywords is an error. This is a synonym for the C function. A full list of the permitted keyword is in the B section below. =item rreturn Use this function instead of C from inside an lvalue subroutine when you know that you're in RVALUE context. If you try to use a normal C, you'll get a compile-time error in Perl 5.6.1 and above unless you return an lvalue. (Note: this is no longer true in Perl 5.16, where an ordinary return will once again work.) =item lnoreturn Use this function instead of C from inside an lvalue subroutine when you're in ASSIGN context and you've used C to carry out the appropriate action. If you use C or C, then you have to put a bare C at the very end of your lvalue subroutine, in order to stop the Perl compiler from complaining. Think of it as akin to the C<1;> that you have to put at the end of a module. (Note: this is no longer true in Perl 5.16.) =item howmany() Returns the I, i.e. the number of items expected. If the expectation count is undefined, that indicates that an unlimited number of items might be used (e.g. the return value is being assigned to an array). In void context the expectation count is zero, and in scalar context it is one. The same as C. =item wantref() Returns the type of reference which the caller is expecting, or the empty string if the caller isn't expecting a reference immediately. The same as C. =back =head1 EXAMPLES use Carp 'croak'; use Want 'howmany'; sub numbers { my $count = howmany(); croak("Can't make an infinite list") if !defined($count); return (1..$count); } my ($one, $two, $three) = numbers(); use Want 'want'; sub pi () { if (want('ARRAY')) { return [3, 1, 4, 1, 5, 9]; } elsif (want('LIST')) { return (3, 1, 4, 1, 5, 9); } else { return 3; } } print pi->[2]; # prints 4 print ((pi)[3]); # prints 1 =head1 ARGUMENTS The permitted arguments to the C function are listed below. The list is structured so that sub-contexts appear below the context that they are part of. =over 4 =item * VOID =item * SCALAR =over 4 =item * REF =over 4 =item * REFSCALAR =item * CODE =item * HASH =item * ARRAY =item * GLOB =item * OBJECT =back =item * BOOL =back =item * LIST =over 4 =item * COUNT =item * EnumberE =item * Infinity =back =item * LVALUE =over 4 =item * ASSIGN =back =item * RVALUE =back =head1 EXPORT The C and C functions are exported by default. The C and/or C functions can also be imported: use Want qw'want howmany'; If you don't import these functions, you must qualify their names as (e.g.) C. =head1 INTERFACE This module is still under development, and the public interface may change in future versions. The C function can now be regarded as stable. I'd be interested to know how you're using this module. =head1 SUBTLETIES There are two different levels of B context. I boolean context occurs in conditional expressions, and the operands of the C and C/C operators. Pure boolean context also propagates down through the C<&&> and C<||> operators. However, consider an expression like C. The subroutine is called in I-boolean context - its return value isn't B ignored, because the undefined value, the empty string and the integer 0 are all false. At the moment C is true in either pure or pseudo boolean context. Let me know if this is a problem. =head1 BUGS * Doesn't work from inside a tie-handler. =head1 AUTHOR Robin Houston, Erobin@cpan.orgE Thanks to Damian Conway for encouragement and good suggestions, and Father Chrysostomos for a patch. =head1 SEE ALSO =over 4 =item * L =item * Perl6 RFC 21, by Damian Conway. http://dev.perl.org/rfc/21.html =back =head1 COPYRIGHT Copyright (c) 2001-2012, Robin Houston. All Rights Reserved. This module is free software. It may be used, redistributed and/or modified under the same terms as Perl itself. =cut Want-0.26/Want.xs000644 000765 000024 00000043321 12517667071 014132 0ustar00robinstaff000000 000000 #include "EXTERN.h" #include "perl.h" #include "XSUB.h" /* The most popular error message */ #define TOO_FAR \ croak("want: Called from outside a subroutine") /* Between 5.9.1 and 5.9.2 the retstack was removed, and the return op is now stored on the cxstack. */ #define HAS_RETSTACK (\ PERL_REVISION < 5 || \ (PERL_REVISION == 5 && PERL_VERSION < 9) || \ (PERL_REVISION == 5 && PERL_VERSION == 9 && PERL_SUBVERSION < 2) \ ) /* After 5.10, the CxLVAL macro was added. */ #ifndef CxLVAL # define CxLVAL(cx) cx->blk_sub.lval #endif #ifndef OpSIBLING # define OpSIBLING(o) o->op_sibling #endif /* Stolen from B.xs */ #ifdef PERL_OBJECT #undef PL_op_name #undef PL_opargs #undef PL_op_desc #define PL_op_name (get_op_names()) #define PL_opargs (get_opargs()) #define PL_op_desc (get_op_descs()) #endif /* Stolen from pp_ctl.c (with modifications) */ I32 dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock) { dTHR; I32 i; PERL_CONTEXT *cx; for (i = startingblock; i >= 0; i--) { cx = &cxstk[i]; switch (CxTYPE(cx)) { default: continue; /*case CXt_EVAL:*/ case CXt_SUB: case CXt_FORMAT: DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i)); return i; } } return i; } I32 dopoptosub(pTHX_ I32 startingblock) { dTHR; return dopoptosub_at(aTHX_ cxstack, startingblock); } PERL_CONTEXT* upcontext(pTHX_ I32 count) { PERL_SI *top_si = PL_curstackinfo; I32 cxix = dopoptosub(aTHX_ cxstack_ix); PERL_CONTEXT *cx; PERL_CONTEXT *ccstack = cxstack; I32 dbcxix; for (;;) { /* we may be in a higher stacklevel, so dig down deeper */ while (cxix < 0 && top_si->si_type != PERLSI_MAIN) { top_si = top_si->si_prev; ccstack = top_si->si_cxstack; cxix = dopoptosub_at(aTHX_ ccstack, top_si->si_cxix); } if (cxix < 0) { return (PERL_CONTEXT *)0; } if (PL_DBsub && cxix >= 0 && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub)) count++; if (!count--) break; cxix = dopoptosub_at(aTHX_ ccstack, cxix - 1); } cx = &ccstack[cxix]; if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) { dbcxix = dopoptosub_at(aTHX_ ccstack, cxix - 1); /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the field below is defined for any cx. */ if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) { cx = &ccstack[dbcxix]; } } return cx; } /* This one is like upcontext except that, when it's found the sub context, it keeps looking to see if the sub was called from within a loop. If it was, it returns the loop context instead. Prior to 0.09, find_ancestors_from was called with start equal to the oldcop of the sub we're looking for. Unfortunately it's not guaranteed that we'll be able to find the sub just by traversing the tree from there: Damian Conway reported a bug against 0.08, where code like while(foo) {...} -- where foo calls want -- causes a crash on the second iteration of the loop. That is because oldcop then points to the last cop in the body of the loop, which is lexically *ahead* of the calling point. Another change in 0.13: if end_of_block == TRUE, then go up another level beyond the sub. */ PERL_CONTEXT* upcontext_plus(pTHX_ I32 count, bool end_of_block) { PERL_SI *top_si = PL_curstackinfo; I32 cxix = dopoptosub(aTHX_ cxstack_ix); PERL_CONTEXT *cx, *tcx; PERL_CONTEXT *ccstack = cxstack; I32 dbcxix, i; bool debugger_trouble; for (;;) { /* we may be in a higher stacklevel, so dig down deeper */ while (cxix < 0 && top_si->si_type != PERLSI_MAIN) { top_si = top_si->si_prev; ccstack = top_si->si_cxstack; cxix = dopoptosub_at(aTHX_ ccstack, top_si->si_cxix); } if (cxix < 0) { return (PERL_CONTEXT *)0; } if (PL_DBsub && cxix >= 0 && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub)) count++; if (!count--) break; cxix = dopoptosub_at(aTHX_ ccstack, cxix - 1); } cx = &ccstack[cxix]; if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) { dbcxix = dopoptosub_at(aTHX_ ccstack, cxix - 1); /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the field below is defined for any cx. */ if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) { cxix = dbcxix; cx = &ccstack[cxix]; } } /* Now for the extra bit */ debugger_trouble = (cx->blk_oldcop->op_type == OP_DBSTATE); for (i = cxix-1; i>=0 ; i--) { tcx = &ccstack[i]; switch (CxTYPE(tcx)) { case CXt_BLOCK: if (debugger_trouble && i > 0) return tcx; default: continue; #ifdef CXt_LOOP_PLAIN case CXt_LOOP_PLAIN: case CXt_LOOP_FOR: #else case CXt_LOOP: #endif return tcx; case CXt_SUB: case CXt_FORMAT: return cx; } } return ((end_of_block && cxix > 1) ? &ccstack[cxix-1] : cx); } /* inspired (loosely) by pp_wantarray */ U8 want_gimme (I32 uplevel) { PERL_CONTEXT* cx = upcontext(aTHX_ uplevel); if (!cx) TOO_FAR; return cx->blk_gimme; } /* end thievery and "inspiration" */ #define OPLIST_MAX 50 typedef struct { U16 numop_num; OP* numop_op; } numop; typedef struct { U16 length; numop ops[OPLIST_MAX]; } oplist; #define new_oplist (oplist*) malloc(sizeof(oplist)) #define init_oplist(l) l->length = 0 numop* lastnumop(oplist* l) { U16 i; numop* ret; if (!l) die("Want panicked: null list in lastnumop"); i = l->length; while (i-- > 0) { ret = &(l->ops)[i]; if (ret->numop_op->op_type != OP_NULL && ret->numop_op->op_type != OP_SCOPE) { return ret; } } return (numop*)0; } /* NB: unlike lastnumop, lastop frees the oplist */ OP* lastop(oplist* l) { U16 i; OP* ret; if (!l) die("Want panicked: null list in lastop"); i = l->length; while (i-- > 0) { ret = (l->ops)[i].numop_op; if (ret->op_type != OP_NULL && ret->op_type != OP_SCOPE && ret->op_type != OP_LEAVE) { free(l); return ret; } } free(l); return Nullop; } oplist* pushop(oplist* l, OP* o, U16 i) { I16 len = l->length; if (o && len < OPLIST_MAX) { ++ l->length; l->ops[len].numop_op = o; l->ops[len].numop_num = -1; } if (len > 0) l->ops[len-1].numop_num = i; return l; } oplist* find_ancestors_from(OP* start, OP* next, oplist* l) { OP *o, *p; U16 cn = 0; U16 ll; bool outer_call = FALSE; if (!next) die("want panicked: I've been asked to find a null return address.\n" " (Are you trying to call me from inside a tie handler?)\n "); if (!l) { outer_call = TRUE; l = new_oplist; init_oplist(l); ll = 0; } else ll = l->length; /* printf("Looking for 0x%x starting at 0x%x\n", next, start); */ for (o = start; o; p = o, o = OpSIBLING(o), ++cn) { /* printf("(0x%x) %s -> 0x%x\n", o, PL_op_name[o->op_type], o->op_next);*/ if (o->op_type == OP_ENTERSUB && o->op_next == next) return pushop(l, Nullop, cn); if (o->op_flags & OPf_KIDS) { U16 ll = l->length; pushop(l, o, cn); if (find_ancestors_from(cUNOPo->op_first, next, l)) return l; else l->length = ll; } } return 0; } OP* find_return_op(pTHX_ I32 uplevel) { PERL_CONTEXT *cx = upcontext(aTHX_ uplevel); if (!cx) TOO_FAR; #if HAS_RETSTACK return PL_retstack[cx->blk_oldretsp - 1]; #else return cx->blk_sub.retop; #endif } OP* find_start_cop(pTHX_ I32 uplevel, bool end_of_block) { PERL_CONTEXT* cx = upcontext_plus(aTHX_ uplevel, end_of_block); if (!cx) TOO_FAR; return (OP*) cx->blk_oldcop; } /** * Return the whole oplist leading down to the subcall. * It's the caller's responsibility to free the returned oplist. */ oplist* ancestor_ops (I32 uplevel, OP** return_op_out) { OP* return_op = find_return_op(aTHX_ uplevel); OP* start_cop = find_start_cop(aTHX_ uplevel, return_op->op_type == OP_LEAVE); if (return_op_out) *return_op_out = return_op; return find_ancestors_from(start_cop, return_op, 0); } /** Return the parent of the OP_ENTERSUB, or the grandparent if the parent * is an OP_NULL or OP_SCOPE. If the parent precedes the last COP, then return Nullop. * (In that last case, we must be in void context.) */ OP* parent_op (I32 uplevel, OP** return_op_out) { return lastop(ancestor_ops(uplevel, return_op_out)); } /* forward declaration - mutual recursion */ I32 count_list (OP* parent, OP* returnop); I32 count_slice (OP* o) { OP* pm = cUNOPo->op_first; OP* l = Nullop; if (pm->op_type != OP_PUSHMARK) die("%s", "Want panicked: slice doesn't start with pushmark\n"); if ( (l = OpSIBLING(pm)) && (l->op_type == OP_LIST || (l->op_type == OP_NULL && l->op_targ == OP_LIST))) return count_list(l, Nullop); else if (l) switch (l->op_type) { case OP_RV2AV: case OP_PADAV: case OP_PADHV: case OP_RV2HV: return 0; case OP_HSLICE: case OP_ASLICE: return count_slice(l); case OP_STUB: return 1; default: die("Want panicked: Unexpected op in slice (%s)\n", PL_op_name[l->op_type]); } else die("Want panicked: Nothing follows pushmark in slice\n"); return -999; /* Should never get here - silence compiler warning */ } /** Count the number of children of this OP. * Except if any of them is OP_RV2AV or OP_ENTERSUB, return 0 instead. * Also, stop counting if an OP_ENTERSUB is reached whose op_next is . */ I32 count_list (OP* parent, OP* returnop) { OP* o; I32 i = 0; if (! (parent->op_flags & OPf_KIDS)) return 0; /*printf("count_list: returnop = 0x%x\n", returnop);*/ for(o = cUNOPx(parent)->op_first; o; o=OpSIBLING(o)) { /* printf("\t%-8s\t(0x%x)\n", PL_op_name[o->op_type], o->op_next);*/ if (returnop && o->op_type == OP_ENTERSUB && o->op_next == returnop) return i; if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV || o->op_type == OP_PADAV || o->op_type == OP_PADHV || o->op_type == OP_ENTERSUB) return 0; if (o->op_type == OP_HSLICE || o->op_type == OP_ASLICE) { I32 slice_length = count_slice(o); if (slice_length == 0) return 0; else i += slice_length - 1; } else ++i; } return i; } I32 countstack(I32 uplevel) { PERL_CONTEXT* cx = upcontext(aTHX_ uplevel); I32 oldmarksp; I32 mark_from; I32 mark_to; if (!cx) return -1; oldmarksp = cx->blk_oldmarksp; mark_from = PL_markstack[oldmarksp]; mark_to = PL_markstack[oldmarksp+1]; return (mark_to - mark_from); } AV* copy_rvals(I32 uplevel, I32 skip) { PERL_CONTEXT* cx = upcontext(aTHX_ uplevel); I32 oldmarksp; I32 mark_from; I32 mark_to; I32 i; AV* a; oldmarksp = cx->blk_oldmarksp; mark_from = PL_markstack[oldmarksp-1]; mark_to = PL_markstack[oldmarksp]; /*printf("\t(%d -> %d) %d skipping %d\n", mark_from, mark_to, oldmarksp, skip);*/ if (!cx) return Nullav; a = newAV(); for(i=mark_from+1; i<=mark_to; ++i) if (skip-- <= 0) av_push(a, newSVsv(PL_stack_base[i])); /* printf("avlen = %d\n", av_len(a)); */ return a; } AV* copy_rval(I32 uplevel) { PERL_CONTEXT* cx = upcontext(aTHX_ uplevel); I32 oldmarksp; AV* a; oldmarksp = cx->blk_oldmarksp; if (!cx) return Nullav; a = newAV(); /* printf("oldmarksp = %d\n", oldmarksp); */ av_push(a, newSVsv(PL_stack_base[PL_markstack[oldmarksp+1]])); return a; } MODULE = Want PACKAGE = Want PROTOTYPES: ENABLE SV* wantarray_up(uplevel) I32 uplevel; PREINIT: U8 gimme = want_gimme(uplevel); CODE: switch(gimme) { case G_ARRAY: RETVAL = &PL_sv_yes; break; case G_SCALAR: RETVAL = &PL_sv_no; break; default: RETVAL = &PL_sv_undef; } OUTPUT: RETVAL U8 want_lvalue(uplevel) I32 uplevel; PREINIT: PERL_CONTEXT* cx; CODE: cx = upcontext(aTHX_ uplevel); if (!cx) TOO_FAR; if (CvLVALUE(cx->blk_sub.cv)) RETVAL = CxLVAL(cx); else RETVAL = 0; OUTPUT: RETVAL char* parent_op_name(uplevel) I32 uplevel; PREINIT: OP *r; OP *o = parent_op(uplevel, &r); OP *first, *second; char *retval; PPCODE: /* This is a bit of a cheat, admittedly... */ if (o && o->op_type == OP_ENTERSUB && (first = cUNOPo->op_first) && (second = OpSIBLING(first)) && OpSIBLING(second) != Nullop) retval = "method_call"; else { retval = o ? (char *)PL_op_name[o->op_type] : "(none)"; } if (GIMME == G_ARRAY) { EXTEND(SP, 2); PUSHs(sv_2mortal(newSVpv(retval, 0))); PUSHs(sv_2mortal(newSVpv(PL_op_name[r->op_type], 0))); } else { EXTEND(SP, 1); PUSHs(sv_2mortal(newSVpv(retval, 0))); } #ifdef OPpMULTIDEREF_EXISTS char* first_multideref_type(uplevel) I32 uplevel; PREINIT: OP *r; OP *o = parent_op(uplevel, &r); UNOP_AUX_item *items; UV actions; bool repeat; char *retval; PPCODE: if (o->op_type != OP_MULTIDEREF) Perl_croak(aTHX_ "Not a multideref op!"); items = cUNOP_AUXx(o)->op_aux; actions = items->uv; do { repeat = FALSE; switch (actions & MDEREF_ACTION_MASK) { case MDEREF_reload: actions = (++items)->uv; repeat = TRUE; continue; case MDEREF_AV_pop_rv2av_aelem: case MDEREF_AV_gvsv_vivify_rv2av_aelem: case MDEREF_AV_padsv_vivify_rv2av_aelem: case MDEREF_AV_vivify_rv2av_aelem: case MDEREF_AV_padav_aelem: case MDEREF_AV_gvav_aelem: retval = "ARRAY"; break; case MDEREF_HV_pop_rv2hv_helem: case MDEREF_HV_gvsv_vivify_rv2hv_helem: case MDEREF_HV_padsv_vivify_rv2hv_helem: case MDEREF_HV_vivify_rv2hv_helem: case MDEREF_HV_padhv_helem: case MDEREF_HV_gvhv_helem: retval = "HASH"; break; default: Perl_croak(aTHX_ "Unrecognised OP_MULTIDEREF action (%lu)!", actions & MDEREF_ACTION_MASK); } } while (repeat); EXTEND(SP, 1); PUSHs(sv_2mortal(newSVpv(retval, 0))); #endif I32 want_count(uplevel) I32 uplevel; PREINIT: OP* returnop; OP* o = parent_op(uplevel, &returnop); U8 gimme = want_gimme(uplevel); CODE: if (o && o->op_type == OP_AASSIGN) { I32 lhs = count_list(cBINOPo->op_last, Nullop ); I32 rhs = countstack(uplevel); /* printf("lhs = %d, rhs = %d\n", lhs, rhs); */ if (lhs == 0) RETVAL = -1; /* (..@x..) = (..., foo(), ...); */ else if (rhs >= lhs-1) RETVAL = 0; else RETVAL = lhs - rhs - 1; } else switch(gimme) { case G_ARRAY: RETVAL = -1; break; case G_SCALAR: RETVAL = 1; break; default: RETVAL = 0; } OUTPUT: RETVAL bool want_boolean(uplevel) I32 uplevel; PREINIT: oplist* l = ancestor_ops(uplevel, 0); U16 i; bool truebool = FALSE, pseudobool = FALSE; CODE: for(i=0; i < l->length; ++i) { OP* o = l->ops[i].numop_op; U16 n = l->ops[i].numop_num; bool v = (OP_GIMME(o, -1) == G_VOID); /* printf("%-8s %c %d\n", PL_op_name[o->op_type], (v ? 'v' : ' '), n); */ switch(o->op_type) { case OP_NOT: case OP_XOR: truebool = TRUE; break; case OP_AND: if (truebool || v) truebool = TRUE; else pseudobool = (pseudobool || n == 0); break; case OP_OR: if (truebool || v) truebool = TRUE; else truebool = FALSE; break; case OP_COND_EXPR: truebool = (truebool || n == 0); break; case OP_NULL: break; default: truebool = FALSE; pseudobool = FALSE; } } free(l); RETVAL = truebool || pseudobool; OUTPUT: RETVAL SV* want_assign(uplevel) U32 uplevel; PREINIT: AV* r; OP* returnop; oplist* os = ancestor_ops(uplevel, &returnop); numop* lno = os ? lastnumop(os) : (numop*)0; OPCODE type; PPCODE: if (lno) type = lno->numop_op->op_type; if (lno && (type == OP_AASSIGN || type == OP_SASSIGN) && lno->numop_num == 1) if (type == OP_AASSIGN) { I32 lhs_count = count_list(cBINOPx(lno->numop_op)->op_last, returnop); if (lhs_count == 0) r = newAV(); else { r = copy_rvals(uplevel, lhs_count-1); } } else r = copy_rval(uplevel); else { /* Not an assignment */ r = Nullav; } if (os) free(os); EXTEND(SP, 1); PUSHs(r ? sv_2mortal(newRV_noinc((SV*) r)) : &PL_sv_undef); void double_return() PREINIT: PERL_CONTEXT *ourcx, *cx; PPCODE: ourcx = upcontext(aTHX_ 0); cx = upcontext(aTHX_ 1); if (!cx) Perl_croak(aTHX_ "Can't return outside a subroutine"); ourcx->cx_type = CXt_NULL; CvDEPTH(ourcx->blk_sub.cv)--; #if HAS_RETSTACK if (PL_retstack_ix > 0) --PL_retstack_ix; #endif return; SV * disarm_temp(sv) SV *sv; CODE: RETVAL = sv_2mortal(SvREFCNT_inc(SvREFCNT_inc(sv))); OUTPUT: RETVAL Want-0.26/t/all.t000644 000765 000024 00000010724 12437311353 014034 0ustar00robinstaff000000 000000 BEGIN { $| = 1; print "1..70\n"; } # Test that we can load the module END {print "not ok 1\n" unless $loaded;} use Want; $loaded = 1; print "ok 1\n"; # Now test the private low-level mechanisms my $xxx; sub lv :lvalue { print (Want::want_lvalue(0) ? "ok 2\n" : "not ok 2\n"); $xxx; } &lv = 23; sub rv :lvalue { print (Want::want_lvalue(0) ? "not ok 3\n" : "ok 3\n"); my $xxx; } &rv; sub foo { my $t = shift(); my $opname = Want::parent_op_name(0); print ($opname eq shift() ? "ok $t\n" : "not ok $t\t# $opname\n"); ++$t; my $c = Want::want_count(0); print ($c == shift() ? "ok $t\n" : "not ok $t\t# $c\n"); shift; } ($x, undef) = foo(4, "aassign", 2); $x = 2 + foo(6, "add", 1, 7); foo(8, "(none)", 0); print foo(10, "print", -1, ""); @x = foo (12, "aassign", -1); # Test the public API # wantref() sub wc { my $ref = Want::wantref(); print ($ref eq 'CODE' ? "ok 14\n" : "not ok 14\t# $ref\n"); sub {} } wc()->(); sub wh { my $n = shift(); my $ref = Want::wantref(); print ($ref eq 'HASH' ? "ok $n\n" : "not ok $n\t# $ref\n"); {} } $x= wh(15)->{foo}; @x= %{wh(16)}; @x= @{wh(17)}{qw/foo bar/}; sub wg { my $n = shift(); my $ref = Want::wantref(); print ($ref eq 'GLOB' ? "ok $n\n" : "not ok $n\t# $ref\n"); \*foo; } $x= *{wg(18)}; $x= *{wg(19)}{FORM}; sub wa { my $n = shift(); my $ref = Want::wantref(); print ($ref eq 'ARRAY' ? "ok $n\n" : "not ok $n\t# $ref\n"); []; } @x= @{wa(20)}; wa(22)->[24] = ${wa(21)}[23]; # howmany() sub hm { my $n = shift(); my $x = shift(); my $h = Want::howmany(); print (!defined($x) && !defined($h) || $x eq $h ? "ok $n\n" : "not ok $n\t# $h\n"); } hm(23, 0); @x = hm(24, undef); (undef) = hm(25, 1); # want() use Want 'want'; sub pi () { if (want('ARRAY')) { return [3, 1, 4, 1, 5, 9]; } elsif (want('LIST')) { return (3, 1, 4, 1, 5, 9); } else { return 3; } } print (pi->[2] == 4 ? "ok 26\n" : "not ok 26\n"); print (((pi)[3]) == 1 ? "ok 27\n" : "not ok 27\n"); sub tc { print (want(2) && !want(3) ? "ok 28\n" : "not ok 28\n"); } (undef, undef) = tc(); sub g :lvalue { my $t = shift; print (want(@_) ? "ok $t\n" : "not ok $t\n"); $y; } sub ng :lvalue { my $t = shift; print (want(@_) ? "not ok $t\n" : "ok $t\n"); $y; } (undef) = g(29, 'LIST', 1); (undef) = ng(30, 'LIST', 2); $x = g(31, '!LIST', 1); $x = ng(32, '!LIST', 2); g(33, 'RVALUE', 'VOID'); g(34, 'LVALUE', 'SCALAR') = 23; print ($y == 23 ? "ok 35\n" : "not ok 35\n"); @x = g(36, 'RVALUE', 'LIST'); @x = \(g(37, 'LVALUE', 'LIST')); ($x) = \(scalar g(38, $] >= 5.021007 ? ('LVALUE', 'SCALAR') : 'RVALUE')); $$x = 29; # There used to be a test here which tested that $y != 29. However this # is really testing the behaviour of perl itself rather than of the Want # module, and the behaviour of perl has changed since 5.14: see # commit bf8fb5ebd. So we don’t have to renumber all following tests, # we just insert a dummy test 39 that always passes. print "ok 39 # Not a real test\n"; ng(41, 'REF') = g(40, 'HASH')->{foo}; $y = sub {}; # Just to silence warning $x = defined &{g(42, 'CODE')}; sub main::23 {} (undef, undef, undef) = ($x, g(43, 2)); (undef, undef, undef) = ($x, ng(44, 3)); ($x) = ($x, ng(45, 1)); @x = g(46, 2); %x = (1 => g(47, 'Infinity')); @x{@x} = g(48, 'Infinity'); @x[1, 2] = g(49, 2, '!3'); %x=(1=>23, 2=>"seven", 23=>9, seven=>2); @x{@x{1, 2}} = g(50, 2, '!3'); @x{()} = g(51, 0, '!1'); @x = (@x, g(52, 'Infinity')); ($x) = (@x, g(53, '!1')); # Check the want('COUNT') and want('REF') synonyms sub tCOUNT { my ($t, $w) = @_; my $a = want('COUNT'); if (!defined $w and !defined $a) { print "ok $t\n"; } else { print ($w == $a ? "ok $t\n" : "not ok $t\t# $a\n"); } return } tCOUNT(54, 0); $x = tCOUNT(55, 1); (undef, $x) = tCOUNT(56, 2); sub tREF { my ($t, $w) = @_; my $a = want('REF'); print ($w eq $a ? "ok $t\n" : "not ok $t\t# $a\n"); } $x = ${tREF(57, 'SCALAR')}; sub not_lvaluable { print (want("LVALUE") ? "not ok 58\n" : "ok 58\n"); } sub{}->(not_lvaluable()); my @x = tCOUNT(59, undef); @::x = tCOUNT(60, undef); (my $x, @x) = tCOUNT(61, undef); ($x, @::x) = tCOUNT(62, undef); (undef, undef, @x) = tCOUNT(63, undef); (undef, undef, @::x) = tCOUNT(64, undef); (@x, @::x) = tCOUNT(65, undef); (@::x, @::x) = tCOUNT(66, undef); my %x = tCOUNT(67, undef); %::x = tCOUNT(68, undef); %x = (a => 1, tCOUNT(69, undef)); %::x = (a => 2, tCOUNT(70, undef)); Want-0.26/t/assign.t000644 000765 000120 00000002116 12253360476 014534 0ustar00robinadmin000000 000000 BEGIN { $| = 1; print "1..10\n"; } # Test that we can load the module END {print "not ok 1\n" unless $loaded;} use Want; $loaded = 1; print "ok 1\n"; # Test the ASSIGN context sub t { my $t = shift(); print (want(@_) ? "ok $t\n" : "not ok $t\n"); } my $t; sub tl :lvalue { $t = shift(); print (want(@_) ? "ok $t\n" : "not ok $t\n"); $t; } sub noop {} sub idl :lvalue {@_[0..$#_]} t (2, qw/RVALUE !ASSIGN/); tl(3, qw/RVALUE !ASSIGN/); noop(tl(4, qw/LVALUE !ASSIGN/)); tl(5, qw/LVALUE ASSIGN/) = (); tl(6, 'ASSIGN') = (); sub backstr :lvalue { if (want('LVALUE')) { carp("Not in ASSIGN context") unless want('ASSIGN'); my $a = want('ASSIGN'); $_[0] = reverse $a; lnoreturn; } else { rreturn scalar reverse $_[0]; } die; return; } my $b = backstr("qwerty"); print ($b eq "ytrewq" ? "ok 7\n" : "not ok 7\t# $b\n"); backstr(my $foo) = "robin"; print ($foo eq 'nibor' ? "ok 8\n" : "not ok 8\n"); # Try with some stuff on the stack for(1..3) { backstr($foo) = 23; } print ($foo eq 32 ? "ok 9\n" : "not ok 9\n"); idl(tl(10, 'LVALUE', '!ASSIGN')) = (); Want-0.26/t/boolean.t000644 000765 000120 00000002300 10411520362 014644 0ustar00robinadmin000000 000000 BEGIN { $| = 1; print "1..25\n"; } # Test that we can load the module END {print "not ok 1\n" unless $loaded;} use Want; $loaded = 1; print "ok 1\n"; # Check the low-level want_boolean() routine sub wb { my ($t, $w, $r) = @_; my $a = Want::want_boolean(0); print ($w == $a ? "ok $t\n" : "not ok $t\t# $a\n"); return $r; } # In older (< 0.10) versions of Want, want_boolean would return true # even in void context. That's no longer true. wb(2, 0); $x = (wb(3, 1, 1) && wb(4, 0)); if (wb(5, 1)) {} $x = (wb(6, 1) ? 17 : 23); $x = ($x ? wb(7, 0, 1) : die); if ($x ? wb(8, 1, 1) : die) { print "ok 9\n"; } else { print "not ok 9\n"; } die unless wb(10, 1, 1); if ((wb(11,1,1) && wb(12,1,0)) || wb(13, 1)) { ()= $x } wb((wb(14,1,1) && wb(15,0,0)) || wb(16, 0, 17), 0); # Now check that want('BOOL') is okay sub wantt { my $t = shift(); my $r = shift(); print (Want::want(@_) ? "ok $t\n" : "not ok $t\n"); $r } wantt(18, 0, 'SCALAR', 'BOOL', '!REF') || !wantt(19, 0, 'SCALAR', 'BOOL', '!REF') || 1; wantt(20, 0, '!BOOL'); $x = wantt(21, 0, '!BOOL'); @x = wantt(22, 0, qw'LIST !BOOL'); $x = (wantt(23, 0, 'BOOL') xor wantt(24, 0, 'BOOL')); $x = !(0 + wantt(25, 1, '!BOOL')); Want-0.26/t/damian.t000644 000765 000120 00000001656 10260775446 014514 0ustar00robinadmin000000 000000 BEGIN { $| = 1; print "1..26\n"; } use warnings; use strict; # Test that we can load the module my $loaded; END {print "not ok 1\n" unless $loaded;} use Want; $loaded = 1; print "ok 1\n"; # Test for Damian's loop bug sub do_something_anything {} my $ok = 2; my @answers = (1,1,0,0,1,1,0,0,1,1,0,0, 0,0,1,1,0,0,1,1,0,0,1,1); sub okedoke { print((shift == shift @answers? "ok " : "not ok "), $ok++, "\n"); } my $flipflop = 0; sub foo { okedoke(want 'BOOL'); return $flipflop=!$flipflop; # alternate true and false } for (1..3) { while (foo() ) { do_something_anything; } while (my $answer = foo() ) { do_something_anything; } } sub bar { okedoke(want '!BOOL'); return $flipflop=!$flipflop; # alternate true and false } for (1..3) { while (bar() ) { do_something_anything; } my $answer; while ($answer = bar() ) { do_something_anything; } } print (@answers == 0 ? "ok 26\n" : "not ok 26\n");Want-0.26/t/err.t000644 000765 000120 00000000674 07343133372 014044 0ustar00robinadmin000000 000000 BEGIN { $| = 1; print "1..3\n"; } # Test that we can load the module END {print "not ok 1\n" unless $loaded;} use Want; $loaded = 1; print "ok 1\n"; sub foo :lvalue { rreturn 23; return; } sub bar :lvalue { lnoreturn; return; } eval { foo() = 7 }; print ($@ =~ /Can't rreturn in lvalue context/ ? "ok 2\n" : "not ok 2\n"); eval { bar() }; print ($@ =~ /Can't lnoreturn except in ASSIGN context/ ? "ok 3\n" : "not ok 3\n"); Want-0.26/t/methcall.t000644 000765 000120 00000001510 10615722564 015036 0ustar00robinadmin000000 000000 BEGIN { $| = 1; print "1..4\n"; } use warnings; use strict; # Test that we can load the module my $loaded; END {print "not ok 1\n" unless $loaded;} use Want; $loaded = 1; print "ok 1\n"; # Test for Joshua Goodall's bug #26847 sub method { my (undef, $t, $expected) = @_; my @ctx; for my $test (qw(VOID SCALAR REF REFSCALAR CODE HASH ARRAY GLOB OBJECT BOOL LIST Infinity LVALUE ASSIGN RVALUE)) { # print "Trying $test\n"; push @ctx, $test if Want::want($test); } if ("@ctx" eq $expected) { print "ok $t\n" } else { print "not ok $t\t#got @ctx, expected $expected\n" } return (want("ARRAY") ? [] : want("HASH") ? {} : 1); } my $obj = bless {}; $obj->method(2, "VOID RVALUE"); my @b = @{$obj->method(3, "SCALAR REF ARRAY RVALUE")}; my %b = %{$obj->method(4, "SCALAR REF HASH RVALUE")};Want-0.26/t/object.t000644 000765 000120 00000001631 07327514612 014516 0ustar00robinadmin000000 000000 BEGIN { $| = 1; print "1..7\n"; } # Test that we can load the module END {print "not ok 1\n" unless $loaded;} use Want; $loaded = 1; print "ok 1\n"; # Test the OBJECT reference type sub t { my $t = shift(); my $opname = Want::parent_op_name(0); print ($opname eq shift() ? "ok $t\n" : "not ok $t\t# $opname\n"); wantarray ? @_ : shift; } sub nop{} my $obj = bless({}, "main"); t(2, "method_call", $obj)->nop("blast"); t(3, "entersub", \&nop)->("blamm!"); sub wrt { my $t = shift(); my $wantref = Want::wantref(); my $expected = shift(); print ($wantref eq $expected ? "ok $t\n" : "not ok $t\t# $wantref\n"); wantarray ? @_ : shift; } wrt(4, "OBJECT", $obj)->nop(); wrt(5, "CODE", \&nop)->(nop()); sub wantt { my $t = shift(); my $r = shift(); print (Want::want(@_) ? "ok $t\n" : "not ok $t\n"); $r } wantt(6, $obj, 'OBJECT')->nop(wantt(7, \&nop, 'CODE')->());Want-0.26/t/threads.p000644 000765 000120 00000000507 10474136605 014676 0ustar00robinadmin000000 000000 use strict; use warnings; { package Foo; use Want; sub new { return (bless({}, shift)); } my $foo; sub foo :lvalue { my (@args) = Want::want('ASSIGN'); $foo = $args[0]; Want::lnoreturn; return; } } use threads; my $obj = Foo->new(); $obj->foo() = 'bar'; # EOF Want-0.26/t/threads.t000644 000765 000120 00000000361 10475117101 014667 0ustar00robinadmin000000 000000 use strict; use warnings; use Test::More 'tests' => 1; use Config; SKIP: { skip "Threads not available", 1 unless $Config{useithreads}; my $out = `$^X -Mblib t/threads.p 2>&1`; is($out, '' => 'No destruct error'); } # EOF