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;
107 SSize_t to_null = 0;
108 SSize_t newmax = 0;
109
110 if (av && *allocp != *arrayp) { /* a shifted SV* array exists */
111 to_null = *arrayp - *allocp;
112 *maxp += to_null;
113 ary_offset = AvFILLp(av) + 1;
114
115 Move(*arrayp, *allocp, AvFILLp(av)+1, SV*);
116
117 if (key > *maxp - 10) {
118 newmax = key + *maxp;
119 goto resize;
120 }
121 } else if (*allocp) { /* a full SV* array exists */
122
123 #ifdef Perl_safesysmalloc_size
124 /* Whilst it would be quite possible to move this logic around
125 (as I did in the SV code), so as to set AvMAX(av) early,
126 based on calling Perl_safesysmalloc_size() immediately after
127 allocation, I'm not convinced that it is a great idea here.
128 In an array we have to loop round setting everything to
129 NULL, which means writing to memory, potentially lots
130 of it, whereas for the SV buffer case we don't touch the
131 "bonus" memory. So there there is no cost in telling the
132 world about it, whereas here we have to do work before we can
133 tell the world about it, and that work involves writing to
134 memory that might never be read. So, I feel, better to keep
135 the current lazy system of only writing to it if our caller
136 has a need for more space. NWC */
137 newmax = Perl_safesysmalloc_size((void*)*allocp) /
138 sizeof(const SV *) - 1;
139
140 if (key <= newmax)
141 goto resized;
142 #endif
143 /* overflow-safe version of newmax = key + *maxp/5 */
144 newmax = *maxp / 5;
145 newmax = (key > SSize_t_MAX - newmax)
146 ? SSize_t_MAX : key + newmax;
147 resize:
148 {
149 /* it should really be newmax+1 here, but if newmax
150 * happens to equal SSize_t_MAX, then newmax+1 is
151 * undefined. This means technically we croak one
152 * index lower than we should in theory; in practice
153 * its unlikely the system has SSize_t_MAX/sizeof(SV*)
154 * bytes to spare! */
155 MEM_WRAP_CHECK_s(newmax, SV*, "Out of memory during array extend");
156 }
157 #ifdef STRESS_REALLOC
158 {
159 SV ** const old_alloc = *allocp;
160 Newx(*allocp, newmax+1, SV*);
161 Copy(old_alloc, *allocp, *maxp + 1, SV*);
162 Safefree(old_alloc);
163 }
164 #else
165 Renew(*allocp,newmax+1, SV*);
166 #endif
167 #ifdef Perl_safesysmalloc_size
168 resized:
169 #endif
170 to_null += newmax - *maxp;
171 *maxp = newmax;
172
173 /* See GH#18014 for discussion of when this might be needed: */
174 if (av == PL_curstack) { /* Oops, grew stack (via av_store()?) */
175 PL_stack_sp = *allocp + (PL_stack_sp - PL_stack_base);
176 PL_stack_base = *allocp;
177 PL_stack_max = PL_stack_base + newmax;
178 }
179 } else { /* there is no SV* array yet */
180 *maxp = key < 3 ? 3 : key;
181 {
182 /* see comment above about newmax+1*/
183 MEM_WRAP_CHECK_s(*maxp, SV*,
184 "Out of memory during array extend");
185 }
186 /* Newxz isn't used below because testing showed it to be slower
187 * than Newx+Zero (also slower than Newx + the previous while
188 * loop) for small arrays, which are very common in perl. */
189 Newx(*allocp, *maxp+1, SV*);
190 /* Stacks require only the first element to be &PL_sv_undef
191 * (set elsewhere). However, since non-stack AVs are likely
192 * to dominate in modern production applications, stacks
193 * don't get any special treatment here.
194 * See https://github.com/Perl/perl5/pull/18690 for more detail */
195 ary_offset = 0;
196 to_null = *maxp+1;
197 goto zero;
198 }
199
200 if (av && AvREAL(av)) {
201 zero:
202 Zero(*allocp + ary_offset,to_null,SV*);
203 }
204
205 *arrayp = *allocp;
206 }
207 }
208
209 /*
210 =for apidoc av_fetch
211
212 Returns the SV at the specified index in the array. The C<key> is the
213 index. If lval is true, you are guaranteed to get a real SV back (in case
214 it wasn't real before), which you can then modify. Check that the return
215 value is non-null before dereferencing it to a C<SV*>.
216
217 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
218 more information on how to use this function on tied arrays.
219
220 The rough perl equivalent is C<$myarray[$key]>.
221
222 =cut
223 */
224
225 static bool
S_adjust_index(pTHX_ AV * av,const MAGIC * mg,SSize_t * keyp)226 S_adjust_index(pTHX_ AV *av, const MAGIC *mg, SSize_t *keyp)
227 {
228 bool adjust_index = 1;
229 if (mg) {
230 /* Handle negative array indices 20020222 MJD */
231 SV * const ref = SvTIED_obj(MUTABLE_SV(av), mg);
232 SvGETMAGIC(ref);
233 if (SvROK(ref) && SvOBJECT(SvRV(ref))) {
234 SV * const * const negative_indices_glob =
235 hv_fetchs(SvSTASH(SvRV(ref)), NEGATIVE_INDICES_VAR, 0);
236
237 if (negative_indices_glob && isGV(*negative_indices_glob)
238 && SvTRUE(GvSV(*negative_indices_glob)))
239 adjust_index = 0;
240 }
241 }
242
243 if (adjust_index) {
244 *keyp += AvFILL(av) + 1;
245 if (*keyp < 0)
246 return FALSE;
247 }
248 return TRUE;
249 }
250
251 SV**
Perl_av_fetch(pTHX_ AV * av,SSize_t key,I32 lval)252 Perl_av_fetch(pTHX_ AV *av, SSize_t key, I32 lval)
253 {
254 SSize_t neg;
255 SSize_t size;
256
257 PERL_ARGS_ASSERT_AV_FETCH;
258 assert(SvTYPE(av) == SVt_PVAV);
259
260 if (UNLIKELY(SvRMAGICAL(av))) {
261 const MAGIC * const tied_magic
262 = mg_find((const SV *)av, PERL_MAGIC_tied);
263 if (tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata)) {
264 SV *sv;
265 if (key < 0) {
266 if (!S_adjust_index(aTHX_ av, tied_magic, &key))
267 return NULL;
268 }
269
270 sv = sv_newmortal();
271 sv_upgrade(sv, SVt_PVLV);
272 mg_copy(MUTABLE_SV(av), sv, 0, key);
273 if (!tied_magic) /* for regdata, force leavesub to make copies */
274 SvTEMP_off(sv);
275 LvTYPE(sv) = 't';
276 LvTARG(sv) = sv; /* fake (SV**) */
277 return &(LvTARG(sv));
278 }
279 }
280
281 neg = (key < 0);
282 size = AvFILLp(av) + 1;
283 key += neg * size; /* handle negative index without using branch */
284
285 /* the cast from SSize_t to Size_t allows both (key < 0) and (key >= size)
286 * to be tested as a single condition */
287 if ((Size_t)key >= (Size_t)size) {
288 if (UNLIKELY(neg))
289 return NULL;
290 goto emptyness;
291 }
292
293 if (!AvARRAY(av)[key]) {
294 emptyness:
295 return lval ? av_store(av,key,newSV(0)) : NULL;
296 }
297
298 return &AvARRAY(av)[key];
299 }
300
301 /*
302 =for apidoc av_store
303
304 Stores an SV in an array. The array index is specified as C<key>. The
305 return value will be C<NULL> if the operation failed or if the value did not
306 need to be actually stored within the array (as in the case of tied
307 arrays). Otherwise, it can be dereferenced
308 to get the C<SV*> that was stored
309 there (= C<val>)).
310
311 Note that the caller is responsible for suitably incrementing the reference
312 count of C<val> before the call, and decrementing it if the function
313 returned C<NULL>.
314
315 Approximate Perl equivalent: C<splice(@myarray, $key, 1, $val)>.
316
317 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
318 more information on how to use this function on tied arrays.
319
320 =cut
321 */
322
323 SV**
Perl_av_store(pTHX_ AV * av,SSize_t key,SV * val)324 Perl_av_store(pTHX_ AV *av, SSize_t key, SV *val)
325 {
326 SV** ary;
327
328 PERL_ARGS_ASSERT_AV_STORE;
329 assert(SvTYPE(av) == SVt_PVAV);
330
331 /* S_regclass relies on being able to pass in a NULL sv
332 (unicode_alternate may be NULL).
333 */
334
335 if (SvRMAGICAL(av)) {
336 const MAGIC * const tied_magic = mg_find((const SV *)av, PERL_MAGIC_tied);
337 if (tied_magic) {
338 if (key < 0) {
339 if (!S_adjust_index(aTHX_ av, tied_magic, &key))
340 return 0;
341 }
342 if (val) {
343 mg_copy(MUTABLE_SV(av), val, 0, key);
344 }
345 return NULL;
346 }
347 }
348
349
350 if (key < 0) {
351 key += AvFILL(av) + 1;
352 if (key < 0)
353 return NULL;
354 }
355
356 if (SvREADONLY(av) && key >= AvFILL(av))
357 Perl_croak_no_modify();
358
359 if (!AvREAL(av) && AvREIFY(av))
360 av_reify(av);
361 if (key > AvMAX(av))
362 av_extend(av,key);
363 ary = AvARRAY(av);
364 if (AvFILLp(av) < key) {
365 if (!AvREAL(av)) {
366 if (av == PL_curstack && key > PL_stack_sp - PL_stack_base)
367 PL_stack_sp = PL_stack_base + key; /* XPUSH in disguise */
368 do {
369 ary[++AvFILLp(av)] = NULL;
370 } while (AvFILLp(av) < key);
371 }
372 AvFILLp(av) = key;
373 }
374 else if (AvREAL(av))
375 SvREFCNT_dec(ary[key]);
376 ary[key] = val;
377 if (SvSMAGICAL(av)) {
378 const MAGIC *mg = SvMAGIC(av);
379 bool set = TRUE;
380 for (; mg; mg = mg->mg_moremagic) {
381 if (!isUPPER(mg->mg_type)) continue;
382 if (val) {
383 sv_magic(val, MUTABLE_SV(av), toLOWER(mg->mg_type), 0, key);
384 }
385 if (PL_delaymagic && mg->mg_type == PERL_MAGIC_isa) {
386 PL_delaymagic |= DM_ARRAY_ISA;
387 set = FALSE;
388 }
389 }
390 if (set)
391 mg_set(MUTABLE_SV(av));
392 }
393 return &ary[key];
394 }
395
396 /*
397 =for apidoc av_new_alloc
398
399 Creates a new AV and allocates its SV* array.
400
401 This is similar to but more efficient than doing:
402
403 AV *av = newAV();
404 av_extend(av, key);
405
406 The size parameter is used to pre-allocate a SV* array large enough to
407 hold at least elements 0..(size-1). size must be at least 1.
408
409 The zeroflag parameter controls whether the array is NULL initialized.
410
411 =cut
412 */
413
414 AV *
Perl_av_new_alloc(pTHX_ SSize_t size,bool zeroflag)415 Perl_av_new_alloc(pTHX_ SSize_t size, bool zeroflag)
416 {
417 AV * const av = newAV();
418 SV** ary;
419 PERL_ARGS_ASSERT_AV_NEW_ALLOC;
420 assert(size > 0);
421
422 Newx(ary, size, SV*); /* Newx performs the memwrap check */
423 AvALLOC(av) = ary;
424 AvARRAY(av) = ary;
425 AvMAX(av) = size - 1;
426
427 if (zeroflag)
428 Zero(ary, size, SV*);
429
430 return av;
431 }
432
433 /*
434 =for apidoc av_make
435
436 Creates a new AV and populates it with a list of SVs. The SVs are copied
437 into the array, so they may be freed after the call to C<av_make>. The new AV
438 will have a reference count of 1.
439
440 Perl equivalent: C<my @new_array = ($scalar1, $scalar2, $scalar3...);>
441
442 =cut
443 */
444
445 AV *
Perl_av_make(pTHX_ SSize_t size,SV ** strp)446 Perl_av_make(pTHX_ SSize_t size, SV **strp)
447 {
448 AV * const av = newAV();
449 /* sv_upgrade does AvREAL_only() */
450 PERL_ARGS_ASSERT_AV_MAKE;
451 assert(SvTYPE(av) == SVt_PVAV);
452
453 if (size) { /* "defined" was returning undef for size==0 anyway. */
454 SV** ary;
455 SSize_t i;
456 SSize_t orig_ix;
457
458 Newx(ary,size,SV*);
459 AvALLOC(av) = ary;
460 AvARRAY(av) = ary;
461 AvMAX(av) = size - 1;
462 /* avoid av being leaked if croak when calling magic below */
463 EXTEND_MORTAL(1);
464 PL_tmps_stack[++PL_tmps_ix] = (SV*)av;
465 orig_ix = PL_tmps_ix;
466
467 for (i = 0; i < size; i++) {
468 assert (*strp);
469
470 /* Don't let sv_setsv swipe, since our source array might
471 have multiple references to the same temp scalar (e.g.
472 from a list slice) */
473
474 SvGETMAGIC(*strp); /* before newSV, in case it dies */
475 AvFILLp(av)++;
476 ary[i] = newSV(0);
477 sv_setsv_flags(ary[i], *strp,
478 SV_DO_COW_SVSETSV|SV_NOSTEAL);
479 strp++;
480 }
481 /* disarm av's leak guard */
482 if (LIKELY(PL_tmps_ix == orig_ix))
483 PL_tmps_ix--;
484 else
485 PL_tmps_stack[orig_ix] = &PL_sv_undef;
486 }
487 return av;
488 }
489
490 /*
491 =for apidoc av_clear
492
493 Frees all the elements of an array, leaving it empty.
494 The XS equivalent of C<@array = ()>. See also L</av_undef>.
495
496 Note that it is possible that the actions of a destructor called directly
497 or indirectly by freeing an element of the array could cause the reference
498 count of the array itself to be reduced (e.g. by deleting an entry in the
499 symbol table). So it is a possibility that the AV could have been freed
500 (or even reallocated) on return from the call unless you hold a reference
501 to it.
502
503 =cut
504 */
505
506 void
Perl_av_clear(pTHX_ AV * av)507 Perl_av_clear(pTHX_ AV *av)
508 {
509 SSize_t extra;
510 bool real;
511 SSize_t orig_ix = 0;
512
513 PERL_ARGS_ASSERT_AV_CLEAR;
514 assert(SvTYPE(av) == SVt_PVAV);
515
516 #ifdef DEBUGGING
517 if (SvREFCNT(av) == 0) {
518 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "Attempt to clear deleted array");
519 }
520 #endif
521
522 if (SvREADONLY(av))
523 Perl_croak_no_modify();
524
525 /* Give any tie a chance to cleanup first */
526 if (SvRMAGICAL(av)) {
527 const MAGIC* const mg = SvMAGIC(av);
528 if (PL_delaymagic && mg && mg->mg_type == PERL_MAGIC_isa)
529 PL_delaymagic |= DM_ARRAY_ISA;
530 else
531 mg_clear(MUTABLE_SV(av));
532 }
533
534 if (AvMAX(av) < 0)
535 return;
536
537 if ((real = cBOOL(AvREAL(av)))) {
538 SV** const ary = AvARRAY(av);
539 SSize_t index = AvFILLp(av) + 1;
540
541 /* avoid av being freed when calling destructors below */
542 EXTEND_MORTAL(1);
543 PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(av);
544 orig_ix = PL_tmps_ix;
545
546 while (index) {
547 SV * const sv = ary[--index];
548 /* undef the slot before freeing the value, because a
549 * destructor might try to modify this array */
550 ary[index] = NULL;
551 SvREFCNT_dec(sv);
552 }
553 }
554 extra = AvARRAY(av) - AvALLOC(av);
555 if (extra) {
556 AvMAX(av) += extra;
557 AvARRAY(av) = AvALLOC(av);
558 }
559 AvFILLp(av) = -1;
560 if (real) {
561 /* disarm av's premature free guard */
562 if (LIKELY(PL_tmps_ix == orig_ix))
563 PL_tmps_ix--;
564 else
565 PL_tmps_stack[orig_ix] = &PL_sv_undef;
566 SvREFCNT_dec_NN(av);
567 }
568 }
569
570 /*
571 =for apidoc av_undef
572
573 Undefines the array. The XS equivalent of C<undef(@array)>.
574
575 As well as freeing all the elements of the array (like C<av_clear()>), this
576 also frees the memory used by the av to store its list of scalars.
577
578 See L</av_clear> for a note about the array possibly being invalid on
579 return.
580
581 =cut
582 */
583
584 void
Perl_av_undef(pTHX_ AV * av)585 Perl_av_undef(pTHX_ AV *av)
586 {
587 bool real;
588 SSize_t orig_ix = PL_tmps_ix; /* silence bogus warning about possible unitialized use */
589
590 PERL_ARGS_ASSERT_AV_UNDEF;
591 assert(SvTYPE(av) == SVt_PVAV);
592
593 /* Give any tie a chance to cleanup first */
594 if (SvTIED_mg((const SV *)av, PERL_MAGIC_tied))
595 av_fill(av, -1);
596
597 real = cBOOL(AvREAL(av));
598 if (real) {
599 SSize_t key = AvFILLp(av) + 1;
600
601 /* avoid av being freed when calling destructors below */
602 EXTEND_MORTAL(1);
603 PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(av);
604 orig_ix = PL_tmps_ix;
605
606 while (key)
607 SvREFCNT_dec(AvARRAY(av)[--key]);
608 }
609
610 Safefree(AvALLOC(av));
611 AvALLOC(av) = NULL;
612 AvARRAY(av) = NULL;
613 AvMAX(av) = AvFILLp(av) = -1;
614
615 if(SvRMAGICAL(av)) mg_clear(MUTABLE_SV(av));
616 if (real) {
617 /* disarm av's premature free guard */
618 if (LIKELY(PL_tmps_ix == orig_ix))
619 PL_tmps_ix--;
620 else
621 PL_tmps_stack[orig_ix] = &PL_sv_undef;
622 SvREFCNT_dec_NN(av);
623 }
624 }
625
626 /*
627
628 =for apidoc av_create_and_push
629
630 Push an SV onto the end of the array, creating the array if necessary.
631 A small internal helper function to remove a commonly duplicated idiom.
632
633 =cut
634 */
635
636 void
Perl_av_create_and_push(pTHX_ AV ** const avp,SV * const val)637 Perl_av_create_and_push(pTHX_ AV **const avp, SV *const val)
638 {
639 PERL_ARGS_ASSERT_AV_CREATE_AND_PUSH;
640
641 if (!*avp)
642 *avp = newAV();
643 av_push(*avp, val);
644 }
645
646 /*
647 =for apidoc av_push
648
649 Pushes an SV (transferring control of one reference count) onto the end of the
650 array. The array will grow automatically to accommodate the addition.
651
652 Perl equivalent: C<push @myarray, $val;>.
653
654 =cut
655 */
656
657 void
Perl_av_push(pTHX_ AV * av,SV * val)658 Perl_av_push(pTHX_ AV *av, SV *val)
659 {
660 MAGIC *mg;
661
662 PERL_ARGS_ASSERT_AV_PUSH;
663 assert(SvTYPE(av) == SVt_PVAV);
664
665 if (SvREADONLY(av))
666 Perl_croak_no_modify();
667
668 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
669 Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(PUSH), G_DISCARD, 1,
670 val);
671 return;
672 }
673 av_store(av,AvFILLp(av)+1,val);
674 }
675
676 /*
677 =for apidoc av_pop
678
679 Removes one SV from the end of the array, reducing its size by one and
680 returning the SV (transferring control of one reference count) to the
681 caller. Returns C<&PL_sv_undef> if the array is empty.
682
683 Perl equivalent: C<pop(@myarray);>
684
685 =cut
686 */
687
688 SV *
Perl_av_pop(pTHX_ AV * av)689 Perl_av_pop(pTHX_ AV *av)
690 {
691 SV *retval;
692 MAGIC* mg;
693
694 PERL_ARGS_ASSERT_AV_POP;
695 assert(SvTYPE(av) == SVt_PVAV);
696
697 if (SvREADONLY(av))
698 Perl_croak_no_modify();
699 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
700 retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(POP), 0, 0);
701 if (retval)
702 retval = newSVsv(retval);
703 return retval;
704 }
705 if (AvFILL(av) < 0)
706 return &PL_sv_undef;
707 retval = AvARRAY(av)[AvFILLp(av)];
708 AvARRAY(av)[AvFILLp(av)--] = NULL;
709 if (SvSMAGICAL(av))
710 mg_set(MUTABLE_SV(av));
711 return retval ? retval : &PL_sv_undef;
712 }
713
714 /*
715
716 =for apidoc av_create_and_unshift_one
717
718 Unshifts an SV onto the beginning of the array, creating the array if
719 necessary.
720 A small internal helper function to remove a commonly duplicated idiom.
721
722 =cut
723 */
724
725 SV **
Perl_av_create_and_unshift_one(pTHX_ AV ** const avp,SV * const val)726 Perl_av_create_and_unshift_one(pTHX_ AV **const avp, SV *const val)
727 {
728 PERL_ARGS_ASSERT_AV_CREATE_AND_UNSHIFT_ONE;
729
730 if (!*avp)
731 *avp = newAV();
732 av_unshift(*avp, 1);
733 return av_store(*avp, 0, val);
734 }
735
736 /*
737 =for apidoc av_unshift
738
739 Unshift the given number of C<undef> values onto the beginning of the
740 array. The array will grow automatically to accommodate the addition.
741
742 Perl equivalent: S<C<unshift @myarray, ((undef) x $num);>>
743
744 =cut
745 */
746
747 void
Perl_av_unshift(pTHX_ AV * av,SSize_t num)748 Perl_av_unshift(pTHX_ AV *av, SSize_t num)
749 {
750 SSize_t i;
751 MAGIC* mg;
752
753 PERL_ARGS_ASSERT_AV_UNSHIFT;
754 assert(SvTYPE(av) == SVt_PVAV);
755
756 if (SvREADONLY(av))
757 Perl_croak_no_modify();
758
759 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
760 Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(UNSHIFT),
761 G_DISCARD | G_UNDEF_FILL, num);
762 return;
763 }
764
765 if (num <= 0)
766 return;
767 if (!AvREAL(av) && AvREIFY(av))
768 av_reify(av);
769 i = AvARRAY(av) - AvALLOC(av);
770 if (i) {
771 if (i > num)
772 i = num;
773 num -= i;
774
775 AvMAX(av) += i;
776 AvFILLp(av) += i;
777 AvARRAY(av) = AvARRAY(av) - i;
778 }
779 if (num) {
780 SV **ary;
781 const SSize_t i = AvFILLp(av);
782 /* Create extra elements */
783 const SSize_t slide = i > 0 ? i : 0;
784 num += slide;
785 av_extend(av, i + num);
786 AvFILLp(av) += num;
787 ary = AvARRAY(av);
788 Move(ary, ary + num, i + 1, SV*);
789 do {
790 ary[--num] = NULL;
791 } while (num);
792 /* Make extra elements into a buffer */
793 AvMAX(av) -= slide;
794 AvFILLp(av) -= slide;
795 AvARRAY(av) = AvARRAY(av) + slide;
796 }
797 }
798
799 /*
800 =for apidoc av_shift
801
802 Removes one SV from the start 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<shift(@myarray);>
807
808 =cut
809 */
810
811 SV *
Perl_av_shift(pTHX_ AV * av)812 Perl_av_shift(pTHX_ AV *av)
813 {
814 SV *retval;
815 MAGIC* mg;
816
817 PERL_ARGS_ASSERT_AV_SHIFT;
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(SHIFT), 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);
831 if (AvREAL(av))
832 *AvARRAY(av) = NULL;
833 AvARRAY(av) = AvARRAY(av) + 1;
834 AvMAX(av)--;
835 AvFILLp(av)--;
836 if (SvSMAGICAL(av))
837 mg_set(MUTABLE_SV(av));
838 return retval ? retval : &PL_sv_undef;
839 }
840
841 /*
842 =for apidoc av_tindex
843 =for apidoc_item av_top_index
844
845 These behave identically.
846 If the array C<av> is empty, these return -1; otherwise they return the maximum
847 value of the indices of all the array elements which are currently defined in
848 C<av>.
849
850 They process 'get' magic.
851
852 The Perl equivalent for these is C<$#av>.
853
854 Use C<L</av_count>> to get the number of elements in an array.
855
856 =for apidoc av_len
857
858 Same as L</av_top_index>. Note that, unlike what the name implies, it returns
859 the maximum index in the array. This is unlike L</sv_len>, which returns what
860 you would expect.
861
862 B<To get the true number of elements in the array, instead use C<L</av_count>>>.
863
864 =cut
865 */
866
867 SSize_t
Perl_av_len(pTHX_ AV * av)868 Perl_av_len(pTHX_ AV *av)
869 {
870 PERL_ARGS_ASSERT_AV_LEN;
871
872 return av_top_index(av);
873 }
874
875 /*
876 =for apidoc av_fill
877
878 Set the highest index in the array to the given number, equivalent to
879 Perl's S<C<$#array = $fill;>>.
880
881 The number of elements in the array will be S<C<fill + 1>> after
882 C<av_fill()> returns. If the array was previously shorter, then the
883 additional elements appended are set to NULL. If the array
884 was longer, then the excess elements are freed. S<C<av_fill(av, -1)>> is
885 the same as C<av_clear(av)>.
886
887 =cut
888 */
889 void
Perl_av_fill(pTHX_ AV * av,SSize_t fill)890 Perl_av_fill(pTHX_ AV *av, SSize_t fill)
891 {
892 MAGIC *mg;
893
894 PERL_ARGS_ASSERT_AV_FILL;
895 assert(SvTYPE(av) == SVt_PVAV);
896
897 if (fill < 0)
898 fill = -1;
899 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
900 SV *arg1 = sv_newmortal();
901 sv_setiv(arg1, (IV)(fill + 1));
902 Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(STORESIZE), G_DISCARD,
903 1, arg1);
904 return;
905 }
906 if (fill <= AvMAX(av)) {
907 SSize_t key = AvFILLp(av);
908 SV** const ary = AvARRAY(av);
909
910 if (AvREAL(av)) {
911 while (key > fill) {
912 SvREFCNT_dec(ary[key]);
913 ary[key--] = NULL;
914 }
915 }
916 else {
917 while (key < fill)
918 ary[++key] = NULL;
919 }
920
921 AvFILLp(av) = fill;
922 if (SvSMAGICAL(av))
923 mg_set(MUTABLE_SV(av));
924 }
925 else
926 (void)av_store(av,fill,NULL);
927 }
928
929 /*
930 =for apidoc av_delete
931
932 Deletes the element indexed by C<key> from the array, makes the element
933 mortal, and returns it. If C<flags> equals C<G_DISCARD>, the element is
934 freed and NULL is returned. NULL is also returned if C<key> is out of
935 range.
936
937 Perl equivalent: S<C<splice(@myarray, $key, 1, undef)>> (with the
938 C<splice> in void context if C<G_DISCARD> is present).
939
940 =cut
941 */
942 SV *
Perl_av_delete(pTHX_ AV * av,SSize_t key,I32 flags)943 Perl_av_delete(pTHX_ AV *av, SSize_t key, I32 flags)
944 {
945 SV *sv;
946
947 PERL_ARGS_ASSERT_AV_DELETE;
948 assert(SvTYPE(av) == SVt_PVAV);
949
950 if (SvREADONLY(av))
951 Perl_croak_no_modify();
952
953 if (SvRMAGICAL(av)) {
954 const MAGIC * const tied_magic
955 = mg_find((const SV *)av, PERL_MAGIC_tied);
956 if ((tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata))) {
957 SV **svp;
958 if (key < 0) {
959 if (!S_adjust_index(aTHX_ av, tied_magic, &key))
960 return NULL;
961 }
962 svp = av_fetch(av, key, TRUE);
963 if (svp) {
964 sv = *svp;
965 mg_clear(sv);
966 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
967 sv_unmagic(sv, PERL_MAGIC_tiedelem); /* No longer an element */
968 return sv;
969 }
970 return NULL;
971 }
972 }
973 }
974
975 if (key < 0) {
976 key += AvFILL(av) + 1;
977 if (key < 0)
978 return NULL;
979 }
980
981 if (key > AvFILLp(av))
982 return NULL;
983 else {
984 if (!AvREAL(av) && AvREIFY(av))
985 av_reify(av);
986 sv = AvARRAY(av)[key];
987 AvARRAY(av)[key] = NULL;
988 if (key == AvFILLp(av)) {
989 do {
990 AvFILLp(av)--;
991 } while (--key >= 0 && !AvARRAY(av)[key]);
992 }
993 if (SvSMAGICAL(av))
994 mg_set(MUTABLE_SV(av));
995 }
996 if(sv != NULL) {
997 if (flags & G_DISCARD) {
998 SvREFCNT_dec_NN(sv);
999 return NULL;
1000 }
1001 else if (AvREAL(av))
1002 sv_2mortal(sv);
1003 }
1004 return sv;
1005 }
1006
1007 /*
1008 =for apidoc av_exists
1009
1010 Returns true if the element indexed by C<key> has been initialized.
1011
1012 This relies on the fact that uninitialized array elements are set to
1013 C<NULL>.
1014
1015 Perl equivalent: C<exists($myarray[$key])>.
1016
1017 =cut
1018 */
1019 bool
Perl_av_exists(pTHX_ AV * av,SSize_t key)1020 Perl_av_exists(pTHX_ AV *av, SSize_t key)
1021 {
1022 PERL_ARGS_ASSERT_AV_EXISTS;
1023 assert(SvTYPE(av) == SVt_PVAV);
1024
1025 if (SvRMAGICAL(av)) {
1026 const MAGIC * const tied_magic
1027 = mg_find((const SV *)av, PERL_MAGIC_tied);
1028 const MAGIC * const regdata_magic
1029 = mg_find((const SV *)av, PERL_MAGIC_regdata);
1030 if (tied_magic || regdata_magic) {
1031 MAGIC *mg;
1032 /* Handle negative array indices 20020222 MJD */
1033 if (key < 0) {
1034 if (!S_adjust_index(aTHX_ av, tied_magic, &key))
1035 return FALSE;
1036 }
1037
1038 if(key >= 0 && regdata_magic) {
1039 if (key <= AvFILL(av))
1040 return TRUE;
1041 else
1042 return FALSE;
1043 }
1044 {
1045 SV * const sv = sv_newmortal();
1046 mg_copy(MUTABLE_SV(av), sv, 0, key);
1047 mg = mg_find(sv, PERL_MAGIC_tiedelem);
1048 if (mg) {
1049 magic_existspack(sv, mg);
1050 {
1051 I32 retbool = SvTRUE_nomg_NN(sv);
1052 return cBOOL(retbool);
1053 }
1054 }
1055 }
1056 }
1057 }
1058
1059 if (key < 0) {
1060 key += AvFILL(av) + 1;
1061 if (key < 0)
1062 return FALSE;
1063 }
1064
1065 if (key <= AvFILLp(av) && AvARRAY(av)[key])
1066 {
1067 if (SvSMAGICAL(AvARRAY(av)[key])
1068 && mg_find(AvARRAY(av)[key], PERL_MAGIC_nonelem))
1069 return FALSE;
1070 return TRUE;
1071 }
1072 else
1073 return FALSE;
1074 }
1075
1076 static MAGIC *
S_get_aux_mg(pTHX_ AV * av)1077 S_get_aux_mg(pTHX_ AV *av) {
1078 MAGIC *mg;
1079
1080 PERL_ARGS_ASSERT_GET_AUX_MG;
1081 assert(SvTYPE(av) == SVt_PVAV);
1082
1083 mg = mg_find((const SV *)av, PERL_MAGIC_arylen_p);
1084
1085 if (!mg) {
1086 mg = sv_magicext(MUTABLE_SV(av), 0, PERL_MAGIC_arylen_p,
1087 &PL_vtbl_arylen_p, 0, 0);
1088 assert(mg);
1089 /* sv_magicext won't set this for us because we pass in a NULL obj */
1090 mg->mg_flags |= MGf_REFCOUNTED;
1091 }
1092 return mg;
1093 }
1094
1095 SV **
Perl_av_arylen_p(pTHX_ AV * av)1096 Perl_av_arylen_p(pTHX_ AV *av) {
1097 MAGIC *const mg = get_aux_mg(av);
1098
1099 PERL_ARGS_ASSERT_AV_ARYLEN_P;
1100 assert(SvTYPE(av) == SVt_PVAV);
1101
1102 return &(mg->mg_obj);
1103 }
1104
1105 IV *
Perl_av_iter_p(pTHX_ AV * av)1106 Perl_av_iter_p(pTHX_ AV *av) {
1107 MAGIC *const mg = get_aux_mg(av);
1108
1109 PERL_ARGS_ASSERT_AV_ITER_P;
1110 assert(SvTYPE(av) == SVt_PVAV);
1111
1112 if (sizeof(IV) == sizeof(SSize_t)) {
1113 return (IV *)&(mg->mg_len);
1114 } else {
1115 if (!mg->mg_ptr) {
1116 IV *temp;
1117 mg->mg_len = IVSIZE;
1118 Newxz(temp, 1, IV);
1119 mg->mg_ptr = (char *) temp;
1120 }
1121 return (IV *)mg->mg_ptr;
1122 }
1123 }
1124
1125 SV *
Perl_av_nonelem(pTHX_ AV * av,SSize_t ix)1126 Perl_av_nonelem(pTHX_ AV *av, SSize_t ix) {
1127 SV * const sv = newSV(0);
1128 PERL_ARGS_ASSERT_AV_NONELEM;
1129 if (!av_store(av,ix,sv))
1130 return sv_2mortal(sv); /* has tie magic */
1131 sv_magic(sv, NULL, PERL_MAGIC_nonelem, NULL, 0);
1132 return sv;
1133 }
1134
1135 /*
1136 * ex: set ts=8 sts=4 sw=4 et:
1137 */
1138