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