X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=av.c;h=819887e2ad59c17e9cc98f3701e558f8aa3117b1;hb=be26652545762cccb4c0118f022cf9d0ec20cf93;hp=265eb7110314467c9dd366a3cf7027a6559e6947;hpb=864dbfa3ca8032ef66f7aa86961933b19b962357;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/av.c b/av.c
index 265eb71..819887e 100644
--- a/av.c
+++ b/av.c
@@ -1,6 +1,6 @@
 /*    av.c
  *
- *    Copyright (c) 1991-1999, 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.
@@ -25,8 +25,8 @@ Perl_av_reify(pTHX_ 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)
@@ -46,12 +46,21 @@ Perl_av_reify(pTHX_ 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
 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;
@@ -91,10 +100,11 @@ Perl_av_extend(pTHX_ 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) 
@@ -107,13 +117,14 @@ Perl_av_extend(pTHX_ 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)
@@ -149,6 +160,19 @@ Perl_av_extend(pTHX_ 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**
 Perl_av_fetch(pTHX_ register AV *av, I32 key, I32 lval)
 {
@@ -196,12 +220,27 @@ Perl_av_fetch(pTHX_ 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**
 Perl_av_store(pTHX_ register AV *av, I32 key, SV *val)
 {
     SV** ary;
-    U32  fill;
-
 
     if (!av)
 	return 0;
@@ -215,7 +254,7 @@ Perl_av_store(pTHX_ 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')) {
@@ -255,6 +294,14 @@ Perl_av_store(pTHX_ 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 *
 Perl_newAV(pTHX)
 {
@@ -269,6 +316,16 @@ Perl_newAV(pTHX)
     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 *
 Perl_av_make(pTHX_ register I32 size, register SV **strp)
 {
@@ -318,6 +375,15 @@ Perl_av_fake(pTHX_ 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
 Perl_av_clear(pTHX_ register AV *av)
 {
@@ -325,8 +391,8 @@ Perl_av_clear(pTHX_ register AV *av)
     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)
@@ -334,7 +400,7 @@ Perl_av_clear(pTHX_ 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))
@@ -351,7 +417,7 @@ Perl_av_clear(pTHX_ 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);
     }
@@ -359,6 +425,14 @@ Perl_av_clear(pTHX_ register AV *av)
 
 }
 
+/*
+=for apidoc av_undef
+
+Undefines the array.  Frees the memory used by the array itself.
+
+=cut
+*/
+
 void
 Perl_av_undef(pTHX_ register AV *av)
 {
@@ -387,6 +461,15 @@ Perl_av_undef(pTHX_ 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
 Perl_av_push(pTHX_ register AV *av, SV *val)
 {             
@@ -394,9 +477,9 @@ Perl_av_push(pTHX_ register AV *av, SV *val)
     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);
@@ -413,6 +496,15 @@ Perl_av_push(pTHX_ 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 *
 Perl_av_pop(pTHX_ register AV *av)
 {
@@ -422,8 +514,8 @@ Perl_av_pop(pTHX_ 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);
@@ -446,6 +538,16 @@ Perl_av_pop(pTHX_ 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
 Perl_av_unshift(pTHX_ register AV *av, register I32 num)
 {
@@ -456,9 +558,9 @@ Perl_av_unshift(pTHX_ 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);
@@ -499,6 +601,14 @@ Perl_av_unshift(pTHX_ register AV *av, register I32 num)
     }
 }
 
+/*
+=for apidoc av_shift
+
+Shifts an SV off the beginning of the array.
+
+=cut
+*/
+
 SV *
 Perl_av_shift(pTHX_ register AV *av)
 {
@@ -508,8 +618,8 @@ Perl_av_shift(pTHX_ 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);
@@ -536,6 +646,15 @@ Perl_av_shift(pTHX_ 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
 Perl_av_len(pTHX_ register AV *av)
 {
@@ -547,10 +666,10 @@ 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;
@@ -589,6 +708,86 @@ Perl_av_fill(pTHX_ register AV *av, I32 fill)
 	(void)av_store(av,fill,&PL_sv_undef);
 }
 
+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;
+}
+
+/*
+ * This relies on the fact that uninitialized array elements
+ * are set to &PL_sv_undef.
+ */
+
+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
@@ -596,14 +795,28 @@ Perl_av_fill(pTHX_ register AV *av, I32 fill)
  */
 
 STATIC I32
-avhv_index_sv(pTHX_ 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*
 Perl_avhv_keys(pTHX_ AV *av)
 {
@@ -618,28 +831,49 @@ Perl_avhv_keys(pTHX_ AV *av)
 		return (HV*)sv;
 	}
     }
-    croak("Can't coerce array into hash");
+    Perl_croak(aTHX_ "Can't coerce array into hash");
     return Nullhv;
 }
 
 SV**
+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)
 {
-    SV **indsvp;
+    return av_fetch(av, avhv_index(av, keysv, hash), lval);
+}
+
+SV *
+Perl_avhv_delete_ent(pTHX_ AV *av, SV *keysv, I32 flags, U32 hash)
+{
     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
 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 *