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