From: Tassilo von Parseval Date: Sat, 6 Dec 2003 11:50:59 +0000 (+0100) Subject: SCALAR/FIRSTKEY for tied hashes in scalar context X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=a3bcc51ebd4e201d85a37d8410b7a375b8d94244;p=p5sagit%2Fp5-mst-13.2.git SCALAR/FIRSTKEY for tied hashes in scalar context Message-id: <20031206105059.GA13989@ethan> p4raw-id: //depot/perl@21855 --- diff --git a/embed.fnc b/embed.fnc index b206c92..52e3465 100644 --- 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 --- a/embed.h +++ b/embed.h @@ -340,6 +340,7 @@ #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 @@ -536,6 +537,9 @@ #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 @@ -2837,6 +2841,7 @@ #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) @@ -3032,6 +3037,9 @@ #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 diff --git a/global.sym b/global.sym index 9fd5974..b79b946 100644 --- a/global.sym +++ b/global.sym @@ -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 --- 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 diff --git a/lib/Tie/Hash.pm b/lib/Tie/Hash.pm index 65f9dd0..6f8c34f 100644 --- a/lib/Tie/Hash.pm +++ b/lib/Tie/Hash.pm @@ -105,6 +105,13 @@ Delete the key I from the tied hash I. Clear all values from the tied hash I. +=item SCALAR this + +Returns what evaluating the hash in scalar context yields. + +B does not implement this method (but B +and B do). + =back =head1 Inheriting from B @@ -131,7 +138,7 @@ should operate on the hash referenced by the first argument: =head1 Inheriting from B 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[0]>. Thus overwritten C 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 does not need to overwrite this method. -=head1 C and C +=head1 C, C and C The methods C and C are not defined in B, B, or B. Tied hashes do not require presense of these methods, but if defined, the methods will be called in proper time, see L. +C is only defined in B and B. + If needed, these methods should be defined by the package inheriting from -B, B, or B. +B, B, or B. See L +to find out what happens when C 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 --- 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) { diff --git a/pod/perlapi.pod b/pod/perlapi.pod index 5532e63..5a1bc57 100644 --- a/pod/perlapi.pod +++ b/pod/perlapi.pod @@ -1280,6 +1280,15 @@ Adds magic to a hash. See C. =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 and C is diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod index 2dbe740..7c69ff6 100644 --- a/pod/perlfunc.pod +++ b/pod/perlfunc.pod @@ -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 diff --git a/pod/perltie.pod b/pod/perltie.pod index b81a51b..468855c 100644 --- a/pod/perltie.pod +++ b/pod/perltie.pod @@ -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 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 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 on the underlying hash +referenced by C<$self-E{LIST}>: + + sub SCALAR { + carp &whowasi if $DEBUG; + my $self = shift; + return scalar %{ $self->{LIST} } + } + =item UNTIE this This is called when C occurs. See L Gotcha> below. @@ -1107,4 +1127,6 @@ TIEHANDLE by Sven Verdoolaege > and Doug MacEachern > +SCALAR by Tassilo von Parseval > + Tying Arrays by Casey West > diff --git a/pp.c b/pp.c index c431ffa..7872c1e 100644 --- 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; diff --git a/pp_hot.c b/pp_hot.c index efc7a27..d8ccf6d 100644 --- 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 --- 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); diff --git a/t/op/tie.t b/t/op/tie.t index 22be612..bd1e980 100755 --- a/t/op/tie.t +++ b/t/op/tie.t @@ -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