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, 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     assert(av);
  31
  32     if (AvREAL(av))
  33         return;
  34 #ifdef DEBUGGING
  35     if (SvTIED_mg((SV*)av, PERL_MAGIC_tied) && ckWARN_d(WARN_DEBUGGING))
  36         Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "av_reify called on tied array");
  37 #endif
  38     key = AvMAX(av) + 1;
  39     while (key > AvFILLp(av) + 1)
  40         AvARRAY(av)[--key] = &PL_sv_undef;
  41     while (key) {
  42         SV * const sv = AvARRAY(av)[--key];
  43         assert(sv);
  44         if (sv != &PL_sv_undef)
  45             SvREFCNT_inc_simple_void_NN(sv);
  46     }
  47     key = AvARRAY(av) - AvALLOC(av);
  48     while (key)
  49         AvALLOC(av)[--key] = &PL_sv_undef;
  50     AvREIFY_off(av);
  51     AvREAL_on(av);
  52 }
  53
  54 /*
  55 =for apidoc av_extend
  56
  57 Pre-extend an array.  The C<key> is the index to which the array should be
  58 extended.
  59
  60 =cut
  61 */
  62
  63 void
  64 Perl_av_extend(pTHX_ AV *av, I32 key)
  65 {
  66     dVAR;
  67     MAGIC *mg;
  68
  69     assert(av);
  70
  71     mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied);
  72     if (mg) {
  73         dSP;
  74         ENTER;
  75         SAVETMPS;
  76         PUSHSTACKi(PERLSI_MAGIC);
  77         PUSHMARK(SP);
  78         EXTEND(SP,2);
  79         PUSHs(SvTIED_obj((SV*)av, mg));
  80         PUSHs(sv_2mortal(newSViv(key+1)));
  81         PUTBACK;
  82         call_method("EXTEND", G_SCALAR|G_DISCARD);
  83         POPSTACK;
  84         FREETMPS;
  85         LEAVE;
  86         return;
  87     }
  88     if (key > AvMAX(av)) {
  89         SV** ary;
  90         I32 tmp;
  91         I32 newmax;
  92
  93         if (AvALLOC(av) != AvARRAY(av)) {
  94             ary = AvALLOC(av) + AvFILLp(av) + 1;
  95             tmp = AvARRAY(av) - AvALLOC(av);
  96             Move(AvARRAY(av), AvALLOC(av), AvFILLp(av)+1, SV*);
  97             AvMAX(av) += tmp;
  98             SvPV_set(av, (char*)AvALLOC(av));
  99             if (AvREAL(av)) {
 100                 while (tmp)
 101                     ary[--tmp] = &PL_sv_undef;
 102             }
 103             if (key > AvMAX(av) - 10) {
 104                 newmax = key + AvMAX(av);
 105                 goto resize;
 106             }
 107         }
 108         else {
 109 #ifdef PERL_MALLOC_WRAP
 110             static const char oom_array_extend[] =
 111               "Out of memory during array extend"; /* Duplicated in pp_hot.c */
 112 #endif
 113
 114             if (AvALLOC(av)) {
 115 #if !defined(STRANGE_MALLOC) && !defined(MYMALLOC)
 116                 MEM_SIZE bytes;
 117                 IV itmp;
 118 #endif
 119
 120 #ifdef MYMALLOC
 121                 newmax = malloced_size((void*)AvALLOC(av))/sizeof(SV*) - 1;
 122
 123                 if (key <= newmax)
 124                     goto resized;
 125 #endif
 126                 newmax = key + AvMAX(av) / 5;
 127               resize:
 128                 MEM_WRAP_CHECK_1(newmax+1, SV*, oom_array_extend);
 129 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
 130                 Renew(AvALLOC(av),newmax+1, SV*);
 131 #else
 132                 bytes = (newmax + 1) * sizeof(SV*);
 133 #define MALLOC_OVERHEAD 16
 134                 itmp = MALLOC_OVERHEAD;
 135                 while ((MEM_SIZE)(itmp - MALLOC_OVERHEAD) < bytes)
 136                     itmp += itmp;
 137                 itmp -= MALLOC_OVERHEAD;
 138                 itmp /= sizeof(SV*);
 139                 assert(itmp > newmax);
 140                 newmax = itmp - 1;
 141                 assert(newmax >= AvMAX(av));
 142                 Newx(ary, newmax+1, SV*);
 143                 Copy(AvALLOC(av), ary, AvMAX(av)+1, SV*);
 144                 if (AvMAX(av) > 64)
 145                     offer_nice_chunk(AvALLOC(av), (AvMAX(av)+1) * sizeof(SV*));
 146                 else
 147                     Safefree(AvALLOC(av));
 148                 AvALLOC(av) = ary;
 149 #endif
 150 #ifdef MYMALLOC
 151               resized:
 152 #endif
 153                 ary = AvALLOC(av) + AvMAX(av) + 1;
 154                 tmp = newmax - AvMAX(av);
 155                 if (av == PL_curstack) {        /* Oops, grew stack (via av_store()?) */
 156                     PL_stack_sp = AvALLOC(av) + (PL_stack_sp - PL_stack_base);
 157                     PL_stack_base = AvALLOC(av);
 158                     PL_stack_max = PL_stack_base + newmax;
 159                 }
 160             }
 161             else {
 162                 newmax = key < 3 ? 3 : key;
 163                 MEM_WRAP_CHECK_1(newmax+1, SV*, oom_array_extend);
 164                 Newx(AvALLOC(av), newmax+1, SV*);
 165                 ary = AvALLOC(av) + 1;
 166                 tmp = newmax;
 167                 AvALLOC(av)[0] = &PL_sv_undef;  /* For the stacks */
 168             }
 169             if (AvREAL(av)) {
 170                 while (tmp)
 171                     ary[--tmp] = &PL_sv_undef;
 172             }
 173
 174             SvPV_set(av, (char*)AvALLOC(av));
 175             AvMAX(av) = newmax;
 176         }
 177     }
 178 }
 179
 180 /*
 181 =for apidoc av_fetch
 182
 183 Returns the SV at the specified index in the array.  The C<key> is the
 184 index.  If C<lval> is set then the fetch will be part of a store.  Check
 185 that the return value is non-null before dereferencing it to a C<SV*>.
 186
 187 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
 188 more information on how to use this function on tied arrays.
 189
 190 =cut
 191 */
 192
 193 SV**
 194 Perl_av_fetch(pTHX_ register AV *av, I32 key, I32 lval)
 195 {
 196     dVAR;
 197
 198     assert(av);
 199
 200     if (SvRMAGICAL(av)) {
 201         const MAGIC * const tied_magic = mg_find((SV*)av, PERL_MAGIC_tied);
 202         if (tied_magic || mg_find((SV*)av, PERL_MAGIC_regdata)) {
 203             SV *sv;
 204             if (key < 0) {
 205                 I32 adjust_index = 1;
 206                 if (tied_magic) {
 207                     /* Handle negative array indices 20020222 MJD */
 208                     SV * const * const negative_indices_glob =
 209                         hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *)av, tied_magic))),
 210                                 NEGATIVE_INDICES_VAR, 16, 0);
 211
 212                     if (negative_indices_glob && SvTRUE(GvSV(*negative_indices_glob)))
 213                         adjust_index = 0;
 214                 }
 215
 216                 if (adjust_index) {
 217                     key += AvFILL(av) + 1;
 218                     if (key < 0)
 219                         return NULL;
 220                 }
 221             }
 222
 223             sv = sv_newmortal();
 224             sv_upgrade(sv, SVt_PVLV);
 225             mg_copy((SV*)av, sv, 0, key);
 226             LvTYPE(sv) = 't';
 227             LvTARG(sv) = sv; /* fake (SV**) */
 228             return &(LvTARG(sv));
 229         }
 230     }
 231
 232     if (key < 0) {
 233         key += AvFILL(av) + 1;
 234         if (key < 0)
 235             return NULL;
 236     }
 237
 238     if (key > AvFILLp(av)) {
 239         if (!lval)
 240             return NULL;
 241         return av_store(av,key,newSV(0));
 242     }
 243     if (AvARRAY(av)[key] == &PL_sv_undef) {
 244     emptyness:
 245         if (lval)
 246             return av_store(av,key,newSV(0));
 247         return NULL;
 248     }
 249     else if (AvREIFY(av)
 250              && (!AvARRAY(av)[key]      /* eg. @_ could have freed elts */
 251                  || SvIS_FREED(AvARRAY(av)[key]))) {
 252         AvARRAY(av)[key] = &PL_sv_undef;        /* 1/2 reify */
 253         goto emptyness;
 254     }
 255     return &AvARRAY(av)[key];
 256 }
 257
 258 /*
 259 =for apidoc av_store
 260
 261 Stores an SV in an array.  The array index is specified as C<key>.  The
 262 return value will be NULL if the operation failed or if the value did not
 263 need to be actually stored within the array (as in the case of tied
 264 arrays). Otherwise it can be dereferenced to get the original C<SV*>.  Note
 265 that the caller is responsible for suitably incrementing the reference
 266 count of C<val> before the call, and decrementing it if the function
 267 returned NULL.
 268
 269 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
 270 more information on how to use this function on tied arrays.
 271
 272 =cut
 273 */
 274
 275 SV**
 276 Perl_av_store(pTHX_ register AV *av, I32 key, SV *val)
 277 {
 278     dVAR;
 279     SV** ary;
 280
 281     assert(av);
 282
 283     /* S_regclass relies on being able to pass in a NULL sv
 284        (unicode_alternate may be NULL).
 285     */
 286
 287     if (!val)
 288         val = &PL_sv_undef;
 289
 290     if (SvRMAGICAL(av)) {
 291         const MAGIC * const tied_magic = mg_find((SV*)av, PERL_MAGIC_tied);
 292         if (tied_magic) {
 293             /* Handle negative array indices 20020222 MJD */
 294             if (key < 0) {
 295                 bool adjust_index = 1;
 296                 SV * const * const negative_indices_glob =
 297                     hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *)av,
 298                                                      tied_magic))),
 299                              NEGATIVE_INDICES_VAR, 16, 0);
 300                 if (negative_indices_glob
 301                     && SvTRUE(GvSV(*negative_indices_glob)))
 302                     adjust_index = 0;
 303                 if (adjust_index) {
 304                     key += AvFILL(av) + 1;
 305                     if (key < 0)
 306                         return 0;
 307                 }
 308             }
 309             if (val != &PL_sv_undef) {
 310                 mg_copy((SV*)av, val, 0, key);
 311             }
 312             return NULL;
 313         }
 314     }
 315
 316
 317     if (key < 0) {
 318         key += AvFILL(av) + 1;
 319         if (key < 0)
 320             return NULL;
 321     }
 322
 323     if (SvREADONLY(av) && key >= AvFILL(av))
 324         Perl_croak(aTHX_ PL_no_modify);
 325
 326     if (!AvREAL(av) && AvREIFY(av))
 327         av_reify(av);
 328     if (key > AvMAX(av))
 329         av_extend(av,key);
 330     ary = AvARRAY(av);
 331     if (AvFILLp(av) < key) {
 332         if (!AvREAL(av)) {
 333             if (av == PL_curstack && key > PL_stack_sp - PL_stack_base)
 334                 PL_stack_sp = PL_stack_base + key;      /* XPUSH in disguise */
 335             do {
 336                 ary[++AvFILLp(av)] = &PL_sv_undef;
 337             } while (AvFILLp(av) < key);
 338         }
 339         AvFILLp(av) = key;
 340     }
 341     else if (AvREAL(av))
 342         SvREFCNT_dec(ary[key]);
 343     ary[key] = val;
 344     if (SvSMAGICAL(av)) {
 345         if (val != &PL_sv_undef) {
 346             const MAGIC* const mg = SvMAGIC(av);
 347             sv_magic(val, (SV*)av, toLOWER(mg->mg_type), 0, key);
 348         }
 349         mg_set((SV*)av);
 350     }
 351     return &ary[key];
 352 }
 353
 354 /*
 355 =for apidoc newAV
 356
 357 Creates a new AV.  The reference count is set to 1.
 358
 359 =cut
 360 */
 361
 362 AV *
 363 Perl_newAV(pTHX)
 364 {
 365     register AV * const av = (AV*)newSV(0);
 366
 367     sv_upgrade((SV *)av, SVt_PVAV);
 368     /* sv_upgrade does AvREAL_only()  */
 369     AvALLOC(av) = 0;
 370     SvPV_set(av, NULL);
 371     AvMAX(av) = AvFILLp(av) = -1;
 372     return av;
 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(0);
 389
 390     sv_upgrade((SV *) av,SVt_PVAV);
 391     /* sv_upgrade does AvREAL_only()  */
 392     if (size) {         /* "defined" was returning undef for size==0 anyway. */
 393         register SV** ary;
 394         register I32 i;
 395         Newx(ary,size,SV*);
 396         AvALLOC(av) = ary;
 397         SvPV_set(av, (char*)ary);
 398         AvFILLp(av) = size - 1;
 399         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     assert(av);
 426 #ifdef DEBUGGING
 427     if (SvREFCNT(av) == 0 && ckWARN_d(WARN_DEBUGGING)) {
 428         Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "Attempt to clear deleted array");
 429     }
 430 #endif
 431
 432     if (SvREADONLY(av))
 433         Perl_croak(aTHX_ PL_no_modify);
 434
 435     /* Give any tie a chance to cleanup first */
 436     if (SvRMAGICAL(av))
 437         mg_clear((SV*)av);
 438
 439     if (AvMAX(av) < 0)
 440         return;
 441
 442     if (AvREAL(av)) {
 443         SV** const ary = AvARRAY(av);
 444         I32 index = AvFILLp(av) + 1;
 445         while (index) {
 446             SV * const sv = ary[--index];
 447             /* undef the slot before freeing the value, because a
 448              * destructor might try to modify this array */
 449             ary[index] = &PL_sv_undef;
 450             SvREFCNT_dec(sv);
 451         }
 452     }
 453     extra = AvARRAY(av) - AvALLOC(av);
 454     if (extra) {
 455         AvMAX(av) += extra;
 456         SvPV_set(av, (char*)AvALLOC(av));
 457     }
 458     AvFILLp(av) = -1;
 459
 460 }
 461
 462 /*
 463 =for apidoc av_undef
 464
 465 Undefines the array.  Frees the memory used by the array itself.
 466
 467 =cut
 468 */
 469
 470 void
 471 Perl_av_undef(pTHX_ register AV *av)
 472 {
 473     assert(av);
 474
 475     /* Give any tie a chance to cleanup first */
 476     if (SvTIED_mg((SV*)av, PERL_MAGIC_tied))
 477         av_fill(av, -1);   /* mg_clear() ? */
 478
 479     if (AvREAL(av)) {
 480         register I32 key = AvFILLp(av) + 1;
 481         while (key)
 482             SvREFCNT_dec(AvARRAY(av)[--key]);
 483     }
 484     Safefree(AvALLOC(av));
 485     AvALLOC(av) = 0;
 486     SvPV_set(av, NULL);
 487     AvMAX(av) = AvFILLp(av) = -1;
 488 }
 489
 490 /*
 491 =for apidoc av_push
 492
 493 Pushes an SV onto the end of the array.  The array will grow automatically
 494 to accommodate the addition.
 495
 496 =cut
 497 */
 498
 499 void
 500 Perl_av_push(pTHX_ register AV *av, SV *val)
 501 {
 502     dVAR;
 503     MAGIC *mg;
 504     assert(av);
 505
 506     if (SvREADONLY(av))
 507         Perl_croak(aTHX_ PL_no_modify);
 508
 509     if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
 510         dSP;
 511         PUSHSTACKi(PERLSI_MAGIC);
 512         PUSHMARK(SP);
 513         EXTEND(SP,2);
 514         PUSHs(SvTIED_obj((SV*)av, mg));
 515         PUSHs(val);
 516         PUTBACK;
 517         ENTER;
 518         call_method("PUSH", G_SCALAR|G_DISCARD);
 519         LEAVE;
 520         POPSTACK;
 521         return;
 522     }
 523     av_store(av,AvFILLp(av)+1,val);
 524 }
 525
 526 /*
 527 =for apidoc av_pop
 528
 529 Pops an SV off the end of the array.  Returns C<&PL_sv_undef> if the array
 530 is empty.
 531
 532 =cut
 533 */
 534
 535 SV *
 536 Perl_av_pop(pTHX_ register AV *av)
 537 {
 538     dVAR;
 539     SV *retval;
 540     MAGIC* mg;
 541
 542     assert(av);
 543
 544     if (SvREADONLY(av))
 545         Perl_croak(aTHX_ PL_no_modify);
 546     if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
 547         dSP;
 548         PUSHSTACKi(PERLSI_MAGIC);
 549         PUSHMARK(SP);
 550         XPUSHs(SvTIED_obj((SV*)av, mg));
 551         PUTBACK;
 552         ENTER;
 553         if (call_method("POP", G_SCALAR)) {
 554             retval = newSVsv(*PL_stack_sp--);
 555         } else {
 556             retval = &PL_sv_undef;
 557         }
 558         LEAVE;
 559         POPSTACK;
 560         return retval;
 561     }
 562     if (AvFILL(av) < 0)
 563         return &PL_sv_undef;
 564     retval = AvARRAY(av)[AvFILLp(av)];
 565     AvARRAY(av)[AvFILLp(av)--] = &PL_sv_undef;
 566     if (SvSMAGICAL(av))
 567         mg_set((SV*)av);
 568     return retval;
 569 }
 570
 571 /*
 572 =for apidoc av_unshift
 573
 574 Unshift the given number of C<undef> values onto the beginning of the
 575 array.  The array will grow automatically to accommodate the addition.  You
 576 must then use C<av_store> to assign values to these new elements.
 577
 578 =cut
 579 */
 580
 581 void
 582 Perl_av_unshift(pTHX_ register AV *av, register I32 num)
 583 {
 584     dVAR;
 585     register I32 i;
 586     MAGIC* mg;
 587
 588     assert(av);
 589
 590     if (SvREADONLY(av))
 591         Perl_croak(aTHX_ PL_no_modify);
 592
 593     if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
 594         dSP;
 595         PUSHSTACKi(PERLSI_MAGIC);
 596         PUSHMARK(SP);
 597         EXTEND(SP,1+num);
 598         PUSHs(SvTIED_obj((SV*)av, mg));
 599         while (num-- > 0) {
 600             PUSHs(&PL_sv_undef);
 601         }
 602         PUTBACK;
 603         ENTER;
 604         call_method("UNSHIFT", G_SCALAR|G_DISCARD);
 605         LEAVE;
 606         POPSTACK;
 607         return;
 608     }
 609
 610     if (num <= 0)
 611       return;
 612     if (!AvREAL(av) && AvREIFY(av))
 613         av_reify(av);
 614     i = AvARRAY(av) - AvALLOC(av);
 615     if (i) {
 616         if (i > num)
 617             i = num;
 618         num -= i;
 619
 620         AvMAX(av) += i;
 621         AvFILLp(av) += i;
 622         SvPV_set(av, (char*)(AvARRAY(av) - i));
 623     }
 624     if (num) {
 625         register SV **ary;
 626         I32 slide;
 627         i = AvFILLp(av);
 628         /* Create extra elements */
 629         slide = i > 0 ? i : 0;
 630         num += slide;
 631         av_extend(av, i + num);
 632         AvFILLp(av) += num;
 633         ary = AvARRAY(av);
 634         Move(ary, ary + num, i + 1, SV*);
 635         do {
 636             ary[--num] = &PL_sv_undef;
 637         } while (num);
 638         /* Make extra elements into a buffer */
 639         AvMAX(av) -= slide;
 640         AvFILLp(av) -= slide;
 641         SvPV_set(av, (char*)(AvARRAY(av) + slide));
 642     }
 643 }
 644
 645 /*
 646 =for apidoc av_shift
 647
 648 Shifts an SV off the beginning of the array.
 649
 650 =cut
 651 */
 652
 653 SV *
 654 Perl_av_shift(pTHX_ register AV *av)
 655 {
 656     dVAR;
 657     SV *retval;
 658     MAGIC* mg;
 659
 660     assert(av);
 661
 662     if (SvREADONLY(av))
 663         Perl_croak(aTHX_ PL_no_modify);
 664     if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
 665         dSP;
 666         PUSHSTACKi(PERLSI_MAGIC);
 667         PUSHMARK(SP);
 668         XPUSHs(SvTIED_obj((SV*)av, mg));
 669         PUTBACK;
 670         ENTER;
 671         if (call_method("SHIFT", G_SCALAR)) {
 672             retval = newSVsv(*PL_stack_sp--);
 673         } else {
 674             retval = &PL_sv_undef;
 675         }
 676         LEAVE;
 677         POPSTACK;
 678         return retval;
 679     }
 680     if (AvFILL(av) < 0)
 681       return &PL_sv_undef;
 682     retval = *AvARRAY(av);
 683     if (AvREAL(av))
 684         *AvARRAY(av) = &PL_sv_undef;
 685     SvPV_set(av, (char*)(AvARRAY(av) + 1));
 686     AvMAX(av)--;
 687     AvFILLp(av)--;
 688     if (SvSMAGICAL(av))
 689         mg_set((SV*)av);
 690     return retval;
 691 }
 692
 693 /*
 694 =for apidoc av_len
 695
 696 Returns the highest index in the array.  Returns -1 if the array is
 697 empty.
 698
 699 =cut
 700 */
 701
 702 I32
 703 Perl_av_len(pTHX_ register const AV *av)
 704 {
 705     assert(av);
 706     return AvFILL(av);
 707 }
 708
 709 /*
 710 =for apidoc av_fill
 711
 712 Ensure than an array has a given number of elements, equivalent to
 713 Perl's C<$#array = $fill;>.
 714
 715 =cut
 716 */
 717 void
 718 Perl_av_fill(pTHX_ register AV *av, I32 fill)
 719 {
 720     dVAR;
 721     MAGIC *mg;
 722
 723     assert(av);
 724
 725     if (fill < 0)
 726         fill = -1;
 727     if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
 728         dSP;
 729         ENTER;
 730         SAVETMPS;
 731         PUSHSTACKi(PERLSI_MAGIC);
 732         PUSHMARK(SP);
 733         EXTEND(SP,2);
 734         PUSHs(SvTIED_obj((SV*)av, mg));
 735         PUSHs(sv_2mortal(newSViv(fill+1)));
 736         PUTBACK;
 737         call_method("STORESIZE", G_SCALAR|G_DISCARD);
 738         POPSTACK;
 739         FREETMPS;
 740         LEAVE;
 741         return;
 742     }
 743     if (fill <= AvMAX(av)) {
 744         I32 key = AvFILLp(av);
 745         SV** const ary = AvARRAY(av);
 746
 747         if (AvREAL(av)) {
 748             while (key > fill) {
 749                 SvREFCNT_dec(ary[key]);
 750                 ary[key--] = &PL_sv_undef;
 751             }
 752         }
 753         else {
 754             while (key < fill)
 755                 ary[++key] = &PL_sv_undef;
 756         }
 757
 758         AvFILLp(av) = fill;
 759         if (SvSMAGICAL(av))
 760             mg_set((SV*)av);
 761     }
 762     else
 763         (void)av_store(av,fill,&PL_sv_undef);
 764 }
 765
 766 /*
 767 =for apidoc av_delete
 768
 769 Deletes the element indexed by C<key> from the array.  Returns the
 770 deleted element. If C<flags> equals C<G_DISCARD>, the element is freed
 771 and null is returned.
 772
 773 =cut
 774 */
 775 SV *
 776 Perl_av_delete(pTHX_ AV *av, I32 key, I32 flags)
 777 {
 778     dVAR;
 779     SV *sv;
 780
 781     assert(av);
 782
 783     if (SvREADONLY(av))
 784         Perl_croak(aTHX_ PL_no_modify);
 785
 786     if (SvRMAGICAL(av)) {
 787         const MAGIC * const tied_magic = mg_find((SV*)av, PERL_MAGIC_tied);
 788         if ((tied_magic || mg_find((SV*)av, PERL_MAGIC_regdata))) {
 789             /* Handle negative array indices 20020222 MJD */
 790             SV **svp;
 791             if (key < 0) {
 792                 unsigned adjust_index = 1;
 793                 if (tied_magic) {
 794                     SV * const * const negative_indices_glob =
 795                         hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *)av,
 796                                                          tied_magic))),
 797                                  NEGATIVE_INDICES_VAR, 16, 0);
 798                     if (negative_indices_glob
 799                         && SvTRUE(GvSV(*negative_indices_glob)))
 800                         adjust_index = 0;
 801                 }
 802                 if (adjust_index) {
 803                     key += AvFILL(av) + 1;
 804                     if (key < 0)
 805                         return NULL;
 806                 }
 807             }
 808             svp = av_fetch(av, key, TRUE);
 809             if (svp) {
 810                 sv = *svp;
 811                 mg_clear(sv);
 812                 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
 813                     sv_unmagic(sv, PERL_MAGIC_tiedelem); /* No longer an element */
 814                     return sv;
 815                 }
 816                 return NULL;
 817             }
 818         }
 819     }
 820
 821     if (key < 0) {
 822         key += AvFILL(av) + 1;
 823         if (key < 0)
 824             return NULL;
 825     }
 826
 827     if (key > AvFILLp(av))
 828         return NULL;
 829     else {
 830         if (!AvREAL(av) && AvREIFY(av))
 831             av_reify(av);
 832         sv = AvARRAY(av)[key];
 833         if (key == AvFILLp(av)) {
 834             AvARRAY(av)[key] = &PL_sv_undef;
 835             do {
 836                 AvFILLp(av)--;
 837             } while (--key >= 0 && AvARRAY(av)[key] == &PL_sv_undef);
 838         }
 839         else
 840             AvARRAY(av)[key] = &PL_sv_undef;
 841         if (SvSMAGICAL(av))
 842             mg_set((SV*)av);
 843     }
 844     if (flags & G_DISCARD) {
 845         SvREFCNT_dec(sv);
 846         sv = NULL;
 847     }
 848     else if (AvREAL(av))
 849         sv = sv_2mortal(sv);
 850     return sv;
 851 }
 852
 853 /*
 854 =for apidoc av_exists
 855
 856 Returns true if the element indexed by C<key> has been initialized.
 857
 858 This relies on the fact that uninitialized array elements are set to
 859 C<&PL_sv_undef>.
 860
 861 =cut
 862 */
 863 bool
 864 Perl_av_exists(pTHX_ AV *av, I32 key)
 865 {
 866     dVAR;
 867     assert(av);
 868
 869     if (SvRMAGICAL(av)) {
 870         const MAGIC * const tied_magic = mg_find((SV*)av, PERL_MAGIC_tied);
 871         if (tied_magic || mg_find((SV*)av, PERL_MAGIC_regdata)) {
 872             SV * const sv = sv_newmortal();
 873             MAGIC *mg;
 874             /* Handle negative array indices 20020222 MJD */
 875             if (key < 0) {
 876                 unsigned adjust_index = 1;
 877                 if (tied_magic) {
 878                     SV * const * const negative_indices_glob =
 879                         hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *)av,
 880                                                          tied_magic))),
 881                                  NEGATIVE_INDICES_VAR, 16, 0);
 882                     if (negative_indices_glob
 883                         && SvTRUE(GvSV(*negative_indices_glob)))
 884                         adjust_index = 0;
 885                 }
 886                 if (adjust_index) {
 887                     key += AvFILL(av) + 1;
 888                     if (key < 0)
 889                         return FALSE;
 890                 }
 891             }
 892
 893             mg_copy((SV*)av, sv, 0, key);
 894             mg = mg_find(sv, PERL_MAGIC_tiedelem);
 895             if (mg) {
 896                 magic_existspack(sv, mg);
 897                 return (bool)SvTRUE(sv);
 898             }
 899
 900         }
 901     }
 902
 903     if (key < 0) {
 904         key += AvFILL(av) + 1;
 905         if (key < 0)
 906             return FALSE;
 907     }
 908
 909     if (key <= AvFILLp(av) && AvARRAY(av)[key] != &PL_sv_undef
 910         && AvARRAY(av)[key])
 911     {
 912         return TRUE;
 913     }
 914     else
 915         return FALSE;
 916 }
 917
 918 SV **
 919 Perl_av_arylen_p(pTHX_ AV *av) {
 920     dVAR;
 921     MAGIC *mg;
 922
 923     assert(av);
 924
 925     mg = mg_find((SV*)av, PERL_MAGIC_arylen_p);
 926
 927     if (!mg) {
 928         mg = sv_magicext((SV*)av, 0, PERL_MAGIC_arylen_p, &PL_vtbl_arylen_p,
 929                          0, 0);
 930         assert(mg);
 931         /* sv_magicext won't set this for us because we pass in a NULL obj  */
 932         mg->mg_flags |= MGf_REFCOUNTED;
 933     }
 934     return &(mg->mg_obj);
 935 }
 936
 937 /*
 938  * Local variables:
 939  * c-indentation-style: bsd
 940  * c-basic-offset: 4
 941  * indent-tabs-mode: t
 942  * End:
 943  *
 944  * ex: set ts=8 sts=4 sw=4 noet:
 945  */