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_no_modify(aTHX);
 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_ISA;
 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 Perl equivalent: C<my @new_array = ($scalar1, $scalar2, $scalar3...);>
 383
 384 =cut
 385 */
 386
 387 AV *
 388 Perl_av_make(pTHX_ register I32 size, register SV **strp)
 389 {
 390     register AV * const av = MUTABLE_AV(newSV_type(SVt_PVAV));
 391     /* sv_upgrade does AvREAL_only()  */
 392     PERL_ARGS_ASSERT_AV_MAKE;
 393     assert(SvTYPE(av) == SVt_PVAV);
 394
 395     if (size) {         /* "defined" was returning undef for size==0 anyway. */
 396         register SV** ary;
 397         register I32 i;
 398         Newx(ary,size,SV*);
 399         AvALLOC(av) = ary;
 400         AvARRAY(av) = ary;
 401         AvFILLp(av) = AvMAX(av) = size - 1;
 402         for (i = 0; i < size; i++) {
 403             assert (*strp);
 404
 405             /* Don't let sv_setsv swipe, since our source array might
 406                have multiple references to the same temp scalar (e.g.
 407                from a list slice) */
 408
 409             ary[i] = newSV(0);
 410             sv_setsv_flags(ary[i], *strp,
 411                            SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
 412             strp++;
 413         }
 414     }
 415     return av;
 416 }
 417
 418 /*
 419 =for apidoc av_clear
 420
 421 Clears an array, making it empty.  Does not free the memory used by the
 422 array itself. Perl equivalent: C<@myarray = ();>.
 423
 424 =cut
 425 */
 426
 427 void
 428 Perl_av_clear(pTHX_ register AV *av)
 429 {
 430     dVAR;
 431     I32 extra;
 432
 433     PERL_ARGS_ASSERT_AV_CLEAR;
 434     assert(SvTYPE(av) == SVt_PVAV);
 435
 436 #ifdef DEBUGGING
 437     if (SvREFCNT(av) == 0) {
 438         Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "Attempt to clear deleted array");
 439     }
 440 #endif
 441
 442     if (SvREADONLY(av))
 443         Perl_croak_no_modify(aTHX);
 444
 445     /* Give any tie a chance to cleanup first */
 446     if (SvRMAGICAL(av)) {
 447         const MAGIC* const mg = SvMAGIC(av);
 448         if (PL_delaymagic && mg && mg->mg_type == PERL_MAGIC_isa)
 449             PL_delaymagic |= DM_ARRAY_ISA;
 450         else
 451             mg_clear(MUTABLE_SV(av));
 452     }
 453
 454     if (AvMAX(av) < 0)
 455         return;
 456
 457     if (AvREAL(av)) {
 458         SV** const ary = AvARRAY(av);
 459         I32 index = AvFILLp(av) + 1;
 460         while (index) {
 461             SV * const sv = ary[--index];
 462             /* undef the slot before freeing the value, because a
 463              * destructor might try to modify this array */
 464             ary[index] = &PL_sv_undef;
 465             SvREFCNT_dec(sv);
 466         }
 467     }
 468     extra = AvARRAY(av) - AvALLOC(av);
 469     if (extra) {
 470         AvMAX(av) += extra;
 471         AvARRAY(av) = AvALLOC(av);
 472     }
 473     AvFILLp(av) = -1;
 474
 475 }
 476
 477 /*
 478 =for apidoc av_undef
 479
 480 Undefines the array.  Frees the memory used by the array itself.
 481
 482 =cut
 483 */
 484
 485 void
 486 Perl_av_undef(pTHX_ register AV *av)
 487 {
 488     PERL_ARGS_ASSERT_AV_UNDEF;
 489     assert(SvTYPE(av) == SVt_PVAV);
 490
 491     /* Give any tie a chance to cleanup first */
 492     if (SvTIED_mg((const SV *)av, PERL_MAGIC_tied))
 493         av_fill(av, -1);
 494
 495     if (AvREAL(av)) {
 496         register I32 key = AvFILLp(av) + 1;
 497         while (key)
 498             SvREFCNT_dec(AvARRAY(av)[--key]);
 499     }
 500
 501     Safefree(AvALLOC(av));
 502     AvALLOC(av) = NULL;
 503     AvARRAY(av) = NULL;
 504     AvMAX(av) = AvFILLp(av) = -1;
 505
 506     if(SvRMAGICAL(av)) mg_clear(MUTABLE_SV(av));
 507 }
 508
 509 /*
 510
 511 =for apidoc av_create_and_push
 512
 513 Push an SV onto the end of the array, creating the array if necessary.
 514 A small internal helper function to remove a commonly duplicated idiom.
 515
 516 =cut
 517 */
 518
 519 void
 520 Perl_av_create_and_push(pTHX_ AV **const avp, SV *const val)
 521 {
 522     PERL_ARGS_ASSERT_AV_CREATE_AND_PUSH;
 523
 524     if (!*avp)
 525         *avp = newAV();
 526     av_push(*avp, val);
 527 }
 528
 529 /*
 530 =for apidoc av_push
 531
 532 Pushes an SV onto the end of the array.  The array will grow automatically
 533 to accommodate the addition. Like C<av_store>, this takes ownership of one
 534 reference count.
 535
 536 =cut
 537 */
 538
 539 void
 540 Perl_av_push(pTHX_ register AV *av, SV *val)
 541 {
 542     dVAR;
 543     MAGIC *mg;
 544
 545     PERL_ARGS_ASSERT_AV_PUSH;
 546     assert(SvTYPE(av) == SVt_PVAV);
 547
 548     if (SvREADONLY(av))
 549         Perl_croak_no_modify(aTHX);
 550
 551     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
 552         Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "PUSH", G_DISCARD, 1,
 553                             val);
 554         return;
 555     }
 556     av_store(av,AvFILLp(av)+1,val);
 557 }
 558
 559 /*
 560 =for apidoc av_pop
 561
 562 Pops an SV off the end of the array.  Returns C<&PL_sv_undef> if the array
 563 is empty.
 564
 565 =cut
 566 */
 567
 568 SV *
 569 Perl_av_pop(pTHX_ register AV *av)
 570 {
 571     dVAR;
 572     SV *retval;
 573     MAGIC* mg;
 574
 575     PERL_ARGS_ASSERT_AV_POP;
 576     assert(SvTYPE(av) == SVt_PVAV);
 577
 578     if (SvREADONLY(av))
 579         Perl_croak_no_modify(aTHX);
 580     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
 581         retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "POP", 0, 0);
 582         if (retval)
 583             retval = newSVsv(retval);
 584         return retval;
 585     }
 586     if (AvFILL(av) < 0)
 587         return &PL_sv_undef;
 588     retval = AvARRAY(av)[AvFILLp(av)];
 589     AvARRAY(av)[AvFILLp(av)--] = &PL_sv_undef;
 590     if (SvSMAGICAL(av))
 591         mg_set(MUTABLE_SV(av));
 592     return retval;
 593 }
 594
 595 /*
 596
 597 =for apidoc av_create_and_unshift_one
 598
 599 Unshifts an SV onto the beginning of the array, creating the array if
 600 necessary.
 601 A small internal helper function to remove a commonly duplicated idiom.
 602
 603 =cut
 604 */
 605
 606 SV **
 607 Perl_av_create_and_unshift_one(pTHX_ AV **const avp, SV *const val)
 608 {
 609     PERL_ARGS_ASSERT_AV_CREATE_AND_UNSHIFT_ONE;
 610
 611     if (!*avp)
 612         *avp = newAV();
 613     av_unshift(*avp, 1);
 614     return av_store(*avp, 0, val);
 615 }
 616
 617 /*
 618 =for apidoc av_unshift
 619
 620 Unshift the given number of C<undef> values onto the beginning of the
 621 array.  The array will grow automatically to accommodate the addition.  You
 622 must then use C<av_store> to assign values to these new elements.
 623
 624 =cut
 625 */
 626
 627 void
 628 Perl_av_unshift(pTHX_ register AV *av, register I32 num)
 629 {
 630     dVAR;
 631     register I32 i;
 632     MAGIC* mg;
 633
 634     PERL_ARGS_ASSERT_AV_UNSHIFT;
 635     assert(SvTYPE(av) == SVt_PVAV);
 636
 637     if (SvREADONLY(av))
 638         Perl_croak_no_modify(aTHX);
 639
 640     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
 641         Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "UNSHIFT",
 642                             G_DISCARD | G_UNDEF_FILL, num);
 643         return;
 644     }
 645
 646     if (num <= 0)
 647       return;
 648     if (!AvREAL(av) && AvREIFY(av))
 649         av_reify(av);
 650     i = AvARRAY(av) - AvALLOC(av);
 651     if (i) {
 652         if (i > num)
 653             i = num;
 654         num -= i;
 655
 656         AvMAX(av) += i;
 657         AvFILLp(av) += i;
 658         AvARRAY(av) = AvARRAY(av) - i;
 659     }
 660     if (num) {
 661         register SV **ary;
 662         const I32 i = AvFILLp(av);
 663         /* Create extra elements */
 664         const I32 slide = i > 0 ? i : 0;
 665         num += slide;
 666         av_extend(av, i + num);
 667         AvFILLp(av) += num;
 668         ary = AvARRAY(av);
 669         Move(ary, ary + num, i + 1, SV*);
 670         do {
 671             ary[--num] = &PL_sv_undef;
 672         } while (num);
 673         /* Make extra elements into a buffer */
 674         AvMAX(av) -= slide;
 675         AvFILLp(av) -= slide;
 676         AvARRAY(av) = AvARRAY(av) + slide;
 677     }
 678 }
 679
 680 /*
 681 =for apidoc av_shift
 682
 683 Shifts an SV off the beginning of the array. Returns C<&PL_sv_undef> if the
 684 array is empty.
 685
 686 =cut
 687 */
 688
 689 SV *
 690 Perl_av_shift(pTHX_ register AV *av)
 691 {
 692     dVAR;
 693     SV *retval;
 694     MAGIC* mg;
 695
 696     PERL_ARGS_ASSERT_AV_SHIFT;
 697     assert(SvTYPE(av) == SVt_PVAV);
 698
 699     if (SvREADONLY(av))
 700         Perl_croak_no_modify(aTHX);
 701     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
 702         retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "SHIFT", 0, 0);
 703         if (retval)
 704             retval = newSVsv(retval);
 705         return retval;
 706     }
 707     if (AvFILL(av) < 0)
 708       return &PL_sv_undef;
 709     retval = *AvARRAY(av);
 710     if (AvREAL(av))
 711         *AvARRAY(av) = &PL_sv_undef;
 712     AvARRAY(av) = AvARRAY(av) + 1;
 713     AvMAX(av)--;
 714     AvFILLp(av)--;
 715     if (SvSMAGICAL(av))
 716         mg_set(MUTABLE_SV(av));
 717     return retval;
 718 }
 719
 720 /*
 721 =for apidoc av_len
 722
 723 Returns the highest index in the array.  The number of elements in the
 724 array is C<av_len(av) + 1>.  Returns -1 if the array is empty.
 725
 726 The Perl equivalent for this is C<$#myarray>.
 727
 728 =cut
 729 */
 730
 731 I32
 732 Perl_av_len(pTHX_ AV *av)
 733 {
 734     PERL_ARGS_ASSERT_AV_LEN;
 735     assert(SvTYPE(av) == SVt_PVAV);
 736
 737     return AvFILL(av);
 738 }
 739
 740 /*
 741 =for apidoc av_fill
 742
 743 Set the highest index in the array to the given number, equivalent to
 744 Perl's C<$#array = $fill;>.
 745
 746 The number of elements in the an array will be C<fill + 1> after
 747 av_fill() returns.  If the array was previously shorter, then the
 748 additional elements appended are set to C<PL_sv_undef>.  If the array
 749 was longer, then the excess elements are freed.  C<av_fill(av, -1)> is
 750 the same as C<av_clear(av)>.
 751
 752 =cut
 753 */
 754 void
 755 Perl_av_fill(pTHX_ register AV *av, I32 fill)
 756 {
 757     dVAR;
 758     MAGIC *mg;
 759
 760     PERL_ARGS_ASSERT_AV_FILL;
 761     assert(SvTYPE(av) == SVt_PVAV);
 762
 763     if (fill < 0)
 764         fill = -1;
 765     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
 766         SV *arg1 = sv_newmortal();
 767         sv_setiv(arg1, (IV)(fill + 1));
 768         Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "STORESIZE", G_DISCARD,
 769                             1, arg1);
 770         return;
 771     }
 772     if (fill <= AvMAX(av)) {
 773         I32 key = AvFILLp(av);
 774         SV** const ary = AvARRAY(av);
 775
 776         if (AvREAL(av)) {
 777             while (key > fill) {
 778                 SvREFCNT_dec(ary[key]);
 779                 ary[key--] = &PL_sv_undef;
 780             }
 781         }
 782         else {
 783             while (key < fill)
 784                 ary[++key] = &PL_sv_undef;
 785         }
 786
 787         AvFILLp(av) = fill;
 788         if (SvSMAGICAL(av))
 789             mg_set(MUTABLE_SV(av));
 790     }
 791     else
 792         (void)av_store(av,fill,&PL_sv_undef);
 793 }
 794
 795 /*
 796 =for apidoc av_delete
 797
 798 Deletes the element indexed by C<key> from the array.  Returns the
 799 deleted element. If C<flags> equals C<G_DISCARD>, the element is freed
 800 and null is returned. Perl equivalent: C<my $elem = delete($myarray[$idx]);>
 801 for the non-C<G_DISCARD> version and a void-context C<delete($myarray[$idx]);>
 802 for the C<G_DISCARD> version.
 803
 804 =cut
 805 */
 806 SV *
 807 Perl_av_delete(pTHX_ AV *av, I32 key, I32 flags)
 808 {
 809     dVAR;
 810     SV *sv;
 811
 812     PERL_ARGS_ASSERT_AV_DELETE;
 813     assert(SvTYPE(av) == SVt_PVAV);
 814
 815     if (SvREADONLY(av))
 816         Perl_croak_no_modify(aTHX);
 817
 818     if (SvRMAGICAL(av)) {
 819         const MAGIC * const tied_magic
 820             = mg_find((const SV *)av, PERL_MAGIC_tied);
 821         if ((tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata))) {
 822             /* Handle negative array indices 20020222 MJD */
 823             SV **svp;
 824             if (key < 0) {
 825                 unsigned adjust_index = 1;
 826                 if (tied_magic) {
 827                     SV * const * const negative_indices_glob =
 828                         hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av),
 829                                                          tied_magic))),
 830                                  NEGATIVE_INDICES_VAR, 16, 0);
 831                     if (negative_indices_glob
 832                         && SvTRUE(GvSV(*negative_indices_glob)))
 833                         adjust_index = 0;
 834                 }
 835                 if (adjust_index) {
 836                     key += AvFILL(av) + 1;
 837                     if (key < 0)
 838                         return NULL;
 839                 }
 840             }
 841             svp = av_fetch(av, key, TRUE);
 842             if (svp) {
 843                 sv = *svp;
 844                 mg_clear(sv);
 845                 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
 846                     sv_unmagic(sv, PERL_MAGIC_tiedelem); /* No longer an element */
 847                     return sv;
 848                 }
 849                 return NULL;
 850             }
 851         }
 852     }
 853
 854     if (key < 0) {
 855         key += AvFILL(av) + 1;
 856         if (key < 0)
 857             return NULL;
 858     }
 859
 860     if (key > AvFILLp(av))
 861         return NULL;
 862     else {
 863         if (!AvREAL(av) && AvREIFY(av))
 864             av_reify(av);
 865         sv = AvARRAY(av)[key];
 866         if (key == AvFILLp(av)) {
 867             AvARRAY(av)[key] = &PL_sv_undef;
 868             do {
 869                 AvFILLp(av)--;
 870             } while (--key >= 0 && AvARRAY(av)[key] == &PL_sv_undef);
 871         }
 872         else
 873             AvARRAY(av)[key] = &PL_sv_undef;
 874         if (SvSMAGICAL(av))
 875             mg_set(MUTABLE_SV(av));
 876     }
 877     if (flags & G_DISCARD) {
 878         SvREFCNT_dec(sv);
 879         sv = NULL;
 880     }
 881     else if (AvREAL(av))
 882         sv = sv_2mortal(sv);
 883     return sv;
 884 }
 885
 886 /*
 887 =for apidoc av_exists
 888
 889 Returns true if the element indexed by C<key> has been initialized.
 890
 891 This relies on the fact that uninitialized array elements are set to
 892 C<&PL_sv_undef>.
 893
 894 Perl equivalent: C<exists($myarray[$key])>.
 895
 896 =cut
 897 */
 898 bool
 899 Perl_av_exists(pTHX_ AV *av, I32 key)
 900 {
 901     dVAR;
 902     PERL_ARGS_ASSERT_AV_EXISTS;
 903     assert(SvTYPE(av) == SVt_PVAV);
 904
 905     if (SvRMAGICAL(av)) {
 906         const MAGIC * const tied_magic
 907             = mg_find((const SV *)av, PERL_MAGIC_tied);
 908         if (tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata)) {
 909             SV * const sv = sv_newmortal();
 910             MAGIC *mg;
 911             /* Handle negative array indices 20020222 MJD */
 912             if (key < 0) {
 913                 unsigned adjust_index = 1;
 914                 if (tied_magic) {
 915                     SV * const * const negative_indices_glob =
 916                         hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av),
 917                                                          tied_magic))),
 918                                  NEGATIVE_INDICES_VAR, 16, 0);
 919                     if (negative_indices_glob
 920                         && SvTRUE(GvSV(*negative_indices_glob)))
 921                         adjust_index = 0;
 922                 }
 923                 if (adjust_index) {
 924                     key += AvFILL(av) + 1;
 925                     if (key < 0)
 926                         return FALSE;
 927                 }
 928             }
 929
 930             mg_copy(MUTABLE_SV(av), sv, 0, key);
 931             mg = mg_find(sv, PERL_MAGIC_tiedelem);
 932             if (mg) {
 933                 magic_existspack(sv, mg);
 934                 return cBOOL(SvTRUE(sv));
 935             }
 936
 937         }
 938     }
 939
 940     if (key < 0) {
 941         key += AvFILL(av) + 1;
 942         if (key < 0)
 943             return FALSE;
 944     }
 945
 946     if (key <= AvFILLp(av) && AvARRAY(av)[key] != &PL_sv_undef
 947         && AvARRAY(av)[key])
 948     {
 949         return TRUE;
 950     }
 951     else
 952         return FALSE;
 953 }
 954
 955 static MAGIC *
 956 S_get_aux_mg(pTHX_ AV *av) {
 957     dVAR;
 958     MAGIC *mg;
 959
 960     PERL_ARGS_ASSERT_GET_AUX_MG;
 961     assert(SvTYPE(av) == SVt_PVAV);
 962
 963     mg = mg_find((const SV *)av, PERL_MAGIC_arylen_p);
 964
 965     if (!mg) {
 966         mg = sv_magicext(MUTABLE_SV(av), 0, PERL_MAGIC_arylen_p,
 967                          &PL_vtbl_arylen_p, 0, 0);
 968         assert(mg);
 969         /* sv_magicext won't set this for us because we pass in a NULL obj  */
 970         mg->mg_flags |= MGf_REFCOUNTED;
 971     }
 972     return mg;
 973 }
 974
 975 SV **
 976 Perl_av_arylen_p(pTHX_ AV *av) {
 977     MAGIC *const mg = get_aux_mg(av);
 978
 979     PERL_ARGS_ASSERT_AV_ARYLEN_P;
 980     assert(SvTYPE(av) == SVt_PVAV);
 981
 982     return &(mg->mg_obj);
 983 }
 984
 985 IV *
 986 Perl_av_iter_p(pTHX_ AV *av) {
 987     MAGIC *const mg = get_aux_mg(av);
 988
 989     PERL_ARGS_ASSERT_AV_ITER_P;
 990     assert(SvTYPE(av) == SVt_PVAV);
 991
 992 #if IVSIZE == I32SIZE
 993     return (IV *)&(mg->mg_len);
 994 #else
 995     if (!mg->mg_ptr) {
 996         IV *temp;
 997         mg->mg_len = IVSIZE;
 998         Newxz(temp, 1, IV);
 999         mg->mg_ptr = (char *) temp;
1000     }
1001     return (IV *)mg->mg_ptr;
1002 #endif
1003 }
1004
1005 /*
1006  * Local variables:
1007  * c-indentation-style: bsd
1008  * c-basic-offset: 4
1009  * indent-tabs-mode: t
1010  * End:
1011  *
1012  * ex: set ts=8 sts=4 sw=4 noet:
1013  */