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