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