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