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     SSize_t 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] = NULL;
  44     while (key) {
  45         SV * const sv = AvARRAY(av)[--key];
  46         if (sv != &PL_sv_undef)
  47             SvREFCNT_inc_simple_void(sv);
  48     }
  49     key = AvARRAY(av) - AvALLOC(av);
  50     while (key)
  51         AvALLOC(av)[--key] = NULL;
  52     AvREIFY_off(av);
  53     AvREAL_on(av);
  54 }
  55
  56 /*
  57 =for apidoc av_extend
  58
  59 Pre-extend an array.  The C<key> is the index to which the array should be
  60 extended.
  61
  62 =cut
  63 */
  64
  65 void
  66 Perl_av_extend(pTHX_ AV *av, SSize_t key)
  67 {
  68     dVAR;
  69     MAGIC *mg;
  70
  71     PERL_ARGS_ASSERT_AV_EXTEND;
  72     assert(SvTYPE(av) == SVt_PVAV);
  73
  74     mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied);
  75     if (mg) {
  76         SV *arg1 = sv_newmortal();
  77         sv_setiv(arg1, (IV)(key + 1));
  78         Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(EXTEND), G_DISCARD, 1,
  79                             arg1);
  80         return;
  81     }
  82     av_extend_guts(av,key,&AvMAX(av),&AvALLOC(av),&AvARRAY(av));
  83 }
  84
  85 /* The guts of av_extend.  *Not* for general use! */
  86 void
  87 Perl_av_extend_guts(pTHX_ AV *av, SSize_t key, SSize_t *maxp, SV ***allocp,
  88                           SV ***arrayp)
  89 {
  90     dVAR;
  91
  92     PERL_ARGS_ASSERT_AV_EXTEND_GUTS;
  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                 newmax = key + *maxp / 5;
 138               resize:
 139                 {
 140 #ifdef PERL_MALLOC_WRAP /* Duplicated in pp_hot.c */
 141                     static const char oom_array_extend[] =
 142                         "Out of memory during array extend";
 143 #endif
 144                     MEM_WRAP_CHECK_1(newmax+1, SV*, oom_array_extend);
 145                 }
 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                 {
 161 #ifdef PERL_MALLOC_WRAP /* Duplicated in pp_hot.c */
 162                     static const char oom_array_extend[] =
 163                         "Out of memory during array extend";
 164 #endif
 165                     MEM_WRAP_CHECK_1(newmax+1, SV*, oom_array_extend);
 166                 }
 167                 Newx(*allocp, newmax+1, SV*);
 168                 ary = *allocp + 1;
 169                 tmp = newmax;
 170                 *allocp[0] = NULL;      /* For the stacks */
 171             }
 172             if (av && AvREAL(av)) {
 173                 while (tmp)
 174                     ary[--tmp] = NULL;
 175             }
 176
 177             *arrayp = *allocp;
 178             *maxp = newmax;
 179         }
 180     }
 181 }
 182
 183 /*
 184 =for apidoc av_fetch
 185
 186 Returns the SV at the specified index in the array.  The C<key> is the
 187 index.  If lval is true, you are guaranteed to get a real SV back (in case
 188 it wasn't real before), which you can then modify.  Check that the return
 189 value is non-null before dereferencing it to a C<SV*>.
 190
 191 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
 192 more information on how to use this function on tied arrays.
 193
 194 The rough perl equivalent is C<$myarray[$idx]>.
 195
 196 =cut
 197 */
 198
 199 static bool
 200 S_adjust_index(pTHX_ AV *av, const MAGIC *mg, SSize_t *keyp)
 201 {
 202     bool adjust_index = 1;
 203     if (mg) {
 204         /* Handle negative array indices 20020222 MJD */
 205         SV * const ref = SvTIED_obj(MUTABLE_SV(av), mg);
 206         SvGETMAGIC(ref);
 207         if (SvROK(ref) && SvOBJECT(SvRV(ref))) {
 208             SV * const * const negative_indices_glob =
 209                 hv_fetchs(SvSTASH(SvRV(ref)), NEGATIVE_INDICES_VAR, 0);
 210
 211             if (negative_indices_glob && isGV(*negative_indices_glob)
 212              && SvTRUE(GvSV(*negative_indices_glob)))
 213                 adjust_index = 0;
 214         }
 215     }
 216
 217     if (adjust_index) {
 218         *keyp += AvFILL(av) + 1;
 219         if (*keyp < 0)
 220             return FALSE;
 221     }
 222     return TRUE;
 223 }
 224
 225 SV**
 226 Perl_av_fetch(pTHX_ AV *av, SSize_t key, I32 lval)
 227 {
 228     dVAR;
 229
 230     PERL_ARGS_ASSERT_AV_FETCH;
 231     assert(SvTYPE(av) == SVt_PVAV);
 232
 233     if (SvRMAGICAL(av)) {
 234         const MAGIC * const tied_magic
 235             = mg_find((const SV *)av, PERL_MAGIC_tied);
 236         if (tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata)) {
 237             SV *sv;
 238             if (key < 0) {
 239                 if (!S_adjust_index(aTHX_ av, tied_magic, &key))
 240                         return NULL;
 241             }
 242
 243             sv = sv_newmortal();
 244             sv_upgrade(sv, SVt_PVLV);
 245             mg_copy(MUTABLE_SV(av), sv, 0, key);
 246             if (!tied_magic) /* for regdata, force leavesub to make copies */
 247                 SvTEMP_off(sv);
 248             LvTYPE(sv) = 't';
 249             LvTARG(sv) = sv; /* fake (SV**) */
 250             return &(LvTARG(sv));
 251         }
 252     }
 253
 254     if (key < 0) {
 255         key += AvFILL(av) + 1;
 256         if (key < 0)
 257             return NULL;
 258     }
 259
 260     if (key > AvFILLp(av) || !AvARRAY(av)[key]) {
 261       emptyness:
 262         return lval ? av_store(av,key,newSV(0)) : NULL;
 263     }
 264
 265     if (AvREIFY(av)
 266              && (!AvARRAY(av)[key]      /* eg. @_ could have freed elts */
 267                  || SvIS_FREED(AvARRAY(av)[key]))) {
 268         AvARRAY(av)[key] = NULL;        /* 1/2 reify */
 269         goto emptyness;
 270     }
 271     return &AvARRAY(av)[key];
 272 }
 273
 274 /*
 275 =for apidoc av_store
 276
 277 Stores an SV in an array.  The array index is specified as C<key>.  The
 278 return value will be NULL if the operation failed or if the value did not
 279 need to be actually stored within the array (as in the case of tied
 280 arrays). Otherwise, it can be dereferenced
 281 to get the C<SV*> that was stored
 282 there (= C<val>)).
 283
 284 Note that the caller is responsible for suitably incrementing the reference
 285 count of C<val> before the call, and decrementing it if the function
 286 returned NULL.
 287
 288 Approximate Perl equivalent: C<$myarray[$key] = $val;>.
 289
 290 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
 291 more information on how to use this function on tied arrays.
 292
 293 =cut
 294 */
 295
 296 SV**
 297 Perl_av_store(pTHX_ AV *av, SSize_t key, SV *val)
 298 {
 299     dVAR;
 300     SV** ary;
 301
 302     PERL_ARGS_ASSERT_AV_STORE;
 303     assert(SvTYPE(av) == SVt_PVAV);
 304
 305     /* S_regclass relies on being able to pass in a NULL sv
 306        (unicode_alternate may be NULL).
 307     */
 308
 309     if (SvRMAGICAL(av)) {
 310         const MAGIC * const tied_magic = mg_find((const SV *)av, PERL_MAGIC_tied);
 311         if (tied_magic) {
 312             if (key < 0) {
 313                 if (!S_adjust_index(aTHX_ av, tied_magic, &key))
 314                         return 0;
 315             }
 316             if (val) {
 317                 mg_copy(MUTABLE_SV(av), val, 0, key);
 318             }
 319             return NULL;
 320         }
 321     }
 322
 323
 324     if (key < 0) {
 325         key += AvFILL(av) + 1;
 326         if (key < 0)
 327             return NULL;
 328     }
 329
 330     if (SvREADONLY(av) && key >= AvFILL(av))
 331         Perl_croak_no_modify();
 332
 333     if (!AvREAL(av) && AvREIFY(av))
 334         av_reify(av);
 335     if (key > AvMAX(av))
 336         av_extend(av,key);
 337     ary = AvARRAY(av);
 338     if (AvFILLp(av) < key) {
 339         if (!AvREAL(av)) {
 340             if (av == PL_curstack && key > PL_stack_sp - PL_stack_base)
 341                 PL_stack_sp = PL_stack_base + key;      /* XPUSH in disguise */
 342             do {
 343                 ary[++AvFILLp(av)] = NULL;
 344             } while (AvFILLp(av) < key);
 345         }
 346         AvFILLp(av) = key;
 347     }
 348     else if (AvREAL(av))
 349         SvREFCNT_dec(ary[key]);
 350     ary[key] = val;
 351     if (SvSMAGICAL(av)) {
 352         const MAGIC *mg = SvMAGIC(av);
 353         bool set = TRUE;
 354         for (; mg; mg = mg->mg_moremagic) {
 355           if (!isUPPER(mg->mg_type)) continue;
 356           if (val) {
 357             sv_magic(val, MUTABLE_SV(av), toLOWER(mg->mg_type), 0, key);
 358           }
 359           if (PL_delaymagic && mg->mg_type == PERL_MAGIC_isa) {
 360             PL_delaymagic |= DM_ARRAY_ISA;
 361             set = FALSE;
 362           }
 363         }
 364         if (set)
 365            mg_set(MUTABLE_SV(av));
 366     }
 367     return &ary[key];
 368 }
 369
 370 /*
 371 =for apidoc av_make
 372
 373 Creates a new AV and populates it with a list of SVs.  The SVs are copied
 374 into the array, so they may be freed after the call to av_make.  The new AV
 375 will have a reference count of 1.
 376
 377 Perl equivalent: C<my @new_array = ($scalar1, $scalar2, $scalar3...);>
 378
 379 =cut
 380 */
 381
 382 AV *
 383 Perl_av_make(pTHX_ SSize_t size, SV **strp)
 384 {
 385     AV * const av = MUTABLE_AV(newSV_type(SVt_PVAV));
 386     /* sv_upgrade does AvREAL_only()  */
 387     PERL_ARGS_ASSERT_AV_MAKE;
 388     assert(SvTYPE(av) == SVt_PVAV);
 389
 390     if (size) {         /* "defined" was returning undef for size==0 anyway. */
 391         SV** ary;
 392         SSize_t i;
 393         Newx(ary,size,SV*);
 394         AvALLOC(av) = ary;
 395         AvARRAY(av) = ary;
 396         AvMAX(av) = size - 1;
 397         AvFILLp(av) = -1;
 398         ENTER;
 399         SAVEFREESV(av);
 400         for (i = 0; i < size; i++) {
 401             assert (*strp);
 402
 403             /* Don't let sv_setsv swipe, since our source array might
 404                have multiple references to the same temp scalar (e.g.
 405                from a list slice) */
 406
 407             SvGETMAGIC(*strp); /* before newSV, in case it dies */
 408             AvFILLp(av)++;
 409             ary[i] = newSV(0);
 410             sv_setsv_flags(ary[i], *strp,
 411                            SV_DO_COW_SVSETSV|SV_NOSTEAL);
 412             strp++;
 413         }
 414         SvREFCNT_inc_simple_void_NN(av);
 415         LEAVE;
 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_ AV *av)
 434 {
 435     dVAR;
 436     SSize_t 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();
 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         SSize_t 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] = NULL;
 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_ 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         SSize_t 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_ 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();
 566
 567     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
 568         Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(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 Removes one SV from the end of the array, reducing its size by one and
 579 returning the SV (transferring control of one reference count) to the
 580 caller.  Returns C<&PL_sv_undef> if the array is empty.
 581
 582 Perl equivalent: C<pop(@myarray);>
 583
 584 =cut
 585 */
 586
 587 SV *
 588 Perl_av_pop(pTHX_ AV *av)
 589 {
 590     dVAR;
 591     SV *retval;
 592     MAGIC* mg;
 593
 594     PERL_ARGS_ASSERT_AV_POP;
 595     assert(SvTYPE(av) == SVt_PVAV);
 596
 597     if (SvREADONLY(av))
 598         Perl_croak_no_modify();
 599     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
 600         retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(POP), 0, 0);
 601         if (retval)
 602             retval = newSVsv(retval);
 603         return retval;
 604     }
 605     if (AvFILL(av) < 0)
 606         return &PL_sv_undef;
 607     retval = AvARRAY(av)[AvFILLp(av)];
 608     AvARRAY(av)[AvFILLp(av)--] = NULL;
 609     if (SvSMAGICAL(av))
 610         mg_set(MUTABLE_SV(av));
 611     return retval ? retval : &PL_sv_undef;
 612 }
 613
 614 /*
 615
 616 =for apidoc av_create_and_unshift_one
 617
 618 Unshifts an SV onto the beginning of the array, creating the array if
 619 necessary.
 620 A small internal helper function to remove a commonly duplicated idiom.
 621
 622 =cut
 623 */
 624
 625 SV **
 626 Perl_av_create_and_unshift_one(pTHX_ AV **const avp, SV *const val)
 627 {
 628     PERL_ARGS_ASSERT_AV_CREATE_AND_UNSHIFT_ONE;
 629
 630     if (!*avp)
 631         *avp = newAV();
 632     av_unshift(*avp, 1);
 633     return av_store(*avp, 0, val);
 634 }
 635
 636 /*
 637 =for apidoc av_unshift
 638
 639 Unshift the given number of C<undef> values onto the beginning of the
 640 array.  The array will grow automatically to accommodate the addition.  You
 641 must then use C<av_store> to assign values to these new elements.
 642
 643 Perl equivalent: C<unshift @myarray, ( (undef) x $n );>
 644
 645 =cut
 646 */
 647
 648 void
 649 Perl_av_unshift(pTHX_ AV *av, SSize_t num)
 650 {
 651     dVAR;
 652     SSize_t i;
 653     MAGIC* mg;
 654
 655     PERL_ARGS_ASSERT_AV_UNSHIFT;
 656     assert(SvTYPE(av) == SVt_PVAV);
 657
 658     if (SvREADONLY(av))
 659         Perl_croak_no_modify();
 660
 661     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
 662         Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(UNSHIFT),
 663                             G_DISCARD | G_UNDEF_FILL, num);
 664         return;
 665     }
 666
 667     if (num <= 0)
 668       return;
 669     if (!AvREAL(av) && AvREIFY(av))
 670         av_reify(av);
 671     i = AvARRAY(av) - AvALLOC(av);
 672     if (i) {
 673         if (i > num)
 674             i = num;
 675         num -= i;
 676
 677         AvMAX(av) += i;
 678         AvFILLp(av) += i;
 679         AvARRAY(av) = AvARRAY(av) - i;
 680     }
 681     if (num) {
 682         SV **ary;
 683         const SSize_t i = AvFILLp(av);
 684         /* Create extra elements */
 685         const SSize_t slide = i > 0 ? i : 0;
 686         num += slide;
 687         av_extend(av, i + num);
 688         AvFILLp(av) += num;
 689         ary = AvARRAY(av);
 690         Move(ary, ary + num, i + 1, SV*);
 691         do {
 692             ary[--num] = NULL;
 693         } while (num);
 694         /* Make extra elements into a buffer */
 695         AvMAX(av) -= slide;
 696         AvFILLp(av) -= slide;
 697         AvARRAY(av) = AvARRAY(av) + slide;
 698     }
 699 }
 700
 701 /*
 702 =for apidoc av_shift
 703
 704 Removes one SV from the start of the array, reducing its size by one and
 705 returning the SV (transferring control of one reference count) to the
 706 caller.  Returns C<&PL_sv_undef> if the array is empty.
 707
 708 Perl equivalent: C<shift(@myarray);>
 709
 710 =cut
 711 */
 712
 713 SV *
 714 Perl_av_shift(pTHX_ AV *av)
 715 {
 716     dVAR;
 717     SV *retval;
 718     MAGIC* mg;
 719
 720     PERL_ARGS_ASSERT_AV_SHIFT;
 721     assert(SvTYPE(av) == SVt_PVAV);
 722
 723     if (SvREADONLY(av))
 724         Perl_croak_no_modify();
 725     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
 726         retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(SHIFT), 0, 0);
 727         if (retval)
 728             retval = newSVsv(retval);
 729         return retval;
 730     }
 731     if (AvFILL(av) < 0)
 732       return &PL_sv_undef;
 733     retval = *AvARRAY(av);
 734     if (AvREAL(av))
 735         *AvARRAY(av) = NULL;
 736     AvARRAY(av) = AvARRAY(av) + 1;
 737     AvMAX(av)--;
 738     AvFILLp(av)--;
 739     if (SvSMAGICAL(av))
 740         mg_set(MUTABLE_SV(av));
 741     return retval ? retval : &PL_sv_undef;
 742 }
 743
 744 /*
 745 =for apidoc av_top_index
 746
 747 Returns the highest index in the array.  The number of elements in the
 748 array is C<av_top_index(av) + 1>.  Returns -1 if the array is empty.
 749
 750 The Perl equivalent for this is C<$#myarray>.
 751
 752 (A slightly shorter form is C<av_tindex>.)
 753
 754 =for apidoc av_len
 755
 756 Same as L</av_top_index>.  Returns the highest index in the array.  Note that the
 757 return value is +1 what its name implies it returns; and hence differs in
 758 meaning from what the similarly named L</sv_len> returns.
 759
 760 =cut
 761 */
 762
 763 SSize_t
 764 Perl_av_len(pTHX_ AV *av)
 765 {
 766     PERL_ARGS_ASSERT_AV_LEN;
 767
 768     return av_top_index(av);
 769 }
 770
 771 /*
 772 =for apidoc av_fill
 773
 774 Set the highest index in the array to the given number, equivalent to
 775 Perl's C<$#array = $fill;>.
 776
 777 The number of elements in the an array will be C<fill + 1> after
 778 av_fill() returns.  If the array was previously shorter, then the
 779 additional elements appended are set to NULL.  If the array
 780 was longer, then the excess elements are freed.  C<av_fill(av, -1)> is
 781 the same as C<av_clear(av)>.
 782
 783 =cut
 784 */
 785 void
 786 Perl_av_fill(pTHX_ AV *av, SSize_t fill)
 787 {
 788     dVAR;
 789     MAGIC *mg;
 790
 791     PERL_ARGS_ASSERT_AV_FILL;
 792     assert(SvTYPE(av) == SVt_PVAV);
 793
 794     if (fill < 0)
 795         fill = -1;
 796     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
 797         SV *arg1 = sv_newmortal();
 798         sv_setiv(arg1, (IV)(fill + 1));
 799         Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(STORESIZE), G_DISCARD,
 800                             1, arg1);
 801         return;
 802     }
 803     if (fill <= AvMAX(av)) {
 804         SSize_t key = AvFILLp(av);
 805         SV** const ary = AvARRAY(av);
 806
 807         if (AvREAL(av)) {
 808             while (key > fill) {
 809                 SvREFCNT_dec(ary[key]);
 810                 ary[key--] = NULL;
 811             }
 812         }
 813         else {
 814             while (key < fill)
 815                 ary[++key] = NULL;
 816         }
 817
 818         AvFILLp(av) = fill;
 819         if (SvSMAGICAL(av))
 820             mg_set(MUTABLE_SV(av));
 821     }
 822     else
 823         (void)av_store(av,fill,NULL);
 824 }
 825
 826 /*
 827 =for apidoc av_delete
 828
 829 Deletes the element indexed by C<key> from the array, makes the element mortal,
 830 and returns it.  If C<flags> equals C<G_DISCARD>, the element is freed and null
 831 is returned.  Perl equivalent: C<my $elem = delete($myarray[$idx]);> for the
 832 non-C<G_DISCARD> version and a void-context C<delete($myarray[$idx]);> for the
 833 C<G_DISCARD> version.
 834
 835 =cut
 836 */
 837 SV *
 838 Perl_av_delete(pTHX_ AV *av, SSize_t key, I32 flags)
 839 {
 840     dVAR;
 841     SV *sv;
 842
 843     PERL_ARGS_ASSERT_AV_DELETE;
 844     assert(SvTYPE(av) == SVt_PVAV);
 845
 846     if (SvREADONLY(av))
 847         Perl_croak_no_modify();
 848
 849     if (SvRMAGICAL(av)) {
 850         const MAGIC * const tied_magic
 851             = mg_find((const SV *)av, PERL_MAGIC_tied);
 852         if ((tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata))) {
 853             SV **svp;
 854             if (key < 0) {
 855                 if (!S_adjust_index(aTHX_ av, tied_magic, &key))
 856                         return NULL;
 857             }
 858             svp = av_fetch(av, key, TRUE);
 859             if (svp) {
 860                 sv = *svp;
 861                 mg_clear(sv);
 862                 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
 863                     sv_unmagic(sv, PERL_MAGIC_tiedelem); /* No longer an element */
 864                     return sv;
 865                 }
 866                 return NULL;
 867             }
 868         }
 869     }
 870
 871     if (key < 0) {
 872         key += AvFILL(av) + 1;
 873         if (key < 0)
 874             return NULL;
 875     }
 876
 877     if (key > AvFILLp(av))
 878         return NULL;
 879     else {
 880         if (!AvREAL(av) && AvREIFY(av))
 881             av_reify(av);
 882         sv = AvARRAY(av)[key];
 883         if (key == AvFILLp(av)) {
 884             AvARRAY(av)[key] = NULL;
 885             do {
 886                 AvFILLp(av)--;
 887             } while (--key >= 0 && !AvARRAY(av)[key]);
 888         }
 889         else
 890             AvARRAY(av)[key] = NULL;
 891         if (SvSMAGICAL(av))
 892             mg_set(MUTABLE_SV(av));
 893     }
 894     if (flags & G_DISCARD) {
 895         SvREFCNT_dec(sv);
 896         sv = NULL;
 897     }
 898     else if (AvREAL(av))
 899         sv = sv_2mortal(sv);
 900     return sv;
 901 }
 902
 903 /*
 904 =for apidoc av_exists
 905
 906 Returns true if the element indexed by C<key> has been initialized.
 907
 908 This relies on the fact that uninitialized array elements are set to
 909 NULL.
 910
 911 Perl equivalent: C<exists($myarray[$key])>.
 912
 913 =cut
 914 */
 915 bool
 916 Perl_av_exists(pTHX_ AV *av, SSize_t key)
 917 {
 918     dVAR;
 919     PERL_ARGS_ASSERT_AV_EXISTS;
 920     assert(SvTYPE(av) == SVt_PVAV);
 921
 922     if (SvRMAGICAL(av)) {
 923         const MAGIC * const tied_magic
 924             = mg_find((const SV *)av, PERL_MAGIC_tied);
 925         const MAGIC * const regdata_magic
 926             = mg_find((const SV *)av, PERL_MAGIC_regdata);
 927         if (tied_magic || regdata_magic) {
 928             MAGIC *mg;
 929             /* Handle negative array indices 20020222 MJD */
 930             if (key < 0) {
 931                 if (!S_adjust_index(aTHX_ av, tied_magic, &key))
 932                         return FALSE;
 933             }
 934
 935             if(key >= 0 && regdata_magic) {
 936                 if (key <= AvFILL(av))
 937                     return TRUE;
 938                 else
 939                     return FALSE;
 940             }
 941             {
 942                 SV * const sv = sv_newmortal();
 943                 mg_copy(MUTABLE_SV(av), sv, 0, key);
 944                 mg = mg_find(sv, PERL_MAGIC_tiedelem);
 945                 if (mg) {
 946                     magic_existspack(sv, mg);
 947                     {
 948                         I32 retbool = SvTRUE_nomg_NN(sv);
 949                         return cBOOL(retbool);
 950                     }
 951                 }
 952             }
 953         }
 954     }
 955
 956     if (key < 0) {
 957         key += AvFILL(av) + 1;
 958         if (key < 0)
 959             return FALSE;
 960     }
 961
 962     if (key <= AvFILLp(av) && AvARRAY(av)[key])
 963     {
 964         return TRUE;
 965     }
 966     else
 967         return FALSE;
 968 }
 969
 970 static MAGIC *
 971 S_get_aux_mg(pTHX_ AV *av) {
 972     dVAR;
 973     MAGIC *mg;
 974
 975     PERL_ARGS_ASSERT_GET_AUX_MG;
 976     assert(SvTYPE(av) == SVt_PVAV);
 977
 978     mg = mg_find((const SV *)av, PERL_MAGIC_arylen_p);
 979
 980     if (!mg) {
 981         mg = sv_magicext(MUTABLE_SV(av), 0, PERL_MAGIC_arylen_p,
 982                          &PL_vtbl_arylen_p, 0, 0);
 983         assert(mg);
 984         /* sv_magicext won't set this for us because we pass in a NULL obj  */
 985         mg->mg_flags |= MGf_REFCOUNTED;
 986     }
 987     return mg;
 988 }
 989
 990 SV **
 991 Perl_av_arylen_p(pTHX_ AV *av) {
 992     MAGIC *const mg = get_aux_mg(av);
 993
 994     PERL_ARGS_ASSERT_AV_ARYLEN_P;
 995     assert(SvTYPE(av) == SVt_PVAV);
 996
 997     return &(mg->mg_obj);
 998 }
 999
1000 IV *
1001 Perl_av_iter_p(pTHX_ AV *av) {
1002     MAGIC *const mg = get_aux_mg(av);
1003
1004     PERL_ARGS_ASSERT_AV_ITER_P;
1005     assert(SvTYPE(av) == SVt_PVAV);
1006
1007 #if IVSIZE == I32SIZE
1008     return (IV *)&(mg->mg_len);
1009 #else
1010     if (!mg->mg_ptr) {
1011         IV *temp;
1012         mg->mg_len = IVSIZE;
1013         Newxz(temp, 1, IV);
1014         mg->mg_ptr = (char *) temp;
1015     }
1016     return (IV *)mg->mg_ptr;
1017 #endif
1018 }
1019
1020 /*
1021  * Local variables:
1022  * c-indentation-style: bsd
1023  * c-basic-offset: 4
1024  * indent-tabs-mode: nil
1025  * End:
1026  *
1027  * ex: set ts=8 sts=4 sw=4 et:
1028  */