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
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
#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
Perl_hv_iterval
Perl_hv_ksplit
Perl_hv_magic
+Perl_hv_scalar
Perl_hv_store
Perl_hv_store_ent
Perl_hv_store_flags
}
/*
+=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
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>
=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] } >>:
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
sub EXISTS { exists $_[0]->{$_[1]} }
sub DELETE { delete $_[0]->{$_[1]} }
sub CLEAR { %{$_[0]} = () }
+sub SCALAR { scalar %{$_[0]} }
package Tie::ExtraHash;
sub EXISTS { exists $_[0][0]->{$_[1]} }
sub DELETE { delete $_[0][0]->{$_[1]} }
sub CLEAR { %{$_[0][0]} = () }
+sub SCALAR { scalar %{$_[0][0]} }
1;
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;
}
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)
{
=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
EXISTS this, key
FIRSTKEY this
NEXTKEY this, lastkey
+ SCALAR this
DESTROY this
UNTIE this
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
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.
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>>
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;
}
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;
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);
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);
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
projects / p5sagit/p5-mst-13.2.git / commitdiff