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
  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. Returns C<&PL_sv_undef> if the
 705 array is empty.
 706
 707 =cut
 708 */
 709
 710 SV *
 711 Perl_av_shift(pTHX_ register AV *av)
 712 {
 713     dVAR;
 714     SV *retval;
 715     MAGIC* mg;
 716
 717     PERL_ARGS_ASSERT_AV_SHIFT;
 718     assert(SvTYPE(av) == SVt_PVAV);
 719
 720     if (SvREADONLY(av))
 721         Perl_croak(aTHX_ PL_no_modify);
 722     if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
 723         dSP;
 724         PUSHSTACKi(PERLSI_MAGIC);
 725         PUSHMARK(SP);
 726         XPUSHs(SvTIED_obj((SV*)av, mg));
 727         PUTBACK;
 728         ENTER;
 729         if (call_method("SHIFT", G_SCALAR)) {
 730             retval = newSVsv(*PL_stack_sp--);
 731         } else {
 732             retval = &PL_sv_undef;
 733         }
 734         LEAVE;
 735         POPSTACK;
 736         return retval;
 737     }
 738     if (AvFILL(av) < 0)
 739       return &PL_sv_undef;
 740     retval = *AvARRAY(av);
 741     if (AvREAL(av))
 742         *AvARRAY(av) = &PL_sv_undef;
 743     AvARRAY(av) = AvARRAY(av) + 1;
 744     AvMAX(av)--;
 745     AvFILLp(av)--;
 746     if (SvSMAGICAL(av))
 747         mg_set((SV*)av);
 748     return retval;
 749 }
 750
 751 /*
 752 =for apidoc av_len
 753
 754 Returns the highest index in the array.  The number of elements in the
 755 array is C<av_len(av) + 1>.  Returns -1 if the array is empty.
 756
 757 =cut
 758 */
 759
 760 I32
 761 Perl_av_len(pTHX_ register const 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((SV*)av, PERL_MAGIC_tied))) {
 795         dSP;
 796         ENTER;
 797         SAVETMPS;
 798         PUSHSTACKi(PERLSI_MAGIC);
 799         PUSHMARK(SP);
 800         EXTEND(SP,2);
 801         PUSHs(SvTIED_obj((SV*)av, mg));
 802         mPUSHi(fill + 1);
 803         PUTBACK;
 804         call_method("STORESIZE", G_SCALAR|G_DISCARD);
 805         POPSTACK;
 806         FREETMPS;
 807         LEAVE;
 808         return;
 809     }
 810     if (fill <= AvMAX(av)) {
 811         I32 key = AvFILLp(av);
 812         SV** const ary = AvARRAY(av);
 813
 814         if (AvREAL(av)) {
 815             while (key > fill) {
 816                 SvREFCNT_dec(ary[key]);
 817                 ary[key--] = &PL_sv_undef;
 818             }
 819         }
 820         else {
 821             while (key < fill)
 822                 ary[++key] = &PL_sv_undef;
 823         }
 824
 825         AvFILLp(av) = fill;
 826         if (SvSMAGICAL(av))
 827             mg_set((SV*)av);
 828     }
 829     else
 830         (void)av_store(av,fill,&PL_sv_undef);
 831 }
 832
 833 /*
 834 =for apidoc av_delete
 835
 836 Deletes the element indexed by C<key> from the array.  Returns the
 837 deleted element. If C<flags> equals C<G_DISCARD>, the element is freed
 838 and null is returned.
 839
 840 =cut
 841 */
 842 SV *
 843 Perl_av_delete(pTHX_ AV *av, I32 key, I32 flags)
 844 {
 845     dVAR;
 846     SV *sv;
 847
 848     PERL_ARGS_ASSERT_AV_DELETE;
 849     assert(SvTYPE(av) == SVt_PVAV);
 850
 851     if (SvREADONLY(av))
 852         Perl_croak(aTHX_ PL_no_modify);
 853
 854     if (SvRMAGICAL(av)) {
 855         const MAGIC * const tied_magic = mg_find((SV*)av, PERL_MAGIC_tied);
 856         if ((tied_magic || mg_find((SV*)av, PERL_MAGIC_regdata))) {
 857             /* Handle negative array indices 20020222 MJD */
 858             SV **svp;
 859             if (key < 0) {
 860                 unsigned adjust_index = 1;
 861                 if (tied_magic) {
 862                     SV * const * const negative_indices_glob =
 863                         hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *)av,
 864                                                          tied_magic))),
 865                                  NEGATIVE_INDICES_VAR, 16, 0);
 866                     if (negative_indices_glob
 867                         && SvTRUE(GvSV(*negative_indices_glob)))
 868                         adjust_index = 0;
 869                 }
 870                 if (adjust_index) {
 871                     key += AvFILL(av) + 1;
 872                     if (key < 0)
 873                         return NULL;
 874                 }
 875             }
 876             svp = av_fetch(av, key, TRUE);
 877             if (svp) {
 878                 sv = *svp;
 879                 mg_clear(sv);
 880                 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
 881                     sv_unmagic(sv, PERL_MAGIC_tiedelem); /* No longer an element */
 882                     return sv;
 883                 }
 884                 return NULL;
 885             }
 886         }
 887     }
 888
 889     if (key < 0) {
 890         key += AvFILL(av) + 1;
 891         if (key < 0)
 892             return NULL;
 893     }
 894
 895     if (key > AvFILLp(av))
 896         return NULL;
 897     else {
 898         if (!AvREAL(av) && AvREIFY(av))
 899             av_reify(av);
 900         sv = AvARRAY(av)[key];
 901         if (key == AvFILLp(av)) {
 902             AvARRAY(av)[key] = &PL_sv_undef;
 903             do {
 904                 AvFILLp(av)--;
 905             } while (--key >= 0 && AvARRAY(av)[key] == &PL_sv_undef);
 906         }
 907         else
 908             AvARRAY(av)[key] = &PL_sv_undef;
 909         if (SvSMAGICAL(av))
 910             mg_set((SV*)av);
 911     }
 912     if (flags & G_DISCARD) {
 913         SvREFCNT_dec(sv);
 914         sv = NULL;
 915     }
 916     else if (AvREAL(av))
 917         sv = sv_2mortal(sv);
 918     return sv;
 919 }
 920
 921 /*
 922 =for apidoc av_exists
 923
 924 Returns true if the element indexed by C<key> has been initialized.
 925
 926 This relies on the fact that uninitialized array elements are set to
 927 C<&PL_sv_undef>.
 928
 929 =cut
 930 */
 931 bool
 932 Perl_av_exists(pTHX_ AV *av, I32 key)
 933 {
 934     dVAR;
 935     PERL_ARGS_ASSERT_AV_EXISTS;
 936     assert(SvTYPE(av) == SVt_PVAV);
 937
 938     if (SvRMAGICAL(av)) {
 939         const MAGIC * const tied_magic = mg_find((SV*)av, PERL_MAGIC_tied);
 940         if (tied_magic || mg_find((SV*)av, PERL_MAGIC_regdata)) {
 941             SV * const sv = sv_newmortal();
 942             MAGIC *mg;
 943             /* Handle negative array indices 20020222 MJD */
 944             if (key < 0) {
 945                 unsigned adjust_index = 1;
 946                 if (tied_magic) {
 947                     SV * const * const negative_indices_glob =
 948                         hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *)av,
 949                                                          tied_magic))),
 950                                  NEGATIVE_INDICES_VAR, 16, 0);
 951                     if (negative_indices_glob
 952                         && SvTRUE(GvSV(*negative_indices_glob)))
 953                         adjust_index = 0;
 954                 }
 955                 if (adjust_index) {
 956                     key += AvFILL(av) + 1;
 957                     if (key < 0)
 958                         return FALSE;
 959                 }
 960             }
 961
 962             mg_copy((SV*)av, sv, 0, key);
 963             mg = mg_find(sv, PERL_MAGIC_tiedelem);
 964             if (mg) {
 965                 magic_existspack(sv, mg);
 966                 return (bool)SvTRUE(sv);
 967             }
 968
 969         }
 970     }
 971
 972     if (key < 0) {
 973         key += AvFILL(av) + 1;
 974         if (key < 0)
 975             return FALSE;
 976     }
 977
 978     if (key <= AvFILLp(av) && AvARRAY(av)[key] != &PL_sv_undef
 979         && AvARRAY(av)[key])
 980     {
 981         return TRUE;
 982     }
 983     else
 984         return FALSE;
 985 }
 986
 987 static MAGIC *
 988 S_get_aux_mg(pTHX_ AV *av) {
 989     dVAR;
 990     MAGIC *mg;
 991
 992     PERL_ARGS_ASSERT_GET_AUX_MG;
 993     assert(SvTYPE(av) == SVt_PVAV);
 994
 995     mg = mg_find((SV*)av, PERL_MAGIC_arylen_p);
 996
 997     if (!mg) {
 998         mg = sv_magicext((SV*)av, 0, PERL_MAGIC_arylen_p, &PL_vtbl_arylen_p,
 999                          0, 0);
1000         assert(mg);
1001         /* sv_magicext won't set this for us because we pass in a NULL obj  */
1002         mg->mg_flags |= MGf_REFCOUNTED;
1003     }
1004     return mg;
1005 }
1006
1007 SV **
1008 Perl_av_arylen_p(pTHX_ AV *av) {
1009     MAGIC *const mg = get_aux_mg(av);
1010
1011     PERL_ARGS_ASSERT_AV_ARYLEN_P;
1012     assert(SvTYPE(av) == SVt_PVAV);
1013
1014     return &(mg->mg_obj);
1015 }
1016
1017 IV *
1018 Perl_av_iter_p(pTHX_ AV *av) {
1019     MAGIC *const mg = get_aux_mg(av);
1020
1021     PERL_ARGS_ASSERT_AV_ITER_P;
1022     assert(SvTYPE(av) == SVt_PVAV);
1023
1024 #if IVSIZE == I32SIZE
1025     return (IV *)&(mg->mg_len);
1026 #else
1027     if (!mg->mg_ptr) {
1028         IV *temp;
1029         mg->mg_len = IVSIZE;
1030         Newxz(temp, 1, IV);
1031         mg->mg_ptr = (char *) temp;
1032     }
1033     return (IV *)mg->mg_ptr;
1034 #endif
1035 }
1036
1037 /*
1038  * Local variables:
1039  * c-indentation-style: bsd
1040  * c-basic-offset: 4
1041  * indent-tabs-mode: t
1042  * End:
1043  *
1044  * ex: set ts=8 sts=4 sw=4 noet:
1045  */