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