#define av_undef pPerl->Perl_av_undef
#undef av_unshift
#define av_unshift pPerl->Perl_av_unshift
-#undef avhv_delete
-#define avhv_delete pPerl->Perl_avhv_delete
-#undef avhv_delete_ent
-#define avhv_delete_ent pPerl->Perl_avhv_delete_ent
-#undef avhv_exists
-#define avhv_exists pPerl->Perl_avhv_exists
#undef avhv_exists_ent
#define avhv_exists_ent pPerl->Perl_avhv_exists_ent
-#undef avhv_fetch
-#define avhv_fetch pPerl->Perl_avhv_fetch
#undef avhv_fetch_ent
#define avhv_fetch_ent pPerl->Perl_avhv_fetch_ent
#undef avhv_iternext
#define avhv_iternext pPerl->Perl_avhv_iternext
-#undef avhv_iternextsv
-#define avhv_iternextsv pPerl->Perl_avhv_iternextsv
#undef avhv_iterval
#define avhv_iterval pPerl->Perl_avhv_iterval
#undef avhv_keys
#define avhv_keys pPerl->Perl_avhv_keys
-#undef avhv_store
-#define avhv_store pPerl->Perl_avhv_store
-#undef avhv_store_ent
-#define avhv_store_ent pPerl->Perl_avhv_store_ent
#undef bind_match
#define bind_match pPerl->Perl_bind_match
#undef block_end
(void)av_store(av,fill,&sv_undef);
}
-
+
+/* AVHV: Support for treating arrays as if they were hashes. The
+ * first element of the array should be a hash reference that maps
+ * hash keys to array indices.
+ */
+
+static I32
+avhv_index_sv(SV* sv)
+{
+ I32 index = SvIV(sv);
+ if (index < 1)
+ croak("Bad index while coercing array into hash");
+ return index;
+}
+
HV*
avhv_keys(AV *av)
{
- SV **keysp;
- HV *keys = Nullhv;
-
- keysp = av_fetch(av, 0, FALSE);
+ SV **keysp = av_fetch(av, 0, FALSE);
if (keysp) {
SV *sv = *keysp;
if (SvGMAGICAL(sv))
if (SvROK(sv)) {
sv = SvRV(sv);
if (SvTYPE(sv) == SVt_PVHV)
- keys = (HV*)sv;
+ return (HV*)sv;
}
}
- if (!keys)
- croak("Can't coerce array into hash");
- return keys;
-}
-
-SV**
-avhv_fetch(AV *av, char *key, U32 klen, I32 lval)
-{
- SV **indsvp;
- HV *keys = avhv_keys(av);
- I32 ind;
-
- indsvp = hv_fetch(keys, key, klen, FALSE);
- if (indsvp) {
- ind = SvIV(*indsvp);
- if (ind < 1)
- croak("Bad index while coercing array into hash");
- } else {
- if (!lval)
- return 0;
-
- ind = AvFILL(av) + 1;
- hv_store(keys, key, klen, newSViv(ind), 0);
- }
- return av_fetch(av, ind, lval);
+ croak("Can't coerce array into hash");
}
SV**
SV **indsvp;
HV *keys = avhv_keys(av);
HE *he;
- I32 ind;
-
- he = hv_fetch_ent(keys, keysv, FALSE, hash);
- if (he) {
- ind = SvIV(HeVAL(he));
- if (ind < 1)
- croak("Bad index while coercing array into hash");
- } else {
- if (!lval)
- return 0;
-
- ind = AvFILL(av) + 1;
- hv_store_ent(keys, keysv, newSViv(ind), 0);
- }
- return av_fetch(av, ind, lval);
-}
-
-SV**
-avhv_store(AV *av, char *key, U32 klen, SV *val, U32 hash)
-{
- SV **indsvp;
- HV *keys = avhv_keys(av);
- I32 ind;
-
- indsvp = hv_fetch(keys, key, klen, FALSE);
- if (indsvp) {
- ind = SvIV(*indsvp);
- if (ind < 1)
- croak("Bad index while coercing array into hash");
- } else {
- ind = AvFILL(av) + 1;
- hv_store(keys, key, klen, newSViv(ind), hash);
- }
- return av_store(av, ind, val);
-}
-
-SV**
-avhv_store_ent(AV *av, SV *keysv, SV *val, U32 hash)
-{
- HV *keys = avhv_keys(av);
- HE *he;
- I32 ind;
he = hv_fetch_ent(keys, keysv, FALSE, hash);
- if (he) {
- ind = SvIV(HeVAL(he));
- if (ind < 1)
- croak("Bad index while coercing array into hash");
- } else {
- ind = AvFILL(av) + 1;
- hv_store_ent(keys, keysv, newSViv(ind), hash);
- }
- return av_store(av, ind, val);
+ if (!he)
+ croak("No such array field");
+ return av_fetch(av, avhv_index_sv(HeVAL(he)), lval);
}
bool
return hv_exists_ent(keys, keysv, hash);
}
-bool
-avhv_exists(AV *av, char *key, U32 klen)
-{
- HV *keys = avhv_keys(av);
- return hv_exists(keys, key, klen);
-}
-
-/* avhv_delete leaks. Caller can re-index and compress if so desired. */
-SV *
-avhv_delete(AV *av, char *key, U32 klen, I32 flags)
-{
- HV *keys = avhv_keys(av);
- SV *sv;
- SV **svp;
- I32 ind;
-
- sv = hv_delete(keys, key, klen, 0);
- if (!sv)
- return Nullsv;
- ind = SvIV(sv);
- if (ind < 1)
- croak("Bad index while coercing array into hash");
- svp = av_fetch(av, ind, FALSE);
- if (!svp)
- return Nullsv;
- if (flags & G_DISCARD) {
- sv = Nullsv;
- SvREFCNT_dec(*svp);
- } else {
- sv = sv_2mortal(*svp);
- }
- *svp = &sv_undef;
- return sv;
-}
-
-/* avhv_delete_ent leaks. Caller can re-index and compress if so desired. */
-SV *
-avhv_delete_ent(AV *av, SV *keysv, I32 flags, U32 hash)
-{
- HV *keys = avhv_keys(av);
- SV *sv;
- SV **svp;
- I32 ind;
-
- sv = hv_delete_ent(keys, keysv, 0, hash);
- if (!sv)
- return Nullsv;
- ind = SvIV(sv);
- if (ind < 1)
- croak("Bad index while coercing array into hash");
- svp = av_fetch(av, ind, FALSE);
- if (!svp)
- return Nullsv;
- if (flags & G_DISCARD) {
- sv = Nullsv;
- SvREFCNT_dec(*svp);
- } else {
- sv = sv_2mortal(*svp);
- }
- *svp = &sv_undef;
- return sv;
-}
-
HE *
avhv_iternext(AV *av)
{
SV *
avhv_iterval(AV *av, register HE *entry)
{
- HV *keys = avhv_keys(av);
- SV *sv;
- I32 ind;
-
- sv = hv_iterval(keys, entry);
- ind = SvIV(sv);
- if (ind < 1)
- croak("Bad index while coercing array into hash");
- return *av_fetch(av, ind, TRUE);
-}
-
-SV *
-avhv_iternextsv(AV *av, char **key, I32 *retlen)
-{
- HV *keys = avhv_keys(av);
- HE *he;
- SV *sv;
- I32 ind;
-
- he = hv_iternext(keys);
- if (!he)
- return Nullsv;
- *key = hv_iterkey(he, retlen);
- sv = hv_iterval(keys, he);
- ind = SvIV(sv);
- if (ind < 1)
- croak("Bad index while coercing array into hash");
- return *av_fetch(av, ind, TRUE);
+ SV *sv = hv_iterval(avhv_keys(av), entry);
+ return *av_fetch(av, avhv_index_sv(sv), TRUE);
}
#define av_store Perl_av_store
#define av_undef Perl_av_undef
#define av_unshift Perl_av_unshift
-#define avhv_delete Perl_avhv_delete
-#define avhv_delete_ent Perl_avhv_delete_ent
-#define avhv_exists Perl_avhv_exists
#define avhv_exists_ent Perl_avhv_exists_ent
-#define avhv_fetch Perl_avhv_fetch
#define avhv_fetch_ent Perl_avhv_fetch_ent
#define avhv_iternext Perl_avhv_iternext
-#define avhv_iternextsv Perl_avhv_iternextsv
#define avhv_iterval Perl_avhv_iterval
#define avhv_keys Perl_avhv_keys
-#define avhv_store Perl_avhv_store
-#define avhv_store_ent Perl_avhv_store_ent
#define band_amg Perl_band_amg
#define bind_match Perl_bind_match
#define block_end Perl_block_end
av_store
av_undef
av_unshift
-avhv_delete
-avhv_delete_ent
-avhv_exists
avhv_exists_ent
-avhv_fetch
avhv_fetch_ent
avhv_iternext
-avhv_iternextsv
avhv_iterval
avhv_keys
-avhv_store
-avhv_store_ent
bind_match
block_end
block_gimme
#define av_unshift CPerlObj::Perl_av_unshift
#undef avhv_keys
#define avhv_keys CPerlObj::Perl_avhv_keys
-#undef avhv_fetch
-#define avhv_fetch CPerlObj::Perl_avhv_fetch
#undef avhv_fetch_ent
#define avhv_fetch_ent CPerlObj::Perl_avhv_fetch_ent
-#undef avhv_store
-#define avhv_store CPerlObj::Perl_avhv_store
-#undef avhv_store_ent
-#define avhv_store_ent CPerlObj::Perl_avhv_store_ent
#undef avhv_exists_ent
#define avhv_exists_ent CPerlObj::Perl_avhv_exists_ent
-#undef avhv_exists
-#define avhv_exists CPerlObj::Perl_avhv_exists
-#undef avhv_delete
-#define avhv_delete CPerlObj::Perl_avhv_delete
-#undef avhv_delete_ent
-#define avhv_delete_ent CPerlObj::Perl_avhv_delete_ent
#undef avhv_iternext
#define avhv_iternext CPerlObj::Perl_avhv_iternext
#undef avhv_iterval
#define avhv_iterval CPerlObj::Perl_avhv_iterval
-#undef avhv_iternextsv
-#define avhv_iternextsv CPerlObj::Perl_avhv_iternextsv
#undef bad_type
#define bad_type CPerlObj::bad_type
#undef bind_match
(F) A field name of a typed variable was looked up in the %FIELDS
hash, but the index found was not legal, i.e. less than 1.
+=item Bad index while coercing array into hash
+
+(F) The index looked up in the hash found as 0'th element of the array
+is not legal. Index values must be at 1 or greater.
+
=item Bad name after %s::
(F) You started to name a symbol by using a package prefix, and then didn't
(F) Certain types of SVs, in particular real symbol table entries
(typeglobs), can't be forced to stop being what they are.
+=item Can't coerce array into hash
+
+(F) You used an array where a hash was expected, but the array has no
+information on how to map from keys to array indices. You can do that
+only with arrays that have a hash reference at index 0.
+
=item Can't create pipe mailbox
(P) An error peculiar to VMS. The process is suffering from exhausted quotas
(F) The argument to B<-I> must follow the B<-I> immediately with no
intervening space.
+=item No such array field
+
+(F) You tried to access an array as a hash, but the field name used is
+not defined. The hash at index 0 should map all valid field names to
+array indices for that to work.
+
=item No such field "%s" in variable %s of type %s
(F) You tried to access a field of a typed variable where the type
while (++MARK <= SP) {
if (hvtype == SVt_PVHV)
sv = hv_delete_ent(hv, *MARK, discard, 0);
- else if (hvtype == SVt_PVAV)
- sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
else
DIE("Not a HASH reference");
*MARK = sv ? sv : &sv_undef;
hv = (HV*)POPs;
if (SvTYPE(hv) == SVt_PVHV)
sv = hv_delete_ent(hv, keysv, discard, 0);
- else if (SvTYPE(hv) == SVt_PVAV)
- sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
else
DIE("Not a HASH reference");
if (!sv)
VIRTUAL OP* append_list _((I32 optype, LISTOP* first, LISTOP* last));
VIRTUAL I32 apply _((I32 type, SV** mark, SV** sp));
VIRTUAL void assertref _((OP* o));
-VIRTUAL SV* avhv_delete _((AV *ar, char* key, U32 klen, I32 flags));
-VIRTUAL SV* avhv_delete_ent _((AV *ar, SV* keysv, I32 flags, U32 hash));
-VIRTUAL bool avhv_exists _((AV *ar, char* key, U32 klen));
VIRTUAL bool avhv_exists_ent _((AV *ar, SV* keysv, U32 hash));
-VIRTUAL SV** avhv_fetch _((AV *ar, char* key, U32 klen, I32 lval));
VIRTUAL SV** avhv_fetch_ent _((AV *ar, SV* keysv, I32 lval, U32 hash));
VIRTUAL HE* avhv_iternext _((AV *ar));
-VIRTUAL SV * avhv_iternextsv _((AV *ar, char** key, I32* retlen));
VIRTUAL SV* avhv_iterval _((AV *ar, HE* entry));
VIRTUAL HV* avhv_keys _((AV *ar));
-VIRTUAL SV** avhv_store _((AV *ar, char* key, U32 klen, SV* val, U32 hash));
-VIRTUAL SV** avhv_store_ent _((AV *av, SV *keysv, SV *val, U32 hash));
VIRTUAL void av_clear _((AV* ar));
VIRTUAL void av_extend _((AV* ar, I32 key));
VIRTUAL AV* av_fake _((I32 size, SV** svp));
$a->{'abc'} = 'ABC';
$a->{'def'} = 'DEF';
$a->{'jkl'} = 'JKL';
-$a->{'a'} = 'A'; #should extend schema
@keys = keys %$a;
@values = values %$a;
-if ($#keys == 3 && $#values == 3) {print "ok 1\n";} else {print "not ok 1\n";}
+if ($#keys == 2 && $#values == 2) {print "ok 1\n";} else {print "not ok 1\n";}
$i = 0; # stop -w complaints
}
}
-if ($i == 4) {print "ok 2\n";} else {print "not ok 2\n";}
+if ($i == 3) {print "ok 2\n";} else {print "not ok 2\n";}
# quick check with tied array
tie @fake, 'Tie::StdArray';
projects / p5sagit/p5-mst-13.2.git / commitdiff