diff options
| -rw-r--r-- | MANIFEST | 1 | ||||
| -rw-r--r-- | doop.c | 5 | ||||
| -rw-r--r-- | embed.h | 4 | ||||
| -rw-r--r-- | op.c | 85 | ||||
| -rw-r--r-- | opcode.h | 21 | ||||
| -rw-r--r-- | opnames.h | 5 | ||||
| -rw-r--r-- | pod/perldelta.pod | 46 | ||||
| -rw-r--r-- | pod/perldiag.pod | 16 | ||||
| -rw-r--r-- | pod/perlfunc.pod | 75 | ||||
| -rw-r--r-- | pod/perlsub.pod | 10 | ||||
| -rw-r--r-- | pp.c | 81 | ||||
| -rw-r--r-- | pp.sym | 4 | ||||
| -rw-r--r-- | proto.h | 9 | ||||
| -rwxr-xr-x | regen/opcode.pl | 12 | ||||
| -rw-r--r-- | t/op/cproto.t | 16 | ||||
| -rw-r--r-- | t/op/push.t | 63 | ||||
| -rw-r--r-- | t/op/smartkve.t | 361 | ||||
| -rw-r--r-- | t/op/splice.t | 7 | ||||
| -rw-r--r-- | t/op/unshift.t | 36 |
19 files changed, 801 insertions, 56 deletions
@@ -4702,6 +4702,7 @@ t/op/runlevel.t See if die() works from perl_call_*() t/op/setpgrpstack.t See if setpgrp works t/op/sigdispatch.t See if signals are always dispatched t/op/sleep.t See if sleep works +t/op/smartkve.t See if smart deref for keys/values/each works t/op/smartmatch.t See if the ~~ operator works t/op/sort.t See if sort works t/op/splice.t See if splice works @@ -1436,8 +1436,9 @@ Perl_do_kv(pTHX) register HE *entry; const I32 gimme = GIMME_V; const I32 dokv = (PL_op->op_type == OP_RV2HV || PL_op->op_type == OP_PADHV); - const I32 dokeys = dokv || (PL_op->op_type == OP_KEYS); - const I32 dovalues = dokv || (PL_op->op_type == OP_VALUES); + /* op_type is OP_RKEYS/OP_RVALUES if pp_rkeys delegated to here */ + const I32 dokeys = dokv || (PL_op->op_type == OP_KEYS || PL_op->op_type == OP_RKEYS); + const I32 dovalues = dokv || (PL_op->op_type == OP_VALUES || PL_op->op_type == OP_RVALUES); if (!hv) { if (PL_op->op_flags & OPf_MOD || LVRET) { /* lvalue */ @@ -938,6 +938,7 @@ #define ck_method(a) Perl_ck_method(aTHX_ a) #define ck_null(a) Perl_ck_null(aTHX_ a) #define ck_open(a) Perl_ck_open(aTHX_ a) +#define ck_push(a) Perl_ck_push(aTHX_ a) #define ck_readline(a) Perl_ck_readline(aTHX_ a) #define ck_repeat(a) Perl_ck_repeat(aTHX_ a) #define ck_require(a) Perl_ck_require(aTHX_ a) @@ -1333,6 +1334,7 @@ #define pp_rand() Perl_pp_rand(aTHX) #define pp_range() Perl_pp_range(aTHX) #define pp_rcatline() Perl_pp_rcatline(aTHX) +#define pp_reach() Perl_pp_reach(aTHX) #define pp_read() Perl_pp_read(aTHX) #define pp_readdir() Perl_pp_readdir(aTHX) #define pp_readline() Perl_pp_readline(aTHX) @@ -1353,12 +1355,14 @@ #define pp_rewinddir() Perl_pp_rewinddir(aTHX) #define pp_right_shift() Perl_pp_right_shift(aTHX) #define pp_rindex() Perl_pp_rindex(aTHX) +#define pp_rkeys() Perl_pp_rkeys(aTHX) #define pp_rmdir() Perl_pp_rmdir(aTHX) #define pp_rv2av() Perl_pp_rv2av(aTHX) #define pp_rv2cv() Perl_pp_rv2cv(aTHX) #define pp_rv2gv() Perl_pp_rv2gv(aTHX) #define pp_rv2hv() Perl_pp_rv2hv(aTHX) #define pp_rv2sv() Perl_pp_rv2sv(aTHX) +#define pp_rvalues() Perl_pp_rvalues(aTHX) #define pp_sassign() Perl_pp_sassign(aTHX) #define pp_say() Perl_pp_say(aTHX) #define pp_scalar() Perl_pp_scalar(aTHX) @@ -310,6 +310,12 @@ Perl_Slab_Free(pTHX_ void *op) #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2) +#define CHANGE_TYPE(o,type) \ + STMT_START { \ + o->op_type = (OPCODE)type; \ + o->op_ppaddr = PL_ppaddr[type]; \ + } STMT_END + STATIC const char* S_gv_ename(pTHX_ GV *gv) { @@ -8259,7 +8265,7 @@ Perl_ck_shift(pTHX_ OP *o) return newUNOP(type, 0, scalar(argop)); #endif } - return scalar(modkids(ck_fun(o), type)); + return scalar(modkids(ck_push(o), type)); } OP * @@ -9125,30 +9131,81 @@ Perl_ck_substr(pTHX_ OP *o) } OP * -Perl_ck_each(pTHX_ OP *o) +Perl_ck_push(pTHX_ OP *o) { dVAR; OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL; + OP *cursor = NULL; + OP *proxy = NULL; - PERL_ARGS_ASSERT_CK_EACH; + PERL_ARGS_ASSERT_CK_PUSH; + /* If 1st kid is pushmark (e.g. push, unshift, splice), we need 2nd kid */ if (kid) { - if (kid->op_type == OP_PADAV || kid->op_type == OP_RV2AV) { - const unsigned new_type = o->op_type == OP_EACH ? OP_AEACH - : o->op_type == OP_KEYS ? OP_AKEYS : OP_AVALUES; - o->op_type = new_type; - o->op_ppaddr = PL_ppaddr[new_type]; - } - else if (!(kid->op_type == OP_PADHV || kid->op_type == OP_RV2HV - || (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) - )) { - bad_type(1, "hash or array", PL_op_desc[o->op_type], kid); - return o; + cursor = kid->op_type == OP_PUSHMARK ? kid->op_sibling : kid; + } + + /* If not array or array deref, wrap it with an array deref. + * For OP_CONST, we only wrap arrayrefs */ + if (cursor) { + if ( ( cursor->op_type != OP_PADAV + && cursor->op_type != OP_RV2AV + && cursor->op_type != OP_CONST + ) + || + ( cursor->op_type == OP_CONST + && SvROK(cSVOPx_sv(cursor)) + && SvTYPE(SvRV(cSVOPx_sv(cursor))) == SVt_PVAV + ) + ) { + proxy = newAVREF(cursor); + if ( cursor == kid ) { + cLISTOPx(o)->op_first = proxy; + } + else { + cLISTOPx(kid)->op_sibling = proxy; + } + cLISTOPx(proxy)->op_sibling = cLISTOPx(cursor)->op_sibling; + cLISTOPx(cursor)->op_sibling = NULL; } } return ck_fun(o); } +OP * +Perl_ck_each(pTHX_ OP *o) +{ + dVAR; + OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL; + const unsigned orig_type = o->op_type; + const unsigned array_type = orig_type == OP_EACH ? OP_AEACH + : orig_type == OP_KEYS ? OP_AKEYS : OP_AVALUES; + const unsigned ref_type = orig_type == OP_EACH ? OP_REACH + : orig_type == OP_KEYS ? OP_RKEYS : OP_RVALUES; + + PERL_ARGS_ASSERT_CK_EACH; + + if (kid) { + switch (kid->op_type) { + case OP_PADHV: + case OP_RV2HV: + break; + case OP_PADAV: + case OP_RV2AV: + CHANGE_TYPE(o, array_type); + break; + case OP_CONST: + if (kid->op_private == OPpCONST_BARE) + /* we let ck_fun treat as hash */ + break; + default: + CHANGE_TYPE(o, ref_type); + } + } + /* if treating as a reference, defer additional checks to runtime */ + return o->op_type == ref_type ? o : ck_fun(o); +} + /* caller is supposed to assign the return to the container of the rep_op var */ STATIC OP * @@ -399,6 +399,9 @@ EXTCONST char* const PL_op_name[] = { "lock", "once", "custom", + "reach", + "rkeys", + "rvalues", }; #endif @@ -772,6 +775,9 @@ EXTCONST char* const PL_op_desc[] = { "lock", "once", "unknown custom operator", + "each on reference", + "keys on reference", + "values on reference", }; #endif @@ -1159,6 +1165,9 @@ EXT Perl_ppaddr_t PL_ppaddr[] /* or perlvars.h */ Perl_pp_lock, Perl_pp_once, Perl_unimplemented_op, /* Perl_pp_custom */ + Perl_pp_rkeys, /* Perl_pp_reach */ + Perl_pp_rkeys, + Perl_pp_rkeys, /* Perl_pp_rvalues */ } #endif #ifdef PERL_PPADDR_INITED @@ -1327,11 +1336,11 @@ EXT Perl_check_t PL_check[] /* or perlvars.h */ Perl_ck_null, /* lslice */ Perl_ck_fun, /* anonlist */ Perl_ck_fun, /* anonhash */ - Perl_ck_fun, /* splice */ - Perl_ck_fun, /* push */ + Perl_ck_push, /* splice */ + Perl_ck_push, /* push */ Perl_ck_shift, /* pop */ Perl_ck_shift, /* shift */ - Perl_ck_fun, /* unshift */ + Perl_ck_push, /* unshift */ Perl_ck_sort, /* sort */ Perl_ck_fun, /* reverse */ Perl_ck_grep, /* grepstart */ @@ -1543,6 +1552,9 @@ EXT Perl_check_t PL_check[] /* or perlvars.h */ Perl_ck_rfun, /* lock */ Perl_ck_null, /* once */ Perl_ck_null, /* custom */ + Perl_ck_each, /* reach */ + Perl_ck_each, /* rkeys */ + Perl_ck_each, /* rvalues */ } #endif #ifdef PERL_CHECK_INITED @@ -1921,6 +1933,9 @@ EXTCONST U32 PL_opargs[] = { 0x00007b04, /* lock */ 0x00000300, /* once */ 0x00000000, /* custom */ + 0x00001b00, /* reach */ + 0x00001b08, /* rkeys */ + 0x00001b08, /* rvalues */ }; #endif @@ -381,10 +381,13 @@ typedef enum opcode { OP_LOCK = 363, OP_ONCE = 364, OP_CUSTOM = 365, + OP_REACH = 366, + OP_RKEYS = 367, + OP_RVALUES = 368, OP_max } opcode; -#define MAXO 366 +#define MAXO 369 #define OP_phoney_INPUT_ONLY -1 #define OP_phoney_OUTPUT_ONLY -2 diff --git a/pod/perldelta.pod b/pod/perldelta.pod index cc5cc23442..c0a55cdc9c 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -77,6 +77,52 @@ with regard to C<[[:posix:]]> character classes Work is underway to add the case sensitive matching to the control of this feature, but was not complete in time for this dot release. +=head2 Array and hash container functions accept references + +All built-in functions that operate directly on array or hash +containers now also accept hard references to arrays or hashes: + + |----------------------------+---------------------------| + | Traditional syntax | Terse syntax | + |----------------------------+---------------------------| + | push @$arrayref, @stuff | push $arrayref, @stuff | + | unshift @$arrayref, @stuff | unshift $arrayref, @stuff | + | pop @$arrayref | pop $arrayref | + | shift @$arrayref | shift $arrayref | + | splice @$arrayref, 0, 2 | splice $arrayref, 0, 2 | + | keys %$hashref | keys $hashref | + | keys @$arrayref | keys $arrayref | + | values %$hashref | values $hashref | + | values @$arrayref | values $arrayref | + | ($k,$v) = each %$hashref | ($k,$v) = each $hashref | + | ($k,$v) = each @$arrayref | ($k,$v) = each $arrayref | + |----------------------------+---------------------------| + +This allows these built-in functions to act on long dereferencing chains +or on the return value of subroutines without needing to wrap them in +C<@{}> or C<%{}>: + + push @{$obj->tags}, $new_tag; # old way + push $obj->tags, $new_tag; # new way + + for ( keys %{$hoh->{genres}{artists}} ) {...} # old way + for ( keys $hoh->{genres}{artists} ) {...} # new way + +For C<push>, C<unshift> and C<splice>, the reference will auto-vivify +if it is not defined, just as if it were wrapped with C<@{}>. + +Calling C<keys> or C<values> directly on a reference gives a substantial +performance improvement over explicit dereferencing. + +For C<keys>, C<values>, C<each>, when overloaded dereferencing is +present, the overloaded dereference is used instead of dereferencing the +underlying reftype. Warnings are issued about assumptions made in the +following three ambiguous cases: + + (a) If both %{} and @{} overloading exists, %{} is used + (b) If %{} overloading exists on a blessed arrayref, %{} is used + (c) If @{} overloading exists on a blessed hashref, @{} is used + =head1 Security XXX Any security-related notices go here. In particular, any security diff --git a/pod/perldiag.pod b/pod/perldiag.pod index 7bbccdd410..3f467af685 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -76,6 +76,17 @@ on the operator (e.g. C<CORE::log($x)>) or declare the subroutine to be an object method (see L<perlsub/"Subroutine Attributes"> or L<attributes>). +=item Ambiguous overloaded argument to %s resolved as %s + +(W ambiguous) You called C<keys>, C<values> or C<each> on an object that had +overloading of C<%{}> or C<@{}> or both. In such a case, the object is +dereferenced according to its overloading, not its underlying reference type. +The warning is issued when C<%{}> overloading exists on a blessed arrayref, +when C<@{}> overloading exists on a blessed hashref, or when both overloadings +are defined (in which case C<%{}> is used). You can force the interpretation +of the object by explictly dereferencing it as an array or hash instead of +passing the object itself to C<keys>, C<values> or C<each>. + =item Ambiguous range in transliteration operator (F) You wrote something like C<tr/a-z-0//> which doesn't mean anything at @@ -4520,6 +4531,11 @@ certain type. Arrays must be @NAME or C<@{EXPR}>. Hashes must be %NAME or C<%{EXPR}>. No implicit dereferencing is allowed--use the {EXPR} forms as an explicit dereference. See L<perlref>. +=item Type of argument to %s must be hashref or arrayref + +(F) You called C<keys>, C<values> or C<each> with an argument that was +expected to be a reference to a hash or a reference to an array. + =item umask not implemented (F) Your machine doesn't implement the umask function and you tried to diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod index 185ad7f240..7311d8be2a 100644 --- a/pod/perlfunc.pod +++ b/pod/perlfunc.pod @@ -1452,10 +1452,10 @@ convert a core file into an executable. That's why you should now invoke it as C<CORE::dump()>, if you don't want to be warned against a possible typo. -=item each HASH +=item each HASH (or HASHREF) X<each> X<hash, iterator> -=item each ARRAY +=item each ARRAY (or ARRAYREF) X<array, iterator> When called in list context, returns a 2-element list consisting of the key @@ -1494,6 +1494,16 @@ but in a different order: print "$key=$value\n"; } +When given a reference to a hash or array, the argument will be +dereferenced automatically. + + while (($key,$value) = each $hashref) { ... } + +If the reference is a blessed object that overrides either C<%{}> or +C<@{}>, the override will be used instead of dereferencing the underlying +variable type. If both overrides are provided, C<%{}> will be the default. +If this is not desired, you must dereference the argument yourself. + See also C<keys>, C<values> and C<sort>. =item eof FILEHANDLE @@ -2602,10 +2612,10 @@ separated by the value of EXPR, and returns that new string. Example: Beware that unlike C<split>, C<join> doesn't take a pattern as its first argument. Compare L</split>. -=item keys HASH +=item keys HASH (or HASHREF) X<keys> X<key> -=item keys ARRAY +=item keys ARRAY (or ARRAYREF) Returns a list consisting of all the keys of the named hash, or the indices of an array. (In scalar context, returns the number of keys or indices.) @@ -2662,6 +2672,17 @@ C<keys> in this way (but you needn't worry about doing this by accident, as trying has no effect). C<keys @array> in an lvalue context is a syntax error. +When given a reference to a hash or array, the argument will be +dereferenced automatically. + + for (keys $hashref) { ... } + for (keys $obj->get_arrayref) { ... } + +If the reference is a blessed object that overrides either C<%{}> or +C<@{}>, the override will be used instead of dereferencing the underlying +variable type. If both overrides are provided, C<%{}> will be the default. +If this is not desired, you must dereference the argument yourself. + See also C<each>, C<values> and C<sort>. =item kill SIGNAL, LIST @@ -4306,7 +4327,7 @@ On systems that support a close-on-exec flag on files, that flag is set on all newly opened file descriptors whose C<fileno>s are I<higher> than the current value of $^F (by default 2 for C<STDERR>). See L<perlvar/$^F>. -=item pop ARRAY +=item pop ARRAY (or ARRAYREF) X<pop> X<stack> =item pop @@ -4318,6 +4339,9 @@ Returns the undefined value if the array is empty, although this may also happen at other times. If ARRAY is omitted, pops the C<@ARGV> array in the main program, but the C<@_> array in subroutines, just like C<shift>. +If given a reference to an array, the argument will be dereferenced +automatically. + =item pos SCALAR X<pos> X<match, position> @@ -4409,7 +4433,7 @@ C<qw//>) or if its arguments cannot be adequately expressed by a prototype does not really behave like a Perl function. Otherwise, the string describing the equivalent prototype is returned. -=item push ARRAY,LIST +=item push ARRAY (or ARRAYREF),LIST X<push> X<stack> Treats ARRAY as a stack, and pushes the values of LIST @@ -4423,6 +4447,9 @@ LIST. Has the same effect as but is more efficient. Returns the number of elements in the array following the completed C<push>. +If given a reference to an array, the argument will be dereferenced +automatically. + =item q/STRING/ =item qq/STRING/ @@ -5315,7 +5342,7 @@ An example disabling Nagle's algorithm on a socket: use Socket qw(IPPROTO_TCP TCP_NODELAY); setsockopt($socket, IPPROTO_TCP, TCP_NODELAY, 1); -=item shift ARRAY +=item shift ARRAY (or ARRAYREF) X<shift> =item shift @@ -5328,6 +5355,9 @@ C<@ARGV> array outside a subroutine and also within the lexical scopes established by the C<eval STRING>, C<BEGIN {}>, C<INIT {}>, C<CHECK {}>, C<UNITCHECK {}> and C<END {}> constructs. +If given a reference to an array, the argument will be dereferenced +automatically. + See also C<unshift>, C<push>, and C<pop>. C<shift> and C<unshift> do the same thing to the left end of an array that C<pop> and C<push> do to the right end. @@ -5659,14 +5689,14 @@ eliminate any C<NaN>s from the input list. @result = sort { $a <=> $b } grep { $_ == $_ } @input; -=item splice ARRAY,OFFSET,LENGTH,LIST +=item splice ARRAY (or ARRAYREF),OFFSET,LENGTH,LIST X<splice> -=item splice ARRAY,OFFSET,LENGTH +=item splice ARRAY (or ARRAYREF),OFFSET,LENGTH -=item splice ARRAY,OFFSET +=item splice ARRAY (or ARRAYREF),OFFSET -=item splice ARRAY +=item splice ARRAY (or ARRAYREF) Removes the elements designated by OFFSET and LENGTH from an array, and replaces them with the elements of LIST, if any. In list context, @@ -5681,6 +5711,9 @@ If both OFFSET and LENGTH are omitted, removes everything. If OFFSET is past the end of the array, Perl issues a warning, and splices at the end of the array. +If given a reference to an array, the argument will be dereferenced +automatically. + The following equivalences hold (assuming C<< $[ == 0 and $#a >= $i >> ) push(@a,$x,$y) splice(@a,@a,0,$x,$y) @@ -7168,7 +7201,7 @@ X<untie> Breaks the binding between a variable and a package. (See C<tie>.) Has no effect if the variable is not tied. -=item unshift ARRAY,LIST +=item unshift ARRAY (or ARRAYREF),LIST X<unshift> Does the opposite of a C<shift>. Or the opposite of a C<push>, @@ -7181,6 +7214,9 @@ Note the LIST is prepended whole, not one element at a time, so the prepended elements stay in the same order. Use C<reverse> to do the reverse. +If given a reference to an array, the argument will be dereferenced +automatically. + =item use Module VERSION LIST X<use> X<module> X<import> @@ -7346,10 +7382,10 @@ files. On systems that don't support futimes(2), passing filehandles raises an exception. Filehandles must be passed as globs or glob references to be recognized; barewords are considered filenames. -=item values HASH +=item values HASH (or HASHREF) X<values> -=item values ARRAY +=item values ARRAY (or ARRAYREF) Returns a list consisting of all the values of the named hash, or the values of an array. (In a scalar context, returns the number of values.) @@ -7377,6 +7413,17 @@ modify the contents of the hash: for (values %hash) { s/foo/bar/g } # modifies %hash values for (@hash{keys %hash}) { s/foo/bar/g } # same +When given a reference to a hash or array, the argument will be +dereferenced automatically. + + for (values $hashref) { ... } + for (values $obj->get_arrayref) { ... } + +If the reference is a blessed object that overrides either C<%{}> or +C<@{}>, the override will be used instead of dereferencing the underlying +variable type. If both overrides are provided, C<%{}> will be the default. +If this is not desired, you must dereference the argument yourself. + See also C<keys>, C<each>, and C<sort>. =item vec EXPR,OFFSET,BITS diff --git a/pod/perlsub.pod b/pod/perlsub.pod index c16db28937..cfa4ad4183 100644 --- a/pod/perlsub.pod +++ b/pod/perlsub.pod @@ -1053,7 +1053,7 @@ X<prototype> X<subroutine, prototype> Perl supports a very limited kind of compile-time argument checking using function prototyping. If you declare - sub mypush (\@@) + sub mypush (+@) then C<mypush()> takes arguments exactly like C<push()> does. The function declaration must be visible at compile time. The prototype @@ -1083,9 +1083,9 @@ corresponding built-in. sub mysyswrite ($$$;$) mysyswrite $buf, 0, length($buf) - $off, $off sub myreverse (@) myreverse $a, $b, $c sub myjoin ($@) myjoin ":", $a, $b, $c - sub mypop (\@) mypop @array - sub mysplice (\@$$@) mysplice @array, 0, 2, @pushme - sub mykeys (\%) mykeys %{$hashref} + sub mypop (+) mypop @array + sub mysplice (+$$@) mysplice @array, 0, 2, @pushme + sub mykeys (+) mykeys %{$hashref} sub myopen (*;$) myopen HANDLE, $name sub mypipe (**) mypipe READHANDLE, WRITEHANDLE sub mygrep (&@) mygrep { /foo/ } $a, $b, $c @@ -1141,7 +1141,7 @@ C<\[@%]> when given a literal array or hash variable, but will otherwise force scalar context on the argument. This is useful for functions which should accept either a literal array or an array reference as the argument: - sub smartpush (+@) { + sub mypush (+@) { my $aref = shift; die "Not an array or arrayref" unless ref $aref eq 'ARRAY'; push @$aref, @_; @@ -429,7 +429,19 @@ PP(pp_prototype) goto set; } if (code == -KEY_keys || code == -KEY_values || code == -KEY_each) { - ret = newSVpvs_flags("\\[@%]", SVs_TEMP); + ret = newSVpvs_flags("+", SVs_TEMP); + goto set; + } + if (code == -KEY_push || code == -KEY_unshift) { + ret = newSVpvs_flags("+@", SVs_TEMP); + goto set; + } + if (code == -KEY_pop || code == -KEY_shift) { + ret = newSVpvs_flags(";+", SVs_TEMP); + goto set; + } + if (code == -KEY_splice) { + ret = newSVpvs_flags("+;$$@", SVs_TEMP); goto set; } if (code == -KEY_tied || code == -KEY_untie) { @@ -4625,6 +4637,71 @@ PP(pp_aslice) RETURN; } +/* Smart dereferencing for keys, values and each */ +PP(pp_rkeys) +{ + dVAR; + dSP; + dPOPss; + + if (!SvOK(sv)) + RETURN; + + if (SvROK(sv)) { + SvGETMAGIC(sv); + if (SvAMAGIC(sv)) { + /* N.B.: AMG macros return sv if no overloading is found */ + SV *maybe_hv = AMG_CALLun_var(sv,to_hv_amg); + SV *maybe_av = AMG_CALLun_var(sv,to_av_amg); + if ( maybe_hv != sv && maybe_av != sv ) { + Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS), "%s", + Perl_form(aTHX_ "Ambiguous overloaded argument to %s resolved as %%{}", + PL_op_desc[PL_op->op_type] + ) + ); + sv = maybe_hv; + } + else if ( maybe_av != sv ) { + if ( SvTYPE(SvRV(sv)) == SVt_PVHV ) { + /* @{} overload, but underlying reftype is HV */ + Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS), "%s", + Perl_form(aTHX_ "Ambiguous overloaded argument to %s resolved as @{}", + PL_op_desc[PL_op->op_type] + ) + ); + } + sv = maybe_av; + } + else if ( maybe_hv != sv ) { + if ( SvTYPE(SvRV(sv)) == SVt_PVAV ) { + /* %{} overload, but underlying reftype is AV */ + Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS), "%s", + Perl_form(aTHX_ "Ambiguous overloaded argument to %s resolved as %%{}", + PL_op_desc[PL_op->op_type] + ) + ); + } + sv = maybe_hv; + } + } + sv = SvRV(sv); + } + + if ( SvTYPE(sv) != SVt_PVHV && SvTYPE(sv) != SVt_PVAV ) { + DIE(aTHX_ Perl_form(aTHX_ "Type of argument to %s must be hashref or arrayref", + PL_op_desc[PL_op->op_type] )); + } + + /* Delegate to correct function for op type */ + PUSHs(sv); + if (PL_op->op_type == OP_RKEYS || PL_op->op_type == OP_RVALUES) { + return (SvTYPE(sv) == SVt_PVHV) ? Perl_do_kv(aTHX) : Perl_pp_akeys(aTHX); + } + else { + return (SvTYPE(sv) == SVt_PVHV) ? Perl_pp_each(aTHX) : Perl_pp_aeach(aTHX); + } +} + PP(pp_aeach) { dVAR; @@ -4670,7 +4747,7 @@ PP(pp_akeys) EXTEND(SP, n + 1); - if (PL_op->op_type == OP_AKEYS) { + if (PL_op->op_type == OP_AKEYS || PL_op->op_type == OP_RKEYS) { n += i; for (; i <= n; i++) { mPUSHi(i); @@ -30,6 +30,7 @@ Perl_ck_match Perl_ck_method Perl_ck_null Perl_ck_open +Perl_ck_push Perl_ck_readline Perl_ck_repeat Perl_ck_require @@ -409,5 +410,8 @@ Perl_pp_getlogin Perl_pp_syscall Perl_pp_lock Perl_pp_once +Perl_pp_reach +Perl_pp_rkeys +Perl_pp_rvalues # ex: set ro: @@ -407,6 +407,12 @@ PERL_CALLCONV OP * Perl_ck_open(pTHX_ OP *o) #define PERL_ARGS_ASSERT_CK_OPEN \ assert(o) +PERL_CALLCONV OP * Perl_ck_push(pTHX_ OP *o) + __attribute__warn_unused_result__ + __attribute__nonnull__(pTHX_1); +#define PERL_ARGS_ASSERT_CK_PUSH \ + assert(o) + PERL_CALLCONV OP * Perl_ck_readline(pTHX_ OP *o) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); @@ -3073,6 +3079,7 @@ PERL_CALLCONV OP * Perl_pp_quotemeta(pTHX); PERL_CALLCONV OP * Perl_pp_rand(pTHX); PERL_CALLCONV OP * Perl_pp_range(pTHX); PERL_CALLCONV OP * Perl_pp_rcatline(pTHX); +PERL_CALLCONV OP * Perl_pp_reach(pTHX); PERL_CALLCONV OP * Perl_pp_read(pTHX); PERL_CALLCONV OP * Perl_pp_readdir(pTHX); PERL_CALLCONV OP * Perl_pp_readline(pTHX); @@ -3093,12 +3100,14 @@ PERL_CALLCONV OP * Perl_pp_reverse(pTHX); PERL_CALLCONV OP * Perl_pp_rewinddir(pTHX); PERL_CALLCONV OP * Perl_pp_right_shift(pTHX); PERL_CALLCONV OP * Perl_pp_rindex(pTHX); +PERL_CALLCONV OP * Perl_pp_rkeys(pTHX); PERL_CALLCONV OP * Perl_pp_rmdir(pTHX); PERL_CALLCONV OP * Perl_pp_rv2av(pTHX); PERL_CALLCONV OP * Perl_pp_rv2cv(pTHX); PERL_CALLCONV OP * Perl_pp_rv2gv(pTHX); PERL_CALLCONV OP * Perl_pp_rv2hv(pTHX); PERL_CALLCONV OP * Perl_pp_rv2sv(pTHX); +PERL_CALLCONV OP * Perl_pp_rvalues(pTHX); PERL_CALLCONV OP * Perl_pp_sassign(pTHX); PERL_CALLCONV OP * Perl_pp_say(pTHX); PERL_CALLCONV OP * Perl_pp_scalar(pTHX); diff --git a/regen/opcode.pl b/regen/opcode.pl index d1a47d552a..9369c2ecef 100755 --- a/regen/opcode.pl +++ b/regen/opcode.pl @@ -105,6 +105,7 @@ my @raw_alias = ( Perl_pp_bit_or => ['bit_xor'], Perl_pp_rv2av => ['rv2hv'], Perl_pp_akeys => ['avalues'], + Perl_pp_rkeys => [qw(rvalues reach)], ); while (my ($func, $names) = splice @raw_alias, 0, 2) { @@ -808,11 +809,11 @@ lslice list slice ck_null 2 H L L anonlist anonymous list ([]) ck_fun ms@ L anonhash anonymous hash ({}) ck_fun ms@ L -splice splice ck_fun m@ A S? S? L -push push ck_fun imsT@ A L +splice splice ck_push m@ A S? S? L +push push ck_push imsT@ A L pop pop ck_shift s% A? shift shift ck_shift s% A? -unshift unshift ck_fun imsT@ A L +unshift unshift ck_push imsT@ A L sort sort ck_sort dm@ C? L reverse reverse ck_fun mt@ L @@ -1099,3 +1100,8 @@ lock lock ck_rfun s% R once once ck_null | custom unknown custom operator ck_null 0 + +# For smart dereference for each/keys/values +reach each on reference ck_each % S +rkeys keys on reference ck_each t% S +rvalues values on reference ck_each t% S diff --git a/t/op/cproto.t b/t/op/cproto.t index 3e3c0de358..b1a49440f6 100644 --- a/t/op/cproto.t +++ b/t/op/cproto.t @@ -57,7 +57,7 @@ delete undef die (@) do undef dump () -each (\[@%]) +each (+) else undef elsif undef endgrent () @@ -120,7 +120,7 @@ index ($$;$) int (_) ioctl (*$$) join ($@) -keys (\[@%]) +keys (+) kill (@) last undef lc (_) @@ -156,12 +156,12 @@ our undef pack ($@) package undef pipe (**) -pop (;\@) +pop (;+) pos undef print undef printf undef prototype undef -push (\@@) +push (+@) q undef qq undef qr undef @@ -204,7 +204,7 @@ setprotoent ($) setpwent () setservent ($) setsockopt (*$$$) -shift (;\@) +shift (;+) shmctl ($$$) shmget ($$$) shmread ($$$$) @@ -215,7 +215,7 @@ sleep (;$) socket (*$$$) socketpair (**$$$) sort undef -splice (\@;$$@) +splice (+;$$@) split undef sprintf ($@) sqrt (_) @@ -247,12 +247,12 @@ undef undef unless undef unlink (@) unpack ($;$) -unshift (\@@) +unshift (+@) untie (\[$@%*]) until undef use undef utime (@) -values (\[@%]) +values (+) vec ($$$) wait () waitpid ($$) diff --git a/t/op/push.t b/t/op/push.t index 20247062b4..2804d5be66 100644 --- a/t/op/push.t +++ b/t/op/push.t @@ -14,7 +14,7 @@ -4, 4 5 6 7, 0 1 2 3 EOF -print "1..", 4 + @tests, "\n"; +print "1..", 13 + 2*@tests, "\n"; die "blech" unless @tests; @x = (1,2,3); @@ -35,18 +35,70 @@ if (join(':',@x) eq '1:2:3:1:2:3:4:3') {print "ok 3\n";} else {print "not ok 3\n } if (join(':',@x) eq '1:2:3:1:2:3:4') {print "ok 4\n";} else {print "not ok 4\n";} -$test = 5; +# test for push/pop on arrayref +push(\@x,5); +if (join(':',@x) eq '1:2:3:1:2:3:4:5') {print "ok 5\n";} else {print "not ok 5\n";} +pop(\@x); +if (join(':',@x) eq '1:2:3:1:2:3:4') {print "ok 6\n";} else {print "not ok 6\n";} + +# test autovivification +push @$undef1, 1, 2, 3; +if (join(':',@$undef1) eq '1:2:3') {print "ok 7\n";} else {print "not ok 7\n";} +push $undef2, 1, 2, 3; +if (join(':',@$undef2) eq '1:2:3') {print "ok 8\n";} else {print "not ok 8\n";} + +# test constant +use constant CONST_ARRAYREF => [qw/a b c/]; +push CONST_ARRAYREF(), qw/d e f/; +if (join(':',@{CONST_ARRAYREF()}) eq 'a:b:c:d:e:f') {print "ok 9\n";} else {print "not ok 9\n";} + +# test implicit dereference errors +eval "push 42, 0, 1, 2, 3"; +if ( $@ && $@ =~ /must be array/ ) {print "ok 10\n"} else {print "not ok 10 # \$\@ = $@\n"} + +$hashref = { }; +eval { push $hashref, 0, 1, 2, 3 }; +if ( $@ && $@ =~ /Not an ARRAY reference/ ) {print "ok 11\n"} else {print "not ok 11 # \$\@ = $@\n"} + +$test = 12; + +# test context +{ + my($first, $second) = ([1], [2]); + sub two_things { return +($first, $second) } + push two_things(), 3; + if (join(':',@$first) eq '1' && + join(':',@$second) eq '2:3') { + print "ok ",$test++,"\n"; + } + else { + print "not ok ",$test++," got: \$first = [ @$first ]; \$second = [ @$second ];\n"; + } + + push @{ two_things() }, 4; + if (join(':',@$first) eq '1' && + join(':',@$second) eq '2:3:4') { + print "ok ",$test++,"\n"; + } + else { + print "not ok ",$test++," got: \$first = [ @$first ]; \$second = [ @$second ];\n"; + } +} + foreach $line (@tests) { ($list,$get,$leave) = split(/,\t*/,$line); ($pos, $len, @list) = split(' ',$list); @get = split(' ',$get); @leave = split(' ',$leave); @x = (0,1,2,3,4,5,6,7); + $y = [0,1,2,3,4,5,6,7]; if (defined $len) { @got = splice(@x, $pos, $len, @list); + @got2 = splice($y, $pos, $len, @list); } else { @got = splice(@x, $pos); + @got2 = splice($y, $pos); } if (join(':',@got) eq join(':',@get) && join(':',@x) eq join(':',@leave)) { @@ -55,6 +107,13 @@ foreach $line (@tests) { else { print "not ok ",$test++," got: @got == @get left: @x == @leave\n"; } + if (join(':',@got2) eq join(':',@get) && + join(':',@$y) eq join(':',@leave)) { + print "ok ",$test++,"\n"; + } + else { + print "not ok ",$test++," got (arrayref): @got2 == @get left: @$y == @leave\n"; + } } 1; # this file is require'd by lib/tie-stdpush.t diff --git a/t/op/smartkve.t b/t/op/smartkve.t new file mode 100644 index 0000000000..4cb19f5452 --- /dev/null +++ b/t/op/smartkve.t @@ -0,0 +1,361 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + require './test.pl'; +} +use strict; +use warnings; +no warnings 'deprecated'; +use vars qw($data $array $values $hash); + +plan 'no_plan'; + +sub j { join(":",@_) } + +BEGIN { # in BEGIN for "use constant ..." later + $array = [ qw(pi e i) ]; + $values = [ 3.14, 2.72, -1 ]; + $hash = { pi => 3.14, e => 2.72, i => -1 } ; + $data = { + hash => { %$hash }, + array => [ @$array ], + }; +} + +package Foo; +sub new { + my $self = { + hash => {%{$main::hash} }, + array => [@{$main::array}] + }; + bless $self, shift; +} +sub hash { no overloading; $_[0]->{hash} }; +sub array { no overloading; $_[0]->{array} }; + +package Foo::Overload::Array; +sub new { return bless [ qw/foo bar/ ], shift } +use overload '@{}' => sub { $main::array }, fallback => 1; + +package Foo::Overload::Hash; +sub new { return bless { qw/foo bar/ }, shift } +use overload '%{}' => sub { $main::hash }, fallback => 1; + +package Foo::Overload::Both; +sub new { return bless { qw/foo bar/ }, shift } +use overload '%{}' => sub { $main::hash }, + '@{}' => sub { $main::array }, fallback => 1; + +package Foo::Overload::HashOnArray; +sub new { return bless [ qw/foo bar/ ], shift } +use overload '%{}' => sub { $main::hash }, fallback => 1; + +package Foo::Overload::ArrayOnHash; +sub new { return bless { qw/foo bar/ }, shift } +use overload '@{}' => sub { $main::array }, fallback => 1; + +package main; + +use constant CONST_HASH => { %$hash }; +use constant CONST_ARRAY => [ @$array ]; + +my %a_hash = %$hash; +my @an_array = @$array; +sub hash_sub { return \%a_hash; } +sub array_sub { return \@an_array; } + +my $obj = Foo->new; + +my ($empty, $h_expect, $a_expect, @tmp, @tmp2, $k, $v); + +# Keys -- void + +keys $hash; pass('Void: keys $hash;'); +keys $data->{hash}; pass('Void: keys $data->{hash};'); +keys CONST_HASH; pass('Void: keys CONST_HASH;'); +keys CONST_HASH(); pass('Void: keys CONST_HASH();'); +keys hash_sub(); pass('Void: keys hash_sub();'); +keys hash_sub; pass('Void: keys hash_sub;'); +keys $obj->hash; pass('Void: keys $obj->hash;'); +keys $array; pass('Void: keys $array;'); +keys $data->{array}; pass('Void: keys $data->{array};'); +keys CONST_ARRAY; pass('Void: keys CONST_ARRAY;'); +keys CONST_ARRAY(); pass('Void: keys CONST_ARRAY();'); +keys array_sub; pass('Void: keys array_sub;'); +keys array_sub(); pass('Void: keys array_sub();'); +keys $obj->array; pass('Void: keys $obj->array;'); + +# Keys -- scalar + +is(keys $hash ,3, 'Scalar: keys $hash'); +is(keys $data->{hash} ,3, 'Scalar: keys $data->{hash}'); +is(keys CONST_HASH ,3, 'Scalar: keys CONST_HASH'); +is(keys CONST_HASH() ,3, 'Scalar: keys CONST_HASH()'); +is(keys hash_sub ,3, 'Scalar: keys hash_sub'); +is(keys hash_sub() ,3, 'Scalar: keys hash_sub()'); +is(keys $obj->hash ,3, 'Scalar: keys $obj->hash'); +is(keys $array ,3, 'Scalar: keys $array'); +is(keys $data->{array} ,3, 'Scalar: keys $data->{array}'); +is(keys CONST_ARRAY ,3, 'Scalar: keys CONST_ARRAY'); +is(keys CONST_ARRAY() ,3, 'Scalar: keys CONST_ARRAY()'); +is(keys array_sub ,3, 'Scalar: keys array_sub'); +is(keys array_sub() ,3, 'Scalar: keys array_sub()'); +is(keys $obj->array ,3, 'Scalar: keys $obj->array'); + +# Keys -- list + +$h_expect = j(keys %$hash); +$a_expect = j(keys @$array); + +is(j(keys $hash) ,$h_expect, 'List: keys $hash'); +is(j(keys $data->{hash}) ,$h_expect, 'List: keys $data->{hash}'); +is(j(keys CONST_HASH) ,$h_expect, 'List: keys CONST_HASH'); +is(j(keys CONST_HASH()) ,$h_expect, 'List: keys CONST_HASH()'); +is(j(keys hash_sub) ,$h_expect, 'List: keys hash_sub'); +is(j(keys hash_sub()) ,$h_expect, 'List: keys hash_sub()'); +is(j(keys $obj->hash) ,$h_expect, 'List: keys $obj->hash'); +is(j(keys $array) ,$a_expect, 'List: keys $array'); +is(j(keys $data->{array}) ,$a_expect, 'List: keys $data->{array}'); +is(j(keys CONST_ARRAY) ,$a_expect, 'List: keys CONST_ARRAY'); +is(j(keys CONST_ARRAY()) ,$a_expect, 'List: keys CONST_ARRAY()'); +is(j(keys array_sub) ,$a_expect, 'List: keys array_sub'); +is(j(keys array_sub()) ,$a_expect, 'List: keys array_sub()'); +is(j(keys $obj->array) ,$a_expect, 'List: keys $obj->array'); + +# Keys -- undef + +undef $empty; +is(j(keys undef), '', 'Undef: keys undef is empty list'); +is(j(keys $empty), '', 'Undef: keys $empty is empty list'); +is($empty, undef, 'Undef: $empty is not vivified'); + +# Keys -- vivification +is(j(keys $empty->{hash}), '', 'Vivify: keys $empty->{hash}'); +ok(defined $empty , 'Vivify: $empty is HASHREF'); +ok(!defined $empty->{hash} , 'Vivify: $empty->{hash} is undef'); + +# Keys -- errors +eval "keys 3"; +ok($@ =~ qr/Type of argument to keys on reference must be hashref or arrayref/, + 'Errors: keys CONSTANT throws error' +); + +eval "keys qr/foo/"; +ok($@ =~ qr/Type of argument to keys on reference must be hashref or arrayref/, + 'Errors: keys qr/foo/ throws error' +); + +eval "keys $hash qw/fo bar/"; +ok($@ =~ qr/syntax error/, + 'Errors: keys $hash, @stuff throws error' +) or print "# Got: $@"; + +# Values -- void + +values $hash; pass('Void: values $hash;'); +values $data->{hash}; pass('Void: values $data->{hash};'); +values CONST_HASH; pass('Void: values CONST_HASH;'); +values CONST_HASH(); pass('Void: values CONST_HASH();'); +values hash_sub(); pass('Void: values hash_sub();'); +values hash_sub; pass('Void: values hash_sub;'); +values $obj->hash; pass('Void: values $obj->hash;'); +values $array; pass('Void: values $array;'); +values $data->{array}; pass('Void: values $data->{array};'); +values CONST_ARRAY; pass('Void: values CONST_ARRAY;'); +values CONST_ARRAY(); pass('Void: values CONST_ARRAY();'); +values array_sub; pass('Void: values array_sub;'); +values array_sub(); pass('Void: values array_sub();'); +values $obj->array; pass('Void: values $obj->array;'); + +# Values -- scalar + +is(values $hash ,3, 'Scalar: values $hash'); +is(values $data->{hash} ,3, 'Scalar: values $data->{hash}'); +is(values CONST_HASH ,3, 'Scalar: values CONST_HASH'); +is(values CONST_HASH() ,3, 'Scalar: values CONST_HASH()'); +is(values hash_sub ,3, 'Scalar: values hash_sub'); +is(values hash_sub() ,3, 'Scalar: values hash_sub()'); +is(values $obj->hash ,3, 'Scalar: values $obj->hash'); +is(values $array ,3, 'Scalar: values $array'); +is(values $data->{array} ,3, 'Scalar: values $data->{array}'); +is(values CONST_ARRAY ,3, 'Scalar: values CONST_ARRAY'); +is(values CONST_ARRAY() ,3, 'Scalar: values CONST_ARRAY()'); +is(values array_sub ,3, 'Scalar: values array_sub'); +is(values array_sub() ,3, 'Scalar: values array_sub()'); +is(values $obj->array ,3, 'Scalar: values $obj->array'); + +# Values -- list + +$h_expect = j(values %$hash); +$a_expect = j(values @$array); + +is(j(values $hash) ,$h_expect, 'List: values $hash'); +is(j(values $data->{hash}) ,$h_expect, 'List: values $data->{hash}'); +is(j(values CONST_HASH) ,$h_expect, 'List: values CONST_HASH'); +is(j(values CONST_HASH()) ,$h_expect, 'List: values CONST_HASH()'); +is(j(values hash_sub) ,$h_expect, 'List: values hash_sub'); +is(j(values hash_sub()) ,$h_expect, 'List: values hash_sub()'); +is(j(values $obj->hash) ,$h_expect, 'List: values $obj->hash'); +is(j(values $array) ,$a_expect, 'List: values $array'); +is(j(values $data->{array}) ,$a_expect, 'List: values $data->{array}'); +is(j(values CONST_ARRAY) ,$a_expect, 'List: values CONST_ARRAY'); +is(j(values CONST_ARRAY()) ,$a_expect, 'List: values CONST_ARRAY()'); +is(j(values array_sub) ,$a_expect, 'List: values array_sub'); +is(j(values array_sub()) ,$a_expect, 'List: values array_sub()'); +is(j(values $obj->array) ,$a_expect, 'List: values $obj->array'); + +# Values -- undef + +undef $empty; +is(j(values undef), '', 'Undef: values undef is empty list'); +is(j(values $empty), '', 'Undef: values $empty is empty list'); +is($empty, undef, 'Undef: $empty is not vivified'); + +# Values -- vivification +is(j(values $empty->{hash}), '', 'Vivify: values $empty->{hash}'); +ok(defined $empty , 'Vivify: $empty is HASHREF'); +ok(!defined $empty->{hash} , 'Vivify: $empty->{hash} is undef'); + +# Values -- errors +eval "values 3"; +ok($@ =~ qr/Type of argument to values on reference must be hashref or arrayref/, + 'Errors: values CONSTANT throws error' +); + +eval "values qr/foo/"; +ok($@ =~ qr/Type of argument to values on reference must be hashref or arrayref/, + 'Errors: values qr/foo/ throws error' +); + +eval "values $hash qw/fo bar/"; +ok($@ =~ qr/syntax error/, + 'Errors: values $hash, @stuff throws error' +) or print "# Got: $@"; + +# Each -- void + +each $hash; pass('Void: each $hash'); +each $data->{hash}; pass('Void: each $data->{hash}'); +each CONST_HASH; pass('Void: each CONST_HASH'); +each CONST_HASH(); pass('Void: each CONST_HASH()'); +each hash_sub(); pass('Void: each hash_sub()'); +each hash_sub; pass('Void: each hash_sub'); +each $obj->hash; pass('Void: each $obj->hash'); +each $array; pass('Void: each $array'); +each $data->{array}; pass('Void: each $data->{array}'); +each CONST_ARRAY; pass('Void: each CONST_ARRAY'); +each CONST_ARRAY(); pass('Void: each CONST_ARRAY()'); +each array_sub; pass('Void: each array_sub'); +each array_sub(); pass('Void: each array_sub()'); +each $obj->array; pass('Void: each $obj->array'); + +# Reset iterators + +keys $hash; +keys $data->{hash}; +keys CONST_HASH; +keys CONST_HASH(); +keys hash_sub(); +keys hash_sub; +keys $obj->hash; +keys $array; +keys $data->{array}; +keys CONST_ARRAY; +keys CONST_ARRAY(); +keys array_sub; +keys array_sub(); +keys $obj->array; + +# Each -- scalar + +@tmp=(); while(defined( $k = each $hash)) {push @tmp,$k}; is(j(@tmp),j(keys $hash), 'Scalar: each $hash'); +@tmp=(); while(defined( $k = each $data->{hash})){push @tmp,$k}; is(j(@tmp),j(keys $data->{hash}), 'Scalar: each $data->{hash}'); +@tmp=(); while(defined( $k = each CONST_HASH)){push @tmp,$k}; is(j(@tmp),j(keys CONST_HASH), 'Scalar: each CONST_HASH'); +@tmp=(); while(defined( $k = each CONST_HASH())){push @tmp,$k}; is(j(@tmp),j(keys CONST_HASH()), 'Scalar: each CONST_HASH()'); +@tmp=(); while(defined( $k = each hash_sub())){push @tmp,$k}; is(j(@tmp),j(keys hash_sub()), 'Scalar: each hash_sub()'); +@tmp=(); while(defined( $k = each hash_sub)){push @tmp,$k}; is(j(@tmp),j(keys hash_sub), 'Scalar: each hash_sub'); +@tmp=(); while(defined( $k = each $obj->hash)){push @tmp,$k}; is(j(@tmp),j(keys $obj->hash), 'Scalar: each $obj->hash'); +@tmp=(); while(defined( $k = each $array)){push @tmp,$k}; is(j(@tmp),j(keys $array), 'Scalar: each $array'); +@tmp=(); while(defined( $k = each $data->{array})){push @tmp,$k}; is(j(@tmp),j(keys $data->{array}), 'Scalar: each $data->{array}'); +@tmp=(); while(defined( $k = each CONST_ARRAY)){push @tmp,$k}; is(j(@tmp),j(keys CONST_ARRAY), 'Scalar: each CONST_ARRAY'); +@tmp=(); while(defined( $k = each CONST_ARRAY())){push @tmp,$k}; is(j(@tmp),j(keys CONST_ARRAY()), 'Scalar: each CONST_ARRAY()'); +@tmp=(); while(defined( $k = each array_sub)){push @tmp,$k}; is(j(@tmp),j(keys array_sub), 'Scalar: each array_sub'); +@tmp=(); while(defined( $k = each array_sub())){push @tmp,$k}; is(j(@tmp),j(keys array_sub()), 'Scalar: each array_sub()'); +@tmp=(); while(defined( $k = each $obj->array)){push @tmp,$k}; is(j(@tmp),j(keys $obj->array), 'Scalar: each $obj->array'); + +# Each -- list + +@tmp=@tmp2=(); while(($k,$v) = each $hash) {push @tmp,$k; push @tmp2,$v}; is(j(@tmp,@tmp2),j(keys $hash, values $hash), 'List: each $hash'); +@tmp=@tmp2=(); while(($k,$v) = each $data->{hash}){push @tmp,$k; push @tmp2,$v}; is(j(@tmp,@tmp2),j(keys $data->{hash}, values $data->{hash}), 'List: each $data->{hash}'); +@tmp=@tmp2=(); while(($k,$v) = each CONST_HASH){push @tmp,$k; push @tmp2,$v}; is(j(@tmp,@tmp2),j(keys CONST_HASH, values CONST_HASH), 'List: each CONST_HASH'); +@tmp=@tmp2=(); while(($k,$v) = each CONST_HASH()){push @tmp,$k; push @tmp2,$v}; is(j(@tmp,@tmp2),j(keys CONST_HASH(), values CONST_HASH()), 'List: each CONST_HASH()'); +@tmp=@tmp2=(); while(($k,$v) = each hash_sub()){push @tmp,$k; push @tmp2,$v}; is(j(@tmp,@tmp2),j(keys hash_sub(), values hash_sub()), 'List: each hash_sub()'); +@tmp=@tmp2=(); while(($k,$v) = each hash_sub){push @tmp,$k; push @tmp2,$v}; is(j(@tmp,@tmp2),j(keys hash_sub, values hash_sub), 'List: each hash_sub'); +@tmp=@tmp2=(); while(($k,$v) = each $obj->hash){push @tmp,$k; push @tmp2,$v}; is(j(@tmp,@tmp2),j(keys $obj->hash, values $obj->hash), 'List: each $obj->hash'); +@tmp=@tmp2=(); while(($k,$v) = each $array){push @tmp,$k; push @tmp2,$v}; is(j(@tmp,@tmp2),j(keys $array, values $array), 'List: each $array'); +@tmp=@tmp2=(); while(($k,$v) = each $data->{array}){push @tmp,$k; push @tmp2,$v}; is(j(@tmp,@tmp2),j(keys $data->{array}, values $data->{array}), 'List: each $data->{array}'); +@tmp=@tmp2=(); while(($k,$v) = each CONST_ARRAY){push @tmp,$k; push @tmp2,$v}; is(j(@tmp,@tmp2),j(keys CONST_ARRAY, values CONST_ARRAY), 'List: each CONST_ARRAY'); +@tmp=@tmp2=(); while(($k,$v) = each CONST_ARRAY()){push @tmp,$k; push @tmp2,$v}; is(j(@tmp,@tmp2),j(keys CONST_ARRAY(), values CONST_ARRAY()), 'List: each CONST_ARRAY()'); +@tmp=@tmp2=(); while(($k,$v) = each array_sub){push @tmp,$k; push @tmp2,$v}; is(j(@tmp,@tmp2),j(keys array_sub, values array_sub), 'List: each array_sub'); +@tmp=@tmp2=(); while(($k,$v) = each array_sub()){push @tmp,$k; push @tmp2,$v}; is(j(@tmp,@tmp2),j(keys array_sub(), values array_sub()), 'List: each array_sub()'); +@tmp=@tmp2=(); while(($k,$v) = each $obj->array){push @tmp,$k; push @tmp2,$v}; is(j(@tmp,@tmp2),j(keys $obj->array, values $obj->array), 'List: each $obj->array'); + +# Each -- undef + +undef $empty; +is(j(@{[each undef]}), '', 'Undef: each undef is empty list'); +is(j(@{[each $empty]}), '', 'Undef: each $empty is empty list'); +is($empty, undef, 'Undef: $empty is not vivified'); + +# Values -- vivification +is(j(@{[each $empty->{hash}]}), '', 'Vivify: each $empty->{hash} is empty list'); +ok(defined $empty , 'Vivify: $empty is HASHREF'); +ok(!defined $empty->{hash} , 'Vivify: $empty->{hash} is undef'); + +# Values -- errors +eval "each 3"; +ok($@ =~ qr/Type of argument to each on reference must be hashref or arrayref/, + 'Errors: each CONSTANT throws error' +); + +eval "each qr/foo/"; +ok($@ =~ qr/Type of argument to each on reference must be hashref or arrayref/, + 'Errors: each qr/foo/ throws error' +); + +eval "each $hash qw/foo bar/"; +ok($@ =~ qr/syntax error/, + 'Errors: each $hash, @stuff throws error' +) or print "# Got: $@"; + +# Overloaded objects +my $over_a = Foo::Overload::Array->new; +my $over_h = Foo::Overload::Hash->new; +my $over_b = Foo::Overload::Both->new; +my $over_h_a = Foo::Overload::HashOnArray->new; +my $over_a_h = Foo::Overload::ArrayOnHash->new; + +my $re_warn_array = qr/Ambiguous overloaded argument to keys on reference resolved as \@\{\}/; +my $re_warn_hash = qr/Ambiguous overloaded argument to keys on reference resolved as \%\{\}/; + +{ + my $warn = ''; + local $SIG{__WARN__} = sub { $warn = shift }; + + is(j(keys $over_a), j(keys @$array), "Overload: array dereference"); + is($warn, '', "no warning issued"); $warn = ''; + + is(j(keys $over_h), j(keys %$hash), "Overload: hash dereference"); + is($warn, '', "no warning issued"); $warn = ''; + + is(j(keys $over_b), j(keys %$hash), "Overload: ambiguous dereference (both) resolves to hash"); + like($warn, $re_warn_hash, "warning correct"); $warn = ''; + + is(j(keys $over_h_a), j(keys %$hash), "Overload: ambiguous dereference resolves to hash"); + like($warn, $re_warn_hash, "warning correct"); $warn = ''; + + is(j(keys $over_a_h), j(keys @$array), "Overload: ambiguous dereference resolves to array"); + like($warn, $re_warn_array, "warning correct"); $warn = ''; +} diff --git a/t/op/splice.t b/t/op/splice.t index 93718a15cb..07a3e6723c 100644 --- a/t/op/splice.t +++ b/t/op/splice.t @@ -1,6 +1,6 @@ #!./perl -print "1..20\n"; +print "1..21\n"; @a = (1..10); @@ -92,3 +92,8 @@ splice @Foo::ISA, 0, 0, 'Bar'; print "not " if !Foo->isa('Bar'); print "ok 20\n"; + +# Test vivification +splice( $new_arrayref, 0, 0, 1, 2, 3 ); +print "not " unless j(@$new_arrayref) eq j(1,2,3); +print "ok 21\n"; diff --git a/t/op/unshift.t b/t/op/unshift.t index 9659ee47a0..475b3e7011 100644 --- a/t/op/unshift.t +++ b/t/op/unshift.t @@ -4,64 +4,98 @@ BEGIN { require "test.pl"; } -plan(18); +plan(36); @array = (1, 2, 3); +$aref = [1, 2, 3]; { no warnings 'syntax'; $count3 = unshift (@array); + $count3r = unshift ($aref); } is(join(' ',@array), '1 2 3', 'unshift null'); cmp_ok($count3, '==', 3, 'unshift count == 3'); +is(join(' ',@$aref), '1 2 3', 'unshift null (ref)'); +cmp_ok($count3r, '==', 3, 'unshift count == 3 (ref)'); + $count3_2 = unshift (@array, ()); is(join(' ',@array), '1 2 3', 'unshift null empty'); cmp_ok($count3_2, '==', 3, 'unshift count == 3 again'); +$count3_2r = unshift ($aref, ()); +is(join(' ',@$aref), '1 2 3', 'unshift null empty (ref)'); +cmp_ok($count3_2r, '==', 3, 'unshift count == 3 again (ref)'); $count4 = unshift (@array, 0); is(join(' ',@array), '0 1 2 3', 'unshift singleton list'); cmp_ok($count4, '==', 4, 'unshift count == 4'); +$count4r = unshift ($aref, 0); +is(join(' ',@$aref), '0 1 2 3', 'unshift singleton list (ref)'); +cmp_ok($count4r, '==', 4, 'unshift count == 4 (ref)'); $count7 = unshift (@array, 3, 2, 1); is(join(' ',@array), '3 2 1 0 1 2 3', 'unshift list'); cmp_ok($count7, '==', 7, 'unshift count == 7'); +$count7r = unshift ($aref, 3, 2, 1); +is(join(' ',@$aref), '3 2 1 0 1 2 3', 'unshift list (ref)'); +cmp_ok($count7r, '==', 7, 'unshift count == 7 (ref)'); @list = (5, 4); $count9 = unshift (@array, @list); is(join(' ',@array), '5 4 3 2 1 0 1 2 3', 'unshift array'); cmp_ok($count9, '==', 9, 'unshift count == 9'); +$count9r = unshift ($aref, @list); +is(join(' ',@$aref), '5 4 3 2 1 0 1 2 3', 'unshift array (ref)'); +cmp_ok($count9r, '==', 9, 'unshift count == 9 (ref)'); + @list = (7); @list2 = (6); $count11 = unshift (@array, @list, @list2); is(join(' ',@array), '7 6 5 4 3 2 1 0 1 2 3', 'unshift arrays'); cmp_ok($count11, '==', 11, 'unshift count == 11'); +$count11r = unshift ($aref, @list, @list2); +is(join(' ',@$aref), '7 6 5 4 3 2 1 0 1 2 3', 'unshift arrays (ref)'); +cmp_ok($count11r, '==', 11, 'unshift count == 11 (ref)'); # ignoring counts @alpha = ('y', 'z'); +$alpharef = ['y', 'z']; { no warnings 'syntax'; unshift (@alpha); + unshift ($alpharef); } is(join(' ',@alpha), 'y z', 'void unshift null'); +is(join(' ',@$alpharef), 'y z', 'void unshift null (ref)'); unshift (@alpha, ()); is(join(' ',@alpha), 'y z', 'void unshift null empty'); +unshift ($alpharef, ()); +is(join(' ',@$alpharef), 'y z', 'void unshift null empty (ref)'); unshift (@alpha, 'x'); is(join(' ',@alpha), 'x y z', 'void unshift singleton list'); +unshift ($alpharef, 'x'); +is(join(' ',@$alpharef), 'x y z', 'void unshift singleton list (ref)'); unshift (@alpha, 'u', 'v', 'w'); is(join(' ',@alpha), 'u v w x y z', 'void unshift list'); +unshift ($alpharef, 'u', 'v', 'w'); +is(join(' ',@$alpharef), 'u v w x y z', 'void unshift list (ref)'); @bet = ('s', 't'); unshift (@alpha, @bet); is(join(' ',@alpha), 's t u v w x y z', 'void unshift array'); +unshift ($alpharef, @bet); +is(join(' ',@$alpharef), 's t u v w x y z', 'void unshift array (ref)'); @bet = ('q'); @gimel = ('r'); unshift (@alpha, @bet, @gimel); is(join(' ',@alpha), 'q r s t u v w x y z', 'void unshift arrays'); +unshift ($alpharef, @bet, @gimel); +is(join(' ',@$alpharef), 'q r s t u v w x y z', 'void unshift arrays (ref)'); |