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