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