av.c

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