This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Allow push/pop/keys/etc to act on references
authorDavid Golden <dagolden@cpan.org>
Thu, 9 Sep 2010 21:22:02 +0000 (17:22 -0400)
committerDavid Golden <dagolden@cpan.org>
Mon, 1 Nov 2010 01:16:21 +0000 (21:16 -0400)
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

19 files changed:
MANIFEST
doop.c
embed.h
op.c
opcode.h
opnames.h
pod/perldelta.pod
pod/perldiag.pod
pod/perlfunc.pod
pod/perlsub.pod
pp.c
pp.sym
proto.h
regen/opcode.pl
t/op/cproto.t
t/op/push.t
t/op/smartkve.t [new file with mode: 0644]
t/op/splice.t
t/op/unshift.t

index 3c3c42f..e28bb8a 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -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
diff --git a/doop.c b/doop.c
index 35efba6..550e6fb 100644 (file)
--- a/doop.c
+++ b/doop.c
@@ -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 */
diff --git a/embed.h b/embed.h
index 134c349..31cd119 100644 (file)
--- a/embed.h
+++ b/embed.h
 #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)
 #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)
 #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)
diff --git a/op.c b/op.c
index ce9c220..290f11a 100644 (file)
--- a/op.c
+++ b/op.c
@@ -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 *
index b670675..c7a304d 100644 (file)
--- a/opcode.h
+++ b/opcode.h
@@ -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
 
index 07626d4..26c3ba1 100644 (file)
--- a/opnames.h
+++ b/opnames.h
@@ -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
 
index cc5cc23..c0a55cd 100644 (file)
@@ -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
index 7bbccdd..3f467af 100644 (file)
@@ -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
index 185ad7f..7311d8b 100644 (file)
@@ -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
index c16db28..cfa4ad4 100644 (file)
@@ -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, @_;
diff --git a/pp.c b/pp.c
index c73fdbf..4e45555 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -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);
diff --git a/pp.sym b/pp.sym
index 611550e..095ee2e 100644 (file)
--- a/pp.sym
+++ b/pp.sym
@@ -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:
diff --git a/proto.h b/proto.h
index 8cc3281..151baf8 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -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);
index d1a47d5..9369c2e 100755 (executable)
@@ -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
index 3e3c0de..b1a4944 100644 (file)
@@ -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 ($$)
index 2024706..2804d5b 100644 (file)
@@ -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 (file)
index 0000000..4cb19f5
--- /dev/null
@@ -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 = '';
+}
index 93718a1..07a3e67 100644 (file)
@@ -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";
index 9659ee4..475b3e7 100644 (file)
@@ -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)');