/* av.c
*
- * Copyright (c) 1991-1997, Larry Wall
+ * Copyright (c) 1991-1999, Larry Wall
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
*/
#include "EXTERN.h"
+#define PERL_IN_AV_C
#include "perl.h"
void
-av_reify(AV *av)
+Perl_av_reify(pTHX_ AV *av)
{
I32 key;
SV* sv;
if (AvREAL(av))
return;
#ifdef DEBUGGING
- if (SvRMAGICAL(av) && mg_find((SV*)av,'P'))
- warn("av_reify called on tied array");
+ if (SvTIED_mg((SV*)av, 'P') && ckWARN_d(WARN_DEBUGGING))
+ Perl_warner(aTHX_ WARN_DEBUGGING, "av_reify called on tied array");
#endif
key = AvMAX(av) + 1;
while (key > AvFILLp(av) + 1)
key = AvARRAY(av) - AvALLOC(av);
while (key)
AvALLOC(av)[--key] = &PL_sv_undef;
+ AvREIFY_off(av);
AvREAL_on(av);
}
void
-av_extend(AV *av, I32 key)
+Perl_av_extend(pTHX_ AV *av, I32 key)
{
dTHR; /* only necessary if we have to extend stack */
MAGIC *mg;
- if (SvRMAGICAL(av) && (mg = mg_find((SV*)av,'P'))) {
+ if (mg = SvTIED_mg((SV*)av, 'P')) {
dSP;
ENTER;
SAVETMPS;
PUSHSTACKi(PERLSI_MAGIC);
PUSHMARK(SP);
EXTEND(SP,2);
- PUSHs(mg->mg_obj);
+ PUSHs(SvTIED_obj((SV*)av, mg));
PUSHs(sv_2mortal(newSViv(key+1)));
PUTBACK;
- perl_call_method("EXTEND", G_SCALAR|G_DISCARD);
+ call_method("EXTEND", G_SCALAR|G_DISCARD);
POPSTACK;
FREETMPS;
LEAVE;
else {
if (AvALLOC(av)) {
#ifndef STRANGE_MALLOC
- U32 bytes;
+ MEM_SIZE bytes;
+ IV itmp;
#endif
-#if defined(MYMALLOC) && !defined(PURIFY)
+#if defined(MYMALLOC) && !defined(PURIFY) && !defined(LEAKTEST)
newmax = malloced_size((void*)AvALLOC(av))/sizeof(SV*) - 1;
if (key <= newmax)
#else
bytes = (newmax + 1) * sizeof(SV*);
#define MALLOC_OVERHEAD 16
- tmp = MALLOC_OVERHEAD;
- while (tmp - MALLOC_OVERHEAD < bytes)
- tmp += tmp;
- tmp -= MALLOC_OVERHEAD;
- tmp /= sizeof(SV*);
- assert(tmp > newmax);
- newmax = tmp - 1;
+ itmp = MALLOC_OVERHEAD;
+ while (itmp - MALLOC_OVERHEAD < bytes)
+ itmp += itmp;
+ itmp -= MALLOC_OVERHEAD;
+ itmp /= sizeof(SV*);
+ assert(itmp > newmax);
+ newmax = itmp - 1;
+ assert(newmax >= AvMAX(av));
New(2,ary, newmax+1, SV*);
Copy(AvALLOC(av), ary, AvMAX(av)+1, SV*);
if (AvMAX(av) > 64)
}
SV**
-av_fetch(register AV *av, I32 key, I32 lval)
+Perl_av_fetch(pTHX_ register AV *av, I32 key, I32 lval)
{
SV *sv;
}
if (SvRMAGICAL(av)) {
- if (mg_find((SV*)av,'P')) {
+ if (mg_find((SV*)av,'P') || mg_find((SV*)av,'D')) {
dTHR;
sv = sv_newmortal();
mg_copy((SV*)av, sv, 0, key);
if (key > AvFILLp(av)) {
if (!lval)
return 0;
- if (AvREALISH(av))
- sv = NEWSV(5,0);
- else
- sv = sv_newmortal();
+ sv = NEWSV(5,0);
return av_store(av,key,sv);
}
if (AvARRAY(av)[key] == &PL_sv_undef) {
}
SV**
-av_store(register AV *av, I32 key, SV *val)
+Perl_av_store(pTHX_ register AV *av, I32 key, SV *val)
{
SV** ary;
U32 fill;
}
if (SvREADONLY(av) && key >= AvFILL(av))
- croak(no_modify);
+ Perl_croak(aTHX_ PL_no_modify);
if (SvRMAGICAL(av)) {
if (mg_find((SV*)av,'P')) {
}
AV *
-newAV(void)
+Perl_newAV(pTHX)
{
register AV *av;
}
AV *
-av_make(register I32 size, register SV **strp)
+Perl_av_make(pTHX_ register I32 size, register SV **strp)
{
register AV *av;
register I32 i;
}
AV *
-av_fake(register I32 size, register SV **strp)
+Perl_av_fake(pTHX_ register I32 size, register SV **strp)
{
register AV *av;
register SV** ary;
}
void
-av_clear(register AV *av)
+Perl_av_clear(pTHX_ register AV *av)
{
register I32 key;
SV** ary;
#ifdef DEBUGGING
- if (SvREFCNT(av) <= 0) {
- warn("Attempt to clear deleted array");
+ if (SvREFCNT(av) <= 0 && ckWARN_d(WARN_DEBUGGING)) {
+ Perl_warner(aTHX_ WARN_DEBUGGING, "Attempt to clear deleted array");
}
#endif
if (!av)
/*SUPPRESS 560*/
if (SvREADONLY(av))
- croak(no_modify);
+ Perl_croak(aTHX_ PL_no_modify);
/* Give any tie a chance to cleanup first */
if (SvRMAGICAL(av))
}
void
-av_undef(register AV *av)
+Perl_av_undef(pTHX_ register AV *av)
{
register I32 key;
/*SUPPRESS 560*/
/* Give any tie a chance to cleanup first */
- if (SvRMAGICAL(av) && mg_find((SV*)av,'P'))
+ if (SvTIED_mg((SV*)av, 'P'))
av_fill(av, -1); /* mg_clear() ? */
if (AvREAL(av)) {
}
void
-av_push(register AV *av, SV *val)
+Perl_av_push(pTHX_ register AV *av, SV *val)
{
MAGIC *mg;
if (!av)
return;
if (SvREADONLY(av))
- croak(no_modify);
+ Perl_croak(aTHX_ PL_no_modify);
- if (SvRMAGICAL(av) && (mg = mg_find((SV*)av,'P'))) {
+ if (mg = SvTIED_mg((SV*)av, 'P')) {
dSP;
PUSHSTACKi(PERLSI_MAGIC);
PUSHMARK(SP);
EXTEND(SP,2);
- PUSHs(mg->mg_obj);
+ PUSHs(SvTIED_obj((SV*)av, mg));
PUSHs(val);
PUTBACK;
ENTER;
- perl_call_method("PUSH", G_SCALAR|G_DISCARD);
+ call_method("PUSH", G_SCALAR|G_DISCARD);
LEAVE;
POPSTACK;
return;
}
SV *
-av_pop(register AV *av)
+Perl_av_pop(pTHX_ register AV *av)
{
SV *retval;
MAGIC* mg;
if (!av || AvFILL(av) < 0)
return &PL_sv_undef;
if (SvREADONLY(av))
- croak(no_modify);
- if (SvRMAGICAL(av) && (mg = mg_find((SV*)av,'P'))) {
+ Perl_croak(aTHX_ PL_no_modify);
+ if (mg = SvTIED_mg((SV*)av, 'P')) {
dSP;
PUSHSTACKi(PERLSI_MAGIC);
PUSHMARK(SP);
- XPUSHs(mg->mg_obj);
+ XPUSHs(SvTIED_obj((SV*)av, mg));
PUTBACK;
ENTER;
- if (perl_call_method("POP", G_SCALAR)) {
+ if (call_method("POP", G_SCALAR)) {
retval = newSVsv(*PL_stack_sp--);
} else {
retval = &PL_sv_undef;
}
void
-av_unshift(register AV *av, register I32 num)
+Perl_av_unshift(pTHX_ register AV *av, register I32 num)
{
register I32 i;
register SV **ary;
if (!av || num <= 0)
return;
if (SvREADONLY(av))
- croak(no_modify);
+ Perl_croak(aTHX_ PL_no_modify);
- if (SvRMAGICAL(av) && (mg = mg_find((SV*)av,'P'))) {
+ if (mg = SvTIED_mg((SV*)av, 'P')) {
dSP;
PUSHSTACKi(PERLSI_MAGIC);
PUSHMARK(SP);
EXTEND(SP,1+num);
- PUSHs(mg->mg_obj);
+ PUSHs(SvTIED_obj((SV*)av, mg));
while (num-- > 0) {
PUSHs(&PL_sv_undef);
}
PUTBACK;
ENTER;
- perl_call_method("UNSHIFT", G_SCALAR|G_DISCARD);
+ call_method("UNSHIFT", G_SCALAR|G_DISCARD);
LEAVE;
POPSTACK;
return;
}
SV *
-av_shift(register AV *av)
+Perl_av_shift(pTHX_ register AV *av)
{
SV *retval;
MAGIC* mg;
if (!av || AvFILL(av) < 0)
return &PL_sv_undef;
if (SvREADONLY(av))
- croak(no_modify);
- if (SvRMAGICAL(av) && (mg = mg_find((SV*)av,'P'))) {
+ Perl_croak(aTHX_ PL_no_modify);
+ if (mg = SvTIED_mg((SV*)av, 'P')) {
dSP;
PUSHSTACKi(PERLSI_MAGIC);
PUSHMARK(SP);
- XPUSHs(mg->mg_obj);
+ XPUSHs(SvTIED_obj((SV*)av, mg));
PUTBACK;
ENTER;
- if (perl_call_method("SHIFT", G_SCALAR)) {
+ if (call_method("SHIFT", G_SCALAR)) {
retval = newSVsv(*PL_stack_sp--);
} else {
retval = &PL_sv_undef;
}
I32
-av_len(register AV *av)
+Perl_av_len(pTHX_ register AV *av)
{
return AvFILL(av);
}
void
-av_fill(register AV *av, I32 fill)
+Perl_av_fill(pTHX_ register AV *av, I32 fill)
{
MAGIC *mg;
if (!av)
- croak("panic: null array");
+ Perl_croak(aTHX_ "panic: null array");
if (fill < 0)
fill = -1;
- if (SvRMAGICAL(av) && (mg = mg_find((SV*)av,'P'))) {
+ if (mg = SvTIED_mg((SV*)av, 'P')) {
dSP;
ENTER;
SAVETMPS;
PUSHSTACKi(PERLSI_MAGIC);
PUSHMARK(SP);
EXTEND(SP,2);
- PUSHs(mg->mg_obj);
+ PUSHs(SvTIED_obj((SV*)av, mg));
PUSHs(sv_2mortal(newSViv(fill+1)));
PUTBACK;
- perl_call_method("STORESIZE", G_SCALAR|G_DISCARD);
+ call_method("STORESIZE", G_SCALAR|G_DISCARD);
POPSTACK;
FREETMPS;
LEAVE;
*/
STATIC I32
-avhv_index_sv(SV* sv)
+S_avhv_index_sv(pTHX_ SV* sv)
{
I32 index = SvIV(sv);
if (index < 1)
- croak("Bad index while coercing array into hash");
+ Perl_croak(aTHX_ "Bad index while coercing array into hash");
return index;
}
HV*
-avhv_keys(AV *av)
+Perl_avhv_keys(pTHX_ AV *av)
{
SV **keysp = av_fetch(av, 0, FALSE);
if (keysp) {
return (HV*)sv;
}
}
- croak("Can't coerce array into hash");
+ Perl_croak(aTHX_ "Can't coerce array into hash");
return Nullhv;
}
SV**
-avhv_fetch_ent(AV *av, SV *keysv, I32 lval, U32 hash)
+Perl_avhv_fetch_ent(pTHX_ AV *av, SV *keysv, I32 lval, U32 hash)
{
SV **indsvp;
HV *keys = avhv_keys(av);
HE *he;
-
+ STRLEN n_a;
+
he = hv_fetch_ent(keys, keysv, FALSE, hash);
if (!he)
- croak("No such array field");
+ Perl_croak(aTHX_ "No such pseudo-hash field \"%s\"", SvPV(keysv,n_a));
return av_fetch(av, avhv_index_sv(HeVAL(he)), lval);
}
+/* Check for the existence of an element named by a given key.
+ *
+ * This relies on the fact that uninitialized array elements
+ * are set to &PL_sv_undef.
+ */
bool
-avhv_exists_ent(AV *av, SV *keysv, U32 hash)
+Perl_avhv_exists_ent(pTHX_ AV *av, SV *keysv, U32 hash)
{
HV *keys = avhv_keys(av);
- return hv_exists_ent(keys, keysv, hash);
+ HE *he;
+ IV ix;
+
+ he = hv_fetch_ent(keys, keysv, FALSE, hash);
+ if (!he || !SvOK(HeVAL(he)))
+ return FALSE;
+
+ ix = SvIV(HeVAL(he));
+
+ /* If the array hasn't been extended to reach the key yet then
+ * it hasn't been accessed and thus does not exist. We use
+ * AvFILL() rather than AvFILLp() to handle tied av. */
+ if (ix > 0 && ix <= AvFILL(av)
+ && (SvRMAGICAL(av)
+ || (AvARRAY(av)[ix] && AvARRAY(av)[ix] != &PL_sv_undef)))
+ {
+ return TRUE;
+ }
+ return FALSE;
}
HE *
-avhv_iternext(AV *av)
+Perl_avhv_iternext(pTHX_ AV *av)
{
HV *keys = avhv_keys(av);
return hv_iternext(keys);
}
SV *
-avhv_iterval(AV *av, register HE *entry)
+Perl_avhv_iterval(pTHX_ AV *av, register HE *entry)
{
SV *sv = hv_iterval(avhv_keys(av), entry);
return *av_fetch(av, avhv_index_sv(sv), TRUE);