av.c

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