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