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