av.c

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