Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

av.c@ 3356

Visit:

Last change on this file since 3356 was 3181, checked in by bird, 18 years ago
perl 5.8.8
File size: 23.3 KB

Line
1	/* av.c
2	*
3	* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4	* 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
5	*
6	* You may distribute under the terms of either the GNU General Public
7	* License or the Artistic License, as specified in the README file.
8	*
9	*/
10
11	/*
12	* "...for the Entwives desired order, and plenty, and peace (by which they
13	* meant that things should remain where they had set them)." --Treebeard
14	*/
15
16	/*
17	=head1 Array Manipulation Functions
18	*/
19
20	#include "EXTERN.h"
21	#define PERL_IN_AV_C
22	#include "perl.h"
23
24	void
25	Perl_av_reify(pTHX_ AV *av)
26	{
27	I32 key;
28
29	if (AvREAL(av))
30	return;
31	#ifdef DEBUGGING
32	if (SvTIED_mg((SV*)av, PERL_MAGIC_tied) && ckWARN_d(WARN_DEBUGGING))
33	Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "av_reify called on tied array");
34	#endif
35	key = AvMAX(av) + 1;
36	while (key > AvFILLp(av) + 1)
37	AvARRAY(av)[--key] = &PL_sv_undef;
38	while (key) {
39	SV * const sv = AvARRAY(av)[--key];
40	assert(sv);
41	if (sv != &PL_sv_undef)
42	(void)SvREFCNT_inc(sv);
43	}
44	key = AvARRAY(av) - AvALLOC(av);
45	while (key)
46	AvALLOC(av)[--key] = &PL_sv_undef;
47	AvREIFY_off(av);
48	AvREAL_on(av);
49	}
50
51	/*
52	=for apidoc av_extend
53
54	Pre-extend an array. The C<key> is the index to which the array should be
55	extended.
56
57	=cut
58	*/
59
60	void
61	Perl_av_extend(pTHX_ AV *av, I32 key)
62	{
63	MAGIC * const mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied);
64	if (mg) {
65	dSP;
66	ENTER;
67	SAVETMPS;
68	PUSHSTACKi(PERLSI_MAGIC);
69	PUSHMARK(SP);
70	EXTEND(SP,2);
71	PUSHs(SvTIED_obj((SV*)av, mg));
72	PUSHs(sv_2mortal(newSViv(key+1)));
73	PUTBACK;
74	call_method("EXTEND", G_SCALAR\|G_DISCARD);
75	POPSTACK;
76	FREETMPS;
77	LEAVE;
78	return;
79	}
80	if (key > AvMAX(av)) {
81	SV** ary;
82	I32 tmp;
83	I32 newmax;
84
85	if (AvALLOC(av) != AvARRAY(av)) {
86	ary = AvALLOC(av) + AvFILLp(av) + 1;
87	tmp = AvARRAY(av) - AvALLOC(av);
88	Move(AvARRAY(av), AvALLOC(av), AvFILLp(av)+1, SV*);
89	AvMAX(av) += tmp;
90	SvPV_set(av, (char*)AvALLOC(av));
91	if (AvREAL(av)) {
92	while (tmp)
93	ary[--tmp] = &PL_sv_undef;
94	}
95	if (key > AvMAX(av) - 10) {
96	newmax = key + AvMAX(av);
97	goto resize;
98	}
99	}
100	else {
101	#ifdef PERL_MALLOC_WRAP
102	static const char oom_array_extend[] =
103	"Out of memory during array extend"; /* Duplicated in pp_hot.c */
104	#endif
105
106	if (AvALLOC(av)) {
107	#if !defined(STRANGE_MALLOC) && !defined(MYMALLOC)
108	MEM_SIZE bytes;
109	IV itmp;
110	#endif
111
112	#ifdef MYMALLOC
113	newmax = malloced_size((void)AvALLOC(av))/sizeof(SV) - 1;
114
115	if (key <= newmax)
116	goto resized;
117	#endif
118	newmax = key + AvMAX(av) / 5;
119	resize:
120	MEM_WRAP_CHECK_1(newmax+1, SV*, oom_array_extend);
121	#if defined(STRANGE_MALLOC) \|\| defined(MYMALLOC)
122	Renew(AvALLOC(av),newmax+1, SV*);
123	#else
124	bytes = (newmax + 1) * sizeof(SV*);
125	#define MALLOC_OVERHEAD 16
126	itmp = MALLOC_OVERHEAD;
127	while ((MEM_SIZE)(itmp - MALLOC_OVERHEAD) < bytes)
128	itmp += itmp;
129	itmp -= MALLOC_OVERHEAD;
130	itmp /= sizeof(SV*);
131	assert(itmp > newmax);
132	newmax = itmp - 1;
133	assert(newmax >= AvMAX(av));
134	Newx(ary, newmax+1, SV*);
135	Copy(AvALLOC(av), ary, AvMAX(av)+1, SV*);
136	if (AvMAX(av) > 64)
137	offer_nice_chunk(AvALLOC(av), (AvMAX(av)+1) * sizeof(SV*));
138	else
139	Safefree(AvALLOC(av));
140	AvALLOC(av) = ary;
141	#endif
142	#ifdef MYMALLOC
143	resized:
144	#endif
145	ary = AvALLOC(av) + AvMAX(av) + 1;
146	tmp = newmax - AvMAX(av);
147	if (av == PL_curstack) { /* Oops, grew stack (via av_store()?) */
148	PL_stack_sp = AvALLOC(av) + (PL_stack_sp - PL_stack_base);
149	PL_stack_base = AvALLOC(av);
150	PL_stack_max = PL_stack_base + newmax;
151	}
152	}
153	else {
154	newmax = key < 3 ? 3 : key;
155	MEM_WRAP_CHECK_1(newmax+1, SV*, oom_array_extend);
156	Newx(AvALLOC(av), newmax+1, SV*);
157	ary = AvALLOC(av) + 1;
158	tmp = newmax;
159	AvALLOC(av)[0] = &PL_sv_undef; /* For the stacks */
160	}
161	if (AvREAL(av)) {
162	while (tmp)
163	ary[--tmp] = &PL_sv_undef;
164	}
165
166	SvPV_set(av, (char*)AvALLOC(av));
167	AvMAX(av) = newmax;
168	}
169	}
170	}
171
172	/*
173	=for apidoc av_fetch
174
175	Returns the SV at the specified index in the array. The C<key> is the
176	index. If C<lval> is set then the fetch will be part of a store. Check
177	that the return value is non-null before dereferencing it to a C<SV*>.
178
179	See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
180	more information on how to use this function on tied arrays.
181
182	=cut
183	*/
184
185	SV**
186	Perl_av_fetch(pTHX_ register AV *av, I32 key, I32 lval)
187	{
188	SV *sv;
189
190	if (!av)
191	return 0;
192
193	if (SvRMAGICAL(av)) {
194	const MAGIC * const tied_magic = mg_find((SV*)av, PERL_MAGIC_tied);
195	if (tied_magic \|\| mg_find((SV*)av, PERL_MAGIC_regdata)) {
196	U32 adjust_index = 1;
197
198	if (tied_magic && key < 0) {
199	/* Handle negative array indices 20020222 MJD */
200	SV * const * const negative_indices_glob =
201	hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *)av,
202	tied_magic))),
203	NEGATIVE_INDICES_VAR, 16, 0);
204
205	if (negative_indices_glob
206	&& SvTRUE(GvSV(*negative_indices_glob)))
207	adjust_index = 0;
208	}
209
210	if (key < 0 && adjust_index) {
211	key += AvFILL(av) + 1;
212	if (key < 0)
213	return 0;
214	}
215
216	sv = sv_newmortal();
217	sv_upgrade(sv, SVt_PVLV);
218	mg_copy((SV*)av, sv, 0, key);
219	LvTYPE(sv) = 't';
220	LvTARG(sv) = sv; /* fake (SV*) /
221	return &(LvTARG(sv));
222	}
223	}
224
225	if (key < 0) {
226	key += AvFILL(av) + 1;
227	if (key < 0)
228	return 0;
229	}
230
231	if (key > AvFILLp(av)) {
232	if (!lval)
233	return 0;
234	sv = NEWSV(5,0);
235	return av_store(av,key,sv);
236	}
237	if (AvARRAY(av)[key] == &PL_sv_undef) {
238	emptyness:
239	if (lval) {
240	sv = NEWSV(6,0);
241	return av_store(av,key,sv);
242	}
243	return 0;
244	}
245	else if (AvREIFY(av)
246	&& (!AvARRAY(av)[key] /* eg. @_ could have freed elts */
247	\|\| SvTYPE(AvARRAY(av)[key]) == SVTYPEMASK)) {
248	AvARRAY(av)[key] = &PL_sv_undef; /* 1/2 reify */
249	goto emptyness;
250	}
251	return &AvARRAY(av)[key];
252	}
253
254	/*
255	=for apidoc av_store
256
257	Stores an SV in an array. The array index is specified as C<key>. The
258	return value will be NULL if the operation failed or if the value did not
259	need to be actually stored within the array (as in the case of tied
260	arrays). Otherwise it can be dereferenced to get the original C<SV*>. Note
261	that the caller is responsible for suitably incrementing the reference
262	count of C<val> before the call, and decrementing it if the function
263	returned NULL.
264
265	See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
266	more information on how to use this function on tied arrays.
267
268	=cut
269	*/
270
271	SV**
272	Perl_av_store(pTHX_ register AV av, I32 key, SV val)
273	{
274	SV** ary;
275
276	if (!av)
277	return 0;
278	if (!val)
279	val = &PL_sv_undef;
280
281	if (SvRMAGICAL(av)) {
282	const MAGIC * const tied_magic = mg_find((SV*)av, PERL_MAGIC_tied);
283	if (tied_magic) {
284	/* Handle negative array indices 20020222 MJD */
285	if (key < 0) {
286	unsigned adjust_index = 1;
287	SV * const * const negative_indices_glob =
288	hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *)av,
289	tied_magic))),
290	NEGATIVE_INDICES_VAR, 16, 0);
291	if (negative_indices_glob
292	&& SvTRUE(GvSV(*negative_indices_glob)))
293	adjust_index = 0;
294	if (adjust_index) {
295	key += AvFILL(av) + 1;
296	if (key < 0)
297	return 0;
298	}
299	}
300	if (val != &PL_sv_undef) {
301	mg_copy((SV*)av, val, 0, key);
302	}
303	return 0;
304	}
305	}
306
307
308	if (key < 0) {
309	key += AvFILL(av) + 1;
310	if (key < 0)
311	return 0;
312	}
313
314	if (SvREADONLY(av) && key >= AvFILL(av))
315	Perl_croak(aTHX_ PL_no_modify);
316
317	if (!AvREAL(av) && AvREIFY(av))
318	av_reify(av);
319	if (key > AvMAX(av))
320	av_extend(av,key);
321	ary = AvARRAY(av);
322	if (AvFILLp(av) < key) {
323	if (!AvREAL(av)) {
324	if (av == PL_curstack && key > PL_stack_sp - PL_stack_base)
325	PL_stack_sp = PL_stack_base + key; /* XPUSH in disguise */
326	do
327	ary[++AvFILLp(av)] = &PL_sv_undef;
328	while (AvFILLp(av) < key);
329	}
330	AvFILLp(av) = key;
331	}
332	else if (AvREAL(av))
333	SvREFCNT_dec(ary[key]);
334	ary[key] = val;
335	if (SvSMAGICAL(av)) {
336	if (val != &PL_sv_undef) {
337	MAGIC* mg = SvMAGIC(av);
338	sv_magic(val, (SV*)av, toLOWER(mg->mg_type), 0, key);
339	}
340	mg_set((SV*)av);
341	}
342	return &ary[key];
343	}
344
345	/*
346	=for apidoc newAV
347
348	Creates a new AV. The reference count is set to 1.
349
350	=cut
351	*/
352
353	AV *
354	Perl_newAV(pTHX)
355	{
356	register AV * const av = (AV*)NEWSV(3,0);
357
358	sv_upgrade((SV *)av, SVt_PVAV);
359	/* sv_upgrade does AvREAL_only() */
360	AvALLOC(av) = 0;
361	SvPV_set(av, (char*)0);
362	AvMAX(av) = AvFILLp(av) = -1;
363	return av;
364	}
365
366	/*
367	=for apidoc av_make
368
369	Creates a new AV and populates it with a list of SVs. The SVs are copied
370	into the array, so they may be freed after the call to av_make. The new AV
371	will have a reference count of 1.
372
373	=cut
374	*/
375
376	AV *
377	Perl_av_make(pTHX_ register I32 size, register SV **strp)
378	{
379	register AV * const av = (AV*)NEWSV(8,0);
380
381	sv_upgrade((SV *) av,SVt_PVAV);
382	/* sv_upgrade does AvREAL_only() */
383	if (size) { /* "defined" was returning undef for size==0 anyway. */
384	register SV** ary;
385	register I32 i;
386	Newx(ary,size,SV*);
387	AvALLOC(av) = ary;
388	SvPV_set(av, (char*)ary);
389	AvFILLp(av) = size - 1;
390	AvMAX(av) = size - 1;
391	for (i = 0; i < size; i++) {
392	assert (*strp);
393	ary[i] = NEWSV(7,0);
394	sv_setsv(ary[i], *strp);
395	strp++;
396	}
397	}
398	return av;
399	}
400
401	AV *
402	Perl_av_fake(pTHX_ register I32 size, register SV **strp)
403	{
404	register SV** ary;
405	register AV * const av = (AV*)NEWSV(9,0);
406
407	sv_upgrade((SV *)av, SVt_PVAV);
408	Newx(ary,size+1,SV*);
409	AvALLOC(av) = ary;
410	Copy(strp,ary,size,SV*);
411	AvFLAGS(av) = AVf_REIFY;
412	SvPV_set(av, (char*)ary);
413	AvFILLp(av) = size - 1;
414	AvMAX(av) = size - 1;
415	while (size--) {
416	assert (*strp);
417	SvTEMP_off(*strp);
418	strp++;
419	}
420	return av;
421	}
422
423	/*
424	=for apidoc av_clear
425
426	Clears an array, making it empty. Does not free the memory used by the
427	array itself.
428
429	=cut
430	*/
431
432	void
433	Perl_av_clear(pTHX_ register AV *av)
434	{
435	register I32 key;
436
437	#ifdef DEBUGGING
438	if (SvREFCNT(av) == 0 && ckWARN_d(WARN_DEBUGGING)) {
439	Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "Attempt to clear deleted array");
440	}
441	#endif
442	if (!av)
443	return;
444
445	if (SvREADONLY(av))
446	Perl_croak(aTHX_ PL_no_modify);
447
448	/* Give any tie a chance to cleanup first */
449	if (SvRMAGICAL(av))
450	mg_clear((SV*)av);
451
452	if (AvMAX(av) < 0)
453	return;
454
455	if (AvREAL(av)) {
456	SV** const ary = AvARRAY(av);
457	key = AvFILLp(av) + 1;
458	while (key) {
459	SV * const sv = ary[--key];
460	/* undef the slot before freeing the value, because a
461	* destructor might try to modify this arrray */
462	ary[key] = &PL_sv_undef;
463	SvREFCNT_dec(sv);
464	}
465	}
466	if ((key = AvARRAY(av) - AvALLOC(av))) {
467	AvMAX(av) += key;
468	SvPV_set(av, (char*)AvALLOC(av));
469	}
470	AvFILLp(av) = -1;
471
472	}
473
474	/*
475	=for apidoc av_undef
476
477	Undefines the array. Frees the memory used by the array itself.
478
479	=cut
480	*/
481
482	void
483	Perl_av_undef(pTHX_ register AV *av)
484	{
485	if (!av)
486	return;
487
488	/* Give any tie a chance to cleanup first */
489	if (SvTIED_mg((SV*)av, PERL_MAGIC_tied))
490	av_fill(av, -1); /* mg_clear() ? */
491
492	if (AvREAL(av)) {
493	register I32 key = AvFILLp(av) + 1;
494	while (key)
495	SvREFCNT_dec(AvARRAY(av)[--key]);
496	}
497	Safefree(AvALLOC(av));
498	AvALLOC(av) = 0;
499	SvPV_set(av, (char*)0);
500	AvMAX(av) = AvFILLp(av) = -1;
501	/* Need to check SvMAGICAL, as during global destruction it may be that
502	AvARYLEN(av) has been freed before av, and hence the SvANY() pointer
503	is now part of the linked list of SV heads, rather than pointing to
504	the original body. */
505	/* FIXME - audit the code for other bugs like this one. */
506	if (AvARYLEN(av) && SvMAGICAL(AvARYLEN(av))) {
507	MAGIC *mg = mg_find (AvARYLEN(av), PERL_MAGIC_arylen);
508
509	if (mg) {
510	/* arylen scalar holds a pointer back to the array, but doesn't
511	own a reference. Hence the we (the array) are about to go away
512	with it still pointing at us. Clear its pointer, else it would
513	be pointing at free memory. See the comment in sv_magic about
514	reference loops, and why it can't own a reference to us. */
515	mg->mg_obj = 0;
516	}
517
518	SvREFCNT_dec(AvARYLEN(av));
519	AvARYLEN(av) = 0;
520	}
521	}
522
523	/*
524	=for apidoc av_push
525
526	Pushes an SV onto the end of the array. The array will grow automatically
527	to accommodate the addition.
528
529	=cut
530	*/
531
532	void
533	Perl_av_push(pTHX_ register AV av, SV val)
534	{
535	MAGIC *mg;
536	if (!av)
537	return;
538	if (SvREADONLY(av))
539	Perl_croak(aTHX_ PL_no_modify);
540
541	if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
542	dSP;
543	PUSHSTACKi(PERLSI_MAGIC);
544	PUSHMARK(SP);
545	EXTEND(SP,2);
546	PUSHs(SvTIED_obj((SV*)av, mg));
547	PUSHs(val);
548	PUTBACK;
549	ENTER;
550	call_method("PUSH", G_SCALAR\|G_DISCARD);
551	LEAVE;
552	POPSTACK;
553	return;
554	}
555	av_store(av,AvFILLp(av)+1,val);
556	}
557
558	/*
559	=for apidoc av_pop
560
561	Pops an SV off the end of the array. Returns C<&PL_sv_undef> if the array
562	is empty.
563
564	=cut
565	*/
566
567	SV *
568	Perl_av_pop(pTHX_ register AV *av)
569	{
570	SV *retval;
571	MAGIC* mg;
572
573	if (!av)
574	return &PL_sv_undef;
575	if (SvREADONLY(av))
576	Perl_croak(aTHX_ PL_no_modify);
577	if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
578	dSP;
579	PUSHSTACKi(PERLSI_MAGIC);
580	PUSHMARK(SP);
581	XPUSHs(SvTIED_obj((SV*)av, mg));
582	PUTBACK;
583	ENTER;
584	if (call_method("POP", G_SCALAR)) {
585	retval = newSVsv(*PL_stack_sp--);
586	} else {
587	retval = &PL_sv_undef;
588	}
589	LEAVE;
590	POPSTACK;
591	return retval;
592	}
593	if (AvFILL(av) < 0)
594	return &PL_sv_undef;
595	retval = AvARRAY(av)[AvFILLp(av)];
596	AvARRAY(av)[AvFILLp(av)--] = &PL_sv_undef;
597	if (SvSMAGICAL(av))
598	mg_set((SV*)av);
599	return retval;
600	}
601
602	/*
603	=for apidoc av_unshift
604
605	Unshift the given number of C<undef> values onto the beginning of the
606	array. The array will grow automatically to accommodate the addition. You
607	must then use C<av_store> to assign values to these new elements.
608
609	=cut
610	*/
611
612	void
613	Perl_av_unshift(pTHX_ register AV *av, register I32 num)
614	{
615	register I32 i;
616	MAGIC* mg;
617
618	if (!av)
619	return;
620	if (SvREADONLY(av))
621	Perl_croak(aTHX_ PL_no_modify);
622
623	if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
624	dSP;
625	PUSHSTACKi(PERLSI_MAGIC);
626	PUSHMARK(SP);
627	EXTEND(SP,1+num);
628	PUSHs(SvTIED_obj((SV*)av, mg));
629	while (num-- > 0) {
630	PUSHs(&PL_sv_undef);
631	}
632	PUTBACK;
633	ENTER;
634	call_method("UNSHIFT", G_SCALAR\|G_DISCARD);
635	LEAVE;
636	POPSTACK;
637	return;
638	}
639
640	if (num <= 0)
641	return;
642	if (!AvREAL(av) && AvREIFY(av))
643	av_reify(av);
644	i = AvARRAY(av) - AvALLOC(av);
645	if (i) {
646	if (i > num)
647	i = num;
648	num -= i;
649
650	AvMAX(av) += i;
651	AvFILLp(av) += i;
652	SvPV_set(av, (char*)(AvARRAY(av) - i));
653	}
654	if (num) {
655	register SV **ary;
656	I32 slide;
657	i = AvFILLp(av);
658	/* Create extra elements */
659	slide = i > 0 ? i : 0;
660	num += slide;
661	av_extend(av, i + num);
662	AvFILLp(av) += num;
663	ary = AvARRAY(av);
664	Move(ary, ary + num, i + 1, SV*);
665	do {
666	ary[--num] = &PL_sv_undef;
667	} while (num);
668	/* Make extra elements into a buffer */
669	AvMAX(av) -= slide;
670	AvFILLp(av) -= slide;
671	SvPV_set(av, (char*)(AvARRAY(av) + slide));
672	}
673	}
674
675	/*
676	=for apidoc av_shift
677
678	Shifts an SV off the beginning of the array.
679
680	=cut
681	*/
682
683	SV *
684	Perl_av_shift(pTHX_ register AV *av)
685	{
686	SV *retval;
687	MAGIC* mg;
688
689	if (!av)
690	return &PL_sv_undef;
691	if (SvREADONLY(av))
692	Perl_croak(aTHX_ PL_no_modify);
693	if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
694	dSP;
695	PUSHSTACKi(PERLSI_MAGIC);
696	PUSHMARK(SP);
697	XPUSHs(SvTIED_obj((SV*)av, mg));
698	PUTBACK;
699	ENTER;
700	if (call_method("SHIFT", G_SCALAR)) {
701	retval = newSVsv(*PL_stack_sp--);
702	} else {
703	retval = &PL_sv_undef;
704	}
705	LEAVE;
706	POPSTACK;
707	return retval;
708	}
709	if (AvFILL(av) < 0)
710	return &PL_sv_undef;
711	retval = *AvARRAY(av);
712	if (AvREAL(av))
713	*AvARRAY(av) = &PL_sv_undef;
714	SvPV_set(av, (char*)(AvARRAY(av) + 1));
715	AvMAX(av)--;
716	AvFILLp(av)--;
717	if (SvSMAGICAL(av))
718	mg_set((SV*)av);
719	return retval;
720	}
721
722	/*
723	=for apidoc av_len
724
725	Returns the highest index in the array. Returns -1 if the array is
726	empty.
727
728	=cut
729	*/
730
731	I32
732	Perl_av_len(pTHX_ register AV *av)
733	{
734	return AvFILL(av);
735	}
736
737	/*
738	=for apidoc av_fill
739
740	Ensure than an array has a given number of elements, equivalent to
741	Perl's C<$#array = $fill;>.
742
743	=cut
744	*/
745	void
746	Perl_av_fill(pTHX_ register AV *av, I32 fill)
747	{
748	MAGIC *mg;
749	if (!av)
750	Perl_croak(aTHX_ "panic: null array");
751	if (fill < 0)
752	fill = -1;
753	if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
754	dSP;
755	ENTER;
756	SAVETMPS;
757	PUSHSTACKi(PERLSI_MAGIC);
758	PUSHMARK(SP);
759	EXTEND(SP,2);
760	PUSHs(SvTIED_obj((SV*)av, mg));
761	PUSHs(sv_2mortal(newSViv(fill+1)));
762	PUTBACK;
763	call_method("STORESIZE", G_SCALAR\|G_DISCARD);
764	POPSTACK;
765	FREETMPS;
766	LEAVE;
767	return;
768	}
769	if (fill <= AvMAX(av)) {
770	I32 key = AvFILLp(av);
771	SV** ary = AvARRAY(av);
772
773	if (AvREAL(av)) {
774	while (key > fill) {
775	SvREFCNT_dec(ary[key]);
776	ary[key--] = &PL_sv_undef;
777	}
778	}
779	else {
780	while (key < fill)
781	ary[++key] = &PL_sv_undef;
782	}
783
784	AvFILLp(av) = fill;
785	if (SvSMAGICAL(av))
786	mg_set((SV*)av);
787	}
788	else
789	(void)av_store(av,fill,&PL_sv_undef);
790	}
791
792	/*
793	=for apidoc av_delete
794
795	Deletes the element indexed by C<key> from the array. Returns the
796	deleted element. If C<flags> equals C<G_DISCARD>, the element is freed
797	and null is returned.
798
799	=cut
800	*/
801	SV *
802	Perl_av_delete(pTHX_ AV *av, I32 key, I32 flags)
803	{
804	SV *sv;
805
806	if (!av)
807	return Nullsv;
808	if (SvREADONLY(av))
809	Perl_croak(aTHX_ PL_no_modify);
810
811	if (SvRMAGICAL(av)) {
812	const MAGIC * const tied_magic = mg_find((SV*)av, PERL_MAGIC_tied);
813	if ((tied_magic \|\| mg_find((SV*)av, PERL_MAGIC_regdata))) {
814	/* Handle negative array indices 20020222 MJD */
815	SV **svp;
816	if (key < 0) {
817	unsigned adjust_index = 1;
818	if (tied_magic) {
819	SV * const * const negative_indices_glob =
820	hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *)av,
821	tied_magic))),
822	NEGATIVE_INDICES_VAR, 16, 0);
823	if (negative_indices_glob
824	&& SvTRUE(GvSV(*negative_indices_glob)))
825	adjust_index = 0;
826	}
827	if (adjust_index) {
828	key += AvFILL(av) + 1;
829	if (key < 0)
830	return Nullsv;
831	}
832	}
833	svp = av_fetch(av, key, TRUE);
834	if (svp) {
835	sv = *svp;
836	mg_clear(sv);
837	if (mg_find(sv, PERL_MAGIC_tiedelem)) {
838	sv_unmagic(sv, PERL_MAGIC_tiedelem); /* No longer an element */
839	return sv;
840	}
841	return Nullsv;
842	}
843	}
844	}
845
846	if (key < 0) {
847	key += AvFILL(av) + 1;
848	if (key < 0)
849	return Nullsv;
850	}
851
852	if (key > AvFILLp(av))
853	return Nullsv;
854	else {
855	if (!AvREAL(av) && AvREIFY(av))
856	av_reify(av);
857	sv = AvARRAY(av)[key];
858	if (key == AvFILLp(av)) {
859	AvARRAY(av)[key] = &PL_sv_undef;
860	do {
861	AvFILLp(av)--;
862	} while (--key >= 0 && AvARRAY(av)[key] == &PL_sv_undef);
863	}
864	else
865	AvARRAY(av)[key] = &PL_sv_undef;
866	if (SvSMAGICAL(av))
867	mg_set((SV*)av);
868	}
869	if (flags & G_DISCARD) {
870	SvREFCNT_dec(sv);
871	sv = Nullsv;
872	}
873	else if (AvREAL(av))
874	sv = sv_2mortal(sv);
875	return sv;
876	}
877
878	/*
879	=for apidoc av_exists
880
881	Returns true if the element indexed by C<key> has been initialized.
882
883	This relies on the fact that uninitialized array elements are set to
884	C<&PL_sv_undef>.
885
886	=cut
887	*/
888	bool
889	Perl_av_exists(pTHX_ AV *av, I32 key)
890	{
891	if (!av)
892	return FALSE;
893
894
895	if (SvRMAGICAL(av)) {
896	const MAGIC * const tied_magic = mg_find((SV*)av, PERL_MAGIC_tied);
897	if (tied_magic \|\| mg_find((SV*)av, PERL_MAGIC_regdata)) {
898	SV *sv = sv_newmortal();
899	MAGIC *mg;
900	/* Handle negative array indices 20020222 MJD */
901	if (key < 0) {
902	unsigned adjust_index = 1;
903	if (tied_magic) {
904	SV * const * const negative_indices_glob =
905	hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *)av,
906	tied_magic))),
907	NEGATIVE_INDICES_VAR, 16, 0);
908	if (negative_indices_glob
909	&& SvTRUE(GvSV(*negative_indices_glob)))
910	adjust_index = 0;
911	}
912	if (adjust_index) {
913	key += AvFILL(av) + 1;
914	if (key < 0)
915	return FALSE;
916	}
917	}
918
919	mg_copy((SV*)av, sv, 0, key);
920	mg = mg_find(sv, PERL_MAGIC_tiedelem);
921	if (mg) {
922	magic_existspack(sv, mg);
923	return (bool)SvTRUE(sv);
924	}
925
926	}
927	}
928
929	if (key < 0) {
930	key += AvFILL(av) + 1;
931	if (key < 0)
932	return FALSE;
933	}
934
935	if (key <= AvFILLp(av) && AvARRAY(av)[key] != &PL_sv_undef
936	&& AvARRAY(av)[key])
937	{
938	return TRUE;
939	}
940	else
941	return FALSE;
942	}
943
944	/* AVHV: Support for treating arrays as if they were hashes. The
945	* first element of the array should be a hash reference that maps
946	* hash keys to array indices.
947	*/
948
949	STATIC I32
950	S_avhv_index_sv(pTHX_ SV* sv)
951	{
952	I32 index = SvIV(sv);
953	if (index < 1)
954	Perl_croak(aTHX_ "Bad index while coercing array into hash");
955	return index;
956	}
957
958	STATIC I32
959	S_avhv_index(pTHX_ AV av, SV keysv, U32 hash)
960	{
961	HV *keys;
962	HE *he;
963	STRLEN n_a;
964
965	keys = avhv_keys(av);
966	he = hv_fetch_ent(keys, keysv, FALSE, hash);
967	if (!he)
968	Perl_croak(aTHX_ "No such pseudo-hash field \"%s\"", SvPV(keysv,n_a));
969	return avhv_index_sv(HeVAL(he));
970	}
971
972	HV*
973	Perl_avhv_keys(pTHX_ AV *av)
974	{
975	SV **keysp = av_fetch(av, 0, FALSE);
976	if (keysp) {
977	SV sv = keysp;
978	if (SvGMAGICAL(sv))
979	mg_get(sv);
980	if (SvROK(sv)) {
981	if (ckWARN(WARN_DEPRECATED) && !sv_isa(sv, "pseudohash"))
982	Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
983	"Pseudo-hashes are deprecated");
984	sv = SvRV(sv);
985	if (SvTYPE(sv) == SVt_PVHV)
986	return (HV*)sv;
987	}
988	}
989	Perl_croak(aTHX_ "Can't coerce array into hash");
990	return Nullhv;
991	}
992
993	SV**
994	Perl_avhv_store_ent(pTHX_ AV av, SV keysv, SV *val, U32 hash)
995	{
996	return av_store(av, avhv_index(av, keysv, hash), val);
997	}
998
999	SV**
1000	Perl_avhv_fetch_ent(pTHX_ AV av, SV keysv, I32 lval, U32 hash)
1001	{
1002	return av_fetch(av, avhv_index(av, keysv, hash), lval);
1003	}
1004
1005	SV *
1006	Perl_avhv_delete_ent(pTHX_ AV av, SV keysv, I32 flags, U32 hash)
1007	{
1008	HV *keys = avhv_keys(av);
1009	HE *he;
1010
1011	he = hv_fetch_ent(keys, keysv, FALSE, hash);
1012	if (!he \|\| !SvOK(HeVAL(he)))
1013	return Nullsv;
1014
1015	return av_delete(av, avhv_index_sv(HeVAL(he)), flags);
1016	}
1017
1018	/* Check for the existence of an element named by a given key.
1019	*
1020	*/
1021	bool
1022	Perl_avhv_exists_ent(pTHX_ AV av, SV keysv, U32 hash)
1023	{
1024	HV *keys = avhv_keys(av);
1025	HE *he;
1026
1027	he = hv_fetch_ent(keys, keysv, FALSE, hash);
1028	if (!he \|\| !SvOK(HeVAL(he)))
1029	return FALSE;
1030
1031	return av_exists(av, avhv_index_sv(HeVAL(he)));
1032	}
1033
1034	HE *
1035	Perl_avhv_iternext(pTHX_ AV *av)
1036	{
1037	HV *keys = avhv_keys(av);
1038	return hv_iternext(keys);
1039	}
1040
1041	SV *
1042	Perl_avhv_iterval(pTHX_ AV av, register HE entry)
1043	{
1044	SV *sv = hv_iterval(avhv_keys(av), entry);
1045	return *av_fetch(av, avhv_index_sv(sv), TRUE);
1046	}
1047
1048	/*
1049	* Local variables:
1050	* c-indentation-style: bsd
1051	* c-basic-offset: 4
1052	* indent-tabs-mode: t
1053	* End:
1054	*
1055	* ex: set ts=8 sts=4 sw=4 noet:
1056	*/

Note: See TracBrowser for help on using the repository browser.

Context Navigation

source: vendor/perl/5.8.8/av.c@ 3356

Download in other formats: