| CARVIEW |
Select Language
HTTP/2 302
server: nginx
date: Thu, 31 Jul 2025 08:58:53 GMT
content-type: text/plain; charset=utf-8
content-length: 0
x-archive-redirect-reason: found capture at 20210119153818
location: https://web.archive.org/web/20210119153818/https://perl5.git.perl.org/perl5.git/blob/HEAD:/av.c
server-timing: captures_list;dur=0.726573, exclusion.robots;dur=0.025557, exclusion.robots.policy;dur=0.012098, esindex;dur=0.016024, cdx.remote;dur=68.671577, LoadShardBlock;dur=202.132270, PetaboxLoader3.resolve;dur=117.506262, PetaboxLoader3.datanode;dur=62.959844
x-app-server: wwwb-app216
x-ts: 302
x-tr: 303
server-timing: TR;dur=0,Tw;dur=0,Tc;dur=0
set-cookie: SERVER=wwwb-app216; path=/
x-location: All
x-rl: 0
x-na: 0
x-page-cache: MISS
server-timing: MISS
x-nid: DigitalOcean
referrer-policy: no-referrer-when-downgrade
permissions-policy: interest-cohort=()
HTTP/2 200
server: nginx
date: Thu, 31 Jul 2025 08:58:55 GMT
content-type: application/xhtml+xml; charset=utf-8
x-archive-orig-date: Tue, 19 Jan 2021 15:38:18 GMT
x-archive-orig-server: Apache/2.4.6 (CentOS) OpenSSL/1.0.2k-fips
x-archive-orig-keep-alive: timeout=5, max=100
x-archive-orig-connection: Keep-Alive
x-archive-orig-x-crawler-transfer-encoding: chunked
x-archive-orig-content-length: 185380
x-archive-guessed-content-type: text/html
x-archive-guessed-charset: utf-8
memento-datetime: Tue, 19 Jan 2021 15:38:18 GMT
link: ; rel="original", ; rel="timemap"; type="application/link-format", ; rel="timegate", ; rel="first memento"; datetime="Tue, 19 Jan 2021 15:38:18 GMT", ; rel="memento"; datetime="Tue, 19 Jan 2021 15:38:18 GMT", ; rel="last memento"; datetime="Tue, 19 Jan 2021 15:38:18 GMT"
content-security-policy: default-src 'self' 'unsafe-eval' 'unsafe-inline' data: blob: archive.org web.archive.org web-static.archive.org wayback-api.archive.org athena.archive.org analytics.archive.org pragma.archivelab.org wwwb-events.archive.org
x-archive-src: CC-MAIN-2021-04-1610703519395.23-0012/CC-MAIN-20210119135001-20210119165001-00246.warc.gz
server-timing: captures_list;dur=0.694072, exclusion.robots;dur=0.024620, exclusion.robots.policy;dur=0.011569, esindex;dur=0.014486, cdx.remote;dur=47.065081, LoadShardBlock;dur=231.416097, PetaboxLoader3.datanode;dur=240.757633, load_resource;dur=281.075913, PetaboxLoader3.resolve;dur=223.059081
x-app-server: wwwb-app216
x-ts: 200
x-tr: 1016
server-timing: TR;dur=0,Tw;dur=0,Tc;dur=0
x-location: All
x-rl: 0
x-na: 0
x-page-cache: MISS
server-timing: MISS
x-nid: DigitalOcean
referrer-policy: no-referrer-when-downgrade
permissions-policy: interest-cohort=()
perl5.git.perl.org Git - perl5.git/blob - av.c
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 */
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 */
18 #include "EXTERN.h"
19 #define PERL_IN_AV_C
20 #include "perl.h"
22 void
23 Perl_av_reify(pTHX_ AV *av)
24 {
25 SSize_t key;
27 PERL_ARGS_ASSERT_AV_REIFY;
28 assert(SvTYPE(av) == SVt_PVAV);
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 }
51 /*
52 =for apidoc av_extend
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.
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)>.
62 =cut
63 */
65 void
66 Perl_av_extend(pTHX_ AV *av, SSize_t key)
67 {
68 MAGIC *mg;
70 PERL_ARGS_ASSERT_AV_EXTEND;
71 assert(SvTYPE(av) == SVt_PVAV);
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 }
93 /* The guts of av_extend. *Not* for general use! */
94 /* Also called directly from pp_assign, padlist_store, padnamelist_store */
95 void
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;
101 if (key < -1) /* -1 is legal */
102 Perl_croak(aTHX_
103 "panic: av_extend_guts() negative count (%" IVdf ")", (IV)key);
105 if (key > *maxp) {
106 SSize_t ary_offset = *maxp + 1;
107 SSize_t to_null = 0;
108 SSize_t newmax = 0;
110 if (av && *allocp != *arrayp) { /* a shifted SV* array exists */
111 to_null = *arrayp - *allocp;
112 *maxp += to_null;
114 Move(*arrayp, *allocp, AvFILLp(av)+1, SV*);
116 if (key > *maxp - 10) {
117 newmax = key + *maxp;
118 goto resize;
119 }
120 } else if (*allocp) { /* a full SV* array exists */
122 #ifdef Perl_safesysmalloc_size
123 /* Whilst it would be quite possible to move this logic around
124 (as I did in the SV code), so as to set AvMAX(av) early,
125 based on calling Perl_safesysmalloc_size() immediately after
126 allocation, I'm not convinced that it is a great idea here.
127 In an array we have to loop round setting everything to
128 NULL, which means writing to memory, potentially lots
129 of it, whereas for the SV buffer case we don't touch the
130 "bonus" memory. So there there is no cost in telling the
131 world about it, whereas here we have to do work before we can
132 tell the world about it, and that work involves writing to
133 memory that might never be read. So, I feel, better to keep
134 the current lazy system of only writing to it if our caller
135 has a need for more space. NWC */
136 newmax = Perl_safesysmalloc_size((void*)*allocp) /
137 sizeof(const SV *) - 1;
139 if (key <= newmax)
140 goto resized;
141 #endif
142 /* overflow-safe version of newmax = key + *maxp/5 */
143 newmax = *maxp / 5;
144 newmax = (key > SSize_t_MAX - newmax)
145 ? SSize_t_MAX : key + newmax;
146 resize:
147 {
148 /* it should really be newmax+1 here, but if newmax
149 * happens to equal SSize_t_MAX, then newmax+1 is
150 * undefined. This means technically we croak one
151 * index lower than we should in theory; in practice
152 * its unlikely the system has SSize_t_MAX/sizeof(SV*)
153 * bytes to spare! */
154 MEM_WRAP_CHECK_s(newmax, SV*, "Out of memory during array extend");
155 }
156 #ifdef STRESS_REALLOC
157 {
158 SV ** const old_alloc = *allocp;
159 Newx(*allocp, newmax+1, SV*);
160 Copy(old_alloc, *allocp, *maxp + 1, SV*);
161 Safefree(old_alloc);
162 }
163 #else
164 Renew(*allocp,newmax+1, SV*);
165 #endif
166 #ifdef Perl_safesysmalloc_size
167 resized:
168 #endif
169 to_null += newmax - *maxp;
170 *maxp = newmax;
172 /* See GH#18014 for discussion of when this might be needed: */
173 if (av == PL_curstack) { /* Oops, grew stack (via av_store()?) */
174 PL_stack_sp = *allocp + (PL_stack_sp - PL_stack_base);
175 PL_stack_base = *allocp;
176 PL_stack_max = PL_stack_base + newmax;
177 }
178 } else { /* there is no SV* array yet */
179 *maxp = key < 3 ? 3 : key;
180 {
181 /* see comment above about newmax+1*/
182 MEM_WRAP_CHECK_s(*maxp, SV*,
183 "Out of memory during array extend");
184 }
185 /* Newxz isn't used below because testing showed it to be slower
186 * than Newx+Zero (also slower than Newx + the previous while
187 * loop) for small arrays, which are very common in perl. */
188 Newx(*allocp, *maxp+1, SV*);
189 /* Stacks require only the first element to be &PL_sv_undef
190 * (set elsewhere). However, since non-stack AVs are likely
191 * to dominate in modern production applications, stacks
192 * don't get any special treatment here. */
193 ary_offset = 0;
194 to_null = *maxp+1;
195 goto zero;
196 }
198 if (av && AvREAL(av)) {
199 zero:
200 Zero(*allocp + ary_offset,to_null,SV*);
201 }
203 *arrayp = *allocp;
204 }
205 }
207 /*
208 =for apidoc av_fetch
210 Returns the SV at the specified index in the array. The C<key> is the
211 index. If lval is true, you are guaranteed to get a real SV back (in case
212 it wasn't real before), which you can then modify. Check that the return
213 value is non-null before dereferencing it to a C<SV*>.
215 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
216 more information on how to use this function on tied arrays.
218 The rough perl equivalent is C<$myarray[$key]>.
220 =cut
221 */
223 static bool
224 S_adjust_index(pTHX_ AV *av, const MAGIC *mg, SSize_t *keyp)
225 {
226 bool adjust_index = 1;
227 if (mg) {
228 /* Handle negative array indices 20020222 MJD */
229 SV * const ref = SvTIED_obj(MUTABLE_SV(av), mg);
230 SvGETMAGIC(ref);
231 if (SvROK(ref) && SvOBJECT(SvRV(ref))) {
232 SV * const * const negative_indices_glob =
233 hv_fetchs(SvSTASH(SvRV(ref)), NEGATIVE_INDICES_VAR, 0);
235 if (negative_indices_glob && isGV(*negative_indices_glob)
236 && SvTRUE(GvSV(*negative_indices_glob)))
237 adjust_index = 0;
238 }
239 }
241 if (adjust_index) {
242 *keyp += AvFILL(av) + 1;
243 if (*keyp < 0)
244 return FALSE;
245 }
246 return TRUE;
247 }
249 SV**
250 Perl_av_fetch(pTHX_ AV *av, SSize_t key, I32 lval)
251 {
252 SSize_t neg;
253 SSize_t size;
255 PERL_ARGS_ASSERT_AV_FETCH;
256 assert(SvTYPE(av) == SVt_PVAV);
258 if (UNLIKELY(SvRMAGICAL(av))) {
259 const MAGIC * const tied_magic
260 = mg_find((const SV *)av, PERL_MAGIC_tied);
261 if (tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata)) {
262 SV *sv;
263 if (key < 0) {
264 if (!S_adjust_index(aTHX_ av, tied_magic, &key))
265 return NULL;
266 }
268 sv = sv_newmortal();
269 sv_upgrade(sv, SVt_PVLV);
270 mg_copy(MUTABLE_SV(av), sv, 0, key);
271 if (!tied_magic) /* for regdata, force leavesub to make copies */
272 SvTEMP_off(sv);
273 LvTYPE(sv) = 't';
274 LvTARG(sv) = sv; /* fake (SV**) */
275 return &(LvTARG(sv));
276 }
277 }
279 neg = (key < 0);
280 size = AvFILLp(av) + 1;
281 key += neg * size; /* handle negative index without using branch */
283 /* the cast from SSize_t to Size_t allows both (key < 0) and (key >= size)
284 * to be tested as a single condition */
285 if ((Size_t)key >= (Size_t)size) {
286 if (UNLIKELY(neg))
287 return NULL;
288 goto emptyness;
289 }
291 if (!AvARRAY(av)[key]) {
292 emptyness:
293 return lval ? av_store(av,key,newSV(0)) : NULL;
294 }
296 return &AvARRAY(av)[key];
297 }
299 /*
300 =for apidoc av_store
302 Stores an SV in an array. The array index is specified as C<key>. The
303 return value will be C<NULL> if the operation failed or if the value did not
304 need to be actually stored within the array (as in the case of tied
305 arrays). Otherwise, it can be dereferenced
306 to get the C<SV*> that was stored
307 there (= C<val>)).
309 Note that the caller is responsible for suitably incrementing the reference
310 count of C<val> before the call, and decrementing it if the function
311 returned C<NULL>.
313 Approximate Perl equivalent: C<splice(@myarray, $key, 1, $val)>.
315 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
316 more information on how to use this function on tied arrays.
318 =cut
319 */
321 SV**
322 Perl_av_store(pTHX_ AV *av, SSize_t key, SV *val)
323 {
324 SV** ary;
326 PERL_ARGS_ASSERT_AV_STORE;
327 assert(SvTYPE(av) == SVt_PVAV);
329 /* S_regclass relies on being able to pass in a NULL sv
330 (unicode_alternate may be NULL).
331 */
333 if (SvRMAGICAL(av)) {
334 const MAGIC * const tied_magic = mg_find((const SV *)av, PERL_MAGIC_tied);
335 if (tied_magic) {
336 if (key < 0) {
337 if (!S_adjust_index(aTHX_ av, tied_magic, &key))
338 return 0;
339 }
340 if (val) {
341 mg_copy(MUTABLE_SV(av), val, 0, key);
342 }
343 return NULL;
344 }
345 }
348 if (key < 0) {
349 key += AvFILL(av) + 1;
350 if (key < 0)
351 return NULL;
352 }
354 if (SvREADONLY(av) && key >= AvFILL(av))
355 Perl_croak_no_modify();
357 if (!AvREAL(av) && AvREIFY(av))
358 av_reify(av);
359 if (key > AvMAX(av))
360 av_extend(av,key);
361 ary = AvARRAY(av);
362 if (AvFILLp(av) < key) {
363 if (!AvREAL(av)) {
364 if (av == PL_curstack && key > PL_stack_sp - PL_stack_base)
365 PL_stack_sp = PL_stack_base + key; /* XPUSH in disguise */
366 do {
367 ary[++AvFILLp(av)] = NULL;
368 } while (AvFILLp(av) < key);
369 }
370 AvFILLp(av) = key;
371 }
372 else if (AvREAL(av))
373 SvREFCNT_dec(ary[key]);
374 ary[key] = val;
375 if (SvSMAGICAL(av)) {
376 const MAGIC *mg = SvMAGIC(av);
377 bool set = TRUE;
378 for (; mg; mg = mg->mg_moremagic) {
379 if (!isUPPER(mg->mg_type)) continue;
380 if (val) {
381 sv_magic(val, MUTABLE_SV(av), toLOWER(mg->mg_type), 0, key);
382 }
383 if (PL_delaymagic && mg->mg_type == PERL_MAGIC_isa) {
384 PL_delaymagic |= DM_ARRAY_ISA;
385 set = FALSE;
386 }
387 }
388 if (set)
389 mg_set(MUTABLE_SV(av));
390 }
391 return &ary[key];
392 }
394 /*
395 =for apidoc av_make
397 Creates a new AV and populates it with a list of SVs. The SVs are copied
398 into the array, so they may be freed after the call to C<av_make>. The new AV
399 will have a reference count of 1.
401 Perl equivalent: C<my @new_array = ($scalar1, $scalar2, $scalar3...);>
403 =cut
404 */
406 AV *
407 Perl_av_make(pTHX_ SSize_t size, SV **strp)
408 {
409 AV * const av = newAV();
410 /* sv_upgrade does AvREAL_only() */
411 PERL_ARGS_ASSERT_AV_MAKE;
412 assert(SvTYPE(av) == SVt_PVAV);
414 if (size) { /* "defined" was returning undef for size==0 anyway. */
415 SV** ary;
416 SSize_t i;
417 SSize_t orig_ix;
419 Newx(ary,size,SV*);
420 AvALLOC(av) = ary;
421 AvARRAY(av) = ary;
422 AvMAX(av) = size - 1;
423 /* avoid av being leaked if croak when calling magic below */
424 EXTEND_MORTAL(1);
425 PL_tmps_stack[++PL_tmps_ix] = (SV*)av;
426 orig_ix = PL_tmps_ix;
428 for (i = 0; i < size; i++) {
429 assert (*strp);
431 /* Don't let sv_setsv swipe, since our source array might
432 have multiple references to the same temp scalar (e.g.
433 from a list slice) */
435 SvGETMAGIC(*strp); /* before newSV, in case it dies */
436 AvFILLp(av)++;
437 ary[i] = newSV(0);
438 sv_setsv_flags(ary[i], *strp,
439 SV_DO_COW_SVSETSV|SV_NOSTEAL);
440 strp++;
441 }
442 /* disarm av's leak guard */
443 if (LIKELY(PL_tmps_ix == orig_ix))
444 PL_tmps_ix--;
445 else
446 PL_tmps_stack[orig_ix] = &PL_sv_undef;
447 }
448 return av;
449 }
451 /*
452 =for apidoc av_clear
454 Frees all the elements of an array, leaving it empty.
455 The XS equivalent of C<@array = ()>. See also L</av_undef>.
457 Note that it is possible that the actions of a destructor called directly
458 or indirectly by freeing an element of the array could cause the reference
459 count of the array itself to be reduced (e.g. by deleting an entry in the
460 symbol table). So it is a possibility that the AV could have been freed
461 (or even reallocated) on return from the call unless you hold a reference
462 to it.
464 =cut
465 */
467 void
468 Perl_av_clear(pTHX_ AV *av)
469 {
470 SSize_t extra;
471 bool real;
472 SSize_t orig_ix = 0;
474 PERL_ARGS_ASSERT_AV_CLEAR;
475 assert(SvTYPE(av) == SVt_PVAV);
477 #ifdef DEBUGGING
478 if (SvREFCNT(av) == 0) {
479 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "Attempt to clear deleted array");
480 }
481 #endif
483 if (SvREADONLY(av))
484 Perl_croak_no_modify();
486 /* Give any tie a chance to cleanup first */
487 if (SvRMAGICAL(av)) {
488 const MAGIC* const mg = SvMAGIC(av);
489 if (PL_delaymagic && mg && mg->mg_type == PERL_MAGIC_isa)
490 PL_delaymagic |= DM_ARRAY_ISA;
491 else
492 mg_clear(MUTABLE_SV(av));
493 }
495 if (AvMAX(av) < 0)
496 return;
498 if ((real = cBOOL(AvREAL(av)))) {
499 SV** const ary = AvARRAY(av);
500 SSize_t index = AvFILLp(av) + 1;
502 /* avoid av being freed when calling destructors below */
503 EXTEND_MORTAL(1);
504 PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(av);
505 orig_ix = PL_tmps_ix;
507 while (index) {
508 SV * const sv = ary[--index];
509 /* undef the slot before freeing the value, because a
510 * destructor might try to modify this array */
511 ary[index] = NULL;
512 SvREFCNT_dec(sv);
513 }
514 }
515 extra = AvARRAY(av) - AvALLOC(av);
516 if (extra) {
517 AvMAX(av) += extra;
518 AvARRAY(av) = AvALLOC(av);
519 }
520 AvFILLp(av) = -1;
521 if (real) {
522 /* disarm av's premature free guard */
523 if (LIKELY(PL_tmps_ix == orig_ix))
524 PL_tmps_ix--;
525 else
526 PL_tmps_stack[orig_ix] = &PL_sv_undef;
527 SvREFCNT_dec_NN(av);
528 }
529 }
531 /*
532 =for apidoc av_undef
534 Undefines the array. The XS equivalent of C<undef(@array)>.
536 As well as freeing all the elements of the array (like C<av_clear()>), this
537 also frees the memory used by the av to store its list of scalars.
539 See L</av_clear> for a note about the array possibly being invalid on
540 return.
542 =cut
543 */
545 void
546 Perl_av_undef(pTHX_ AV *av)
547 {
548 bool real;
549 SSize_t orig_ix = PL_tmps_ix; /* silence bogus warning about possible unitialized use */
551 PERL_ARGS_ASSERT_AV_UNDEF;
552 assert(SvTYPE(av) == SVt_PVAV);
554 /* Give any tie a chance to cleanup first */
555 if (SvTIED_mg((const SV *)av, PERL_MAGIC_tied))
556 av_fill(av, -1);
558 real = cBOOL(AvREAL(av));
559 if (real) {
560 SSize_t key = AvFILLp(av) + 1;
562 /* avoid av being freed when calling destructors below */
563 EXTEND_MORTAL(1);
564 PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(av);
565 orig_ix = PL_tmps_ix;
567 while (key)
568 SvREFCNT_dec(AvARRAY(av)[--key]);
569 }
571 Safefree(AvALLOC(av));
572 AvALLOC(av) = NULL;
573 AvARRAY(av) = NULL;
574 AvMAX(av) = AvFILLp(av) = -1;
576 if(SvRMAGICAL(av)) mg_clear(MUTABLE_SV(av));
577 if (real) {
578 /* disarm av's premature free guard */
579 if (LIKELY(PL_tmps_ix == orig_ix))
580 PL_tmps_ix--;
581 else
582 PL_tmps_stack[orig_ix] = &PL_sv_undef;
583 SvREFCNT_dec_NN(av);
584 }
585 }
587 /*
589 =for apidoc av_create_and_push
591 Push an SV onto the end of the array, creating the array if necessary.
592 A small internal helper function to remove a commonly duplicated idiom.
594 =cut
595 */
597 void
598 Perl_av_create_and_push(pTHX_ AV **const avp, SV *const val)
599 {
600 PERL_ARGS_ASSERT_AV_CREATE_AND_PUSH;
602 if (!*avp)
603 *avp = newAV();
604 av_push(*avp, val);
605 }
607 /*
608 =for apidoc av_push
610 Pushes an SV (transferring control of one reference count) onto the end of the
611 array. The array will grow automatically to accommodate the addition.
613 Perl equivalent: C<push @myarray, $val;>.
615 =cut
616 */
618 void
619 Perl_av_push(pTHX_ AV *av, SV *val)
620 {
621 MAGIC *mg;
623 PERL_ARGS_ASSERT_AV_PUSH;
624 assert(SvTYPE(av) == SVt_PVAV);
626 if (SvREADONLY(av))
627 Perl_croak_no_modify();
629 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
630 Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(PUSH), G_DISCARD, 1,
631 val);
632 return;
633 }
634 av_store(av,AvFILLp(av)+1,val);
635 }
637 /*
638 =for apidoc av_pop
640 Removes one SV from the end of the array, reducing its size by one and
641 returning the SV (transferring control of one reference count) to the
642 caller. Returns C<&PL_sv_undef> if the array is empty.
644 Perl equivalent: C<pop(@myarray);>
646 =cut
647 */
649 SV *
650 Perl_av_pop(pTHX_ AV *av)
651 {
652 SV *retval;
653 MAGIC* mg;
655 PERL_ARGS_ASSERT_AV_POP;
656 assert(SvTYPE(av) == SVt_PVAV);
658 if (SvREADONLY(av))
659 Perl_croak_no_modify();
660 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
661 retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(POP), 0, 0);
662 if (retval)
663 retval = newSVsv(retval);
664 return retval;
665 }
666 if (AvFILL(av) < 0)
667 return &PL_sv_undef;
668 retval = AvARRAY(av)[AvFILLp(av)];
669 AvARRAY(av)[AvFILLp(av)--] = NULL;
670 if (SvSMAGICAL(av))
671 mg_set(MUTABLE_SV(av));
672 return retval ? retval : &PL_sv_undef;
673 }
675 /*
677 =for apidoc av_create_and_unshift_one
679 Unshifts an SV onto the beginning of the array, creating the array if
680 necessary.
681 A small internal helper function to remove a commonly duplicated idiom.
683 =cut
684 */
686 SV **
687 Perl_av_create_and_unshift_one(pTHX_ AV **const avp, SV *const val)
688 {
689 PERL_ARGS_ASSERT_AV_CREATE_AND_UNSHIFT_ONE;
691 if (!*avp)
692 *avp = newAV();
693 av_unshift(*avp, 1);
694 return av_store(*avp, 0, val);
695 }
697 /*
698 =for apidoc av_unshift
700 Unshift the given number of C<undef> values onto the beginning of the
701 array. The array will grow automatically to accommodate the addition.
703 Perl equivalent: S<C<unshift @myarray, ((undef) x $num);>>
705 =cut
706 */
708 void
709 Perl_av_unshift(pTHX_ AV *av, SSize_t num)
710 {
711 SSize_t i;
712 MAGIC* mg;
714 PERL_ARGS_ASSERT_AV_UNSHIFT;
715 assert(SvTYPE(av) == SVt_PVAV);
717 if (SvREADONLY(av))
718 Perl_croak_no_modify();
720 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
721 Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(UNSHIFT),
722 G_DISCARD | G_UNDEF_FILL, num);
723 return;
724 }
726 if (num <= 0)
727 return;
728 if (!AvREAL(av) && AvREIFY(av))
729 av_reify(av);
730 i = AvARRAY(av) - AvALLOC(av);
731 if (i) {
732 if (i > num)
733 i = num;
734 num -= i;
736 AvMAX(av) += i;
737 AvFILLp(av) += i;
738 AvARRAY(av) = AvARRAY(av) - i;
739 }
740 if (num) {
741 SV **ary;
742 const SSize_t i = AvFILLp(av);
743 /* Create extra elements */
744 const SSize_t slide = i > 0 ? i : 0;
745 num += slide;
746 av_extend(av, i + num);
747 AvFILLp(av) += num;
748 ary = AvARRAY(av);
749 Move(ary, ary + num, i + 1, SV*);
750 do {
751 ary[--num] = NULL;
752 } while (num);
753 /* Make extra elements into a buffer */
754 AvMAX(av) -= slide;
755 AvFILLp(av) -= slide;
756 AvARRAY(av) = AvARRAY(av) + slide;
757 }
758 }
760 /*
761 =for apidoc av_shift
763 Removes one SV from the start of the array, reducing its size by one and
764 returning the SV (transferring control of one reference count) to the
765 caller. Returns C<&PL_sv_undef> if the array is empty.
767 Perl equivalent: C<shift(@myarray);>
769 =cut
770 */
772 SV *
773 Perl_av_shift(pTHX_ AV *av)
774 {
775 SV *retval;
776 MAGIC* mg;
778 PERL_ARGS_ASSERT_AV_SHIFT;
779 assert(SvTYPE(av) == SVt_PVAV);
781 if (SvREADONLY(av))
782 Perl_croak_no_modify();
783 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
784 retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(SHIFT), 0, 0);
785 if (retval)
786 retval = newSVsv(retval);
787 return retval;
788 }
789 if (AvFILL(av) < 0)
790 return &PL_sv_undef;
791 retval = *AvARRAY(av);
792 if (AvREAL(av))
793 *AvARRAY(av) = NULL;
794 AvARRAY(av) = AvARRAY(av) + 1;
795 AvMAX(av)--;
796 AvFILLp(av)--;
797 if (SvSMAGICAL(av))
798 mg_set(MUTABLE_SV(av));
799 return retval ? retval : &PL_sv_undef;
800 }
802 /*
803 =for apidoc av_tindex
804 =for apidoc_item av_top_index
806 These behave identically.
807 If the array C<av> is empty, these return -1; otherwise they return the maximum
808 value of the indices of all the array elements which are currently defined in
809 C<av>.
811 They process 'get' magic.
813 The Perl equivalent for these is C<$#av>.
815 Use C<L</av_count>> to get the number of elements in an array.
817 =for apidoc av_len
819 Same as L</av_top_index>. Note that, unlike what the name implies, it returns
820 the maximum index in the array. This is unlike L</sv_len>, which returns what
821 you would expect.
823 B<To get the true number of elements in the array, instead use C<L</av_count>>>.
825 =cut
826 */
828 SSize_t
829 Perl_av_len(pTHX_ AV *av)
830 {
831 PERL_ARGS_ASSERT_AV_LEN;
833 return av_top_index(av);
834 }
836 /*
837 =for apidoc av_fill
839 Set the highest index in the array to the given number, equivalent to
840 Perl's S<C<$#array = $fill;>>.
842 The number of elements in the array will be S<C<fill + 1>> after
843 C<av_fill()> returns. If the array was previously shorter, then the
844 additional elements appended are set to NULL. If the array
845 was longer, then the excess elements are freed. S<C<av_fill(av, -1)>> is
846 the same as C<av_clear(av)>.
848 =cut
849 */
850 void
851 Perl_av_fill(pTHX_ AV *av, SSize_t fill)
852 {
853 MAGIC *mg;
855 PERL_ARGS_ASSERT_AV_FILL;
856 assert(SvTYPE(av) == SVt_PVAV);
858 if (fill < 0)
859 fill = -1;
860 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
861 SV *arg1 = sv_newmortal();
862 sv_setiv(arg1, (IV)(fill + 1));
863 Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(STORESIZE), G_DISCARD,
864 1, arg1);
865 return;
866 }
867 if (fill <= AvMAX(av)) {
868 SSize_t key = AvFILLp(av);
869 SV** const ary = AvARRAY(av);
871 if (AvREAL(av)) {
872 while (key > fill) {
873 SvREFCNT_dec(ary[key]);
874 ary[key--] = NULL;
875 }
876 }
877 else {
878 while (key < fill)
879 ary[++key] = NULL;
880 }
882 AvFILLp(av) = fill;
883 if (SvSMAGICAL(av))
884 mg_set(MUTABLE_SV(av));
885 }
886 else
887 (void)av_store(av,fill,NULL);
888 }
890 /*
891 =for apidoc av_delete
893 Deletes the element indexed by C<key> from the array, makes the element
894 mortal, and returns it. If C<flags> equals C<G_DISCARD>, the element is
895 freed and NULL is returned. NULL is also returned if C<key> is out of
896 range.
898 Perl equivalent: S<C<splice(@myarray, $key, 1, undef)>> (with the
899 C<splice> in void context if C<G_DISCARD> is present).
901 =cut
902 */
903 SV *
904 Perl_av_delete(pTHX_ AV *av, SSize_t key, I32 flags)
905 {
906 SV *sv;
908 PERL_ARGS_ASSERT_AV_DELETE;
909 assert(SvTYPE(av) == SVt_PVAV);
911 if (SvREADONLY(av))
912 Perl_croak_no_modify();
914 if (SvRMAGICAL(av)) {
915 const MAGIC * const tied_magic
916 = mg_find((const SV *)av, PERL_MAGIC_tied);
917 if ((tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata))) {
918 SV **svp;
919 if (key < 0) {
920 if (!S_adjust_index(aTHX_ av, tied_magic, &key))
921 return NULL;
922 }
923 svp = av_fetch(av, key, TRUE);
924 if (svp) {
925 sv = *svp;
926 mg_clear(sv);
927 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
928 sv_unmagic(sv, PERL_MAGIC_tiedelem); /* No longer an element */
929 return sv;
930 }
931 return NULL;
932 }
933 }
934 }
936 if (key < 0) {
937 key += AvFILL(av) + 1;
938 if (key < 0)
939 return NULL;
940 }
942 if (key > AvFILLp(av))
943 return NULL;
944 else {
945 if (!AvREAL(av) && AvREIFY(av))
946 av_reify(av);
947 sv = AvARRAY(av)[key];
948 AvARRAY(av)[key] = NULL;
949 if (key == AvFILLp(av)) {
950 do {
951 AvFILLp(av)--;
952 } while (--key >= 0 && !AvARRAY(av)[key]);
953 }
954 if (SvSMAGICAL(av))
955 mg_set(MUTABLE_SV(av));
956 }
957 if(sv != NULL) {
958 if (flags & G_DISCARD) {
959 SvREFCNT_dec_NN(sv);
960 return NULL;
961 }
962 else if (AvREAL(av))
963 sv_2mortal(sv);
964 }
965 return sv;
966 }
968 /*
969 =for apidoc av_exists
971 Returns true if the element indexed by C<key> has been initialized.
973 This relies on the fact that uninitialized array elements are set to
974 C<NULL>.
976 Perl equivalent: C<exists($myarray[$key])>.
978 =cut
979 */
980 bool
981 Perl_av_exists(pTHX_ AV *av, SSize_t key)
982 {
983 PERL_ARGS_ASSERT_AV_EXISTS;
984 assert(SvTYPE(av) == SVt_PVAV);
986 if (SvRMAGICAL(av)) {
987 const MAGIC * const tied_magic
988 = mg_find((const SV *)av, PERL_MAGIC_tied);
989 const MAGIC * const regdata_magic
990 = mg_find((const SV *)av, PERL_MAGIC_regdata);
991 if (tied_magic || regdata_magic) {
992 MAGIC *mg;
993 /* Handle negative array indices 20020222 MJD */
994 if (key < 0) {
995 if (!S_adjust_index(aTHX_ av, tied_magic, &key))
996 return FALSE;
997 }
999 if(key >= 0 && regdata_magic) {
1000 if (key <= AvFILL(av))
1001 return TRUE;
1002 else
1003 return FALSE;
1004 }
1005 {
1006 SV * const sv = sv_newmortal();
1007 mg_copy(MUTABLE_SV(av), sv, 0, key);
1008 mg = mg_find(sv, PERL_MAGIC_tiedelem);
1009 if (mg) {
1010 magic_existspack(sv, mg);
1011 {
1012 I32 retbool = SvTRUE_nomg_NN(sv);
1013 return cBOOL(retbool);
1014 }
1015 }
1016 }
1017 }
1018 }
1020 if (key < 0) {
1021 key += AvFILL(av) + 1;
1022 if (key < 0)
1023 return FALSE;
1024 }
1026 if (key <= AvFILLp(av) && AvARRAY(av)[key])
1027 {
1028 if (SvSMAGICAL(AvARRAY(av)[key])
1029 && mg_find(AvARRAY(av)[key], PERL_MAGIC_nonelem))
1030 return FALSE;
1031 return TRUE;
1032 }
1033 else
1034 return FALSE;
1035 }
1037 static MAGIC *
1038 S_get_aux_mg(pTHX_ AV *av) {
1039 MAGIC *mg;
1041 PERL_ARGS_ASSERT_GET_AUX_MG;
1042 assert(SvTYPE(av) == SVt_PVAV);
1044 mg = mg_find((const SV *)av, PERL_MAGIC_arylen_p);
1046 if (!mg) {
1047 mg = sv_magicext(MUTABLE_SV(av), 0, PERL_MAGIC_arylen_p,
1048 &PL_vtbl_arylen_p, 0, 0);
1049 assert(mg);
1050 /* sv_magicext won't set this for us because we pass in a NULL obj */
1051 mg->mg_flags |= MGf_REFCOUNTED;
1052 }
1053 return mg;
1054 }
1056 SV **
1057 Perl_av_arylen_p(pTHX_ AV *av) {
1058 MAGIC *const mg = get_aux_mg(av);
1060 PERL_ARGS_ASSERT_AV_ARYLEN_P;
1061 assert(SvTYPE(av) == SVt_PVAV);
1063 return &(mg->mg_obj);
1064 }
1066 IV *
1067 Perl_av_iter_p(pTHX_ AV *av) {
1068 MAGIC *const mg = get_aux_mg(av);
1070 PERL_ARGS_ASSERT_AV_ITER_P;
1071 assert(SvTYPE(av) == SVt_PVAV);
1073 if (sizeof(IV) == sizeof(SSize_t)) {
1074 return (IV *)&(mg->mg_len);
1075 } else {
1076 if (!mg->mg_ptr) {
1077 IV *temp;
1078 mg->mg_len = IVSIZE;
1079 Newxz(temp, 1, IV);
1080 mg->mg_ptr = (char *) temp;
1081 }
1082 return (IV *)mg->mg_ptr;
1083 }
1084 }
1086 SV *
1087 Perl_av_nonelem(pTHX_ AV *av, SSize_t ix) {
1088 SV * const sv = newSV(0);
1089 PERL_ARGS_ASSERT_AV_NONELEM;
1090 if (!av_store(av,ix,sv))
1091 return sv_2mortal(sv); /* has tie magic */
1092 sv_magic(sv, NULL, PERL_MAGIC_nonelem, NULL, 0);
1093 return sv;
1094 }
1096 /*
1097 * ex: set ts=8 sts=4 sw=4 et:
1098 */