X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=av.c;h=ef2c90562d30fab93bff585b0114dd94595b65d5;hb=1d68d6cd5ca16f48de9798b0758052a6de564551;hp=3f288f3805a685ab3593001f6d781bf6c1317d39;hpb=22c35a8c2392967a5ba6b5370695be464bd7012c;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/av.c b/av.c
index 3f288f3..ef2c905 100644
--- a/av.c
+++ b/av.c
@@ -1,6 +1,6 @@
 /*    av.c
  *
- *    Copyright (c) 1991-1997, Larry Wall
+ *    Copyright (c) 1991-2000, 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.
@@ -13,10 +13,11 @@
  */
 
 #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;
@@ -24,8 +25,8 @@ av_reify(AV *av)
     if (AvREAL(av))
 	return;
 #ifdef DEBUGGING
-    if (SvTIED_mg((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)
@@ -45,12 +46,21 @@ av_reify(AV *av)
     AvREAL_on(av);
 }
 
+/*
+=for apidoc av_extend
+
+Pre-extend an array.  The C<key> is the index to which the array should be
+extended.
+
+=cut
+*/
+
 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 (mg = SvTIED_mg((SV*)av, 'P')) {
+    if ((mg = SvTIED_mg((SV*)av, 'P'))) {
 	dSP;
 	ENTER;
 	SAVETMPS;
@@ -60,7 +70,7 @@ av_extend(AV *av, I32 key)
 	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;
@@ -90,10 +100,11 @@ av_extend(AV *av, I32 key)
 	else {
 	    if (AvALLOC(av)) {
 #ifndef STRANGE_MALLOC
-		U32 bytes;
+		MEM_SIZE bytes;
+		IV itmp;
 #endif
 
-#if defined(MYMALLOC) && !defined(PURIFY) && !defined(LEAKTEST)
+#if defined(MYMALLOC) && !defined(LEAKTEST)
 		newmax = malloced_size((void*)AvALLOC(av))/sizeof(SV*) - 1;
 
 		if (key <= newmax) 
@@ -106,13 +117,14 @@ av_extend(AV *av, I32 key)
 #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)
@@ -148,8 +160,21 @@ av_extend(AV *av, I32 key)
     }
 }
 
+/*
+=for apidoc av_fetch
+
+Returns the SV at the specified index in the array.  The C<key> is the
+index.  If C<lval> is set then the fetch will be part of a store.  Check
+that the return value is non-null before dereferencing it to a C<SV*>.
+
+See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
+more information on how to use this function on tied arrays. 
+
+=cut
+*/
+
 SV**
-av_fetch(register AV *av, I32 key, I32 lval)
+Perl_av_fetch(pTHX_ register AV *av, I32 key, I32 lval)
 {
     SV *sv;
 
@@ -175,10 +200,7 @@ av_fetch(register AV *av, I32 key, I32 lval)
     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) {
@@ -198,12 +220,27 @@ av_fetch(register AV *av, I32 key, I32 lval)
     return &AvARRAY(av)[key];
 }
 
+/*
+=for apidoc av_store
+
+Stores an SV in an array.  The array index is specified as C<key>.  The
+return value will be NULL if the operation failed or if the value did not
+need to be actually stored within the array (as in the case of tied
+arrays). Otherwise it can be dereferenced to get the original C<SV*>.  Note
+that the caller is responsible for suitably incrementing the reference
+count of C<val> before the call, and decrementing it if the function
+returned NULL.
+
+See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
+more information on how to use this function on tied arrays.
+
+=cut
+*/
+
 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 (!av)
 	return 0;
@@ -217,7 +254,7 @@ av_store(register AV *av, I32 key, SV *val)
     }
 
     if (SvREADONLY(av) && key >= AvFILL(av))
-	croak(PL_no_modify);
+	Perl_croak(aTHX_ PL_no_modify);
 
     if (SvRMAGICAL(av)) {
 	if (mg_find((SV*)av,'P')) {
@@ -257,8 +294,16 @@ av_store(register AV *av, I32 key, SV *val)
     return &ary[key];
 }
 
+/*
+=for apidoc newAV
+
+Creates a new AV.  The reference count is set to 1.
+
+=cut
+*/
+
 AV *
-newAV(void)
+Perl_newAV(pTHX)
 {
     register AV *av;
 
@@ -271,8 +316,18 @@ newAV(void)
     return av;
 }
 
+/*
+=for apidoc av_make
+
+Creates a new AV and populates it with a list of SVs.  The SVs are copied
+into the array, so they may be freed after the call to av_make.  The new AV
+will have a reference count of 1.
+
+=cut
+*/
+
 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;
@@ -298,7 +353,7 @@ av_make(register I32 size, register SV **strp)
 }
 
 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;
@@ -320,15 +375,24 @@ av_fake(register I32 size, register SV **strp)
     return av;
 }
 
+/*
+=for apidoc av_clear
+
+Clears an array, making it empty.  Does not free the memory used by the
+array itself.
+
+=cut
+*/
+
 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)
@@ -336,7 +400,7 @@ av_clear(register AV *av)
     /*SUPPRESS 560*/
 
     if (SvREADONLY(av))
-	croak(PL_no_modify);
+	Perl_croak(aTHX_ PL_no_modify);
 
     /* Give any tie a chance to cleanup first */
     if (SvRMAGICAL(av))
@@ -353,7 +417,7 @@ av_clear(register AV *av)
 	    ary[key] = &PL_sv_undef;
 	}
     }
-    if (key = AvARRAY(av) - AvALLOC(av)) {
+    if ((key = AvARRAY(av) - AvALLOC(av))) {
 	AvMAX(av) += key;
 	SvPVX(av) = (char*)AvALLOC(av);
     }
@@ -361,8 +425,16 @@ av_clear(register AV *av)
 
 }
 
+/*
+=for apidoc av_undef
+
+Undefines the array.  Frees the memory used by the array itself.
+
+=cut
+*/
+
 void
-av_undef(register AV *av)
+Perl_av_undef(pTHX_ register AV *av)
 {
     register I32 key;
 
@@ -389,16 +461,25 @@ av_undef(register AV *av)
     }
 }
 
+/*
+=for apidoc av_push
+
+Pushes an SV onto the end of the array.  The array will grow automatically
+to accommodate the addition.
+
+=cut
+*/
+
 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(PL_no_modify);
+	Perl_croak(aTHX_ PL_no_modify);
 
-    if (mg = SvTIED_mg((SV*)av, 'P')) {
+    if ((mg = SvTIED_mg((SV*)av, 'P'))) {
 	dSP;
 	PUSHSTACKi(PERLSI_MAGIC);
 	PUSHMARK(SP);
@@ -407,7 +488,7 @@ av_push(register AV *av, SV *val)
 	PUSHs(val);
 	PUTBACK;
 	ENTER;
-	perl_call_method("PUSH", G_SCALAR|G_DISCARD);
+	call_method("PUSH", G_SCALAR|G_DISCARD);
 	LEAVE;
 	POPSTACK;
 	return;
@@ -415,8 +496,17 @@ av_push(register AV *av, SV *val)
     av_store(av,AvFILLp(av)+1,val);
 }
 
+/*
+=for apidoc av_pop
+
+Pops an SV off the end of the array.  Returns C<&PL_sv_undef> if the array
+is empty.
+
+=cut
+*/
+
 SV *
-av_pop(register AV *av)
+Perl_av_pop(pTHX_ register AV *av)
 {
     SV *retval;
     MAGIC* mg;
@@ -424,15 +514,15 @@ av_pop(register AV *av)
     if (!av || AvFILL(av) < 0)
 	return &PL_sv_undef;
     if (SvREADONLY(av))
-	croak(PL_no_modify);
-    if (mg = SvTIED_mg((SV*)av, 'P')) {
+	Perl_croak(aTHX_ PL_no_modify);
+    if ((mg = SvTIED_mg((SV*)av, 'P'))) {
 	dSP;    
 	PUSHSTACKi(PERLSI_MAGIC);
 	PUSHMARK(SP);
 	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;
@@ -448,8 +538,18 @@ av_pop(register AV *av)
     return retval;
 }
 
+/*
+=for apidoc av_unshift
+
+Unshift the given number of C<undef> values onto the beginning of the
+array.  The array will grow automatically to accommodate the addition.  You
+must then use C<av_store> to assign values to these new elements.
+
+=cut
+*/
+
 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;
@@ -458,9 +558,9 @@ av_unshift(register AV *av, register I32 num)
     if (!av || num <= 0)
 	return;
     if (SvREADONLY(av))
-	croak(PL_no_modify);
+	Perl_croak(aTHX_ PL_no_modify);
 
-    if (mg = SvTIED_mg((SV*)av, 'P')) {
+    if ((mg = SvTIED_mg((SV*)av, 'P'))) {
 	dSP;
 	PUSHSTACKi(PERLSI_MAGIC);
 	PUSHMARK(SP);
@@ -471,7 +571,7 @@ av_unshift(register AV *av, register I32 num)
 	}
 	PUTBACK;
 	ENTER;
-	perl_call_method("UNSHIFT", G_SCALAR|G_DISCARD);
+	call_method("UNSHIFT", G_SCALAR|G_DISCARD);
 	LEAVE;
 	POPSTACK;
 	return;
@@ -501,8 +601,16 @@ av_unshift(register AV *av, register I32 num)
     }
 }
 
+/*
+=for apidoc av_shift
+
+Shifts an SV off the beginning of the array.
+
+=cut
+*/
+
 SV *
-av_shift(register AV *av)
+Perl_av_shift(pTHX_ register AV *av)
 {
     SV *retval;
     MAGIC* mg;
@@ -510,15 +618,15 @@ av_shift(register AV *av)
     if (!av || AvFILL(av) < 0)
 	return &PL_sv_undef;
     if (SvREADONLY(av))
-	croak(PL_no_modify);
-    if (mg = SvTIED_mg((SV*)av, 'P')) {
+	Perl_croak(aTHX_ PL_no_modify);
+    if ((mg = SvTIED_mg((SV*)av, 'P'))) {
 	dSP;
 	PUSHSTACKi(PERLSI_MAGIC);
 	PUSHMARK(SP);
 	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;
@@ -538,21 +646,38 @@ av_shift(register AV *av)
     return retval;
 }
 
+/*
+=for apidoc av_len
+
+Returns the highest index in the array.  Returns -1 if the array is
+empty.
+
+=cut
+*/
+
 I32
-av_len(register AV *av)
+Perl_av_len(pTHX_ register AV *av)
 {
     return AvFILL(av);
 }
 
+/*
+=for apidoc av_fill
+
+Ensure than an array has a given number of elements, equivalent to
+Perl's C<$#array = $fill;>.
+
+=cut
+*/
 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 (mg = SvTIED_mg((SV*)av, 'P')) {
+    if ((mg = SvTIED_mg((SV*)av, 'P'))) {
 	dSP;            
 	ENTER;
 	SAVETMPS;
@@ -562,7 +687,7 @@ av_fill(register AV *av, I32 fill)
 	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;
@@ -591,6 +716,99 @@ av_fill(register AV *av, I32 fill)
 	(void)av_store(av,fill,&PL_sv_undef);
 }
 
+/*
+=for apidoc av_delete
+
+Deletes the element indexed by C<key> from the array.  Returns the
+deleted element. C<flags> is currently ignored.
+
+=cut
+*/
+SV *
+Perl_av_delete(pTHX_ AV *av, I32 key, I32 flags)
+{
+    SV *sv;
+
+    if (!av)
+	return Nullsv;
+    if (SvREADONLY(av))
+	Perl_croak(aTHX_ PL_no_modify);
+    if (key < 0) {
+	key += AvFILL(av) + 1;
+	if (key < 0)
+	    return Nullsv;
+    }
+    if (SvRMAGICAL(av)) {
+	SV **svp;
+	if ((mg_find((SV*)av,'P') || mg_find((SV*)av,'D'))
+	    && (svp = av_fetch(av, key, TRUE)))
+	{
+	    sv = *svp;
+	    mg_clear(sv);
+	    if (mg_find(sv, 'p')) {
+		sv_unmagic(sv, 'p');		/* No longer an element */
+		return sv;
+	    }
+	    return Nullsv;			/* element cannot be deleted */
+	}
+    }
+    if (key > AvFILLp(av))
+	return Nullsv;
+    else {
+	sv = AvARRAY(av)[key];
+	if (key == AvFILLp(av)) {
+	    do {
+		AvFILLp(av)--;
+	    } while (--key >= 0 && AvARRAY(av)[key] == &PL_sv_undef);
+	}
+	else
+	    AvARRAY(av)[key] = &PL_sv_undef;
+	if (SvSMAGICAL(av))
+	    mg_set((SV*)av);
+    }
+    if (flags & G_DISCARD) {
+	SvREFCNT_dec(sv);
+	sv = Nullsv;
+    }
+    return sv;
+}
+
+/*
+=for apidoc av_exists
+
+Returns true if the element indexed by C<key> has been initialized.
+
+This relies on the fact that uninitialized array elements are set to
+C<&PL_sv_undef>.
+
+=cut
+*/
+bool
+Perl_av_exists(pTHX_ AV *av, I32 key)
+{
+    if (!av)
+	return FALSE;
+    if (key < 0) {
+	key += AvFILL(av) + 1;
+	if (key < 0)
+	    return FALSE;
+    }
+    if (SvRMAGICAL(av)) {
+	if (mg_find((SV*)av,'P') || mg_find((SV*)av,'D')) {
+	    SV *sv = sv_newmortal();
+	    mg_copy((SV*)av, sv, 0, key);
+	    magic_existspack(sv, mg_find(sv, 'p'));
+	    return SvTRUE(sv);
+	}
+    }
+    if (key <= AvFILLp(av) && AvARRAY(av)[key] != &PL_sv_undef
+	&& AvARRAY(av)[key])
+    {
+	return TRUE;
+    }
+    else
+	return FALSE;
+}
 
 /* AVHV: Support for treating arrays as if they were hashes.  The
  * first element of the array should be a hash reference that maps
@@ -598,16 +816,30 @@ av_fill(register AV *av, I32 fill)
  */
 
 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;    
 }
 
+STATIC I32
+S_avhv_index(pTHX_ AV *av, SV *keysv, U32 hash)
+{
+    HV *keys;
+    HE *he;
+    STRLEN n_a;
+
+    keys = avhv_keys(av);
+    he = hv_fetch_ent(keys, keysv, FALSE, hash);
+    if (!he)
+        Perl_croak(aTHX_ "No such pseudo-hash field \"%s\"", SvPV(keysv,n_a));
+    return avhv_index_sv(HeVAL(he));
+}
+
 HV*
-avhv_keys(AV *av)
+Perl_avhv_keys(pTHX_ AV *av)
 {
     SV **keysp = av_fetch(av, 0, FALSE);
     if (keysp) {
@@ -620,39 +852,60 @@ avhv_keys(AV *av)
 		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_store_ent(pTHX_ AV *av, SV *keysv, SV *val, U32 hash)
+{
+    return av_store(av, avhv_index(av, keysv, hash), val);
+}
+
+SV**
+Perl_avhv_fetch_ent(pTHX_ AV *av, SV *keysv, I32 lval, U32 hash)
+{
+    return av_fetch(av, avhv_index(av, keysv, hash), lval);
+}
+
+SV *
+Perl_avhv_delete_ent(pTHX_ AV *av, SV *keysv, I32 flags, U32 hash)
 {
-    SV **indsvp;
     HV *keys = avhv_keys(av);
     HE *he;
-    
+	
     he = hv_fetch_ent(keys, keysv, FALSE, hash);
-    if (!he)
-        croak("No such array field");
-    return av_fetch(av, avhv_index_sv(HeVAL(he)), lval);
+    if (!he || !SvOK(HeVAL(he)))
+	return Nullsv;
+
+    return av_delete(av, avhv_index_sv(HeVAL(he)), flags);
 }
 
+/* Check for the existence of an element named by a given key.
+ *
+ */
 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;
+	
+    he = hv_fetch_ent(keys, keysv, FALSE, hash);
+    if (!he || !SvOK(HeVAL(he)))
+	return FALSE;
+
+    return av_exists(av, avhv_index_sv(HeVAL(he)));
 }
 
 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);