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_new_alloc
 398
 399 Creates a new AV and allocates its SV* array.
 400
 401 This is similar to but more efficient than doing:
 402
 403     AV *av = newAV();
 404     av_extend(av, key);
 405
 406 The size parameter is used to pre-allocate a SV* array large enough to
 407 hold at least elements 0..(size-1). size must be at least 1.
 408
 409 The zeroflag parameter controls whether the array is NULL initialized.
 410
 411 =cut
 412 */
 413
 414 AV *
 415 Perl_av_new_alloc(pTHX_ SSize_t size, bool zeroflag)
 416 {
 417     AV * const av = newAV();
 418     SV** ary;
 419     PERL_ARGS_ASSERT_AV_NEW_ALLOC;
 420     assert(size > 0);
 421
 422     Newx(ary, size, SV*); /* Newx performs the memwrap check */
 423     AvALLOC(av) = ary;
 424     AvARRAY(av) = ary;
 425     AvMAX(av) = size - 1;
 426
 427     if (zeroflag)
 428         Zero(ary, size, SV*);
 429
 430     return av;
 431 }
 432
 433 /*
 434 =for apidoc av_make
 435
 436 Creates a new AV and populates it with a list of SVs.  The SVs are copied
 437 into the array, so they may be freed after the call to C<av_make>.  The new AV
 438 will have a reference count of 1.
 439
 440 Perl equivalent: C<my @new_array = ($scalar1, $scalar2, $scalar3...);>
 441
 442 =cut
 443 */
 444
 445 AV *
 446 Perl_av_make(pTHX_ SSize_t size, SV **strp)
 447 {
 448     AV * const av = newAV();
 449     /* sv_upgrade does AvREAL_only()  */
 450     PERL_ARGS_ASSERT_AV_MAKE;
 451     assert(SvTYPE(av) == SVt_PVAV);
 452
 453     if (size) {         /* "defined" was returning undef for size==0 anyway. */
 454         SV** ary;
 455         SSize_t i;
 456         SSize_t orig_ix;
 457
 458         Newx(ary,size,SV*);
 459         AvALLOC(av) = ary;
 460         AvARRAY(av) = ary;
 461         AvMAX(av) = size - 1;
 462         /* avoid av being leaked if croak when calling magic below */
 463         EXTEND_MORTAL(1);
 464         PL_tmps_stack[++PL_tmps_ix] = (SV*)av;
 465         orig_ix = PL_tmps_ix;
 466
 467         for (i = 0; i < size; i++) {
 468             assert (*strp);
 469
 470             /* Don't let sv_setsv swipe, since our source array might
 471                have multiple references to the same temp scalar (e.g.
 472                from a list slice) */
 473
 474             SvGETMAGIC(*strp); /* before newSV, in case it dies */
 475             AvFILLp(av)++;
 476             ary[i] = newSV(0);
 477             sv_setsv_flags(ary[i], *strp,
 478                            SV_DO_COW_SVSETSV|SV_NOSTEAL);
 479             strp++;
 480         }
 481         /* disarm av's leak guard */
 482         if (LIKELY(PL_tmps_ix == orig_ix))
 483             PL_tmps_ix--;
 484         else
 485             PL_tmps_stack[orig_ix] = &PL_sv_undef;
 486     }
 487     return av;
 488 }
 489
 490 /*
 491 =for apidoc av_clear
 492
 493 Frees all the elements of an array, leaving it empty.
 494 The XS equivalent of C<@array = ()>.  See also L</av_undef>.
 495
 496 Note that it is possible that the actions of a destructor called directly
 497 or indirectly by freeing an element of the array could cause the reference
 498 count of the array itself to be reduced (e.g. by deleting an entry in the
 499 symbol table). So it is a possibility that the AV could have been freed
 500 (or even reallocated) on return from the call unless you hold a reference
 501 to it.
 502
 503 =cut
 504 */
 505
 506 void
 507 Perl_av_clear(pTHX_ AV *av)
 508 {
 509     SSize_t extra;
 510     bool real;
 511     SSize_t orig_ix = 0;
 512
 513     PERL_ARGS_ASSERT_AV_CLEAR;
 514     assert(SvTYPE(av) == SVt_PVAV);
 515
 516 #ifdef DEBUGGING
 517     if (SvREFCNT(av) == 0) {
 518         Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "Attempt to clear deleted array");
 519     }
 520 #endif
 521
 522     if (SvREADONLY(av))
 523         Perl_croak_no_modify();
 524
 525     /* Give any tie a chance to cleanup first */
 526     if (SvRMAGICAL(av)) {
 527         const MAGIC* const mg = SvMAGIC(av);
 528         if (PL_delaymagic && mg && mg->mg_type == PERL_MAGIC_isa)
 529             PL_delaymagic |= DM_ARRAY_ISA;
 530         else
 531             mg_clear(MUTABLE_SV(av));
 532     }
 533
 534     if (AvMAX(av) < 0)
 535         return;
 536
 537     if ((real = cBOOL(AvREAL(av)))) {
 538         SV** const ary = AvARRAY(av);
 539         SSize_t index = AvFILLp(av) + 1;
 540
 541         /* avoid av being freed when calling destructors below */
 542         EXTEND_MORTAL(1);
 543         PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(av);
 544         orig_ix = PL_tmps_ix;
 545
 546         while (index) {
 547             SV * const sv = ary[--index];
 548             /* undef the slot before freeing the value, because a
 549              * destructor might try to modify this array */
 550             ary[index] = NULL;
 551             SvREFCNT_dec(sv);
 552         }
 553     }
 554     extra = AvARRAY(av) - AvALLOC(av);
 555     if (extra) {
 556         AvMAX(av) += extra;
 557         AvARRAY(av) = AvALLOC(av);
 558     }
 559     AvFILLp(av) = -1;
 560     if (real) {
 561         /* disarm av's premature free guard */
 562         if (LIKELY(PL_tmps_ix == orig_ix))
 563             PL_tmps_ix--;
 564         else
 565             PL_tmps_stack[orig_ix] = &PL_sv_undef;
 566         SvREFCNT_dec_NN(av);
 567     }
 568 }
 569
 570 /*
 571 =for apidoc av_undef
 572
 573 Undefines the array. The XS equivalent of C<undef(@array)>.
 574
 575 As well as freeing all the elements of the array (like C<av_clear()>), this
 576 also frees the memory used by the av to store its list of scalars.
 577
 578 See L</av_clear> for a note about the array possibly being invalid on
 579 return.
 580
 581 =cut
 582 */
 583
 584 void
 585 Perl_av_undef(pTHX_ AV *av)
 586 {
 587     bool real;
 588     SSize_t orig_ix = PL_tmps_ix; /* silence bogus warning about possible unitialized use */
 589
 590     PERL_ARGS_ASSERT_AV_UNDEF;
 591     assert(SvTYPE(av) == SVt_PVAV);
 592
 593     /* Give any tie a chance to cleanup first */
 594     if (SvTIED_mg((const SV *)av, PERL_MAGIC_tied))
 595         av_fill(av, -1);
 596
 597     real = cBOOL(AvREAL(av));
 598     if (real) {
 599         SSize_t key = AvFILLp(av) + 1;
 600
 601         /* avoid av being freed when calling destructors below */
 602         EXTEND_MORTAL(1);
 603         PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(av);
 604         orig_ix = PL_tmps_ix;
 605
 606         while (key)
 607             SvREFCNT_dec(AvARRAY(av)[--key]);
 608     }
 609
 610     Safefree(AvALLOC(av));
 611     AvALLOC(av) = NULL;
 612     AvARRAY(av) = NULL;
 613     AvMAX(av) = AvFILLp(av) = -1;
 614
 615     if(SvRMAGICAL(av)) mg_clear(MUTABLE_SV(av));
 616     if (real) {
 617         /* disarm av's premature free guard */
 618         if (LIKELY(PL_tmps_ix == orig_ix))
 619             PL_tmps_ix--;
 620         else
 621             PL_tmps_stack[orig_ix] = &PL_sv_undef;
 622         SvREFCNT_dec_NN(av);
 623     }
 624 }
 625
 626 /*
 627
 628 =for apidoc av_create_and_push
 629
 630 Push an SV onto the end of the array, creating the array if necessary.
 631 A small internal helper function to remove a commonly duplicated idiom.
 632
 633 =cut
 634 */
 635
 636 void
 637 Perl_av_create_and_push(pTHX_ AV **const avp, SV *const val)
 638 {
 639     PERL_ARGS_ASSERT_AV_CREATE_AND_PUSH;
 640
 641     if (!*avp)
 642         *avp = newAV();
 643     av_push(*avp, val);
 644 }
 645
 646 /*
 647 =for apidoc av_push
 648
 649 Pushes an SV (transferring control of one reference count) onto the end of the
 650 array.  The array will grow automatically to accommodate the addition.
 651
 652 Perl equivalent: C<push @myarray, $val;>.
 653
 654 =cut
 655 */
 656
 657 void
 658 Perl_av_push(pTHX_ AV *av, SV *val)
 659 {
 660     MAGIC *mg;
 661
 662     PERL_ARGS_ASSERT_AV_PUSH;
 663     assert(SvTYPE(av) == SVt_PVAV);
 664
 665     if (SvREADONLY(av))
 666         Perl_croak_no_modify();
 667
 668     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
 669         Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(PUSH), G_DISCARD, 1,
 670                             val);
 671         return;
 672     }
 673     av_store(av,AvFILLp(av)+1,val);
 674 }
 675
 676 /*
 677 =for apidoc av_pop
 678
 679 Removes one SV from the end of the array, reducing its size by one and
 680 returning the SV (transferring control of one reference count) to the
 681 caller.  Returns C<&PL_sv_undef> if the array is empty.
 682
 683 Perl equivalent: C<pop(@myarray);>
 684
 685 =cut
 686 */
 687
 688 SV *
 689 Perl_av_pop(pTHX_ AV *av)
 690 {
 691     SV *retval;
 692     MAGIC* mg;
 693
 694     PERL_ARGS_ASSERT_AV_POP;
 695     assert(SvTYPE(av) == SVt_PVAV);
 696
 697     if (SvREADONLY(av))
 698         Perl_croak_no_modify();
 699     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
 700         retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(POP), 0, 0);
 701         if (retval)
 702             retval = newSVsv(retval);
 703         return retval;
 704     }
 705     if (AvFILL(av) < 0)
 706         return &PL_sv_undef;
 707     retval = AvARRAY(av)[AvFILLp(av)];
 708     AvARRAY(av)[AvFILLp(av)--] = NULL;
 709     if (SvSMAGICAL(av))
 710         mg_set(MUTABLE_SV(av));
 711     return retval ? retval : &PL_sv_undef;
 712 }
 713
 714 /*
 715
 716 =for apidoc av_create_and_unshift_one
 717
 718 Unshifts an SV onto the beginning of the array, creating the array if
 719 necessary.
 720 A small internal helper function to remove a commonly duplicated idiom.
 721
 722 =cut
 723 */
 724
 725 SV **
 726 Perl_av_create_and_unshift_one(pTHX_ AV **const avp, SV *const val)
 727 {
 728     PERL_ARGS_ASSERT_AV_CREATE_AND_UNSHIFT_ONE;
 729
 730     if (!*avp)
 731         *avp = newAV();
 732     av_unshift(*avp, 1);
 733     return av_store(*avp, 0, val);
 734 }
 735
 736 /*
 737 =for apidoc av_unshift
 738
 739 Unshift the given number of C<undef> values onto the beginning of the
 740 array.  The array will grow automatically to accommodate the addition.
 741
 742 Perl equivalent: S<C<unshift @myarray, ((undef) x $num);>>
 743
 744 =cut
 745 */
 746
 747 void
 748 Perl_av_unshift(pTHX_ AV *av, SSize_t num)
 749 {
 750     SSize_t i;
 751     MAGIC* mg;
 752
 753     PERL_ARGS_ASSERT_AV_UNSHIFT;
 754     assert(SvTYPE(av) == SVt_PVAV);
 755
 756     if (SvREADONLY(av))
 757         Perl_croak_no_modify();
 758
 759     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
 760         Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(UNSHIFT),
 761                             G_DISCARD | G_UNDEF_FILL, num);
 762         return;
 763     }
 764
 765     if (num <= 0)
 766       return;
 767     if (!AvREAL(av) && AvREIFY(av))
 768         av_reify(av);
 769     i = AvARRAY(av) - AvALLOC(av);
 770     if (i) {
 771         if (i > num)
 772             i = num;
 773         num -= i;
 774
 775         AvMAX(av) += i;
 776         AvFILLp(av) += i;
 777         AvARRAY(av) = AvARRAY(av) - i;
 778     }
 779     if (num) {
 780         SV **ary;
 781         const SSize_t i = AvFILLp(av);
 782         /* Create extra elements */
 783         const SSize_t slide = i > 0 ? i : 0;
 784         num += slide;
 785         av_extend(av, i + num);
 786         AvFILLp(av) += num;
 787         ary = AvARRAY(av);
 788         Move(ary, ary + num, i + 1, SV*);
 789         do {
 790             ary[--num] = NULL;
 791         } while (num);
 792         /* Make extra elements into a buffer */
 793         AvMAX(av) -= slide;
 794         AvFILLp(av) -= slide;
 795         AvARRAY(av) = AvARRAY(av) + slide;
 796     }
 797 }
 798
 799 /*
 800 =for apidoc av_shift
 801
 802 Removes one SV from the start of the array, reducing its size by one and
 803 returning the SV (transferring control of one reference count) to the
 804 caller.  Returns C<&PL_sv_undef> if the array is empty.
 805
 806 Perl equivalent: C<shift(@myarray);>
 807
 808 =cut
 809 */
 810
 811 SV *
 812 Perl_av_shift(pTHX_ AV *av)
 813 {
 814     SV *retval;
 815     MAGIC* mg;
 816
 817     PERL_ARGS_ASSERT_AV_SHIFT;
 818     assert(SvTYPE(av) == SVt_PVAV);
 819
 820     if (SvREADONLY(av))
 821         Perl_croak_no_modify();
 822     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
 823         retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(SHIFT), 0, 0);
 824         if (retval)
 825             retval = newSVsv(retval);
 826         return retval;
 827     }
 828     if (AvFILL(av) < 0)
 829       return &PL_sv_undef;
 830     retval = *AvARRAY(av);
 831     if (AvREAL(av))
 832         *AvARRAY(av) = NULL;
 833     AvARRAY(av) = AvARRAY(av) + 1;
 834     AvMAX(av)--;
 835     AvFILLp(av)--;
 836     if (SvSMAGICAL(av))
 837         mg_set(MUTABLE_SV(av));
 838     return retval ? retval : &PL_sv_undef;
 839 }
 840
 841 /*
 842 =for apidoc av_tindex
 843 =for apidoc_item av_top_index
 844
 845 These behave identically.
 846 If the array C<av> is empty, these return -1; otherwise they return the maximum
 847 value of the indices of all the array elements which are currently defined in
 848 C<av>.
 849
 850 They process 'get' magic.
 851
 852 The Perl equivalent for these is C<$#av>.
 853
 854 Use C<L</av_count>> to get the number of elements in an array.
 855
 856 =for apidoc av_len
 857
 858 Same as L</av_top_index>.  Note that, unlike what the name implies, it returns
 859 the maximum index in the array.  This is unlike L</sv_len>, which returns what
 860 you would expect.
 861
 862 B<To get the true number of elements in the array, instead use C<L</av_count>>>.
 863
 864 =cut
 865 */
 866
 867 SSize_t
 868 Perl_av_len(pTHX_ AV *av)
 869 {
 870     PERL_ARGS_ASSERT_AV_LEN;
 871
 872     return av_top_index(av);
 873 }
 874
 875 /*
 876 =for apidoc av_fill
 877
 878 Set the highest index in the array to the given number, equivalent to
 879 Perl's S<C<$#array = $fill;>>.
 880
 881 The number of elements in the array will be S<C<fill + 1>> after
 882 C<av_fill()> returns.  If the array was previously shorter, then the
 883 additional elements appended are set to NULL.  If the array
 884 was longer, then the excess elements are freed.  S<C<av_fill(av, -1)>> is
 885 the same as C<av_clear(av)>.
 886
 887 =cut
 888 */
 889 void
 890 Perl_av_fill(pTHX_ AV *av, SSize_t fill)
 891 {
 892     MAGIC *mg;
 893
 894     PERL_ARGS_ASSERT_AV_FILL;
 895     assert(SvTYPE(av) == SVt_PVAV);
 896
 897     if (fill < 0)
 898         fill = -1;
 899     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
 900         SV *arg1 = sv_newmortal();
 901         sv_setiv(arg1, (IV)(fill + 1));
 902         Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(STORESIZE), G_DISCARD,
 903                             1, arg1);
 904         return;
 905     }
 906     if (fill <= AvMAX(av)) {
 907         SSize_t key = AvFILLp(av);
 908         SV** const ary = AvARRAY(av);
 909
 910         if (AvREAL(av)) {
 911             while (key > fill) {
 912                 SvREFCNT_dec(ary[key]);
 913                 ary[key--] = NULL;
 914             }
 915         }
 916         else {
 917             while (key < fill)
 918                 ary[++key] = NULL;
 919         }
 920
 921         AvFILLp(av) = fill;
 922         if (SvSMAGICAL(av))
 923             mg_set(MUTABLE_SV(av));
 924     }
 925     else
 926         (void)av_store(av,fill,NULL);
 927 }
 928
 929 /*
 930 =for apidoc av_delete
 931
 932 Deletes the element indexed by C<key> from the array, makes the element
 933 mortal, and returns it.  If C<flags> equals C<G_DISCARD>, the element is
 934 freed and NULL is returned. NULL is also returned if C<key> is out of
 935 range.
 936
 937 Perl equivalent: S<C<splice(@myarray, $key, 1, undef)>> (with the
 938 C<splice> in void context if C<G_DISCARD> is present).
 939
 940 =cut
 941 */
 942 SV *
 943 Perl_av_delete(pTHX_ AV *av, SSize_t key, I32 flags)
 944 {
 945     SV *sv;
 946
 947     PERL_ARGS_ASSERT_AV_DELETE;
 948     assert(SvTYPE(av) == SVt_PVAV);
 949
 950     if (SvREADONLY(av))
 951         Perl_croak_no_modify();
 952
 953     if (SvRMAGICAL(av)) {
 954         const MAGIC * const tied_magic
 955             = mg_find((const SV *)av, PERL_MAGIC_tied);
 956         if ((tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata))) {
 957             SV **svp;
 958             if (key < 0) {
 959                 if (!S_adjust_index(aTHX_ av, tied_magic, &key))
 960                         return NULL;
 961             }
 962             svp = av_fetch(av, key, TRUE);
 963             if (svp) {
 964                 sv = *svp;
 965                 mg_clear(sv);
 966                 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
 967                     sv_unmagic(sv, PERL_MAGIC_tiedelem); /* No longer an element */
 968                     return sv;
 969                 }
 970                 return NULL;
 971             }
 972         }
 973     }
 974
 975     if (key < 0) {
 976         key += AvFILL(av) + 1;
 977         if (key < 0)
 978             return NULL;
 979     }
 980
 981     if (key > AvFILLp(av))
 982         return NULL;
 983     else {
 984         if (!AvREAL(av) && AvREIFY(av))
 985             av_reify(av);
 986         sv = AvARRAY(av)[key];
 987         AvARRAY(av)[key] = NULL;
 988         if (key == AvFILLp(av)) {
 989             do {
 990                 AvFILLp(av)--;
 991             } while (--key >= 0 && !AvARRAY(av)[key]);
 992         }
 993         if (SvSMAGICAL(av))
 994             mg_set(MUTABLE_SV(av));
 995     }
 996     if(sv != NULL) {
 997         if (flags & G_DISCARD) {
 998             SvREFCNT_dec_NN(sv);
 999             return NULL;
1000         }
1001         else if (AvREAL(av))
1002             sv_2mortal(sv);
1003     }
1004     return sv;
1005 }
1006
1007 /*
1008 =for apidoc av_exists
1009
1010 Returns true if the element indexed by C<key> has been initialized.
1011
1012 This relies on the fact that uninitialized array elements are set to
1013 C<NULL>.
1014
1015 Perl equivalent: C<exists($myarray[$key])>.
1016
1017 =cut
1018 */
1019 bool
1020 Perl_av_exists(pTHX_ AV *av, SSize_t key)
1021 {
1022     PERL_ARGS_ASSERT_AV_EXISTS;
1023     assert(SvTYPE(av) == SVt_PVAV);
1024
1025     if (SvRMAGICAL(av)) {
1026         const MAGIC * const tied_magic
1027             = mg_find((const SV *)av, PERL_MAGIC_tied);
1028         const MAGIC * const regdata_magic
1029             = mg_find((const SV *)av, PERL_MAGIC_regdata);
1030         if (tied_magic || regdata_magic) {
1031             MAGIC *mg;
1032             /* Handle negative array indices 20020222 MJD */
1033             if (key < 0) {
1034                 if (!S_adjust_index(aTHX_ av, tied_magic, &key))
1035                         return FALSE;
1036             }
1037
1038             if(key >= 0 && regdata_magic) {
1039                 if (key <= AvFILL(av))
1040                     return TRUE;
1041                 else
1042                     return FALSE;
1043             }
1044             {
1045                 SV * const sv = sv_newmortal();
1046                 mg_copy(MUTABLE_SV(av), sv, 0, key);
1047                 mg = mg_find(sv, PERL_MAGIC_tiedelem);
1048                 if (mg) {
1049                     magic_existspack(sv, mg);
1050                     {
1051                         I32 retbool = SvTRUE_nomg_NN(sv);
1052                         return cBOOL(retbool);
1053                     }
1054                 }
1055             }
1056         }
1057     }
1058
1059     if (key < 0) {
1060         key += AvFILL(av) + 1;
1061         if (key < 0)
1062             return FALSE;
1063     }
1064
1065     if (key <= AvFILLp(av) && AvARRAY(av)[key])
1066     {
1067         if (SvSMAGICAL(AvARRAY(av)[key])
1068          && mg_find(AvARRAY(av)[key], PERL_MAGIC_nonelem))
1069             return FALSE;
1070         return TRUE;
1071     }
1072     else
1073         return FALSE;
1074 }
1075
1076 static MAGIC *
1077 S_get_aux_mg(pTHX_ AV *av) {
1078     MAGIC *mg;
1079
1080     PERL_ARGS_ASSERT_GET_AUX_MG;
1081     assert(SvTYPE(av) == SVt_PVAV);
1082
1083     mg = mg_find((const SV *)av, PERL_MAGIC_arylen_p);
1084
1085     if (!mg) {
1086         mg = sv_magicext(MUTABLE_SV(av), 0, PERL_MAGIC_arylen_p,
1087                          &PL_vtbl_arylen_p, 0, 0);
1088         assert(mg);
1089         /* sv_magicext won't set this for us because we pass in a NULL obj  */
1090         mg->mg_flags |= MGf_REFCOUNTED;
1091     }
1092     return mg;
1093 }
1094
1095 SV **
1096 Perl_av_arylen_p(pTHX_ AV *av) {
1097     MAGIC *const mg = get_aux_mg(av);
1098
1099     PERL_ARGS_ASSERT_AV_ARYLEN_P;
1100     assert(SvTYPE(av) == SVt_PVAV);
1101
1102     return &(mg->mg_obj);
1103 }
1104
1105 IV *
1106 Perl_av_iter_p(pTHX_ AV *av) {
1107     MAGIC *const mg = get_aux_mg(av);
1108
1109     PERL_ARGS_ASSERT_AV_ITER_P;
1110     assert(SvTYPE(av) == SVt_PVAV);
1111
1112     if (sizeof(IV) == sizeof(SSize_t)) {
1113         return (IV *)&(mg->mg_len);
1114     } else {
1115         if (!mg->mg_ptr) {
1116             IV *temp;
1117             mg->mg_len = IVSIZE;
1118             Newxz(temp, 1, IV);
1119             mg->mg_ptr = (char *) temp;
1120         }
1121         return (IV *)mg->mg_ptr;
1122     }
1123 }
1124
1125 SV *
1126 Perl_av_nonelem(pTHX_ AV *av, SSize_t ix) {
1127     SV * const sv = newSV(0);
1128     PERL_ARGS_ASSERT_AV_NONELEM;
1129     if (!av_store(av,ix,sv))
1130         return sv_2mortal(sv); /* has tie magic */
1131     sv_magic(sv, NULL, PERL_MAGIC_nonelem, NULL, 0);
1132     return sv;
1133 }
1134
1135 /*
1136  * ex: set ts=8 sts=4 sw=4 et:
1137  */