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