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) || AvARRAY(av)[key] == &PL_sv_undef) {
 253       emptyness:
 254         return lval ? av_store(av,key,newSV(0)) : NULL;
 255     }
 256
 257     if (AvREIFY(av)
 258              && (!AvARRAY(av)[key]      /* eg. @_ could have freed elts */
 259                  || SvIS_FREED(AvARRAY(av)[key]))) {
 260         AvARRAY(av)[key] = &PL_sv_undef;        /* 1/2 reify */
 261         goto emptyness;
 262     }
 263     return &AvARRAY(av)[key];
 264 }
 265
 266 /*
 267 =for apidoc av_store
 268
 269 Stores an SV in an array.  The array index is specified as C<key>.  The
 270 return value will be NULL if the operation failed or if the value did not
 271 need to be actually stored within the array (as in the case of tied
 272 arrays). Otherwise, it can be dereferenced
 273 to get the C<SV*> that was stored
 274 there (= C<val>)).
 275
 276 Note that the caller is responsible for suitably incrementing the reference
 277 count of C<val> before the call, and decrementing it if the function
 278 returned NULL.
 279
 280 Approximate Perl equivalent: C<$myarray[$key] = $val;>.
 281
 282 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
 283 more information on how to use this function on tied arrays.
 284
 285 =cut
 286 */
 287
 288 SV**
 289 Perl_av_store(pTHX_ register AV *av, I32 key, SV *val)
 290 {
 291     dVAR;
 292     SV** ary;
 293
 294     PERL_ARGS_ASSERT_AV_STORE;
 295     assert(SvTYPE(av) == SVt_PVAV);
 296
 297     /* S_regclass relies on being able to pass in a NULL sv
 298        (unicode_alternate may be NULL).
 299     */
 300
 301     if (!val)
 302         val = &PL_sv_undef;
 303
 304     if (SvRMAGICAL(av)) {
 305         const MAGIC * const tied_magic = mg_find((const SV *)av, PERL_MAGIC_tied);
 306         if (tied_magic) {
 307             /* Handle negative array indices 20020222 MJD */
 308             if (key < 0) {
 309                 bool adjust_index = 1;
 310                 SV * const * const negative_indices_glob =
 311                     hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av),
 312                                                      tied_magic))),
 313                              NEGATIVE_INDICES_VAR, 16, 0);
 314                 if (negative_indices_glob
 315                     && SvTRUE(GvSV(*negative_indices_glob)))
 316                     adjust_index = 0;
 317                 if (adjust_index) {
 318                     key += AvFILL(av) + 1;
 319                     if (key < 0)
 320                         return 0;
 321                 }
 322             }
 323             if (val != &PL_sv_undef) {
 324                 mg_copy(MUTABLE_SV(av), val, 0, key);
 325             }
 326             return NULL;
 327         }
 328     }
 329
 330
 331     if (key < 0) {
 332         key += AvFILL(av) + 1;
 333         if (key < 0)
 334             return NULL;
 335     }
 336
 337     if (SvREADONLY(av) && key >= AvFILL(av))
 338         Perl_croak_no_modify(aTHX);
 339
 340     if (!AvREAL(av) && AvREIFY(av))
 341         av_reify(av);
 342     if (key > AvMAX(av))
 343         av_extend(av,key);
 344     ary = AvARRAY(av);
 345     if (AvFILLp(av) < key) {
 346         if (!AvREAL(av)) {
 347             if (av == PL_curstack && key > PL_stack_sp - PL_stack_base)
 348                 PL_stack_sp = PL_stack_base + key;      /* XPUSH in disguise */
 349             do {
 350                 ary[++AvFILLp(av)] = &PL_sv_undef;
 351             } while (AvFILLp(av) < key);
 352         }
 353         AvFILLp(av) = key;
 354     }
 355     else if (AvREAL(av))
 356         SvREFCNT_dec(ary[key]);
 357     ary[key] = val;
 358     if (SvSMAGICAL(av)) {
 359         const MAGIC *mg = SvMAGIC(av);
 360         bool set = TRUE;
 361         for (; mg; mg = mg->mg_moremagic) {
 362           if (!isUPPER(mg->mg_type)) continue;
 363           if (val != &PL_sv_undef) {
 364             sv_magic(val, MUTABLE_SV(av), toLOWER(mg->mg_type), 0, key);
 365           }
 366           if (PL_delaymagic && mg->mg_type == PERL_MAGIC_isa) {
 367             PL_delaymagic |= DM_ARRAY_ISA;
 368             set = FALSE;
 369           }
 370         }
 371         if (set)
 372            mg_set(MUTABLE_SV(av));
 373     }
 374     return &ary[key];
 375 }
 376
 377 /*
 378 =for apidoc av_make
 379
 380 Creates a new AV and populates it with a list of SVs.  The SVs are copied
 381 into the array, so they may be freed after the call to av_make.  The new AV
 382 will have a reference count of 1.
 383
 384 Perl equivalent: C<my @new_array = ($scalar1, $scalar2, $scalar3...);>
 385
 386 =cut
 387 */
 388
 389 AV *
 390 Perl_av_make(pTHX_ register I32 size, register SV **strp)
 391 {
 392     register AV * const av = MUTABLE_AV(newSV_type(SVt_PVAV));
 393     /* sv_upgrade does AvREAL_only()  */
 394     PERL_ARGS_ASSERT_AV_MAKE;
 395     assert(SvTYPE(av) == SVt_PVAV);
 396
 397     if (size) {         /* "defined" was returning undef for size==0 anyway. */
 398         register SV** ary;
 399         register I32 i;
 400         Newx(ary,size,SV*);
 401         AvALLOC(av) = ary;
 402         AvARRAY(av) = ary;
 403         AvFILLp(av) = AvMAX(av) = size - 1;
 404         for (i = 0; i < size; i++) {
 405             assert (*strp);
 406
 407             /* Don't let sv_setsv swipe, since our source array might
 408                have multiple references to the same temp scalar (e.g.
 409                from a list slice) */
 410
 411             ary[i] = newSV(0);
 412             sv_setsv_flags(ary[i], *strp,
 413                            SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
 414             strp++;
 415         }
 416     }
 417     return av;
 418 }
 419
 420 /*
 421 =for apidoc av_clear
 422
 423 Clears an array, making it empty.  Does not free the memory the av uses to
 424 store its list of scalars.  If any destructors are triggered as a result,
 425 the av itself may be freed when this function returns.
 426
 427 Perl equivalent: C<@myarray = ();>.
 428
 429 =cut
 430 */
 431
 432 void
 433 Perl_av_clear(pTHX_ register AV *av)
 434 {
 435     dVAR;
 436     I32 extra;
 437     bool real;
 438
 439     PERL_ARGS_ASSERT_AV_CLEAR;
 440     assert(SvTYPE(av) == SVt_PVAV);
 441
 442 #ifdef DEBUGGING
 443     if (SvREFCNT(av) == 0) {
 444         Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "Attempt to clear deleted array");
 445     }
 446 #endif
 447
 448     if (SvREADONLY(av))
 449         Perl_croak_no_modify(aTHX);
 450
 451     /* Give any tie a chance to cleanup first */
 452     if (SvRMAGICAL(av)) {
 453         const MAGIC* const mg = SvMAGIC(av);
 454         if (PL_delaymagic && mg && mg->mg_type == PERL_MAGIC_isa)
 455             PL_delaymagic |= DM_ARRAY_ISA;
 456         else
 457             mg_clear(MUTABLE_SV(av));
 458     }
 459
 460     if (AvMAX(av) < 0)
 461         return;
 462
 463     if ((real = !!AvREAL(av))) {
 464         SV** const ary = AvARRAY(av);
 465         I32 index = AvFILLp(av) + 1;
 466         ENTER;
 467         SAVEFREESV(SvREFCNT_inc_simple_NN(av));
 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     if (real) LEAVE;
 483 }
 484
 485 /*
 486 =for apidoc av_undef
 487
 488 Undefines the array.  Frees the memory used by the av to store its list of
 489 scalars.  If any destructors are triggered as a result, the av itself may
 490 be freed.
 491
 492 =cut
 493 */
 494
 495 void
 496 Perl_av_undef(pTHX_ register AV *av)
 497 {
 498     bool real;
 499
 500     PERL_ARGS_ASSERT_AV_UNDEF;
 501     assert(SvTYPE(av) == SVt_PVAV);
 502
 503     /* Give any tie a chance to cleanup first */
 504     if (SvTIED_mg((const SV *)av, PERL_MAGIC_tied))
 505         av_fill(av, -1);
 506
 507     if ((real = !!AvREAL(av))) {
 508         register I32 key = AvFILLp(av) + 1;
 509         ENTER;
 510         SAVEFREESV(SvREFCNT_inc_simple_NN(av));
 511         while (key)
 512             SvREFCNT_dec(AvARRAY(av)[--key]);
 513     }
 514
 515     Safefree(AvALLOC(av));
 516     AvALLOC(av) = NULL;
 517     AvARRAY(av) = NULL;
 518     AvMAX(av) = AvFILLp(av) = -1;
 519
 520     if(SvRMAGICAL(av)) mg_clear(MUTABLE_SV(av));
 521     if(real) LEAVE;
 522 }
 523
 524 /*
 525
 526 =for apidoc av_create_and_push
 527
 528 Push an SV onto the end of the array, creating the array if necessary.
 529 A small internal helper function to remove a commonly duplicated idiom.
 530
 531 =cut
 532 */
 533
 534 void
 535 Perl_av_create_and_push(pTHX_ AV **const avp, SV *const val)
 536 {
 537     PERL_ARGS_ASSERT_AV_CREATE_AND_PUSH;
 538
 539     if (!*avp)
 540         *avp = newAV();
 541     av_push(*avp, val);
 542 }
 543
 544 /*
 545 =for apidoc av_push
 546
 547 Pushes an SV onto the end of the array.  The array will grow automatically
 548 to accommodate the addition.  This takes ownership of one reference count.
 549
 550 Perl equivalent: C<push @myarray, $elem;>.
 551
 552 =cut
 553 */
 554
 555 void
 556 Perl_av_push(pTHX_ register AV *av, SV *val)
 557 {
 558     dVAR;
 559     MAGIC *mg;
 560
 561     PERL_ARGS_ASSERT_AV_PUSH;
 562     assert(SvTYPE(av) == SVt_PVAV);
 563
 564     if (SvREADONLY(av))
 565         Perl_croak_no_modify(aTHX);
 566
 567     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
 568         Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "PUSH", G_DISCARD, 1,
 569                             val);
 570         return;
 571     }
 572     av_store(av,AvFILLp(av)+1,val);
 573 }
 574
 575 /*
 576 =for apidoc av_pop
 577
 578 Pops an SV off the end of the array.  Returns C<&PL_sv_undef> if the array
 579 is empty.
 580
 581 Perl equivalent: C<pop(@myarray);>
 582
 583 =cut
 584 */
 585
 586 SV *
 587 Perl_av_pop(pTHX_ register AV *av)
 588 {
 589     dVAR;
 590     SV *retval;
 591     MAGIC* mg;
 592
 593     PERL_ARGS_ASSERT_AV_POP;
 594     assert(SvTYPE(av) == SVt_PVAV);
 595
 596     if (SvREADONLY(av))
 597         Perl_croak_no_modify(aTHX);
 598     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
 599         retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "POP", 0, 0);
 600         if (retval)
 601             retval = newSVsv(retval);
 602         return retval;
 603     }
 604     if (AvFILL(av) < 0)
 605         return &PL_sv_undef;
 606     retval = AvARRAY(av)[AvFILLp(av)];
 607     AvARRAY(av)[AvFILLp(av)--] = &PL_sv_undef;
 608     if (SvSMAGICAL(av))
 609         mg_set(MUTABLE_SV(av));
 610     return retval;
 611 }
 612
 613 /*
 614
 615 =for apidoc av_create_and_unshift_one
 616
 617 Unshifts an SV onto the beginning of the array, creating the array if
 618 necessary.
 619 A small internal helper function to remove a commonly duplicated idiom.
 620
 621 =cut
 622 */
 623
 624 SV **
 625 Perl_av_create_and_unshift_one(pTHX_ AV **const avp, SV *const val)
 626 {
 627     PERL_ARGS_ASSERT_AV_CREATE_AND_UNSHIFT_ONE;
 628
 629     if (!*avp)
 630         *avp = newAV();
 631     av_unshift(*avp, 1);
 632     return av_store(*avp, 0, val);
 633 }
 634
 635 /*
 636 =for apidoc av_unshift
 637
 638 Unshift the given number of C<undef> values onto the beginning of the
 639 array.  The array will grow automatically to accommodate the addition.  You
 640 must then use C<av_store> to assign values to these new elements.
 641
 642 Perl equivalent: C<unshift @myarray, ( (undef) x $n );>
 643
 644 =cut
 645 */
 646
 647 void
 648 Perl_av_unshift(pTHX_ register AV *av, register I32 num)
 649 {
 650     dVAR;
 651     register I32 i;
 652     MAGIC* mg;
 653
 654     PERL_ARGS_ASSERT_AV_UNSHIFT;
 655     assert(SvTYPE(av) == SVt_PVAV);
 656
 657     if (SvREADONLY(av))
 658         Perl_croak_no_modify(aTHX);
 659
 660     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
 661         Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "UNSHIFT",
 662                             G_DISCARD | G_UNDEF_FILL, num);
 663         return;
 664     }
 665
 666     if (num <= 0)
 667       return;
 668     if (!AvREAL(av) && AvREIFY(av))
 669         av_reify(av);
 670     i = AvARRAY(av) - AvALLOC(av);
 671     if (i) {
 672         if (i > num)
 673             i = num;
 674         num -= i;
 675
 676         AvMAX(av) += i;
 677         AvFILLp(av) += i;
 678         AvARRAY(av) = AvARRAY(av) - i;
 679     }
 680     if (num) {
 681         register SV **ary;
 682         const I32 i = AvFILLp(av);
 683         /* Create extra elements */
 684         const I32 slide = i > 0 ? i : 0;
 685         num += slide;
 686         av_extend(av, i + num);
 687         AvFILLp(av) += num;
 688         ary = AvARRAY(av);
 689         Move(ary, ary + num, i + 1, SV*);
 690         do {
 691             ary[--num] = &PL_sv_undef;
 692         } while (num);
 693         /* Make extra elements into a buffer */
 694         AvMAX(av) -= slide;
 695         AvFILLp(av) -= slide;
 696         AvARRAY(av) = AvARRAY(av) + slide;
 697     }
 698 }
 699
 700 /*
 701 =for apidoc av_shift
 702
 703 Shifts an SV off the beginning of the
 704 array.  Returns C<&PL_sv_undef> if the
 705 array is empty.
 706
 707 Perl equivalent: C<shift(@myarray);>
 708
 709 =cut
 710 */
 711
 712 SV *
 713 Perl_av_shift(pTHX_ register AV *av)
 714 {
 715     dVAR;
 716     SV *retval;
 717     MAGIC* mg;
 718
 719     PERL_ARGS_ASSERT_AV_SHIFT;
 720     assert(SvTYPE(av) == SVt_PVAV);
 721
 722     if (SvREADONLY(av))
 723         Perl_croak_no_modify(aTHX);
 724     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
 725         retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "SHIFT", 0, 0);
 726         if (retval)
 727             retval = newSVsv(retval);
 728         return retval;
 729     }
 730     if (AvFILL(av) < 0)
 731       return &PL_sv_undef;
 732     retval = *AvARRAY(av);
 733     if (AvREAL(av))
 734         *AvARRAY(av) = &PL_sv_undef;
 735     AvARRAY(av) = AvARRAY(av) + 1;
 736     AvMAX(av)--;
 737     AvFILLp(av)--;
 738     if (SvSMAGICAL(av))
 739         mg_set(MUTABLE_SV(av));
 740     return retval;
 741 }
 742
 743 /*
 744 =for apidoc av_len
 745
 746 Returns the highest index in the array.  The number of elements in the
 747 array is C<av_len(av) + 1>.  Returns -1 if the array is empty.
 748
 749 The Perl equivalent for this is C<$#myarray>.
 750
 751 =cut
 752 */
 753
 754 I32
 755 Perl_av_len(pTHX_ AV *av)
 756 {
 757     PERL_ARGS_ASSERT_AV_LEN;
 758     assert(SvTYPE(av) == SVt_PVAV);
 759
 760     return AvFILL(av);
 761 }
 762
 763 /*
 764 =for apidoc av_fill
 765
 766 Set the highest index in the array to the given number, equivalent to
 767 Perl's C<$#array = $fill;>.
 768
 769 The number of elements in the an array will be C<fill + 1> after
 770 av_fill() returns.  If the array was previously shorter, then the
 771 additional elements appended are set to C<PL_sv_undef>.  If the array
 772 was longer, then the excess elements are freed.  C<av_fill(av, -1)> is
 773 the same as C<av_clear(av)>.
 774
 775 =cut
 776 */
 777 void
 778 Perl_av_fill(pTHX_ register AV *av, I32 fill)
 779 {
 780     dVAR;
 781     MAGIC *mg;
 782
 783     PERL_ARGS_ASSERT_AV_FILL;
 784     assert(SvTYPE(av) == SVt_PVAV);
 785
 786     if (fill < 0)
 787         fill = -1;
 788     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
 789         SV *arg1 = sv_newmortal();
 790         sv_setiv(arg1, (IV)(fill + 1));
 791         Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "STORESIZE", G_DISCARD,
 792                             1, arg1);
 793         return;
 794     }
 795     if (fill <= AvMAX(av)) {
 796         I32 key = AvFILLp(av);
 797         SV** const ary = AvARRAY(av);
 798
 799         if (AvREAL(av)) {
 800             while (key > fill) {
 801                 SvREFCNT_dec(ary[key]);
 802                 ary[key--] = &PL_sv_undef;
 803             }
 804         }
 805         else {
 806             while (key < fill)
 807                 ary[++key] = &PL_sv_undef;
 808         }
 809
 810         AvFILLp(av) = fill;
 811         if (SvSMAGICAL(av))
 812             mg_set(MUTABLE_SV(av));
 813     }
 814     else
 815         (void)av_store(av,fill,&PL_sv_undef);
 816 }
 817
 818 /*
 819 =for apidoc av_delete
 820
 821 Deletes the element indexed by C<key> from the array, makes the element mortal,
 822 and returns it.  If C<flags> equals C<G_DISCARD>, the element is freed and null
 823 is returned.  Perl equivalent: C<my $elem = delete($myarray[$idx]);> for the
 824 non-C<G_DISCARD> version and a void-context C<delete($myarray[$idx]);> for the
 825 C<G_DISCARD> version.
 826
 827 =cut
 828 */
 829 SV *
 830 Perl_av_delete(pTHX_ AV *av, I32 key, I32 flags)
 831 {
 832     dVAR;
 833     SV *sv;
 834
 835     PERL_ARGS_ASSERT_AV_DELETE;
 836     assert(SvTYPE(av) == SVt_PVAV);
 837
 838     if (SvREADONLY(av))
 839         Perl_croak_no_modify(aTHX);
 840
 841     if (SvRMAGICAL(av)) {
 842         const MAGIC * const tied_magic
 843             = mg_find((const SV *)av, PERL_MAGIC_tied);
 844         if ((tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata))) {
 845             /* Handle negative array indices 20020222 MJD */
 846             SV **svp;
 847             if (key < 0) {
 848                 unsigned adjust_index = 1;
 849                 if (tied_magic) {
 850                     SV * const * const negative_indices_glob =
 851                         hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av),
 852                                                          tied_magic))),
 853                                  NEGATIVE_INDICES_VAR, 16, 0);
 854                     if (negative_indices_glob
 855                         && SvTRUE(GvSV(*negative_indices_glob)))
 856                         adjust_index = 0;
 857                 }
 858                 if (adjust_index) {
 859                     key += AvFILL(av) + 1;
 860                     if (key < 0)
 861                         return NULL;
 862                 }
 863             }
 864             svp = av_fetch(av, key, TRUE);
 865             if (svp) {
 866                 sv = *svp;
 867                 mg_clear(sv);
 868                 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
 869                     sv_unmagic(sv, PERL_MAGIC_tiedelem); /* No longer an element */
 870                     return sv;
 871                 }
 872                 return NULL;
 873             }
 874         }
 875     }
 876
 877     if (key < 0) {
 878         key += AvFILL(av) + 1;
 879         if (key < 0)
 880             return NULL;
 881     }
 882
 883     if (key > AvFILLp(av))
 884         return NULL;
 885     else {
 886         if (!AvREAL(av) && AvREIFY(av))
 887             av_reify(av);
 888         sv = AvARRAY(av)[key];
 889         if (key == AvFILLp(av)) {
 890             AvARRAY(av)[key] = &PL_sv_undef;
 891             do {
 892                 AvFILLp(av)--;
 893             } while (--key >= 0 && AvARRAY(av)[key] == &PL_sv_undef);
 894         }
 895         else
 896             AvARRAY(av)[key] = &PL_sv_undef;
 897         if (SvSMAGICAL(av))
 898             mg_set(MUTABLE_SV(av));
 899     }
 900     if (flags & G_DISCARD) {
 901         SvREFCNT_dec(sv);
 902         sv = NULL;
 903     }
 904     else if (AvREAL(av))
 905         sv = sv_2mortal(sv);
 906     return sv;
 907 }
 908
 909 /*
 910 =for apidoc av_exists
 911
 912 Returns true if the element indexed by C<key> has been initialized.
 913
 914 This relies on the fact that uninitialized array elements are set to
 915 C<&PL_sv_undef>.
 916
 917 Perl equivalent: C<exists($myarray[$key])>.
 918
 919 =cut
 920 */
 921 bool
 922 Perl_av_exists(pTHX_ AV *av, I32 key)
 923 {
 924     dVAR;
 925     PERL_ARGS_ASSERT_AV_EXISTS;
 926     assert(SvTYPE(av) == SVt_PVAV);
 927
 928     if (SvRMAGICAL(av)) {
 929         const MAGIC * const tied_magic
 930             = mg_find((const SV *)av, PERL_MAGIC_tied);
 931         const MAGIC * const regdata_magic
 932             = mg_find((const SV *)av, PERL_MAGIC_regdata);
 933         if (tied_magic || regdata_magic) {
 934             SV * const sv = sv_newmortal();
 935             MAGIC *mg;
 936             /* Handle negative array indices 20020222 MJD */
 937             if (key < 0) {
 938                 unsigned adjust_index = 1;
 939                 if (tied_magic) {
 940                     SV * const * const negative_indices_glob =
 941                         hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av),
 942                                                          tied_magic))),
 943                                  NEGATIVE_INDICES_VAR, 16, 0);
 944                     if (negative_indices_glob
 945                         && SvTRUE(GvSV(*negative_indices_glob)))
 946                         adjust_index = 0;
 947                 }
 948                 if (adjust_index) {
 949                     key += AvFILL(av) + 1;
 950                     if (key < 0)
 951                         return FALSE;
 952                     else
 953                         return TRUE;
 954                 }
 955             }
 956
 957             if(key >= 0 && regdata_magic) {
 958                 if (key <= AvFILL(av))
 959                     return TRUE;
 960                 else
 961                     return FALSE;
 962             }
 963
 964             mg_copy(MUTABLE_SV(av), sv, 0, key);
 965             mg = mg_find(sv, PERL_MAGIC_tiedelem);
 966             if (mg) {
 967                 magic_existspack(sv, mg);
 968                 return cBOOL(SvTRUE_nomg(sv));
 969             }
 970
 971         }
 972     }
 973
 974     if (key < 0) {
 975         key += AvFILL(av) + 1;
 976         if (key < 0)
 977             return FALSE;
 978     }
 979
 980     if (key <= AvFILLp(av) && AvARRAY(av)[key] != &PL_sv_undef
 981         && AvARRAY(av)[key])
 982     {
 983         return TRUE;
 984     }
 985     else
 986         return FALSE;
 987 }
 988
 989 static MAGIC *
 990 S_get_aux_mg(pTHX_ AV *av) {
 991     dVAR;
 992     MAGIC *mg;
 993
 994     PERL_ARGS_ASSERT_GET_AUX_MG;
 995     assert(SvTYPE(av) == SVt_PVAV);
 996
 997     mg = mg_find((const SV *)av, PERL_MAGIC_arylen_p);
 998
 999     if (!mg) {
1000         mg = sv_magicext(MUTABLE_SV(av), 0, PERL_MAGIC_arylen_p,
1001                          &PL_vtbl_arylen_p, 0, 0);
1002         assert(mg);
1003         /* sv_magicext won't set this for us because we pass in a NULL obj  */
1004         mg->mg_flags |= MGf_REFCOUNTED;
1005     }
1006     return mg;
1007 }
1008
1009 SV **
1010 Perl_av_arylen_p(pTHX_ AV *av) {
1011     MAGIC *const mg = get_aux_mg(av);
1012
1013     PERL_ARGS_ASSERT_AV_ARYLEN_P;
1014     assert(SvTYPE(av) == SVt_PVAV);
1015
1016     return &(mg->mg_obj);
1017 }
1018
1019 IV *
1020 Perl_av_iter_p(pTHX_ AV *av) {
1021     MAGIC *const mg = get_aux_mg(av);
1022
1023     PERL_ARGS_ASSERT_AV_ITER_P;
1024     assert(SvTYPE(av) == SVt_PVAV);
1025
1026 #if IVSIZE == I32SIZE
1027     return (IV *)&(mg->mg_len);
1028 #else
1029     if (!mg->mg_ptr) {
1030         IV *temp;
1031         mg->mg_len = IVSIZE;
1032         Newxz(temp, 1, IV);
1033         mg->mg_ptr = (char *) temp;
1034     }
1035     return (IV *)mg->mg_ptr;
1036 #endif
1037 }
1038
1039 /*
1040  * Local variables:
1041  * c-indentation-style: bsd
1042  * c-basic-offset: 4
1043  * indent-tabs-mode: nil
1044  * End:
1045  *
1046  * ex: set ts=8 sts=4 sw=4 et:
1047  */