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     bool real;
 441
 442     PERL_ARGS_ASSERT_AV_CLEAR;
 443     assert(SvTYPE(av) == SVt_PVAV);
 444
 445 #ifdef DEBUGGING
 446     if (SvREFCNT(av) == 0) {
 447         Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "Attempt to clear deleted array");
 448     }
 449 #endif
 450
 451     if (SvREADONLY(av))
 452         Perl_croak_no_modify(aTHX);
 453
 454     /* Give any tie a chance to cleanup first */
 455     if (SvRMAGICAL(av)) {
 456         const MAGIC* const mg = SvMAGIC(av);
 457         if (PL_delaymagic && mg && mg->mg_type == PERL_MAGIC_isa)
 458             PL_delaymagic |= DM_ARRAY_ISA;
 459         else
 460             mg_clear(MUTABLE_SV(av));
 461     }
 462
 463     if (AvMAX(av) < 0)
 464         return;
 465
 466     if ((real = !!AvREAL(av))) {
 467         SV** const ary = AvARRAY(av);
 468         I32 index = AvFILLp(av) + 1;
 469         ENTER;
 470         SAVEFREESV(SvREFCNT_inc_simple_NN(av));
 471         while (index) {
 472             SV * const sv = ary[--index];
 473             /* undef the slot before freeing the value, because a
 474              * destructor might try to modify this array */
 475             ary[index] = &PL_sv_undef;
 476             SvREFCNT_dec(sv);
 477         }
 478     }
 479     extra = AvARRAY(av) - AvALLOC(av);
 480     if (extra) {
 481         AvMAX(av) += extra;
 482         AvARRAY(av) = AvALLOC(av);
 483     }
 484     AvFILLp(av) = -1;
 485     if (real) LEAVE;
 486 }
 487
 488 /*
 489 =for apidoc av_undef
 490
 491 Undefines the array.  Frees the memory used by the array itself.
 492
 493 =cut
 494 */
 495
 496 void
 497 Perl_av_undef(pTHX_ register AV *av)
 498 {
 499     bool real;
 500
 501     PERL_ARGS_ASSERT_AV_UNDEF;
 502     assert(SvTYPE(av) == SVt_PVAV);
 503
 504     /* Give any tie a chance to cleanup first */
 505     if (SvTIED_mg((const SV *)av, PERL_MAGIC_tied))
 506         av_fill(av, -1);
 507
 508     if ((real = !!AvREAL(av))) {
 509         register I32 key = AvFILLp(av) + 1;
 510         ENTER;
 511         SAVEFREESV(SvREFCNT_inc_simple_NN(av));
 512         while (key)
 513             SvREFCNT_dec(AvARRAY(av)[--key]);
 514     }
 515
 516     Safefree(AvALLOC(av));
 517     AvALLOC(av) = NULL;
 518     AvARRAY(av) = NULL;
 519     AvMAX(av) = AvFILLp(av) = -1;
 520
 521     if(SvRMAGICAL(av)) mg_clear(MUTABLE_SV(av));
 522     if(real) LEAVE;
 523 }
 524
 525 /*
 526
 527 =for apidoc av_create_and_push
 528
 529 Push an SV onto the end of the array, creating the array if necessary.
 530 A small internal helper function to remove a commonly duplicated idiom.
 531
 532 =cut
 533 */
 534
 535 void
 536 Perl_av_create_and_push(pTHX_ AV **const avp, SV *const val)
 537 {
 538     PERL_ARGS_ASSERT_AV_CREATE_AND_PUSH;
 539
 540     if (!*avp)
 541         *avp = newAV();
 542     av_push(*avp, val);
 543 }
 544
 545 /*
 546 =for apidoc av_push
 547
 548 Pushes an SV onto the end of the array.  The array will grow automatically
 549 to accommodate the addition.  This takes ownership of one reference count.
 550
 551 Perl equivalent: C<push @myarray, $elem;>.
 552
 553 =cut
 554 */
 555
 556 void
 557 Perl_av_push(pTHX_ register AV *av, SV *val)
 558 {
 559     dVAR;
 560     MAGIC *mg;
 561
 562     PERL_ARGS_ASSERT_AV_PUSH;
 563     assert(SvTYPE(av) == SVt_PVAV);
 564
 565     if (SvREADONLY(av))
 566         Perl_croak_no_modify(aTHX);
 567
 568     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
 569         Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "PUSH", G_DISCARD, 1,
 570                             val);
 571         return;
 572     }
 573     av_store(av,AvFILLp(av)+1,val);
 574 }
 575
 576 /*
 577 =for apidoc av_pop
 578
 579 Pops an SV off the end of the array.  Returns C<&PL_sv_undef> if the array
 580 is empty.
 581
 582 Perl equivalent: C<pop(@myarray);>
 583
 584 =cut
 585 */
 586
 587 SV *
 588 Perl_av_pop(pTHX_ register AV *av)
 589 {
 590     dVAR;
 591     SV *retval;
 592     MAGIC* mg;
 593
 594     PERL_ARGS_ASSERT_AV_POP;
 595     assert(SvTYPE(av) == SVt_PVAV);
 596
 597     if (SvREADONLY(av))
 598         Perl_croak_no_modify(aTHX);
 599     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
 600         retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "POP", 0, 0);
 601         if (retval)
 602             retval = newSVsv(retval);
 603         return retval;
 604     }
 605     if (AvFILL(av) < 0)
 606         return &PL_sv_undef;
 607     retval = AvARRAY(av)[AvFILLp(av)];
 608     AvARRAY(av)[AvFILLp(av)--] = &PL_sv_undef;
 609     if (SvSMAGICAL(av))
 610         mg_set(MUTABLE_SV(av));
 611     return retval;
 612 }
 613
 614 /*
 615
 616 =for apidoc av_create_and_unshift_one
 617
 618 Unshifts an SV onto the beginning of the array, creating the array if
 619 necessary.
 620 A small internal helper function to remove a commonly duplicated idiom.
 621
 622 =cut
 623 */
 624
 625 SV **
 626 Perl_av_create_and_unshift_one(pTHX_ AV **const avp, SV *const val)
 627 {
 628     PERL_ARGS_ASSERT_AV_CREATE_AND_UNSHIFT_ONE;
 629
 630     if (!*avp)
 631         *avp = newAV();
 632     av_unshift(*avp, 1);
 633     return av_store(*avp, 0, val);
 634 }
 635
 636 /*
 637 =for apidoc av_unshift
 638
 639 Unshift the given number of C<undef> values onto the beginning of the
 640 array.  The array will grow automatically to accommodate the addition.  You
 641 must then use C<av_store> to assign values to these new elements.
 642
 643 Perl equivalent: C<unshift @myarray, ( (undef) x $n );>
 644
 645 =cut
 646 */
 647
 648 void
 649 Perl_av_unshift(pTHX_ register AV *av, register I32 num)
 650 {
 651     dVAR;
 652     register I32 i;
 653     MAGIC* mg;
 654
 655     PERL_ARGS_ASSERT_AV_UNSHIFT;
 656     assert(SvTYPE(av) == SVt_PVAV);
 657
 658     if (SvREADONLY(av))
 659         Perl_croak_no_modify(aTHX);
 660
 661     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
 662         Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "UNSHIFT",
 663                             G_DISCARD | G_UNDEF_FILL, num);
 664         return;
 665     }
 666
 667     if (num <= 0)
 668       return;
 669     if (!AvREAL(av) && AvREIFY(av))
 670         av_reify(av);
 671     i = AvARRAY(av) - AvALLOC(av);
 672     if (i) {
 673         if (i > num)
 674             i = num;
 675         num -= i;
 676
 677         AvMAX(av) += i;
 678         AvFILLp(av) += i;
 679         AvARRAY(av) = AvARRAY(av) - i;
 680     }
 681     if (num) {
 682         register SV **ary;
 683         const I32 i = AvFILLp(av);
 684         /* Create extra elements */
 685         const I32 slide = i > 0 ? i : 0;
 686         num += slide;
 687         av_extend(av, i + num);
 688         AvFILLp(av) += num;
 689         ary = AvARRAY(av);
 690         Move(ary, ary + num, i + 1, SV*);
 691         do {
 692             ary[--num] = &PL_sv_undef;
 693         } while (num);
 694         /* Make extra elements into a buffer */
 695         AvMAX(av) -= slide;
 696         AvFILLp(av) -= slide;
 697         AvARRAY(av) = AvARRAY(av) + slide;
 698     }
 699 }
 700
 701 /*
 702 =for apidoc av_shift
 703
 704 Shifts an SV off the beginning of the
 705 array.  Returns C<&PL_sv_undef> if the
 706 array is empty.
 707
 708 Perl equivalent: C<shift(@myarray);>
 709
 710 =cut
 711 */
 712
 713 SV *
 714 Perl_av_shift(pTHX_ register AV *av)
 715 {
 716     dVAR;
 717     SV *retval;
 718     MAGIC* mg;
 719
 720     PERL_ARGS_ASSERT_AV_SHIFT;
 721     assert(SvTYPE(av) == SVt_PVAV);
 722
 723     if (SvREADONLY(av))
 724         Perl_croak_no_modify(aTHX);
 725     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
 726         retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "SHIFT", 0, 0);
 727         if (retval)
 728             retval = newSVsv(retval);
 729         return retval;
 730     }
 731     if (AvFILL(av) < 0)
 732       return &PL_sv_undef;
 733     retval = *AvARRAY(av);
 734     if (AvREAL(av))
 735         *AvARRAY(av) = &PL_sv_undef;
 736     AvARRAY(av) = AvARRAY(av) + 1;
 737     AvMAX(av)--;
 738     AvFILLp(av)--;
 739     if (SvSMAGICAL(av))
 740         mg_set(MUTABLE_SV(av));
 741     return retval;
 742 }
 743
 744 /*
 745 =for apidoc av_len
 746
 747 Returns the highest index in the array.  The number of elements in the
 748 array is C<av_len(av) + 1>.  Returns -1 if the array is empty.
 749
 750 The Perl equivalent for this is C<$#myarray>.
 751
 752 =cut
 753 */
 754
 755 I32
 756 Perl_av_len(pTHX_ AV *av)
 757 {
 758     PERL_ARGS_ASSERT_AV_LEN;
 759     assert(SvTYPE(av) == SVt_PVAV);
 760
 761     return AvFILL(av);
 762 }
 763
 764 /*
 765 =for apidoc av_fill
 766
 767 Set the highest index in the array to the given number, equivalent to
 768 Perl's C<$#array = $fill;>.
 769
 770 The number of elements in the an array will be C<fill + 1> after
 771 av_fill() returns.  If the array was previously shorter, then the
 772 additional elements appended are set to C<PL_sv_undef>.  If the array
 773 was longer, then the excess elements are freed.  C<av_fill(av, -1)> is
 774 the same as C<av_clear(av)>.
 775
 776 =cut
 777 */
 778 void
 779 Perl_av_fill(pTHX_ register AV *av, I32 fill)
 780 {
 781     dVAR;
 782     MAGIC *mg;
 783
 784     PERL_ARGS_ASSERT_AV_FILL;
 785     assert(SvTYPE(av) == SVt_PVAV);
 786
 787     if (fill < 0)
 788         fill = -1;
 789     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
 790         SV *arg1 = sv_newmortal();
 791         sv_setiv(arg1, (IV)(fill + 1));
 792         Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "STORESIZE", G_DISCARD,
 793                             1, arg1);
 794         return;
 795     }
 796     if (fill <= AvMAX(av)) {
 797         I32 key = AvFILLp(av);
 798         SV** const ary = AvARRAY(av);
 799
 800         if (AvREAL(av)) {
 801             while (key > fill) {
 802                 SvREFCNT_dec(ary[key]);
 803                 ary[key--] = &PL_sv_undef;
 804             }
 805         }
 806         else {
 807             while (key < fill)
 808                 ary[++key] = &PL_sv_undef;
 809         }
 810
 811         AvFILLp(av) = fill;
 812         if (SvSMAGICAL(av))
 813             mg_set(MUTABLE_SV(av));
 814     }
 815     else
 816         (void)av_store(av,fill,&PL_sv_undef);
 817 }
 818
 819 /*
 820 =for apidoc av_delete
 821
 822 Deletes the element indexed by C<key> from the array, makes the element mortal,
 823 and returns it.  If C<flags> equals C<G_DISCARD>, the element is freed and null
 824 is returned.  Perl equivalent: C<my $elem = delete($myarray[$idx]);> for the
 825 non-C<G_DISCARD> version and a void-context C<delete($myarray[$idx]);> for the
 826 C<G_DISCARD> version.
 827
 828 =cut
 829 */
 830 SV *
 831 Perl_av_delete(pTHX_ AV *av, I32 key, I32 flags)
 832 {
 833     dVAR;
 834     SV *sv;
 835
 836     PERL_ARGS_ASSERT_AV_DELETE;
 837     assert(SvTYPE(av) == SVt_PVAV);
 838
 839     if (SvREADONLY(av))
 840         Perl_croak_no_modify(aTHX);
 841
 842     if (SvRMAGICAL(av)) {
 843         const MAGIC * const tied_magic
 844             = mg_find((const SV *)av, PERL_MAGIC_tied);
 845         if ((tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata))) {
 846             /* Handle negative array indices 20020222 MJD */
 847             SV **svp;
 848             if (key < 0) {
 849                 unsigned adjust_index = 1;
 850                 if (tied_magic) {
 851                     SV * const * const negative_indices_glob =
 852                         hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av),
 853                                                          tied_magic))),
 854                                  NEGATIVE_INDICES_VAR, 16, 0);
 855                     if (negative_indices_glob
 856                         && SvTRUE(GvSV(*negative_indices_glob)))
 857                         adjust_index = 0;
 858                 }
 859                 if (adjust_index) {
 860                     key += AvFILL(av) + 1;
 861                     if (key < 0)
 862                         return NULL;
 863                 }
 864             }
 865             svp = av_fetch(av, key, TRUE);
 866             if (svp) {
 867                 sv = *svp;
 868                 mg_clear(sv);
 869                 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
 870                     sv_unmagic(sv, PERL_MAGIC_tiedelem); /* No longer an element */
 871                     return sv;
 872                 }
 873                 return NULL;
 874             }
 875         }
 876     }
 877
 878     if (key < 0) {
 879         key += AvFILL(av) + 1;
 880         if (key < 0)
 881             return NULL;
 882     }
 883
 884     if (key > AvFILLp(av))
 885         return NULL;
 886     else {
 887         if (!AvREAL(av) && AvREIFY(av))
 888             av_reify(av);
 889         sv = AvARRAY(av)[key];
 890         if (key == AvFILLp(av)) {
 891             AvARRAY(av)[key] = &PL_sv_undef;
 892             do {
 893                 AvFILLp(av)--;
 894             } while (--key >= 0 && AvARRAY(av)[key] == &PL_sv_undef);
 895         }
 896         else
 897             AvARRAY(av)[key] = &PL_sv_undef;
 898         if (SvSMAGICAL(av))
 899             mg_set(MUTABLE_SV(av));
 900     }
 901     if (flags & G_DISCARD) {
 902         SvREFCNT_dec(sv);
 903         sv = NULL;
 904     }
 905     else if (AvREAL(av))
 906         sv = sv_2mortal(sv);
 907     return sv;
 908 }
 909
 910 /*
 911 =for apidoc av_exists
 912
 913 Returns true if the element indexed by C<key> has been initialized.
 914
 915 This relies on the fact that uninitialized array elements are set to
 916 C<&PL_sv_undef>.
 917
 918 Perl equivalent: C<exists($myarray[$key])>.
 919
 920 =cut
 921 */
 922 bool
 923 Perl_av_exists(pTHX_ AV *av, I32 key)
 924 {
 925     dVAR;
 926     PERL_ARGS_ASSERT_AV_EXISTS;
 927     assert(SvTYPE(av) == SVt_PVAV);
 928
 929     if (SvRMAGICAL(av)) {
 930         const MAGIC * const tied_magic
 931             = mg_find((const SV *)av, PERL_MAGIC_tied);
 932         const MAGIC * const regdata_magic
 933             = mg_find((const SV *)av, PERL_MAGIC_regdata);
 934         if (tied_magic || regdata_magic) {
 935             SV * const sv = sv_newmortal();
 936             MAGIC *mg;
 937             /* Handle negative array indices 20020222 MJD */
 938             if (key < 0) {
 939                 unsigned adjust_index = 1;
 940                 if (tied_magic) {
 941                     SV * const * const negative_indices_glob =
 942                         hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av),
 943                                                          tied_magic))),
 944                                  NEGATIVE_INDICES_VAR, 16, 0);
 945                     if (negative_indices_glob
 946                         && SvTRUE(GvSV(*negative_indices_glob)))
 947                         adjust_index = 0;
 948                 }
 949                 if (adjust_index) {
 950                     key += AvFILL(av) + 1;
 951                     if (key < 0)
 952                         return FALSE;
 953                     else
 954                         return TRUE;
 955                 }
 956             }
 957
 958             if(key >= 0 && regdata_magic) {
 959                 if (key <= AvFILL(av))
 960                     return TRUE;
 961                 else
 962                     return FALSE;
 963             }
 964
 965             mg_copy(MUTABLE_SV(av), sv, 0, key);
 966             mg = mg_find(sv, PERL_MAGIC_tiedelem);
 967             if (mg) {
 968                 magic_existspack(sv, mg);
 969                 return cBOOL(SvTRUE(sv));
 970             }
 971
 972         }
 973     }
 974
 975     if (key < 0) {
 976         key += AvFILL(av) + 1;
 977         if (key < 0)
 978             return FALSE;
 979     }
 980
 981     if (key <= AvFILLp(av) && AvARRAY(av)[key] != &PL_sv_undef
 982         && AvARRAY(av)[key])
 983     {
 984         return TRUE;
 985     }
 986     else
 987         return FALSE;
 988 }
 989
 990 static MAGIC *
 991 S_get_aux_mg(pTHX_ AV *av) {
 992     dVAR;
 993     MAGIC *mg;
 994
 995     PERL_ARGS_ASSERT_GET_AUX_MG;
 996     assert(SvTYPE(av) == SVt_PVAV);
 997
 998     mg = mg_find((const SV *)av, PERL_MAGIC_arylen_p);
 999
1000     if (!mg) {
1001         mg = sv_magicext(MUTABLE_SV(av), 0, PERL_MAGIC_arylen_p,
1002                          &PL_vtbl_arylen_p, 0, 0);
1003         assert(mg);
1004         /* sv_magicext won't set this for us because we pass in a NULL obj  */
1005         mg->mg_flags |= MGf_REFCOUNTED;
1006     }
1007     return mg;
1008 }
1009
1010 SV **
1011 Perl_av_arylen_p(pTHX_ AV *av) {
1012     MAGIC *const mg = get_aux_mg(av);
1013
1014     PERL_ARGS_ASSERT_AV_ARYLEN_P;
1015     assert(SvTYPE(av) == SVt_PVAV);
1016
1017     return &(mg->mg_obj);
1018 }
1019
1020 IV *
1021 Perl_av_iter_p(pTHX_ AV *av) {
1022     MAGIC *const mg = get_aux_mg(av);
1023
1024     PERL_ARGS_ASSERT_AV_ITER_P;
1025     assert(SvTYPE(av) == SVt_PVAV);
1026
1027 #if IVSIZE == I32SIZE
1028     return (IV *)&(mg->mg_len);
1029 #else
1030     if (!mg->mg_ptr) {
1031         IV *temp;
1032         mg->mg_len = IVSIZE;
1033         Newxz(temp, 1, IV);
1034         mg->mg_ptr = (char *) temp;
1035     }
1036     return (IV *)mg->mg_ptr;
1037 #endif
1038 }
1039
1040 /*
1041  * Local variables:
1042  * c-indentation-style: bsd
1043  * c-basic-offset: 4
1044  * indent-tabs-mode: t
1045  * End:
1046  *
1047  * ex: set ts=8 sts=4 sw=4 noet:
1048  */