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         Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "av_reify called on tied array");
  35 #endif
  36     key = AvMAX(av) + 1;
  37     while (key > AvFILLp(av) + 1)
  38         AvARRAY(av)[--key] = NULL;
  39     while (key) {
  40         SV * const sv = AvARRAY(av)[--key];
  41         if (sv != &PL_sv_undef)
  42             SvREFCNT_inc_simple_void(sv);
  43     }
  44     key = AvARRAY(av) - AvALLOC(av);
  45     while (key)
  46         AvALLOC(av)[--key] = NULL;
  47     AvREIFY_off(av);
  48     AvREAL_on(av);
  49 }
  50
  51 /*
  52 =for apidoc av_extend
  53
  54 Pre-extend an array so that it is capable of storing values at indexes
  55 C<0..key>. Thus C<av_extend(av,99)> guarantees that the array can store 100
  56 elements, i.e. that C<av_store(av, 0, sv)> through C<av_store(av, 99, sv)>
  57 on a plain array will work without any further memory allocation.
  58
  59 If the av argument is a tied array then will call the C<EXTEND> tied
  60 array method with an argument of C<(key+1)>.
  61
  62 =cut
  63 */
  64
  65 void
  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         Perl_croak(aTHX_
 103             "panic: av_extend_guts() negative count (%" IVdf ")", (IV)key);
 104
 105     if (key > *maxp) {
 106         SSize_t ary_offset = *maxp + 1;
 107         SSize_t to_null = 0;
 108         SSize_t newmax  = 0;
 109
 110         if (av && *allocp != *arrayp) { /* a shifted SV* array exists */
 111             to_null = *arrayp - *allocp;
 112             *maxp += to_null;
 113             ary_offset = AvFILLp(av) + 1;
 114
 115             Move(*arrayp, *allocp, AvFILLp(av)+1, SV*);
 116
 117             if (key > *maxp - 10) {
 118                 newmax = key + *maxp;
 119                 goto resize;
 120             }
 121         } else if (*allocp) { /* a full SV* array exists */
 122
 123 #ifdef Perl_safesysmalloc_size
 124             /* Whilst it would be quite possible to move this logic around
 125                (as I did in the SV code), so as to set AvMAX(av) early,
 126                based on calling Perl_safesysmalloc_size() immediately after
 127                allocation, I'm not convinced that it is a great idea here.
 128                In an array we have to loop round setting everything to
 129                NULL, which means writing to memory, potentially lots
 130                of it, whereas for the SV buffer case we don't touch the
 131                "bonus" memory. So there there is no cost in telling the
 132                world about it, whereas here we have to do work before we can
 133                tell the world about it, and that work involves writing to
 134                memory that might never be read. So, I feel, better to keep
 135                the current lazy system of only writing to it if our caller
 136                has a need for more space. NWC  */
 137             newmax = Perl_safesysmalloc_size((void*)*allocp) /
 138                 sizeof(const SV *) - 1;
 139
 140             if (key <= newmax)
 141                 goto resized;
 142 #endif
 143             /* overflow-safe version of newmax = key + *maxp/5 */
 144             newmax = *maxp / 5;
 145             newmax = (key > SSize_t_MAX - newmax)
 146                         ? SSize_t_MAX : key + newmax;
 147           resize:
 148         {
 149           /* it should really be newmax+1 here, but if newmax
 150            * happens to equal SSize_t_MAX, then newmax+1 is
 151            * undefined. This means technically we croak one
 152            * index lower than we should in theory; in practice
 153            * its unlikely the system has SSize_t_MAX/sizeof(SV*)
 154            * bytes to spare! */
 155           MEM_WRAP_CHECK_s(newmax, SV*, "Out of memory during array extend");
 156         }
 157 #ifdef STRESS_REALLOC
 158             {
 159                 SV ** const old_alloc = *allocp;
 160                 Newx(*allocp, newmax+1, SV*);
 161                 Copy(old_alloc, *allocp, *maxp + 1, SV*);
 162                 Safefree(old_alloc);
 163             }
 164 #else
 165             Renew(*allocp,newmax+1, SV*);
 166 #endif
 167 #ifdef Perl_safesysmalloc_size
 168           resized:
 169 #endif
 170             to_null += newmax - *maxp;
 171             *maxp = newmax;
 172
 173             /* See GH#18014 for discussion of when this might be needed: */
 174             if (av == PL_curstack) { /* Oops, grew stack (via av_store()?) */
 175                 PL_stack_sp = *allocp + (PL_stack_sp - PL_stack_base);
 176                 PL_stack_base = *allocp;
 177                 PL_stack_max = PL_stack_base + newmax;
 178             }
 179         } else { /* there is no SV* array yet */
 180             *maxp = key < 3 ? 3 : key;
 181             {
 182                 /* see comment above about newmax+1*/
 183                 MEM_WRAP_CHECK_s(*maxp, SV*,
 184                                  "Out of memory during array extend");
 185             }
 186             /* Newxz isn't used below because testing showed it to be slower
 187              * than Newx+Zero (also slower than Newx + the previous while
 188              * loop) for small arrays, which are very common in perl. */
 189             Newx(*allocp, *maxp+1, SV*);
 190             /* Stacks require only the first element to be &PL_sv_undef
 191              * (set elsewhere). However, since non-stack AVs are likely
 192              * to dominate in modern production applications, stacks
 193              * don't get any special treatment here.
 194              * See https://github.com/Perl/perl5/pull/18690 for more detail */
 195             ary_offset = 0;
 196             to_null = *maxp+1;
 197             goto zero;
 198         }
 199
 200         if (av && AvREAL(av)) {
 201           zero:
 202             Zero(*allocp + ary_offset,to_null,SV*);
 203         }
 204
 205         *arrayp = *allocp;
 206     }
 207 }
 208
 209 /*
 210 =for apidoc av_fetch
 211
 212 Returns the SV at the specified index in the array.  The C<key> is the
 213 index.  If lval is true, you are guaranteed to get a real SV back (in case
 214 it wasn't real before), which you can then modify.  Check that the return
 215 value is non-null before dereferencing it to a C<SV*>.
 216
 217 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
 218 more information on how to use this function on tied arrays.
 219
 220 The rough perl equivalent is C<$myarray[$key]>.
 221
 222 =cut
 223 */
 224
 225 static bool
 226 S_adjust_index(pTHX_ AV *av, const MAGIC *mg, SSize_t *keyp)
 227 {
 228     bool adjust_index = 1;
 229     if (mg) {
 230         /* Handle negative array indices 20020222 MJD */
 231         SV * const ref = SvTIED_obj(MUTABLE_SV(av), mg);
 232         SvGETMAGIC(ref);
 233         if (SvROK(ref) && SvOBJECT(SvRV(ref))) {
 234             SV * const * const negative_indices_glob =
 235                 hv_fetchs(SvSTASH(SvRV(ref)), NEGATIVE_INDICES_VAR, 0);
 236
 237             if (negative_indices_glob && isGV(*negative_indices_glob)
 238              && SvTRUE(GvSV(*negative_indices_glob)))
 239                 adjust_index = 0;
 240         }
 241     }
 242
 243     if (adjust_index) {
 244         *keyp += AvFILL(av) + 1;
 245         if (*keyp < 0)
 246             return FALSE;
 247     }
 248     return TRUE;
 249 }
 250
 251 SV**
 252 Perl_av_fetch(pTHX_ AV *av, SSize_t key, I32 lval)
 253 {
 254     SSize_t neg;
 255     SSize_t size;
 256
 257     PERL_ARGS_ASSERT_AV_FETCH;
 258     assert(SvTYPE(av) == SVt_PVAV);
 259
 260     if (UNLIKELY(SvRMAGICAL(av))) {
 261         const MAGIC * const tied_magic
 262             = mg_find((const SV *)av, PERL_MAGIC_tied);
 263         if (tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata)) {
 264             SV *sv;
 265             if (key < 0) {
 266                 if (!S_adjust_index(aTHX_ av, tied_magic, &key))
 267                         return NULL;
 268             }
 269
 270             sv = sv_newmortal();
 271             sv_upgrade(sv, SVt_PVLV);
 272             mg_copy(MUTABLE_SV(av), sv, 0, key);
 273             if (!tied_magic) /* for regdata, force leavesub to make copies */
 274                 SvTEMP_off(sv);
 275             LvTYPE(sv) = 't';
 276             LvTARG(sv) = sv; /* fake (SV**) */
 277             return &(LvTARG(sv));
 278         }
 279     }
 280
 281     neg  = (key < 0);
 282     size = AvFILLp(av) + 1;
 283     key += neg * size; /* handle negative index without using branch */
 284
 285     /* the cast from SSize_t to Size_t allows both (key < 0) and (key >= size)
 286      * to be tested as a single condition */
 287     if ((Size_t)key >= (Size_t)size) {
 288         if (UNLIKELY(neg))
 289             return NULL;
 290         goto emptyness;
 291     }
 292
 293     if (!AvARRAY(av)[key]) {
 294       emptyness:
 295         return lval ? av_store(av,key,newSV(0)) : NULL;
 296     }
 297
 298     return &AvARRAY(av)[key];
 299 }
 300
 301 /*
 302 =for apidoc av_store
 303
 304 Stores an SV in an array.  The array index is specified as C<key>.  The
 305 return value will be C<NULL> if the operation failed or if the value did not
 306 need to be actually stored within the array (as in the case of tied
 307 arrays).  Otherwise, it can be dereferenced
 308 to get the C<SV*> that was stored
 309 there (= C<val>)).
 310
 311 Note that the caller is responsible for suitably incrementing the reference
 312 count of C<val> before the call, and decrementing it if the function
 313 returned C<NULL>.
 314
 315 Approximate Perl equivalent: C<splice(@myarray, $key, 1, $val)>.
 316
 317 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
 318 more information on how to use this function on tied arrays.
 319
 320 =cut
 321 */
 322
 323 SV**
 324 Perl_av_store(pTHX_ AV *av, SSize_t key, SV *val)
 325 {
 326     SV** ary;
 327
 328     PERL_ARGS_ASSERT_AV_STORE;
 329     assert(SvTYPE(av) == SVt_PVAV);
 330
 331     /* S_regclass relies on being able to pass in a NULL sv
 332        (unicode_alternate may be NULL).
 333     */
 334
 335     if (SvRMAGICAL(av)) {
 336         const MAGIC * const tied_magic = mg_find((const SV *)av, PERL_MAGIC_tied);
 337         if (tied_magic) {
 338             if (key < 0) {
 339                 if (!S_adjust_index(aTHX_ av, tied_magic, &key))
 340                         return 0;
 341             }
 342             if (val) {
 343                 mg_copy(MUTABLE_SV(av), val, 0, key);
 344             }
 345             return NULL;
 346         }
 347     }
 348
 349
 350     if (key < 0) {
 351         key += AvFILL(av) + 1;
 352         if (key < 0)
 353             return NULL;
 354     }
 355
 356     if (SvREADONLY(av) && key >= AvFILL(av))
 357         Perl_croak_no_modify();
 358
 359     if (!AvREAL(av) && AvREIFY(av))
 360         av_reify(av);
 361     if (key > AvMAX(av))
 362         av_extend(av,key);
 363     ary = AvARRAY(av);
 364     if (AvFILLp(av) < key) {
 365         if (!AvREAL(av)) {
 366             if (av == PL_curstack && key > PL_stack_sp - PL_stack_base)
 367                 PL_stack_sp = PL_stack_base + key;      /* XPUSH in disguise */
 368             do {
 369                 ary[++AvFILLp(av)] = NULL;
 370             } while (AvFILLp(av) < key);
 371         }
 372         AvFILLp(av) = key;
 373     }
 374     else if (AvREAL(av))
 375         SvREFCNT_dec(ary[key]);
 376     ary[key] = val;
 377     if (SvSMAGICAL(av)) {
 378         const MAGIC *mg = SvMAGIC(av);
 379         bool set = TRUE;
 380         for (; mg; mg = mg->mg_moremagic) {
 381           if (!isUPPER(mg->mg_type)) continue;
 382           if (val) {
 383             sv_magic(val, MUTABLE_SV(av), toLOWER(mg->mg_type), 0, key);
 384           }
 385           if (PL_delaymagic && mg->mg_type == PERL_MAGIC_isa) {
 386             PL_delaymagic |= DM_ARRAY_ISA;
 387             set = FALSE;
 388           }
 389         }
 390         if (set)
 391            mg_set(MUTABLE_SV(av));
 392     }
 393     return &ary[key];
 394 }
 395
 396 /*
 397 =for apidoc av_make
 398
 399 Creates a new AV and populates it with a list of SVs.  The SVs are copied
 400 into the array, so they may be freed after the call to C<av_make>.  The new AV
 401 will have a reference count of 1.
 402
 403 Perl equivalent: C<my @new_array = ($scalar1, $scalar2, $scalar3...);>
 404
 405 =cut
 406 */
 407
 408 AV *
 409 Perl_av_make(pTHX_ SSize_t size, SV **strp)
 410 {
 411     AV * const av = newAV();
 412     /* sv_upgrade does AvREAL_only()  */
 413     PERL_ARGS_ASSERT_AV_MAKE;
 414     assert(SvTYPE(av) == SVt_PVAV);
 415
 416     if (size) {         /* "defined" was returning undef for size==0 anyway. */
 417         SV** ary;
 418         SSize_t i;
 419         SSize_t orig_ix;
 420
 421         Newx(ary,size,SV*);
 422         AvALLOC(av) = ary;
 423         AvARRAY(av) = ary;
 424         AvMAX(av) = size - 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 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
 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
 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
 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
 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 *
 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 **
 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
 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 *
 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_tindex
 806 =for apidoc_item av_top_index
 807
 808 These behave identically.
 809 If the array C<av> is empty, these return -1; otherwise they return the maximum
 810 value of the indices of all the array elements which are currently defined in
 811 C<av>.
 812
 813 They process 'get' magic.
 814
 815 The Perl equivalent for these is C<$#av>.
 816
 817 Use C<L</av_count>> to get the number of elements in an array.
 818
 819 =for apidoc av_len
 820
 821 Same as L</av_top_index>.  Note that, unlike what the name implies, it returns
 822 the maximum index in the array.  This is unlike L</sv_len>, which returns what
 823 you would expect.
 824
 825 B<To get the true number of elements in the array, instead use C<L</av_count>>>.
 826
 827 =cut
 828 */
 829
 830 SSize_t
 831 Perl_av_len(pTHX_ AV *av)
 832 {
 833     PERL_ARGS_ASSERT_AV_LEN;
 834
 835     return av_top_index(av);
 836 }
 837
 838 /*
 839 =for apidoc av_fill
 840
 841 Set the highest index in the array to the given number, equivalent to
 842 Perl's S<C<$#array = $fill;>>.
 843
 844 The number of elements in the array will be S<C<fill + 1>> after
 845 C<av_fill()> returns.  If the array was previously shorter, then the
 846 additional elements appended are set to NULL.  If the array
 847 was longer, then the excess elements are freed.  S<C<av_fill(av, -1)>> is
 848 the same as C<av_clear(av)>.
 849
 850 =cut
 851 */
 852 void
 853 Perl_av_fill(pTHX_ AV *av, SSize_t fill)
 854 {
 855     MAGIC *mg;
 856
 857     PERL_ARGS_ASSERT_AV_FILL;
 858     assert(SvTYPE(av) == SVt_PVAV);
 859
 860     if (fill < 0)
 861         fill = -1;
 862     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
 863         SV *arg1 = sv_newmortal();
 864         sv_setiv(arg1, (IV)(fill + 1));
 865         Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(STORESIZE), G_DISCARD,
 866                             1, arg1);
 867         return;
 868     }
 869     if (fill <= AvMAX(av)) {
 870         SSize_t key = AvFILLp(av);
 871         SV** const ary = AvARRAY(av);
 872
 873         if (AvREAL(av)) {
 874             while (key > fill) {
 875                 SvREFCNT_dec(ary[key]);
 876                 ary[key--] = NULL;
 877             }
 878         }
 879         else {
 880             while (key < fill)
 881                 ary[++key] = NULL;
 882         }
 883
 884         AvFILLp(av) = fill;
 885         if (SvSMAGICAL(av))
 886             mg_set(MUTABLE_SV(av));
 887     }
 888     else
 889         (void)av_store(av,fill,NULL);
 890 }
 891
 892 /*
 893 =for apidoc av_delete
 894
 895 Deletes the element indexed by C<key> from the array, makes the element
 896 mortal, and returns it.  If C<flags> equals C<G_DISCARD>, the element is
 897 freed and NULL is returned. NULL is also returned if C<key> is out of
 898 range.
 899
 900 Perl equivalent: S<C<splice(@myarray, $key, 1, undef)>> (with the
 901 C<splice> in void context if C<G_DISCARD> is present).
 902
 903 =cut
 904 */
 905 SV *
 906 Perl_av_delete(pTHX_ AV *av, SSize_t key, I32 flags)
 907 {
 908     SV *sv;
 909
 910     PERL_ARGS_ASSERT_AV_DELETE;
 911     assert(SvTYPE(av) == SVt_PVAV);
 912
 913     if (SvREADONLY(av))
 914         Perl_croak_no_modify();
 915
 916     if (SvRMAGICAL(av)) {
 917         const MAGIC * const tied_magic
 918             = mg_find((const SV *)av, PERL_MAGIC_tied);
 919         if ((tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata))) {
 920             SV **svp;
 921             if (key < 0) {
 922                 if (!S_adjust_index(aTHX_ av, tied_magic, &key))
 923                         return NULL;
 924             }
 925             svp = av_fetch(av, key, TRUE);
 926             if (svp) {
 927                 sv = *svp;
 928                 mg_clear(sv);
 929                 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
 930                     sv_unmagic(sv, PERL_MAGIC_tiedelem); /* No longer an element */
 931                     return sv;
 932                 }
 933                 return NULL;
 934             }
 935         }
 936     }
 937
 938     if (key < 0) {
 939         key += AvFILL(av) + 1;
 940         if (key < 0)
 941             return NULL;
 942     }
 943
 944     if (key > AvFILLp(av))
 945         return NULL;
 946     else {
 947         if (!AvREAL(av) && AvREIFY(av))
 948             av_reify(av);
 949         sv = AvARRAY(av)[key];
 950         AvARRAY(av)[key] = NULL;
 951         if (key == AvFILLp(av)) {
 952             do {
 953                 AvFILLp(av)--;
 954             } while (--key >= 0 && !AvARRAY(av)[key]);
 955         }
 956         if (SvSMAGICAL(av))
 957             mg_set(MUTABLE_SV(av));
 958     }
 959     if(sv != NULL) {
 960         if (flags & G_DISCARD) {
 961             SvREFCNT_dec_NN(sv);
 962             return NULL;
 963         }
 964         else if (AvREAL(av))
 965             sv_2mortal(sv);
 966     }
 967     return sv;
 968 }
 969
 970 /*
 971 =for apidoc av_exists
 972
 973 Returns true if the element indexed by C<key> has been initialized.
 974
 975 This relies on the fact that uninitialized array elements are set to
 976 C<NULL>.
 977
 978 Perl equivalent: C<exists($myarray[$key])>.
 979
 980 =cut
 981 */
 982 bool
 983 Perl_av_exists(pTHX_ AV *av, SSize_t key)
 984 {
 985     PERL_ARGS_ASSERT_AV_EXISTS;
 986     assert(SvTYPE(av) == SVt_PVAV);
 987
 988     if (SvRMAGICAL(av)) {
 989         const MAGIC * const tied_magic
 990             = mg_find((const SV *)av, PERL_MAGIC_tied);
 991         const MAGIC * const regdata_magic
 992             = mg_find((const SV *)av, PERL_MAGIC_regdata);
 993         if (tied_magic || regdata_magic) {
 994             MAGIC *mg;
 995             /* Handle negative array indices 20020222 MJD */
 996             if (key < 0) {
 997                 if (!S_adjust_index(aTHX_ av, tied_magic, &key))
 998                         return FALSE;
 999             }
1000
1001             if(key >= 0 && regdata_magic) {
1002                 if (key <= AvFILL(av))
1003                     return TRUE;
1004                 else
1005                     return FALSE;
1006             }
1007             {
1008                 SV * const sv = sv_newmortal();
1009                 mg_copy(MUTABLE_SV(av), sv, 0, key);
1010                 mg = mg_find(sv, PERL_MAGIC_tiedelem);
1011                 if (mg) {
1012                     magic_existspack(sv, mg);
1013                     {
1014                         I32 retbool = SvTRUE_nomg_NN(sv);
1015                         return cBOOL(retbool);
1016                     }
1017                 }
1018             }
1019         }
1020     }
1021
1022     if (key < 0) {
1023         key += AvFILL(av) + 1;
1024         if (key < 0)
1025             return FALSE;
1026     }
1027
1028     if (key <= AvFILLp(av) && AvARRAY(av)[key])
1029     {
1030         if (SvSMAGICAL(AvARRAY(av)[key])
1031          && mg_find(AvARRAY(av)[key], PERL_MAGIC_nonelem))
1032             return FALSE;
1033         return TRUE;
1034     }
1035     else
1036         return FALSE;
1037 }
1038
1039 static MAGIC *
1040 S_get_aux_mg(pTHX_ AV *av) {
1041     MAGIC *mg;
1042
1043     PERL_ARGS_ASSERT_GET_AUX_MG;
1044     assert(SvTYPE(av) == SVt_PVAV);
1045
1046     mg = mg_find((const SV *)av, PERL_MAGIC_arylen_p);
1047
1048     if (!mg) {
1049         mg = sv_magicext(MUTABLE_SV(av), 0, PERL_MAGIC_arylen_p,
1050                          &PL_vtbl_arylen_p, 0, 0);
1051         assert(mg);
1052         /* sv_magicext won't set this for us because we pass in a NULL obj  */
1053         mg->mg_flags |= MGf_REFCOUNTED;
1054     }
1055     return mg;
1056 }
1057
1058 SV **
1059 Perl_av_arylen_p(pTHX_ AV *av) {
1060     MAGIC *const mg = get_aux_mg(av);
1061
1062     PERL_ARGS_ASSERT_AV_ARYLEN_P;
1063     assert(SvTYPE(av) == SVt_PVAV);
1064
1065     return &(mg->mg_obj);
1066 }
1067
1068 IV *
1069 Perl_av_iter_p(pTHX_ AV *av) {
1070     MAGIC *const mg = get_aux_mg(av);
1071
1072     PERL_ARGS_ASSERT_AV_ITER_P;
1073     assert(SvTYPE(av) == SVt_PVAV);
1074
1075     if (sizeof(IV) == sizeof(SSize_t)) {
1076         return (IV *)&(mg->mg_len);
1077     } else {
1078         if (!mg->mg_ptr) {
1079             IV *temp;
1080             mg->mg_len = IVSIZE;
1081             Newxz(temp, 1, IV);
1082             mg->mg_ptr = (char *) temp;
1083         }
1084         return (IV *)mg->mg_ptr;
1085     }
1086 }
1087
1088 SV *
1089 Perl_av_nonelem(pTHX_ AV *av, SSize_t ix) {
1090     SV * const sv = newSV(0);
1091     PERL_ARGS_ASSERT_AV_NONELEM;
1092     if (!av_store(av,ix,sv))
1093         return sv_2mortal(sv); /* has tie magic */
1094     sv_magic(sv, NULL, PERL_MAGIC_nonelem, NULL, 0);
1095     return sv;
1096 }
1097
1098 /*
1099  * ex: set ts=8 sts=4 sw=4 et:
1100  */