This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
SCALAR/FIRSTKEY for tied hashes in scalar context
authorTassilo von Parseval <tassilo.parseval@post.rwth-aachen.de>
Sat, 6 Dec 2003 11:50:59 +0000 (12:50 +0100)
committerRafael Garcia-Suarez <rgarciasuarez@gmail.com>
Sat, 6 Dec 2003 19:50:07 +0000 (19:50 +0000)
Message-id: <20031206105059.GA13989@ethan>

p4raw-id: //depot/perl@21855

13 files changed:
embed.fnc
embed.h
global.sym
hv.c
lib/Tie/Hash.pm
mg.c
pod/perlapi.pod
pod/perlfunc.pod
pod/perltie.pod
pp.c
pp_hot.c
proto.h
t/op/tie.t

index b206c92..52e3465 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -280,6 +280,7 @@ ApMd        |HE*    |hv_iternext_flags|HV* tb|I32 flags
 Apd    |SV*    |hv_iterval     |HV* tb|HE* entry
 Ap     |void   |hv_ksplit      |HV* hv|IV newmax
 Apd    |void   |hv_magic       |HV* hv|GV* gv|int how
+Apd    |SV*    |hv_scalar      |HV* hv|
 Apd    |SV**   |hv_store       |HV* tb|const char* key|I32 klen|SV* val \
                                |U32 hash
 Apd    |HE*    |hv_store_ent   |HV* tb|SV* key|SV* val|U32 hash
@@ -397,6 +398,7 @@ p   |int    |magic_nextpack |SV* sv|MAGIC* mg|SV* key
 p      |U32    |magic_regdata_cnt|SV* sv|MAGIC* mg
 p      |int    |magic_regdatum_get|SV* sv|MAGIC* mg
 p      |int    |magic_regdatum_set|SV* sv|MAGIC* mg
+p      |SV*    |magic_scalarpack|HV* hv|MAGIC* mg
 p      |int    |magic_set      |SV* sv|MAGIC* mg
 p      |int    |magic_setamagic|SV* sv|MAGIC* mg
 p      |int    |magic_setarylen|SV* sv|MAGIC* mg
diff --git a/embed.h b/embed.h
index bace751..2d195b6 100644 (file)
--- a/embed.h
+++ b/embed.h
 #define hv_iterval             Perl_hv_iterval
 #define hv_ksplit              Perl_hv_ksplit
 #define hv_magic               Perl_hv_magic
+#define hv_scalar              Perl_hv_scalar
 #define hv_store               Perl_hv_store
 #define hv_store_ent           Perl_hv_store_ent
 #define hv_store_flags         Perl_hv_store_flags
 #define magic_regdatum_set     Perl_magic_regdatum_set
 #endif
 #ifdef PERL_CORE
+#define magic_scalarpack       Perl_magic_scalarpack
+#endif
+#ifdef PERL_CORE
 #define magic_set              Perl_magic_set
 #endif
 #ifdef PERL_CORE
 #define hv_iterval(a,b)                Perl_hv_iterval(aTHX_ a,b)
 #define hv_ksplit(a,b)         Perl_hv_ksplit(aTHX_ a,b)
 #define hv_magic(a,b,c)                Perl_hv_magic(aTHX_ a,b,c)
+#define hv_scalar(a)           Perl_hv_scalar(aTHX_ a)
 #define hv_store(a,b,c,d,e)    Perl_hv_store(aTHX_ a,b,c,d,e)
 #define hv_store_ent(a,b,c,d)  Perl_hv_store_ent(aTHX_ a,b,c,d)
 #define hv_store_flags(a,b,c,d,e,f)    Perl_hv_store_flags(aTHX_ a,b,c,d,e,f)
 #define magic_regdatum_set(a,b)        Perl_magic_regdatum_set(aTHX_ a,b)
 #endif
 #ifdef PERL_CORE
+#define magic_scalarpack(a,b)  Perl_magic_scalarpack(aTHX_ a,b)
+#endif
+#ifdef PERL_CORE
 #define magic_set(a,b)         Perl_magic_set(aTHX_ a,b)
 #endif
 #ifdef PERL_CORE
index 9fd5974..b79b946 100644 (file)
@@ -156,6 +156,7 @@ Perl_hv_iternext_flags
 Perl_hv_iterval
 Perl_hv_ksplit
 Perl_hv_magic
+Perl_hv_scalar
 Perl_hv_store
 Perl_hv_store_ent
 Perl_hv_store_flags
diff --git a/hv.c b/hv.c
index 39684b0..ec616c0 100644 (file)
--- a/hv.c
+++ b/hv.c
@@ -786,6 +786,35 @@ S_hv_magic_check(pTHX_ HV *hv, bool *needs_copy, bool *needs_store)
 }
 
 /*
+=for apidoc hv_scalar
+
+Evaluates the hash in scalar context and returns the result. Handles magic when the hash is tied.
+
+=cut
+*/
+
+SV *
+Perl_hv_scalar(pTHX_ HV *hv)
+{
+    MAGIC *mg;
+    SV *sv;
+    
+    if ((SvRMAGICAL(hv) && (mg = mg_find((SV*)hv, PERL_MAGIC_tied)))) {
+        sv = magic_scalarpack(hv, mg);
+        return sv;
+    } 
+
+    sv = sv_newmortal();
+    if (HvFILL((HV*)hv)) 
+        Perl_sv_setpvf(aTHX_ sv, "%ld/%ld",
+                (long)HvFILL(hv), (long)HvMAX(hv) + 1);
+    else
+        sv_setiv(sv, 0);
+    
+    return sv;
+}
+
+/*
 =for apidoc hv_delete
 
 Deletes a key/value pair in the hash.  The value SV is removed from the
index 65f9dd0..6f8c34f 100644 (file)
@@ -105,6 +105,13 @@ Delete the key I<key> from the tied hash I<this>.
 
 Clear all values from the tied hash I<this>.
 
+=item SCALAR this
+
+Returns what evaluating the hash in scalar context yields.
+
+B<Tie::Hash> does not implement this method (but B<Tie::StdHash>
+and B<Tie::ExtraHash> do).
+
 =back
 
 =head1 Inheriting from B<Tie::StdHash>
@@ -131,7 +138,7 @@ should operate on the hash referenced by the first argument:
 =head1 Inheriting from B<Tie::ExtraHash>
 
 The accessor methods assume that the actual storage for the data in the tied
-hash is in the hash referenced by C<(tied(%tiedhash))[0]>.  Thus overwritten
+hash is in the hash referenced by C<(tied(%tiedhash))-E<gt>[0]>.  Thus overwritten
 C<TIEHASH> method should return an array reference with the first
 element being a hash reference, and the remaining methods should operate on the
 hash C<< %{ $_[0]->[0] } >>:
@@ -156,15 +163,18 @@ same storage algorithm as in TIEHASH subroutine above.  Hence, a typical
 package inheriting from B<Tie::ExtraHash> does not need to overwrite this
 method.
 
-=head1 C<UNTIE> and C<DESTROY>
+=head1 C<SCALAR>, C<UNTIE> and C<DESTROY>
 
 The methods C<UNTIE> and C<DESTROY> are not defined in B<Tie::Hash>,
 B<Tie::StdHash>, or B<Tie::ExtraHash>.  Tied hashes do not require
 presense of these methods, but if defined, the methods will be called in
 proper time, see L<perltie>.
 
+C<SCALAR> is only defined in B<Tie::StdHash> and B<Tie::ExtraHash>.
+
 If needed, these methods should be defined by the package inheriting from
-B<Tie::Hash>, B<Tie::StdHash>, or B<Tie::ExtraHash>.
+B<Tie::Hash>, B<Tie::StdHash>, or B<Tie::ExtraHash>. See L<pertie/"SCALAR">
+to find out what happens when C<SCALAR> does not exist.
 
 =head1 MORE INFORMATION
 
@@ -230,6 +240,7 @@ sub NEXTKEY  { each %{$_[0]} }
 sub EXISTS   { exists $_[0]->{$_[1]} }
 sub DELETE   { delete $_[0]->{$_[1]} }
 sub CLEAR    { %{$_[0]} = () }
+sub SCALAR   { scalar %{$_[0]} }
 
 package Tie::ExtraHash;
 
@@ -241,5 +252,6 @@ sub NEXTKEY  { each %{$_[0][0]} }
 sub EXISTS   { exists $_[0][0]->{$_[1]} }
 sub DELETE   { delete $_[0][0]->{$_[1]} }
 sub CLEAR    { %{$_[0][0]} = () }
+sub SCALAR   { scalar %{$_[0][0]} }
 
 1;
diff --git a/mg.c b/mg.c
index 3e864da..2529ff7 100644 (file)
--- a/mg.c
+++ b/mg.c
@@ -1538,6 +1538,12 @@ Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
     call_method("CLEAR", G_SCALAR|G_DISCARD);
     POPSTACK;
     LEAVE;
+
+    if (SvTYPE(sv) == SVt_PVHV)
+        /* must reset iterator otherwise Perl_magic_scalarpack
+         * wont report a false value on a cleared hash */
+        HvEITER((HV*)sv) = NULL;
+    
     return 0;
 }
 
@@ -1572,6 +1578,41 @@ Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg)
     return magic_methpack(sv,mg,"EXISTS");
 }
 
+SV *
+Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
+{
+    dSP;
+    SV *retval = &PL_sv_undef;
+    SV *tied = SvTIED_obj((SV*)hv, mg);
+    HV *pkg = SvSTASH((SV*)SvRV(tied));
+   
+    if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
+        SV *key;
+        if (HvEITER(hv))
+            /* we are in an iteration so the hash cannot be empty */
+            return &PL_sv_yes;
+        /* no xhv_eiter so now use FIRSTKEY */
+        key = sv_newmortal();
+        magic_nextpack((SV*)hv, mg, key);
+        HvEITER(hv) = NULL;     /* need to reset iterator */
+        return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
+    }
+   
+    /* there is a SCALAR method that we can call */
+    ENTER;
+    PUSHSTACKi(PERLSI_MAGIC);
+    PUSHMARK(SP);
+    EXTEND(SP, 1);
+    PUSHs(tied);
+    PUTBACK;
+
+    if (call_method("SCALAR", G_SCALAR))
+        retval = *PL_stack_sp--; 
+    POPSTACK;
+    LEAVE;
+    return retval;
+}
+
 int
 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
 {
index 5532e63..5a1bc57 100644 (file)
@@ -1280,6 +1280,15 @@ Adds magic to a hash.  See C<sv_magic>.
 =for hackers
 Found in file hv.c
 
+=item hv_scalar
+
+Evaluates the hash in scalar context and returns the result. Handles magic when the hash is tied.
+
+       SV*     hv_scalar(HV* hv)
+
+=for hackers
+Found in file hv.c
+
 =item hv_store
 
 Stores an SV in a hash.  The hash key is specified as C<key> and C<klen> is
index 2dbe740..7c69ff6 100644 (file)
@@ -5871,6 +5871,7 @@ A class implementing a hash should have the following methods:
     EXISTS this, key
     FIRSTKEY this
     NEXTKEY this, lastkey
+    SCALAR this
     DESTROY this
     UNTIE this
 
index b81a51b..468855c 100644 (file)
@@ -474,7 +474,8 @@ the constructor.  FETCH and STORE access the key and value pairs.  EXISTS
 reports whether a key is present in the hash, and DELETE deletes one.
 CLEAR empties the hash by deleting all the key and value pairs.  FIRSTKEY
 and NEXTKEY implement the keys() and each() functions to iterate over all
-the keys.  UNTIE is called when C<untie> happens, and DESTROY is called when
+the keys. SCALAR is triggered when the tied hash is evaluated in scalar 
+context. UNTIE is called when C<untie> happens, and DESTROY is called when
 the tied variable is garbage collected.
 
 If this seems like a lot, then feel free to inherit from merely the
@@ -757,6 +758,25 @@ thing, but we'll have to go through the LIST field indirectly.
        return each %{ $self->{LIST} }
     }
 
+=item SCALAR this
+
+This is called when the hash is evaluated in scalar context. In order
+to mimic the behaviour of untied hashes, this method should return a
+false value when the tied hash is considered empty. If this method does
+not exist, perl will make some educated guesses and return false when
+the hash is not inside an iteration. In this case, FIRSTKEY is called
+and the result will be a false value if FIRSTKEY returns the empty list,
+true otherwise.
+
+In our example we can just call C<scalar> on the underlying hash
+referenced by C<$self-E<gt>{LIST}>:
+
+    sub SCALAR {
+       carp &whowasi if $DEBUG;
+       my $self = shift;
+       return scalar %{ $self->{LIST} }
+    }
+
 =item UNTIE this
 
 This is called when C<untie> occurs.  See L<The C<untie> Gotcha> below.
@@ -1107,4 +1127,6 @@ TIEHANDLE by Sven Verdoolaege <F<skimo@dns.ufsia.ac.be>> and Doug MacEachern <F<
 
 UNTIE by Nick Ing-Simmons <F<nick@ing-simmons.net>>
 
+SCALAR by Tassilo von Parseval <F<tassilo.von.parseval@rwth-aachen.de>>
+
 Tying Arrays by Casey West <F<casey@geeknest.com>>
diff --git a/pp.c b/pp.c
index c431ffa..7872c1e 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -106,15 +106,7 @@ PP(pp_padhv)
        RETURNOP(do_kv());
     }
     else if (gimme == G_SCALAR) {
-       SV* sv = sv_newmortal();
-        if (SvRMAGICAL(TARG) && mg_find(TARG, PERL_MAGIC_tied))
-            Perl_croak(aTHX_ "Can't provide tied hash usage; "
-                       "use keys(%%hash) to test if empty");
-       if (HvFILL((HV*)TARG))
-           Perl_sv_setpvf(aTHX_ sv, "%ld/%ld",
-                     (long)HvFILL((HV*)TARG), (long)HvMAX((HV*)TARG) + 1);
-       else
-           sv_setiv(sv, 0);
+       SV* sv = Perl_hv_scalar((HV*)TARG);
        SETs(sv);
     }
     RETURN;
index efc7a27..d8ccf6d 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -901,15 +901,7 @@ PP(pp_rv2hv)
     }
     else if (gimme == G_SCALAR) {
        dTARGET;
-       if (SvRMAGICAL(hv) && mg_find((SV *)hv, PERL_MAGIC_tied))
-           Perl_croak(aTHX_ "Can't provide tied hash usage; "
-                      "use keys(%%hash) to test if empty");
-       if (HvFILL(hv))
-            Perl_sv_setpvf(aTHX_ TARG, "%"IVdf"/%"IVdf,
-                          (IV)HvFILL(hv), (IV)HvMAX(hv) + 1);
-       else
-           sv_setiv(TARG, 0);
-       
+    TARG = Perl_hv_scalar(hv);
        SETTARG;
     }
     RETURN;
diff --git a/proto.h b/proto.h
index 810965a..ac4c39a 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -261,6 +261,7 @@ PERL_CALLCONV HE*   Perl_hv_iternext_flags(pTHX_ HV* tb, I32 flags);
 PERL_CALLCONV SV*      Perl_hv_iterval(pTHX_ HV* tb, HE* entry);
 PERL_CALLCONV void     Perl_hv_ksplit(pTHX_ HV* hv, IV newmax);
 PERL_CALLCONV void     Perl_hv_magic(pTHX_ HV* hv, GV* gv, int how);
+PERL_CALLCONV SV*      Perl_hv_scalar(pTHX_ HV* hv);
 PERL_CALLCONV SV**     Perl_hv_store(pTHX_ HV* tb, const char* key, I32 klen, SV* val, U32 hash);
 PERL_CALLCONV HE*      Perl_hv_store_ent(pTHX_ HV* tb, SV* key, SV* val, U32 hash);
 PERL_CALLCONV SV**     Perl_hv_store_flags(pTHX_ HV* tb, const char* key, I32 klen, SV* val, U32 hash, int flags);
@@ -376,6 +377,7 @@ PERL_CALLCONV int   Perl_magic_nextpack(pTHX_ SV* sv, MAGIC* mg, SV* key);
 PERL_CALLCONV U32      Perl_magic_regdata_cnt(pTHX_ SV* sv, MAGIC* mg);
 PERL_CALLCONV int      Perl_magic_regdatum_get(pTHX_ SV* sv, MAGIC* mg);
 PERL_CALLCONV int      Perl_magic_regdatum_set(pTHX_ SV* sv, MAGIC* mg);
+PERL_CALLCONV SV*      Perl_magic_scalarpack(pTHX_ HV* hv, MAGIC*      mg);
 PERL_CALLCONV int      Perl_magic_set(pTHX_ SV* sv, MAGIC* mg);
 PERL_CALLCONV int      Perl_magic_setamagic(pTHX_ SV* sv, MAGIC* mg);
 PERL_CALLCONV int      Perl_magic_setarylen(pTHX_ SV* sv, MAGIC* mg);
index 22be612..bd1e980 100755 (executable)
@@ -477,3 +477,98 @@ STORE set 'BOBBINS'
 FETCH
 FETCH
 joinBOBBINSthingsBOBBINSup
+########
+
+# test SCALAR method
+package TieScalar;
+
+sub TIEHASH {
+    my $pkg = shift;
+    bless { } => $pkg;
+}
+
+sub STORE {
+    $_[0]->{$_[1]} = $_[2];
+}
+
+sub FETCH {
+    $_[0]->{$_[1]}
+}
+
+sub CLEAR {
+    %{ $_[0] } = ();
+}
+
+sub SCALAR {
+    print "SCALAR\n";
+    return 0 if ! keys %{$_[0]};
+    sprintf "%i/%i", scalar keys %{$_[0]}, scalar keys %{$_[0]};
+}
+
+package main;
+tie my %h => "TieScalar";
+$h{key1} = "val1";
+$h{key2} = "val2";
+print scalar %h, "\n";
+%h = ();
+print scalar %h, "\n";
+EXPECT
+SCALAR
+2/2
+SCALAR
+0
+########
+
+# test scalar on tied hash when no SCALAR method has been given
+package TieScalar;
+
+sub TIEHASH {
+    my $pkg = shift;
+    bless { } => $pkg;
+}
+sub STORE {
+    $_[0]->{$_[1]} = $_[2];
+}
+sub FETCH {
+    $_[0]->{$_[1]}
+}
+sub CLEAR {
+    %{ $_[0] } = ();
+}
+sub FIRSTKEY {
+    my $a = keys %{ $_[0] };
+    print "FIRSTKEY\n";
+    each %{ $_[0] };
+}
+
+package main;
+tie my %h => "TieScalar";
+
+if (!%h) {
+    print "empty\n";
+} else {
+    print "not empty\n";
+}
+
+$h{key1} = "val1";
+print "not empty\n" if %h;
+print "not empty\n" if %h;
+print "-->\n";
+my ($k,$v) = each %h;
+print "<--\n";
+print "not empty\n" if %h;
+%h = ();
+print "empty\n" if ! %h;
+EXPECT
+FIRSTKEY
+empty
+FIRSTKEY
+not empty
+FIRSTKEY
+not empty
+-->
+FIRSTKEY
+<--
+not empty
+FIRSTKEY
+empty