1 /* av.c
2 *
3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 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 * [p.476 of _The Lord of the Rings_, III/iv: "Treebeard"]
16 */
17
18 #include "EXTERN.h"
19 #define PERL_IN_AV_C
20 #include "perl.h"
21
22 void
Perl_av_reify(pTHX_ AV * av)23 Perl_av_reify(pTHX_ AV *av)
24 {
25 SSize_t key;
26
27 PERL_ARGS_ASSERT_AV_REIFY;
28 assert(SvTYPE(av) == SVt_PVAV);
29
30 if (AvREAL(av))
31 return;
32 #ifdef DEBUGGING
33 if (SvTIED_mg((const SV *)av, PERL_MAGIC_tied))
34 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "av_reify called on tied array");
35 #endif
36 key = AvMAX(av) + 1;
37 while (key > AvFILLp(av) + 1)
38 AvARRAY(av)[--key] = NULL;
39 while (key) {
40 SV * const sv = AvARRAY(av)[--key];
41 if (sv != &PL_sv_undef)
42 SvREFCNT_inc_simple_void(sv);
43 }
44 key = AvARRAY(av) - AvALLOC(av);
45 if (key)
46 Zero(AvALLOC(av), key, SV*);
47 AvREIFY_off(av);
48 AvREAL_on(av);
49 }
50
51 /*
52 =for apidoc av_extend
53
54 Pre-extend an array so that it is capable of storing values at indexes
55 C<0..key>. Thus C<av_extend(av,99)> guarantees that the array can store 100
56 elements, i.e. that C<av_store(av, 0, sv)> through C<av_store(av, 99, sv)>
57 on a plain array will work without any further memory allocation.
58
59 If the av argument is a tied array then will call the C<EXTEND> tied
60 array method with an argument of C<(key+1)>.
61
62 =cut
63 */
64
65 void
Perl_av_extend(pTHX_ AV * av,SSize_t key)66 Perl_av_extend(pTHX_ AV *av, SSize_t key)
67 {
68 MAGIC *mg;
69
70 PERL_ARGS_ASSERT_AV_EXTEND;
71 assert(SvTYPE(av) == SVt_PVAV);
72
73 mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied);
74 if (mg) {
75 SV *arg1 = sv_newmortal();
76 /* NOTE: the API for av_extend() is NOT the same as the tie method EXTEND.
77 *
78 * The C function takes an *index* (assumes 0 indexed arrays) and ensures
79 * that the array is at least as large as the index provided.
80 *
81 * The tied array method EXTEND takes a *count* and ensures that the array
82 * is at least that many elements large. Thus we have to +1 the key when
83 * we call the tied method.
84 */
85 sv_setiv(arg1, (IV)(key + 1));
86 Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(EXTEND), G_DISCARD, 1,
87 arg1);
88 return;
89 }
90 av_extend_guts(av,key,&AvMAX(av),&AvALLOC(av),&AvARRAY(av));
91 }
92
93 /* The guts of av_extend. *Not* for general use! */
94 /* Also called directly from pp_assign, padlist_store, padnamelist_store */
95 void
Perl_av_extend_guts(pTHX_ AV * av,SSize_t key,SSize_t * maxp,SV *** allocp,SV *** arrayp)96 Perl_av_extend_guts(pTHX_ AV *av, SSize_t key, SSize_t *maxp, SV ***allocp,
97 SV ***arrayp)
98 {
99 PERL_ARGS_ASSERT_AV_EXTEND_GUTS;
100
101 if (key < -1) /* -1 is legal */
102 Perl_croak(aTHX_
103 "panic: av_extend_guts() negative count (%" IVdf ")", (IV)key);
104
105 if (key > *maxp) {
106 SSize_t ary_offset = *maxp + 1; /* Start NULL initialization
107 * from this element */
108 SSize_t to_null = 0; /* How many elements to Zero */
109 SSize_t newmax = 0;
110
111 if (av && *allocp != *arrayp) { /* a shifted SV* array exists */
112
113 /* to_null will contain the number of elements currently
114 * shifted and about to be unshifted. If the array has not
115 * been shifted to the maximum possible extent, this will be
116 * a smaller number than (*maxp - AvFILLp(av)). */
117 to_null = *arrayp - *allocp;
118
119 *maxp += to_null;
120 ary_offset = AvFILLp(av) + 1;
121
122 Move(*arrayp, *allocp, AvFILLp(av)+1, SV*);
123
124 if (key > *maxp - 10) {
125 newmax = key + *maxp;
126
127 /* Zero everything above AvFILLp(av), which could be more
128 * elements than have actually been shifted. If we don't
129 * do this, trailing elements at the end of the resized
130 * array may not be correctly initialized. */
131 to_null = *maxp - AvFILLp(av);
132
133 goto resize;
134 }
135 } else if (*allocp) { /* a full SV* array exists */
136
137 #ifdef Perl_safesysmalloc_size
138 /* Whilst it would be quite possible to move this logic around
139 (as I did in the SV code), so as to set AvMAX(av) early,
140 based on calling Perl_safesysmalloc_size() immediately after
141 allocation, I'm not convinced that it is a great idea here.
142 In an array we have to loop round setting everything to
143 NULL, which means writing to memory, potentially lots
144 of it, whereas for the SV buffer case we don't touch the
145 "bonus" memory. So there there is no cost in telling the
146 world about it, whereas here we have to do work before we can
147 tell the world about it, and that work involves writing to
148 memory that might never be read. So, I feel, better to keep
149 the current lazy system of only writing to it if our caller
150 has a need for more space. NWC */
151 newmax = Perl_safesysmalloc_size((void*)*allocp) /
152 sizeof(const SV *) - 1;
153
154 if (key <= newmax)
155 goto resized;
156 #endif
157 /* overflow-safe version of newmax = key + *maxp/5 */
158 newmax = *maxp / 5;
159 newmax = (key > SSize_t_MAX - newmax)
160 ? SSize_t_MAX : key + newmax;
161 resize:
162 {
163 /* it should really be newmax+1 here, but if newmax
164 * happens to equal SSize_t_MAX, then newmax+1 is
165 * undefined. This means technically we croak one
166 * index lower than we should in theory; in practice
167 * its unlikely the system has SSize_t_MAX/sizeof(SV*)
168 * bytes to spare! */
169 MEM_WRAP_CHECK_s(newmax, SV*, "Out of memory during array extend");
170 }
171 #ifdef STRESS_REALLOC
172 {
173 SV ** const old_alloc = *allocp;
174 Newx(*allocp, newmax+1, SV*);
175 Copy(old_alloc, *allocp, *maxp + 1, SV*);
176 Safefree(old_alloc);
177 }
178 #else
179 Renew(*allocp,newmax+1, SV*);
180 #endif
181 #ifdef Perl_safesysmalloc_size
182 resized:
183 #endif
184 to_null += newmax - *maxp; /* Initialize all new elements
185 * (newmax - *maxp) in addition to
186 * any previously specified */
187 *maxp = newmax;
188
189 /* See GH#18014 for discussion of when this might be needed: */
190 if (av == PL_curstack) { /* Oops, grew stack (via av_store()?) */
191 PL_stack_sp = *allocp + (PL_stack_sp - PL_stack_base);
192 PL_stack_base = *allocp;
193 PL_stack_max = PL_stack_base + newmax;
194 }
195 } else { /* there is no SV* array yet */
196 *maxp = key < PERL_ARRAY_NEW_MIN_KEY ?
197 PERL_ARRAY_NEW_MIN_KEY : key;
198 {
199 /* see comment above about newmax+1*/
200 MEM_WRAP_CHECK_s(*maxp, SV*,
201 "Out of memory during array extend");
202 }
203 /* Newxz isn't used below because testing showed it to be slower
204 * than Newx+Zero (also slower than Newx + the previous while
205 * loop) for small arrays, which are very common in perl. */
206 Newx(*allocp, *maxp+1, SV*);
207 /* Stacks require only the first element to be &PL_sv_undef
208 * (set elsewhere). However, since non-stack AVs are likely
209 * to dominate in modern production applications, stacks
210 * don't get any special treatment here.
211 * See https://github.com/Perl/perl5/pull/18690 for more detail */
212 ary_offset = 0;
213 to_null = *maxp+1; /* Initialize all new array elements */
214 goto zero;
215 }
216
217 if (av && AvREAL(av)) {
218 zero:
219 Zero(*allocp + ary_offset,to_null,SV*);
220 }
221
222 *arrayp = *allocp;
223 }
224 }
225
226 /*
227 =for apidoc av_fetch
228
229 Returns the SV at the specified index in the array. The C<key> is the
230 index. If C<lval> is true, you are guaranteed to get a real SV back (in case
231 it wasn't real before), which you can then modify. Check that the return
232 value is non-NULL before dereferencing it to a C<SV*>.
233
234 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
235 more information on how to use this function on tied arrays.
236
237 The rough perl equivalent is C<$myarray[$key]>.
238
239 =cut
240 */
241
242 static bool
S_adjust_index(pTHX_ AV * av,const MAGIC * mg,SSize_t * keyp)243 S_adjust_index(pTHX_ AV *av, const MAGIC *mg, SSize_t *keyp)
244 {
245 bool adjust_index = 1;
246 if (mg) {
247 /* Handle negative array indices 20020222 MJD */
248 SV * const ref = SvTIED_obj(MUTABLE_SV(av), mg);
249 SvGETMAGIC(ref);
250 if (SvROK(ref) && SvOBJECT(SvRV(ref))) {
251 SV * const * const negative_indices_glob =
252 hv_fetchs(SvSTASH(SvRV(ref)), NEGATIVE_INDICES_VAR, 0);
253
254 if (negative_indices_glob && isGV(*negative_indices_glob)
255 && SvTRUE(GvSV(*negative_indices_glob)))
256 adjust_index = 0;
257 }
258 }
259
260 if (adjust_index) {
261 *keyp += AvFILL(av) + 1;
262 if (*keyp < 0)
263 return FALSE;
264 }
265 return TRUE;
266 }
267
268 SV**
Perl_av_fetch(pTHX_ AV * av,SSize_t key,I32 lval)269 Perl_av_fetch(pTHX_ AV *av, SSize_t key, I32 lval)
270 {
271 SSize_t neg;
272 SSize_t size;
273
274 PERL_ARGS_ASSERT_AV_FETCH;
275 assert(SvTYPE(av) == SVt_PVAV);
276
277 if (UNLIKELY(SvRMAGICAL(av))) {
278 const MAGIC * const tied_magic
279 = mg_find((const SV *)av, PERL_MAGIC_tied);
280 if (tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata)) {
281 SV *sv;
282 if (key < 0) {
283 if (!S_adjust_index(aTHX_ av, tied_magic, &key))
284 return NULL;
285 }
286
287 sv = newSV_type_mortal(SVt_PVLV);
288 mg_copy(MUTABLE_SV(av), sv, 0, key);
289 if (!tied_magic) /* for regdata, force leavesub to make copies */
290 SvTEMP_off(sv);
291 LvTYPE(sv) = 't';
292 LvTARG(sv) = sv; /* fake (SV**) */
293 return &(LvTARG(sv));
294 }
295 }
296
297 neg = (key < 0);
298 size = AvFILLp(av) + 1;
299 key += neg * size; /* handle negative index without using branch */
300
301 /* the cast from SSize_t to Size_t allows both (key < 0) and (key >= size)
302 * to be tested as a single condition */
303 if ((Size_t)key >= (Size_t)size) {
304 if (UNLIKELY(neg))
305 return NULL;
306 goto emptiness;
307 }
308
309 if (!AvARRAY(av)[key]) {
310 emptiness:
311 return lval ? av_store(av,key,newSV_type(SVt_NULL)) : NULL;
312 }
313
314 return &AvARRAY(av)[key];
315 }
316
317 /*
318 =for apidoc av_store
319
320 Stores an SV in an array. The array index is specified as C<key>. The
321 return value will be C<NULL> if the operation failed or if the value did not
322 need to be actually stored within the array (as in the case of tied
323 arrays). Otherwise, it can be dereferenced
324 to get the C<SV*> that was stored
325 there (= C<val>)).
326
327 Note that the caller is responsible for suitably incrementing the reference
328 count of C<val> before the call, and decrementing it if the function
329 returned C<NULL>.
330
331 Approximate Perl equivalent: C<splice(@myarray, $key, 1, $val)>.
332
333 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
334 more information on how to use this function on tied arrays.
335
336 =cut
337 */
338
339 SV**
Perl_av_store(pTHX_ AV * av,SSize_t key,SV * val)340 Perl_av_store(pTHX_ AV *av, SSize_t key, SV *val)
341 {
342 SV** ary;
343
344 PERL_ARGS_ASSERT_AV_STORE;
345 assert(SvTYPE(av) == SVt_PVAV);
346
347 /* S_regclass relies on being able to pass in a NULL sv
348 (unicode_alternate may be NULL).
349 */
350
351 if (SvRMAGICAL(av)) {
352 const MAGIC * const tied_magic = mg_find((const SV *)av, PERL_MAGIC_tied);
353 if (tied_magic) {
354 if (key < 0) {
355 if (!S_adjust_index(aTHX_ av, tied_magic, &key))
356 return 0;
357 }
358 if (val) {
359 mg_copy(MUTABLE_SV(av), val, 0, key);
360 }
361 return NULL;
362 }
363 }
364
365
366 if (key < 0) {
367 key += AvFILL(av) + 1;
368 if (key < 0)
369 return NULL;
370 }
371
372 if (SvREADONLY(av) && key >= AvFILL(av))
373 Perl_croak_no_modify();
374
375 if (!AvREAL(av) && AvREIFY(av))
376 av_reify(av);
377 if (key > AvMAX(av))
378 av_extend(av,key);
379 ary = AvARRAY(av);
380 if (AvFILLp(av) < key) {
381 if (!AvREAL(av)) {
382 if (av == PL_curstack && key > PL_stack_sp - PL_stack_base)
383 PL_stack_sp = PL_stack_base + key; /* XPUSH in disguise */
384 do {
385 ary[++AvFILLp(av)] = NULL;
386 } while (AvFILLp(av) < key);
387 }
388 AvFILLp(av) = key;
389 }
390 else if (AvREAL(av))
391 SvREFCNT_dec(ary[key]);
392
393 /* store the val into the AV before we call magic so that the magic can
394 * "see" the new value. Especially set magic on the AV itself. */
395 ary[key] = val;
396
397 if (SvSMAGICAL(av)) {
398 const MAGIC *mg = SvMAGIC(av);
399 bool set = TRUE;
400 /* We have to increment the refcount on val before we call any magic,
401 * as it is now stored in the AV (just before this block), we will
402 * then call the magic handlers which might die/Perl_croak, and
403 * longjmp up the stack to the most recent exception trap. Which means
404 * the caller code that would be expected to handle the refcount
405 * increment likely would never be executed, leading to a double free.
406 * This can happen in a case like
407 *
408 * @ary = (1);
409 *
410 * or this:
411 *
412 * if (av_store(av,n,sv)) SvREFCNT_inc(sv);
413 *
414 * where @ary/av has set magic applied to it which can die. In the
415 * first case the sv representing 1 would be mortalized, so when the
416 * set magic threw an exception it would be freed as part of the
417 * normal stack unwind. However this leaves the av structure still
418 * holding a valid visible pointer to the now freed value. In practice
419 * the next SV created will reuse the same reference, but without the
420 * refcount to account for the previous ownership and we end up with
421 * warnings about a totally different variable being double freed in
422 * the form of "attempt to free unreferenced variable"
423 * warnings/errors.
424 *
425 * https://github.com/Perl/perl5/issues/20675
426 *
427 * Arguably the API for av_store is broken in the face of magic. Instead
428 * av_store should be responsible for the refcount increment, and only
429 * not do it when specifically told to do so (eg, when storing an
430 * otherwise unreferenced scalar into an AV).
431 */
432 SvREFCNT_inc(val); /* see comment above */
433 for (; mg; mg = mg->mg_moremagic) {
434 if (!isUPPER(mg->mg_type)) continue;
435 if (val) {
436 sv_magic(val, MUTABLE_SV(av), toLOWER(mg->mg_type), 0, key);
437 }
438 if (PL_delaymagic && mg->mg_type == PERL_MAGIC_isa) {
439 PL_delaymagic |= DM_ARRAY_ISA;
440 set = FALSE;
441 }
442 }
443 if (set)
444 mg_set(MUTABLE_SV(av));
445 /* And now we are done the magic, we have to decrement it back as the av_store() api
446 * says the caller is responsible for the refcount increment, assuming
447 * av_store returns true. */
448 SvREFCNT_dec(val);
449 }
450 return &ary[key];
451 }
452
453 /*
454 =for apidoc av_make
455
456 Creates a new AV and populates it with a list (C<**strp>, length C<size>) of
457 SVs. A copy is made of each SV, so their refcounts are not changed. The new
458 AV will have a reference count of 1.
459
460 Perl equivalent: C<my @new_array = ($scalar1, $scalar2, $scalar3...);>
461
462 =cut
463 */
464
465 AV *
Perl_av_make(pTHX_ SSize_t size,SV ** strp)466 Perl_av_make(pTHX_ SSize_t size, SV **strp)
467 {
468 AV * const av = newAV();
469 /* sv_upgrade does AvREAL_only() */
470 PERL_ARGS_ASSERT_AV_MAKE;
471 assert(SvTYPE(av) == SVt_PVAV);
472
473 if (size) { /* "defined" was returning undef for size==0 anyway. */
474 SV** ary;
475 SSize_t i;
476 SSize_t orig_ix;
477
478 Newx(ary,size,SV*);
479 AvALLOC(av) = ary;
480 AvARRAY(av) = ary;
481 AvMAX(av) = size - 1;
482 /* avoid av being leaked if croak when calling magic below */
483 EXTEND_MORTAL(1);
484 PL_tmps_stack[++PL_tmps_ix] = (SV*)av;
485 orig_ix = PL_tmps_ix;
486
487 for (i = 0; i < size; i++) {
488 assert (*strp);
489
490 /* Don't let sv_setsv swipe, since our source array might
491 have multiple references to the same temp scalar (e.g.
492 from a list slice) */
493
494 SvGETMAGIC(*strp); /* before newSV, in case it dies */
495 AvFILLp(av)++;
496 ary[i] = newSV_type(SVt_NULL);
497 sv_setsv_flags(ary[i], *strp,
498 SV_DO_COW_SVSETSV|SV_NOSTEAL);
499 strp++;
500 }
501 /* disarm av's leak guard */
502 if (LIKELY(PL_tmps_ix == orig_ix))
503 PL_tmps_ix--;
504 else
505 PL_tmps_stack[orig_ix] = &PL_sv_undef;
506 }
507 return av;
508 }
509
510 /*
511 =for apidoc newAVav
512
513 Creates a new AV and populates it with values copied from an existing AV. The
514 new AV will have a reference count of 1, and will contain newly created SVs
515 copied from the original SV. The original source will remain unchanged.
516
517 Perl equivalent: C<my @new_array = @existing_array;>
518
519 =cut
520 */
521
522 AV *
Perl_newAVav(pTHX_ AV * oav)523 Perl_newAVav(pTHX_ AV *oav)
524 {
525 PERL_ARGS_ASSERT_NEWAVAV;
526
527 Size_t count = av_count(oav);
528
529 if(UNLIKELY(!oav) || count == 0)
530 return newAV();
531
532 AV *ret = newAV_alloc_x(count);
533
534 /* avoid ret being leaked if croak when calling magic below */
535 EXTEND_MORTAL(1);
536 PL_tmps_stack[++PL_tmps_ix] = (SV *)ret;
537 SSize_t ret_at_tmps_ix = PL_tmps_ix;
538
539 Size_t i;
540 if(LIKELY(!SvRMAGICAL(oav) && AvREAL(oav) && (SvTYPE(oav) == SVt_PVAV))) {
541 for(i = 0; i < count; i++) {
542 SV **svp = av_fetch_simple(oav, i, 0);
543 av_push_simple(ret, svp ? newSVsv(*svp) : &PL_sv_undef);
544 }
545 } else {
546 for(i = 0; i < count; i++) {
547 SV **svp = av_fetch(oav, i, 0);
548 av_push_simple(ret, svp ? newSVsv(*svp) : &PL_sv_undef);
549 }
550 }
551
552 /* disarm leak guard */
553 if(LIKELY(PL_tmps_ix == ret_at_tmps_ix))
554 PL_tmps_ix--;
555 else
556 PL_tmps_stack[ret_at_tmps_ix] = &PL_sv_undef;
557
558 return ret;
559 }
560
561 /*
562 =for apidoc newAVhv
563
564 Creates a new AV and populates it with keys and values copied from an existing
565 HV. The new AV will have a reference count of 1, and will contain newly
566 created SVs copied from the original HV. The original source will remain
567 unchanged.
568
569 Perl equivalent: C<my @new_array = %existing_hash;>
570
571 =cut
572 */
573
574 AV *
Perl_newAVhv(pTHX_ HV * ohv)575 Perl_newAVhv(pTHX_ HV *ohv)
576 {
577 PERL_ARGS_ASSERT_NEWAVHV;
578
579 if(UNLIKELY(!ohv))
580 return newAV();
581
582 bool tied = SvRMAGICAL(ohv) && mg_find(MUTABLE_SV(ohv), PERL_MAGIC_tied);
583
584 Size_t nkeys = hv_iterinit(ohv);
585 /* This number isn't perfect but it doesn't matter; it only has to be
586 * close to make the initial allocation about the right size
587 */
588 AV *ret = newAV_alloc_xz(nkeys ? nkeys * 2 : 2);
589
590 /* avoid ret being leaked if croak when calling magic below */
591 EXTEND_MORTAL(1);
592 PL_tmps_stack[++PL_tmps_ix] = (SV *)ret;
593 SSize_t ret_at_tmps_ix = PL_tmps_ix;
594
595
596 HE *he;
597 while((he = hv_iternext(ohv))) {
598 if(tied) {
599 av_push_simple(ret, newSVsv(hv_iterkeysv(he)));
600 av_push_simple(ret, newSVsv(hv_iterval(ohv, he)));
601 }
602 else {
603 av_push_simple(ret, newSVhek(HeKEY_hek(he)));
604 av_push_simple(ret, HeVAL(he) ? newSVsv(HeVAL(he)) : &PL_sv_undef);
605 }
606 }
607
608 /* disarm leak guard */
609 if(LIKELY(PL_tmps_ix == ret_at_tmps_ix))
610 PL_tmps_ix--;
611 else
612 PL_tmps_stack[ret_at_tmps_ix] = &PL_sv_undef;
613
614 return ret;
615 }
616
617 /*
618 =for apidoc av_clear
619
620 Frees all the elements of an array, leaving it empty.
621 The XS equivalent of C<@array = ()>. See also L</av_undef>.
622
623 Note that it is possible that the actions of a destructor called directly
624 or indirectly by freeing an element of the array could cause the reference
625 count of the array itself to be reduced (e.g. by deleting an entry in the
626 symbol table). So it is a possibility that the AV could have been freed
627 (or even reallocated) on return from the call unless you hold a reference
628 to it.
629
630 =cut
631 */
632
633 void
Perl_av_clear(pTHX_ AV * av)634 Perl_av_clear(pTHX_ AV *av)
635 {
636 bool real;
637 SSize_t orig_ix = 0;
638
639 PERL_ARGS_ASSERT_AV_CLEAR;
640 assert(SvTYPE(av) == SVt_PVAV);
641
642 #ifdef DEBUGGING
643 if (SvREFCNT(av) == 0) {
644 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "Attempt to clear deleted array");
645 }
646 #endif
647
648 if (SvREADONLY(av))
649 Perl_croak_no_modify();
650
651 /* Give any tie a chance to cleanup first */
652 if (SvRMAGICAL(av)) {
653 const MAGIC* const mg = SvMAGIC(av);
654 if (PL_delaymagic && mg && mg->mg_type == PERL_MAGIC_isa)
655 PL_delaymagic |= DM_ARRAY_ISA;
656 else
657 mg_clear(MUTABLE_SV(av));
658 }
659
660 if (AvMAX(av) < 0)
661 return;
662
663 if ((real = cBOOL(AvREAL(av)))) {
664 SV** const ary = AvARRAY(av);
665 SSize_t index = AvFILLp(av) + 1;
666
667 /* avoid av being freed when calling destructors below */
668 EXTEND_MORTAL(1);
669 PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(av);
670 orig_ix = PL_tmps_ix;
671
672 while (index) {
673 SV * const sv = ary[--index];
674 /* undef the slot before freeing the value, because a
675 * destructor might try to modify this array */
676 ary[index] = NULL;
677 SvREFCNT_dec(sv);
678 }
679 }
680 AvFILLp(av) = -1;
681 av_remove_offset(av);
682
683 if (real) {
684 /* disarm av's premature free guard */
685 if (LIKELY(PL_tmps_ix == orig_ix))
686 PL_tmps_ix--;
687 else
688 PL_tmps_stack[orig_ix] = &PL_sv_undef;
689 SvREFCNT_dec_NN(av);
690 }
691 }
692
693 /*
694 =for apidoc av_undef
695
696 Undefines the array. The XS equivalent of C<undef(@array)>.
697
698 As well as freeing all the elements of the array (like C<av_clear()>), this
699 also frees the memory used by the av to store its list of scalars.
700
701 See L</av_clear> for a note about the array possibly being invalid on
702 return.
703
704 =cut
705 */
706
707 void
Perl_av_undef(pTHX_ AV * av)708 Perl_av_undef(pTHX_ AV *av)
709 {
710 bool real;
711 SSize_t orig_ix = PL_tmps_ix; /* silence bogus warning about possible uninitialized use */
712
713 PERL_ARGS_ASSERT_AV_UNDEF;
714 assert(SvTYPE(av) == SVt_PVAV);
715
716 /* Give any tie a chance to cleanup first */
717 if (SvTIED_mg((const SV *)av, PERL_MAGIC_tied))
718 av_fill(av, -1);
719
720 real = cBOOL(AvREAL(av));
721 if (real) {
722 SSize_t key = AvFILLp(av) + 1;
723
724 /* avoid av being freed when calling destructors below */
725 EXTEND_MORTAL(1);
726 PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(av);
727 orig_ix = PL_tmps_ix;
728
729 while (key)
730 SvREFCNT_dec(AvARRAY(av)[--key]);
731 }
732
733 Safefree(AvALLOC(av));
734 AvALLOC(av) = NULL;
735 AvARRAY(av) = NULL;
736 AvMAX(av) = AvFILLp(av) = -1;
737
738 if(SvRMAGICAL(av)) mg_clear(MUTABLE_SV(av));
739 if (real) {
740 /* disarm av's premature free guard */
741 if (LIKELY(PL_tmps_ix == orig_ix))
742 PL_tmps_ix--;
743 else
744 PL_tmps_stack[orig_ix] = &PL_sv_undef;
745 SvREFCNT_dec_NN(av);
746 }
747 }
748
749 /*
750
751 =for apidoc av_create_and_push
752
753 Push an SV onto the end of the array, creating the array if necessary.
754 A small internal helper function to remove a commonly duplicated idiom.
755
756 =cut
757 */
758
759 void
Perl_av_create_and_push(pTHX_ AV ** const avp,SV * const val)760 Perl_av_create_and_push(pTHX_ AV **const avp, SV *const val)
761 {
762 PERL_ARGS_ASSERT_AV_CREATE_AND_PUSH;
763
764 if (!*avp)
765 *avp = newAV();
766 av_push(*avp, val);
767 }
768
769 /*
770 =for apidoc av_push
771
772 Pushes an SV (transferring control of one reference count) onto the end of the
773 array. The array will grow automatically to accommodate the addition.
774
775 Perl equivalent: C<push @myarray, $val;>.
776
777 =cut
778 */
779
780 void
Perl_av_push(pTHX_ AV * av,SV * val)781 Perl_av_push(pTHX_ AV *av, SV *val)
782 {
783 MAGIC *mg;
784
785 PERL_ARGS_ASSERT_AV_PUSH;
786 assert(SvTYPE(av) == SVt_PVAV);
787
788 if (SvREADONLY(av))
789 Perl_croak_no_modify();
790
791 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
792 Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(PUSH), G_DISCARD, 1,
793 val);
794 return;
795 }
796 av_store(av,AvFILLp(av)+1,val);
797 }
798
799 /*
800 =for apidoc av_pop
801
802 Removes one SV from the end of the array, reducing its size by one and
803 returning the SV (transferring control of one reference count) to the
804 caller. Returns C<&PL_sv_undef> if the array is empty.
805
806 Perl equivalent: C<pop(@myarray);>
807
808 =cut
809 */
810
811 SV *
Perl_av_pop(pTHX_ AV * av)812 Perl_av_pop(pTHX_ AV *av)
813 {
814 SV *retval;
815 MAGIC* mg;
816
817 PERL_ARGS_ASSERT_AV_POP;
818 assert(SvTYPE(av) == SVt_PVAV);
819
820 if (SvREADONLY(av))
821 Perl_croak_no_modify();
822 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
823 retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(POP), 0, 0);
824 if (retval)
825 retval = newSVsv(retval);
826 return retval;
827 }
828 if (AvFILL(av) < 0)
829 return &PL_sv_undef;
830 retval = AvARRAY(av)[AvFILLp(av)];
831 AvARRAY(av)[AvFILLp(av)--] = NULL;
832 if (SvSMAGICAL(av))
833 mg_set(MUTABLE_SV(av));
834 return retval ? retval : &PL_sv_undef;
835 }
836
837 /*
838
839 =for apidoc av_create_and_unshift_one
840
841 Unshifts an SV onto the beginning of the array, creating the array if
842 necessary.
843 A small internal helper function to remove a commonly duplicated idiom.
844
845 =cut
846 */
847
848 SV **
Perl_av_create_and_unshift_one(pTHX_ AV ** const avp,SV * const val)849 Perl_av_create_and_unshift_one(pTHX_ AV **const avp, SV *const val)
850 {
851 PERL_ARGS_ASSERT_AV_CREATE_AND_UNSHIFT_ONE;
852
853 if (!*avp)
854 *avp = newAV();
855 av_unshift(*avp, 1);
856 return av_store(*avp, 0, val);
857 }
858
859 /*
860 =for apidoc av_unshift
861
862 Unshift the given number of C<undef> values onto the beginning of the
863 array. The array will grow automatically to accommodate the addition.
864
865 Perl equivalent: S<C<unshift @myarray, ((undef) x $num);>>
866
867 =cut
868 */
869
870 void
Perl_av_unshift(pTHX_ AV * av,SSize_t num)871 Perl_av_unshift(pTHX_ AV *av, SSize_t num)
872 {
873 SSize_t i;
874 MAGIC* mg;
875
876 PERL_ARGS_ASSERT_AV_UNSHIFT;
877 assert(SvTYPE(av) == SVt_PVAV);
878
879 if (SvREADONLY(av))
880 Perl_croak_no_modify();
881
882 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
883 Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(UNSHIFT),
884 G_DISCARD | G_UNDEF_FILL, num);
885 return;
886 }
887
888 if (num <= 0)
889 return;
890 if (!AvREAL(av) && AvREIFY(av))
891 av_reify(av);
892 i = AvARRAY(av) - AvALLOC(av);
893 if (i) {
894 if (i > num)
895 i = num;
896 num -= i;
897
898 AvMAX(av) += i;
899 AvFILLp(av) += i;
900 AvARRAY(av) = AvARRAY(av) - i;
901 #ifdef PERL_RC_STACK
902 Zero(AvARRAY(av), i, SV*);
903 #endif
904 }
905 if (num) {
906 SV **ary;
907 const SSize_t i = AvFILLp(av);
908 /* Create extra elements */
909 const SSize_t slide = i > 0 ? i : 0;
910 num += slide;
911 av_extend(av, i + num);
912 AvFILLp(av) += num;
913 ary = AvARRAY(av);
914 Move(ary, ary + num, i + 1, SV*);
915 do {
916 ary[--num] = NULL;
917 } while (num);
918 /* Make extra elements into a buffer */
919 AvMAX(av) -= slide;
920 AvFILLp(av) -= slide;
921 AvARRAY(av) = AvARRAY(av) + slide;
922 }
923 }
924
925 /*
926 =for apidoc av_shift
927
928 Removes one SV from the start of the array, reducing its size by one and
929 returning the SV (transferring control of one reference count) to the
930 caller. Returns C<&PL_sv_undef> if the array is empty.
931
932 Perl equivalent: C<shift(@myarray);>
933
934 =cut
935 */
936
937 SV *
Perl_av_shift(pTHX_ AV * av)938 Perl_av_shift(pTHX_ AV *av)
939 {
940 SV *retval;
941 MAGIC* mg;
942
943 PERL_ARGS_ASSERT_AV_SHIFT;
944 assert(SvTYPE(av) == SVt_PVAV);
945
946 if (SvREADONLY(av))
947 Perl_croak_no_modify();
948 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
949 retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(SHIFT), 0, 0);
950 if (retval)
951 retval = newSVsv(retval);
952 return retval;
953 }
954 if (AvFILL(av) < 0)
955 return &PL_sv_undef;
956 retval = *AvARRAY(av);
957 #ifndef PERL_RC_STACK
958 if (AvREAL(av))
959 *AvARRAY(av) = NULL;
960 #endif
961 AvARRAY(av) = AvARRAY(av) + 1;
962 AvMAX(av)--;
963 AvFILLp(av)--;
964 if (SvSMAGICAL(av))
965 mg_set(MUTABLE_SV(av));
966 return retval ? retval : &PL_sv_undef;
967 }
968
969 /*
970 =for apidoc av_tindex
971 =for apidoc_item av_top_index
972
973 These behave identically.
974 If the array C<av> is empty, these return -1; otherwise they return the maximum
975 value of the indices of all the array elements which are currently defined in
976 C<av>.
977
978 They process 'get' magic.
979
980 The Perl equivalent for these is C<$#av>.
981
982 Use C<L</av_count>> to get the number of elements in an array.
983
984 =for apidoc av_len
985
986 Same as L</av_top_index>. Note that, unlike what the name implies, it returns
987 the maximum index in the array. This is unlike L</sv_len>, which returns what
988 you would expect.
989
990 B<To get the true number of elements in the array, instead use C<L</av_count>>>.
991
992 =cut
993 */
994
995 SSize_t
Perl_av_len(pTHX_ AV * av)996 Perl_av_len(pTHX_ AV *av)
997 {
998 PERL_ARGS_ASSERT_AV_LEN;
999
1000 return av_top_index(av);
1001 }
1002
1003 /*
1004 =for apidoc av_fill
1005
1006 Set the highest index in the array to the given number, equivalent to
1007 Perl's S<C<$#array = $fill;>>.
1008
1009 The number of elements in the array will be S<C<fill + 1>> after
1010 C<av_fill()> returns. If the array was previously shorter, then the
1011 additional elements appended are set to NULL. If the array
1012 was longer, then the excess elements are freed. S<C<av_fill(av, -1)>> is
1013 the same as C<av_clear(av)>.
1014
1015 =cut
1016 */
1017 void
Perl_av_fill(pTHX_ AV * av,SSize_t fill)1018 Perl_av_fill(pTHX_ AV *av, SSize_t fill)
1019 {
1020 MAGIC *mg;
1021
1022 PERL_ARGS_ASSERT_AV_FILL;
1023 assert(SvTYPE(av) == SVt_PVAV);
1024
1025 if (fill < 0)
1026 fill = -1;
1027 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
1028 SV *arg1 = sv_newmortal();
1029 sv_setiv(arg1, (IV)(fill + 1));
1030 Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(STORESIZE), G_DISCARD,
1031 1, arg1);
1032 return;
1033 }
1034 if (fill <= AvMAX(av)) {
1035 SSize_t key = AvFILLp(av);
1036 SV** const ary = AvARRAY(av);
1037
1038 if (AvREAL(av)) {
1039 while (key > fill) {
1040 SvREFCNT_dec(ary[key]);
1041 ary[key--] = NULL;
1042 }
1043 }
1044 else {
1045 while (key < fill)
1046 ary[++key] = NULL;
1047 }
1048
1049 AvFILLp(av) = fill;
1050 if (SvSMAGICAL(av))
1051 mg_set(MUTABLE_SV(av));
1052 }
1053 else
1054 (void)av_store(av,fill,NULL);
1055 }
1056
1057 /*
1058 =for apidoc av_delete
1059
1060 Deletes the element indexed by C<key> from the array, makes the element
1061 mortal, and returns it. If C<flags> equals C<G_DISCARD>, the element is
1062 freed and NULL is returned. NULL is also returned if C<key> is out of
1063 range.
1064
1065 Perl equivalent: S<C<splice(@myarray, $key, 1, undef)>> (with the
1066 C<splice> in void context if C<G_DISCARD> is present).
1067
1068 =cut
1069 */
1070 SV *
Perl_av_delete(pTHX_ AV * av,SSize_t key,I32 flags)1071 Perl_av_delete(pTHX_ AV *av, SSize_t key, I32 flags)
1072 {
1073 SV *sv;
1074
1075 PERL_ARGS_ASSERT_AV_DELETE;
1076 assert(SvTYPE(av) == SVt_PVAV);
1077
1078 if (SvREADONLY(av))
1079 Perl_croak_no_modify();
1080
1081 if (SvRMAGICAL(av)) {
1082 const MAGIC * const tied_magic
1083 = mg_find((const SV *)av, PERL_MAGIC_tied);
1084 if ((tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata))) {
1085 SV **svp;
1086 if (key < 0) {
1087 if (!S_adjust_index(aTHX_ av, tied_magic, &key))
1088 return NULL;
1089 }
1090 svp = av_fetch(av, key, TRUE);
1091 if (svp) {
1092 sv = *svp;
1093 mg_clear(sv);
1094 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
1095 sv_unmagic(sv, PERL_MAGIC_tiedelem); /* No longer an element */
1096 return sv;
1097 }
1098 return NULL;
1099 }
1100 }
1101 }
1102
1103 if (key < 0) {
1104 key += AvFILL(av) + 1;
1105 if (key < 0)
1106 return NULL;
1107 }
1108
1109 if (key > AvFILLp(av))
1110 return NULL;
1111 else {
1112 if (!AvREAL(av) && AvREIFY(av))
1113 av_reify(av);
1114 sv = AvARRAY(av)[key];
1115 AvARRAY(av)[key] = NULL;
1116 if (key == AvFILLp(av)) {
1117 do {
1118 AvFILLp(av)--;
1119 } while (--key >= 0 && !AvARRAY(av)[key]);
1120 }
1121 if (SvSMAGICAL(av))
1122 mg_set(MUTABLE_SV(av));
1123 }
1124 if(sv != NULL) {
1125 if (flags & G_DISCARD) {
1126 SvREFCNT_dec_NN(sv);
1127 return NULL;
1128 }
1129 else if (AvREAL(av))
1130 sv_2mortal(sv);
1131 }
1132 return sv;
1133 }
1134
1135 /*
1136 =for apidoc av_exists
1137
1138 Returns true if the element indexed by C<key> has been initialized.
1139
1140 This relies on the fact that uninitialized array elements are set to
1141 C<NULL>.
1142
1143 Perl equivalent: C<exists($myarray[$key])>.
1144
1145 =cut
1146 */
1147 bool
Perl_av_exists(pTHX_ AV * av,SSize_t key)1148 Perl_av_exists(pTHX_ AV *av, SSize_t key)
1149 {
1150 PERL_ARGS_ASSERT_AV_EXISTS;
1151 assert(SvTYPE(av) == SVt_PVAV);
1152
1153 if (SvRMAGICAL(av)) {
1154 const MAGIC * const tied_magic
1155 = mg_find((const SV *)av, PERL_MAGIC_tied);
1156 const MAGIC * const regdata_magic
1157 = mg_find((const SV *)av, PERL_MAGIC_regdata);
1158 if (tied_magic || regdata_magic) {
1159 MAGIC *mg;
1160 /* Handle negative array indices 20020222 MJD */
1161 if (key < 0) {
1162 if (!S_adjust_index(aTHX_ av, tied_magic, &key))
1163 return FALSE;
1164 }
1165
1166 if(key >= 0 && regdata_magic) {
1167 if (key <= AvFILL(av))
1168 return TRUE;
1169 else
1170 return FALSE;
1171 }
1172 {
1173 SV * const sv = sv_newmortal();
1174 mg_copy(MUTABLE_SV(av), sv, 0, key);
1175 mg = mg_find(sv, PERL_MAGIC_tiedelem);
1176 if (mg) {
1177 magic_existspack(sv, mg);
1178 {
1179 I32 retbool = SvTRUE_nomg_NN(sv);
1180 return cBOOL(retbool);
1181 }
1182 }
1183 }
1184 }
1185 }
1186
1187 if (key < 0) {
1188 key += AvFILL(av) + 1;
1189 if (key < 0)
1190 return FALSE;
1191 }
1192
1193 if (key <= AvFILLp(av) && AvARRAY(av)[key])
1194 {
1195 if (SvSMAGICAL(AvARRAY(av)[key])
1196 && mg_find(AvARRAY(av)[key], PERL_MAGIC_nonelem))
1197 return FALSE;
1198 return TRUE;
1199 }
1200 else
1201 return FALSE;
1202 }
1203
1204 static MAGIC *
S_get_aux_mg(pTHX_ AV * av)1205 S_get_aux_mg(pTHX_ AV *av) {
1206 MAGIC *mg;
1207
1208 PERL_ARGS_ASSERT_GET_AUX_MG;
1209 assert(SvTYPE(av) == SVt_PVAV);
1210
1211 mg = mg_find((const SV *)av, PERL_MAGIC_arylen_p);
1212
1213 if (!mg) {
1214 mg = sv_magicext(MUTABLE_SV(av), 0, PERL_MAGIC_arylen_p,
1215 &PL_vtbl_arylen_p, 0, 0);
1216 assert(mg);
1217 /* sv_magicext won't set this for us because we pass in a NULL obj */
1218 mg->mg_flags |= MGf_REFCOUNTED;
1219 }
1220 return mg;
1221 }
1222
1223 SV **
Perl_av_arylen_p(pTHX_ AV * av)1224 Perl_av_arylen_p(pTHX_ AV *av) {
1225 MAGIC *const mg = get_aux_mg(av);
1226
1227 PERL_ARGS_ASSERT_AV_ARYLEN_P;
1228 assert(SvTYPE(av) == SVt_PVAV);
1229
1230 return &(mg->mg_obj);
1231 }
1232
1233 IV *
Perl_av_iter_p(pTHX_ AV * av)1234 Perl_av_iter_p(pTHX_ AV *av) {
1235 MAGIC *const mg = get_aux_mg(av);
1236
1237 PERL_ARGS_ASSERT_AV_ITER_P;
1238 assert(SvTYPE(av) == SVt_PVAV);
1239
1240 if (sizeof(IV) == sizeof(SSize_t)) {
1241 return (IV *)&(mg->mg_len);
1242 } else {
1243 if (!mg->mg_ptr) {
1244 IV *temp;
1245 mg->mg_len = IVSIZE;
1246 Newxz(temp, 1, IV);
1247 mg->mg_ptr = (char *) temp;
1248 }
1249 return (IV *)mg->mg_ptr;
1250 }
1251 }
1252
1253 SV *
Perl_av_nonelem(pTHX_ AV * av,SSize_t ix)1254 Perl_av_nonelem(pTHX_ AV *av, SSize_t ix) {
1255 SV * const sv = newSV_type(SVt_NULL);
1256 PERL_ARGS_ASSERT_AV_NONELEM;
1257 if (!av_store(av,ix,sv))
1258 return sv_2mortal(sv); /* has tie magic */
1259 sv_magic(sv, NULL, PERL_MAGIC_nonelem, NULL, 0);
1260 return sv;
1261 }
1262
1263 /*
1264 * ex: set ts=8 sts=4 sw=4 et:
1265 */
1266