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 while (key)
46 AvALLOC(av)[--key] = NULL;
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 SSize_t extra;
637 bool real;
638 SSize_t orig_ix = 0;
639
640 PERL_ARGS_ASSERT_AV_CLEAR;
641 assert(SvTYPE(av) == SVt_PVAV);
642
643 #ifdef DEBUGGING
644 if (SvREFCNT(av) == 0) {
645 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "Attempt to clear deleted array");
646 }
647 #endif
648
649 if (SvREADONLY(av))
650 Perl_croak_no_modify();
651
652 /* Give any tie a chance to cleanup first */
653 if (SvRMAGICAL(av)) {
654 const MAGIC* const mg = SvMAGIC(av);
655 if (PL_delaymagic && mg && mg->mg_type == PERL_MAGIC_isa)
656 PL_delaymagic |= DM_ARRAY_ISA;
657 else
658 mg_clear(MUTABLE_SV(av));
659 }
660
661 if (AvMAX(av) < 0)
662 return;
663
664 if ((real = cBOOL(AvREAL(av)))) {
665 SV** const ary = AvARRAY(av);
666 SSize_t index = AvFILLp(av) + 1;
667
668 /* avoid av being freed when calling destructors below */
669 EXTEND_MORTAL(1);
670 PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(av);
671 orig_ix = PL_tmps_ix;
672
673 while (index) {
674 SV * const sv = ary[--index];
675 /* undef the slot before freeing the value, because a
676 * destructor might try to modify this array */
677 ary[index] = NULL;
678 SvREFCNT_dec(sv);
679 }
680 }
681 extra = AvARRAY(av) - AvALLOC(av);
682 if (extra) {
683 AvMAX(av) += extra;
684 AvARRAY(av) = AvALLOC(av);
685 }
686 AvFILLp(av) = -1;
687 if (real) {
688 /* disarm av's premature free guard */
689 if (LIKELY(PL_tmps_ix == orig_ix))
690 PL_tmps_ix--;
691 else
692 PL_tmps_stack[orig_ix] = &PL_sv_undef;
693 SvREFCNT_dec_NN(av);
694 }
695 }
696
697 /*
698 =for apidoc av_undef
699
700 Undefines the array. The XS equivalent of C<undef(@array)>.
701
702 As well as freeing all the elements of the array (like C<av_clear()>), this
703 also frees the memory used by the av to store its list of scalars.
704
705 See L</av_clear> for a note about the array possibly being invalid on
706 return.
707
708 =cut
709 */
710
711 void
Perl_av_undef(pTHX_ AV * av)712 Perl_av_undef(pTHX_ AV *av)
713 {
714 bool real;
715 SSize_t orig_ix = PL_tmps_ix; /* silence bogus warning about possible uninitialized use */
716
717 PERL_ARGS_ASSERT_AV_UNDEF;
718 assert(SvTYPE(av) == SVt_PVAV);
719
720 /* Give any tie a chance to cleanup first */
721 if (SvTIED_mg((const SV *)av, PERL_MAGIC_tied))
722 av_fill(av, -1);
723
724 real = cBOOL(AvREAL(av));
725 if (real) {
726 SSize_t key = AvFILLp(av) + 1;
727
728 /* avoid av being freed when calling destructors below */
729 EXTEND_MORTAL(1);
730 PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(av);
731 orig_ix = PL_tmps_ix;
732
733 while (key)
734 SvREFCNT_dec(AvARRAY(av)[--key]);
735 }
736
737 Safefree(AvALLOC(av));
738 AvALLOC(av) = NULL;
739 AvARRAY(av) = NULL;
740 AvMAX(av) = AvFILLp(av) = -1;
741
742 if(SvRMAGICAL(av)) mg_clear(MUTABLE_SV(av));
743 if (real) {
744 /* disarm av's premature free guard */
745 if (LIKELY(PL_tmps_ix == orig_ix))
746 PL_tmps_ix--;
747 else
748 PL_tmps_stack[orig_ix] = &PL_sv_undef;
749 SvREFCNT_dec_NN(av);
750 }
751 }
752
753 /*
754
755 =for apidoc av_create_and_push
756
757 Push an SV onto the end of the array, creating the array if necessary.
758 A small internal helper function to remove a commonly duplicated idiom.
759
760 =cut
761 */
762
763 void
Perl_av_create_and_push(pTHX_ AV ** const avp,SV * const val)764 Perl_av_create_and_push(pTHX_ AV **const avp, SV *const val)
765 {
766 PERL_ARGS_ASSERT_AV_CREATE_AND_PUSH;
767
768 if (!*avp)
769 *avp = newAV();
770 av_push(*avp, val);
771 }
772
773 /*
774 =for apidoc av_push
775
776 Pushes an SV (transferring control of one reference count) onto the end of the
777 array. The array will grow automatically to accommodate the addition.
778
779 Perl equivalent: C<push @myarray, $val;>.
780
781 =cut
782 */
783
784 void
Perl_av_push(pTHX_ AV * av,SV * val)785 Perl_av_push(pTHX_ AV *av, SV *val)
786 {
787 MAGIC *mg;
788
789 PERL_ARGS_ASSERT_AV_PUSH;
790 assert(SvTYPE(av) == SVt_PVAV);
791
792 if (SvREADONLY(av))
793 Perl_croak_no_modify();
794
795 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
796 Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(PUSH), G_DISCARD, 1,
797 val);
798 return;
799 }
800 av_store(av,AvFILLp(av)+1,val);
801 }
802
803 /*
804 =for apidoc av_pop
805
806 Removes one SV from the end of the array, reducing its size by one and
807 returning the SV (transferring control of one reference count) to the
808 caller. Returns C<&PL_sv_undef> if the array is empty.
809
810 Perl equivalent: C<pop(@myarray);>
811
812 =cut
813 */
814
815 SV *
Perl_av_pop(pTHX_ AV * av)816 Perl_av_pop(pTHX_ AV *av)
817 {
818 SV *retval;
819 MAGIC* mg;
820
821 PERL_ARGS_ASSERT_AV_POP;
822 assert(SvTYPE(av) == SVt_PVAV);
823
824 if (SvREADONLY(av))
825 Perl_croak_no_modify();
826 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
827 retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(POP), 0, 0);
828 if (retval)
829 retval = newSVsv(retval);
830 return retval;
831 }
832 if (AvFILL(av) < 0)
833 return &PL_sv_undef;
834 retval = AvARRAY(av)[AvFILLp(av)];
835 AvARRAY(av)[AvFILLp(av)--] = NULL;
836 if (SvSMAGICAL(av))
837 mg_set(MUTABLE_SV(av));
838 return retval ? retval : &PL_sv_undef;
839 }
840
841 /*
842
843 =for apidoc av_create_and_unshift_one
844
845 Unshifts an SV onto the beginning of the array, creating the array if
846 necessary.
847 A small internal helper function to remove a commonly duplicated idiom.
848
849 =cut
850 */
851
852 SV **
Perl_av_create_and_unshift_one(pTHX_ AV ** const avp,SV * const val)853 Perl_av_create_and_unshift_one(pTHX_ AV **const avp, SV *const val)
854 {
855 PERL_ARGS_ASSERT_AV_CREATE_AND_UNSHIFT_ONE;
856
857 if (!*avp)
858 *avp = newAV();
859 av_unshift(*avp, 1);
860 return av_store(*avp, 0, val);
861 }
862
863 /*
864 =for apidoc av_unshift
865
866 Unshift the given number of C<undef> values onto the beginning of the
867 array. The array will grow automatically to accommodate the addition.
868
869 Perl equivalent: S<C<unshift @myarray, ((undef) x $num);>>
870
871 =cut
872 */
873
874 void
Perl_av_unshift(pTHX_ AV * av,SSize_t num)875 Perl_av_unshift(pTHX_ AV *av, SSize_t num)
876 {
877 SSize_t i;
878 MAGIC* mg;
879
880 PERL_ARGS_ASSERT_AV_UNSHIFT;
881 assert(SvTYPE(av) == SVt_PVAV);
882
883 if (SvREADONLY(av))
884 Perl_croak_no_modify();
885
886 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
887 Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(UNSHIFT),
888 G_DISCARD | G_UNDEF_FILL, num);
889 return;
890 }
891
892 if (num <= 0)
893 return;
894 if (!AvREAL(av) && AvREIFY(av))
895 av_reify(av);
896 i = AvARRAY(av) - AvALLOC(av);
897 if (i) {
898 if (i > num)
899 i = num;
900 num -= i;
901
902 AvMAX(av) += i;
903 AvFILLp(av) += i;
904 AvARRAY(av) = AvARRAY(av) - i;
905 }
906 if (num) {
907 SV **ary;
908 const SSize_t i = AvFILLp(av);
909 /* Create extra elements */
910 const SSize_t slide = i > 0 ? i : 0;
911 num += slide;
912 av_extend(av, i + num);
913 AvFILLp(av) += num;
914 ary = AvARRAY(av);
915 Move(ary, ary + num, i + 1, SV*);
916 do {
917 ary[--num] = NULL;
918 } while (num);
919 /* Make extra elements into a buffer */
920 AvMAX(av) -= slide;
921 AvFILLp(av) -= slide;
922 AvARRAY(av) = AvARRAY(av) + slide;
923 }
924 }
925
926 /*
927 =for apidoc av_shift
928
929 Removes one SV from the start of the array, reducing its size by one and
930 returning the SV (transferring control of one reference count) to the
931 caller. Returns C<&PL_sv_undef> if the array is empty.
932
933 Perl equivalent: C<shift(@myarray);>
934
935 =cut
936 */
937
938 SV *
Perl_av_shift(pTHX_ AV * av)939 Perl_av_shift(pTHX_ AV *av)
940 {
941 SV *retval;
942 MAGIC* mg;
943
944 PERL_ARGS_ASSERT_AV_SHIFT;
945 assert(SvTYPE(av) == SVt_PVAV);
946
947 if (SvREADONLY(av))
948 Perl_croak_no_modify();
949 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
950 retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(SHIFT), 0, 0);
951 if (retval)
952 retval = newSVsv(retval);
953 return retval;
954 }
955 if (AvFILL(av) < 0)
956 return &PL_sv_undef;
957 retval = *AvARRAY(av);
958 if (AvREAL(av))
959 *AvARRAY(av) = NULL;
960 AvARRAY(av) = AvARRAY(av) + 1;
961 AvMAX(av)--;
962 AvFILLp(av)--;
963 if (SvSMAGICAL(av))
964 mg_set(MUTABLE_SV(av));
965 return retval ? retval : &PL_sv_undef;
966 }
967
968 /*
969 =for apidoc av_tindex
970 =for apidoc_item av_top_index
971
972 These behave identically.
973 If the array C<av> is empty, these return -1; otherwise they return the maximum
974 value of the indices of all the array elements which are currently defined in
975 C<av>.
976
977 They process 'get' magic.
978
979 The Perl equivalent for these is C<$#av>.
980
981 Use C<L</av_count>> to get the number of elements in an array.
982
983 =for apidoc av_len
984
985 Same as L</av_top_index>. Note that, unlike what the name implies, it returns
986 the maximum index in the array. This is unlike L</sv_len>, which returns what
987 you would expect.
988
989 B<To get the true number of elements in the array, instead use C<L</av_count>>>.
990
991 =cut
992 */
993
994 SSize_t
Perl_av_len(pTHX_ AV * av)995 Perl_av_len(pTHX_ AV *av)
996 {
997 PERL_ARGS_ASSERT_AV_LEN;
998
999 return av_top_index(av);
1000 }
1001
1002 /*
1003 =for apidoc av_fill
1004
1005 Set the highest index in the array to the given number, equivalent to
1006 Perl's S<C<$#array = $fill;>>.
1007
1008 The number of elements in the array will be S<C<fill + 1>> after
1009 C<av_fill()> returns. If the array was previously shorter, then the
1010 additional elements appended are set to NULL. If the array
1011 was longer, then the excess elements are freed. S<C<av_fill(av, -1)>> is
1012 the same as C<av_clear(av)>.
1013
1014 =cut
1015 */
1016 void
Perl_av_fill(pTHX_ AV * av,SSize_t fill)1017 Perl_av_fill(pTHX_ AV *av, SSize_t fill)
1018 {
1019 MAGIC *mg;
1020
1021 PERL_ARGS_ASSERT_AV_FILL;
1022 assert(SvTYPE(av) == SVt_PVAV);
1023
1024 if (fill < 0)
1025 fill = -1;
1026 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
1027 SV *arg1 = sv_newmortal();
1028 sv_setiv(arg1, (IV)(fill + 1));
1029 Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(STORESIZE), G_DISCARD,
1030 1, arg1);
1031 return;
1032 }
1033 if (fill <= AvMAX(av)) {
1034 SSize_t key = AvFILLp(av);
1035 SV** const ary = AvARRAY(av);
1036
1037 if (AvREAL(av)) {
1038 while (key > fill) {
1039 SvREFCNT_dec(ary[key]);
1040 ary[key--] = NULL;
1041 }
1042 }
1043 else {
1044 while (key < fill)
1045 ary[++key] = NULL;
1046 }
1047
1048 AvFILLp(av) = fill;
1049 if (SvSMAGICAL(av))
1050 mg_set(MUTABLE_SV(av));
1051 }
1052 else
1053 (void)av_store(av,fill,NULL);
1054 }
1055
1056 /*
1057 =for apidoc av_delete
1058
1059 Deletes the element indexed by C<key> from the array, makes the element
1060 mortal, and returns it. If C<flags> equals C<G_DISCARD>, the element is
1061 freed and NULL is returned. NULL is also returned if C<key> is out of
1062 range.
1063
1064 Perl equivalent: S<C<splice(@myarray, $key, 1, undef)>> (with the
1065 C<splice> in void context if C<G_DISCARD> is present).
1066
1067 =cut
1068 */
1069 SV *
Perl_av_delete(pTHX_ AV * av,SSize_t key,I32 flags)1070 Perl_av_delete(pTHX_ AV *av, SSize_t key, I32 flags)
1071 {
1072 SV *sv;
1073
1074 PERL_ARGS_ASSERT_AV_DELETE;
1075 assert(SvTYPE(av) == SVt_PVAV);
1076
1077 if (SvREADONLY(av))
1078 Perl_croak_no_modify();
1079
1080 if (SvRMAGICAL(av)) {
1081 const MAGIC * const tied_magic
1082 = mg_find((const SV *)av, PERL_MAGIC_tied);
1083 if ((tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata))) {
1084 SV **svp;
1085 if (key < 0) {
1086 if (!S_adjust_index(aTHX_ av, tied_magic, &key))
1087 return NULL;
1088 }
1089 svp = av_fetch(av, key, TRUE);
1090 if (svp) {
1091 sv = *svp;
1092 mg_clear(sv);
1093 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
1094 sv_unmagic(sv, PERL_MAGIC_tiedelem); /* No longer an element */
1095 return sv;
1096 }
1097 return NULL;
1098 }
1099 }
1100 }
1101
1102 if (key < 0) {
1103 key += AvFILL(av) + 1;
1104 if (key < 0)
1105 return NULL;
1106 }
1107
1108 if (key > AvFILLp(av))
1109 return NULL;
1110 else {
1111 if (!AvREAL(av) && AvREIFY(av))
1112 av_reify(av);
1113 sv = AvARRAY(av)[key];
1114 AvARRAY(av)[key] = NULL;
1115 if (key == AvFILLp(av)) {
1116 do {
1117 AvFILLp(av)--;
1118 } while (--key >= 0 && !AvARRAY(av)[key]);
1119 }
1120 if (SvSMAGICAL(av))
1121 mg_set(MUTABLE_SV(av));
1122 }
1123 if(sv != NULL) {
1124 if (flags & G_DISCARD) {
1125 SvREFCNT_dec_NN(sv);
1126 return NULL;
1127 }
1128 else if (AvREAL(av))
1129 sv_2mortal(sv);
1130 }
1131 return sv;
1132 }
1133
1134 /*
1135 =for apidoc av_exists
1136
1137 Returns true if the element indexed by C<key> has been initialized.
1138
1139 This relies on the fact that uninitialized array elements are set to
1140 C<NULL>.
1141
1142 Perl equivalent: C<exists($myarray[$key])>.
1143
1144 =cut
1145 */
1146 bool
Perl_av_exists(pTHX_ AV * av,SSize_t key)1147 Perl_av_exists(pTHX_ AV *av, SSize_t key)
1148 {
1149 PERL_ARGS_ASSERT_AV_EXISTS;
1150 assert(SvTYPE(av) == SVt_PVAV);
1151
1152 if (SvRMAGICAL(av)) {
1153 const MAGIC * const tied_magic
1154 = mg_find((const SV *)av, PERL_MAGIC_tied);
1155 const MAGIC * const regdata_magic
1156 = mg_find((const SV *)av, PERL_MAGIC_regdata);
1157 if (tied_magic || regdata_magic) {
1158 MAGIC *mg;
1159 /* Handle negative array indices 20020222 MJD */
1160 if (key < 0) {
1161 if (!S_adjust_index(aTHX_ av, tied_magic, &key))
1162 return FALSE;
1163 }
1164
1165 if(key >= 0 && regdata_magic) {
1166 if (key <= AvFILL(av))
1167 return TRUE;
1168 else
1169 return FALSE;
1170 }
1171 {
1172 SV * const sv = sv_newmortal();
1173 mg_copy(MUTABLE_SV(av), sv, 0, key);
1174 mg = mg_find(sv, PERL_MAGIC_tiedelem);
1175 if (mg) {
1176 magic_existspack(sv, mg);
1177 {
1178 I32 retbool = SvTRUE_nomg_NN(sv);
1179 return cBOOL(retbool);
1180 }
1181 }
1182 }
1183 }
1184 }
1185
1186 if (key < 0) {
1187 key += AvFILL(av) + 1;
1188 if (key < 0)
1189 return FALSE;
1190 }
1191
1192 if (key <= AvFILLp(av) && AvARRAY(av)[key])
1193 {
1194 if (SvSMAGICAL(AvARRAY(av)[key])
1195 && mg_find(AvARRAY(av)[key], PERL_MAGIC_nonelem))
1196 return FALSE;
1197 return TRUE;
1198 }
1199 else
1200 return FALSE;
1201 }
1202
1203 static MAGIC *
S_get_aux_mg(pTHX_ AV * av)1204 S_get_aux_mg(pTHX_ AV *av) {
1205 MAGIC *mg;
1206
1207 PERL_ARGS_ASSERT_GET_AUX_MG;
1208 assert(SvTYPE(av) == SVt_PVAV);
1209
1210 mg = mg_find((const SV *)av, PERL_MAGIC_arylen_p);
1211
1212 if (!mg) {
1213 mg = sv_magicext(MUTABLE_SV(av), 0, PERL_MAGIC_arylen_p,
1214 &PL_vtbl_arylen_p, 0, 0);
1215 assert(mg);
1216 /* sv_magicext won't set this for us because we pass in a NULL obj */
1217 mg->mg_flags |= MGf_REFCOUNTED;
1218 }
1219 return mg;
1220 }
1221
1222 SV **
Perl_av_arylen_p(pTHX_ AV * av)1223 Perl_av_arylen_p(pTHX_ AV *av) {
1224 MAGIC *const mg = get_aux_mg(av);
1225
1226 PERL_ARGS_ASSERT_AV_ARYLEN_P;
1227 assert(SvTYPE(av) == SVt_PVAV);
1228
1229 return &(mg->mg_obj);
1230 }
1231
1232 IV *
Perl_av_iter_p(pTHX_ AV * av)1233 Perl_av_iter_p(pTHX_ AV *av) {
1234 MAGIC *const mg = get_aux_mg(av);
1235
1236 PERL_ARGS_ASSERT_AV_ITER_P;
1237 assert(SvTYPE(av) == SVt_PVAV);
1238
1239 if (sizeof(IV) == sizeof(SSize_t)) {
1240 return (IV *)&(mg->mg_len);
1241 } else {
1242 if (!mg->mg_ptr) {
1243 IV *temp;
1244 mg->mg_len = IVSIZE;
1245 Newxz(temp, 1, IV);
1246 mg->mg_ptr = (char *) temp;
1247 }
1248 return (IV *)mg->mg_ptr;
1249 }
1250 }
1251
1252 SV *
Perl_av_nonelem(pTHX_ AV * av,SSize_t ix)1253 Perl_av_nonelem(pTHX_ AV *av, SSize_t ix) {
1254 SV * const sv = newSV_type(SVt_NULL);
1255 PERL_ARGS_ASSERT_AV_NONELEM;
1256 if (!av_store(av,ix,sv))
1257 return sv_2mortal(sv); /* has tie magic */
1258 sv_magic(sv, NULL, PERL_MAGIC_nonelem, NULL, 0);
1259 return sv;
1260 }
1261
1262 /*
1263 * ex: set ts=8 sts=4 sw=4 et:
1264 */
1265