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             AvARRAY(av) = 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             AvARRAY(av) = 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     AvARRAY(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         AvARRAY(av) = ary;
 398         AvFILLp(av) = AvMAX(av) = size - 1;
 399         for (i = 0; i < size; i++) {
 400             assert (*strp);
 401             ary[i] = newSV(0);
 402             sv_setsv(ary[i], *strp);
 403             strp++;
 404         }
 405     }
 406     return av;
 407 }
 408
 409 /*
 410 =for apidoc av_clear
 411
 412 Clears an array, making it empty.  Does not free the memory used by the
 413 array itself.
 414
 415 =cut
 416 */
 417
 418 void
 419 Perl_av_clear(pTHX_ register AV *av)
 420 {
 421     dVAR;
 422     I32 extra;
 423
 424     assert(av);
 425 #ifdef DEBUGGING
 426     if (SvREFCNT(av) == 0 && ckWARN_d(WARN_DEBUGGING)) {
 427         Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "Attempt to clear deleted array");
 428     }
 429 #endif
 430
 431     if (SvREADONLY(av))
 432         Perl_croak(aTHX_ PL_no_modify);
 433
 434     /* Give any tie a chance to cleanup first */
 435     if (SvRMAGICAL(av))
 436         mg_clear((SV*)av);
 437
 438     if (AvMAX(av) < 0)
 439         return;
 440
 441     if (AvREAL(av)) {
 442         SV** const ary = AvARRAY(av);
 443         I32 index = AvFILLp(av) + 1;
 444         while (index) {
 445             SV * const sv = ary[--index];
 446             /* undef the slot before freeing the value, because a
 447              * destructor might try to modify this array */
 448             ary[index] = &PL_sv_undef;
 449             SvREFCNT_dec(sv);
 450         }
 451     }
 452     extra = AvARRAY(av) - AvALLOC(av);
 453     if (extra) {
 454         AvMAX(av) += extra;
 455         AvARRAY(av) = AvALLOC(av);
 456     }
 457     AvFILLp(av) = -1;
 458
 459 }
 460
 461 /*
 462 =for apidoc av_undef
 463
 464 Undefines the array.  Frees the memory used by the array itself.
 465
 466 =cut
 467 */
 468
 469 void
 470 Perl_av_undef(pTHX_ register AV *av)
 471 {
 472     assert(av);
 473
 474     /* Give any tie a chance to cleanup first */
 475     if (SvTIED_mg((SV*)av, PERL_MAGIC_tied))
 476         av_fill(av, -1);   /* mg_clear() ? */
 477
 478     if (AvREAL(av)) {
 479         register I32 key = AvFILLp(av) + 1;
 480         while (key)
 481             SvREFCNT_dec(AvARRAY(av)[--key]);
 482     }
 483     Safefree(AvALLOC(av));
 484     AvALLOC(av) = NULL;
 485     AvARRAY(av) = NULL;
 486     AvMAX(av) = AvFILLp(av) = -1;
 487 }
 488
 489 /*
 490 =for apidoc av_push
 491
 492 Pushes an SV onto the end of the array.  The array will grow automatically
 493 to accommodate the addition.
 494
 495 =cut
 496 */
 497
 498 void
 499 Perl_av_push(pTHX_ register AV *av, SV *val)
 500 {
 501     dVAR;
 502     MAGIC *mg;
 503     assert(av);
 504
 505     if (SvREADONLY(av))
 506         Perl_croak(aTHX_ PL_no_modify);
 507
 508     if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
 509         dSP;
 510         PUSHSTACKi(PERLSI_MAGIC);
 511         PUSHMARK(SP);
 512         EXTEND(SP,2);
 513         PUSHs(SvTIED_obj((SV*)av, mg));
 514         PUSHs(val);
 515         PUTBACK;
 516         ENTER;
 517         call_method("PUSH", G_SCALAR|G_DISCARD);
 518         LEAVE;
 519         POPSTACK;
 520         return;
 521     }
 522     av_store(av,AvFILLp(av)+1,val);
 523 }
 524
 525 /*
 526 =for apidoc av_pop
 527
 528 Pops an SV off the end of the array.  Returns C<&PL_sv_undef> if the array
 529 is empty.
 530
 531 =cut
 532 */
 533
 534 SV *
 535 Perl_av_pop(pTHX_ register AV *av)
 536 {
 537     dVAR;
 538     SV *retval;
 539     MAGIC* mg;
 540
 541     assert(av);
 542
 543     if (SvREADONLY(av))
 544         Perl_croak(aTHX_ PL_no_modify);
 545     if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
 546         dSP;
 547         PUSHSTACKi(PERLSI_MAGIC);
 548         PUSHMARK(SP);
 549         XPUSHs(SvTIED_obj((SV*)av, mg));
 550         PUTBACK;
 551         ENTER;
 552         if (call_method("POP", G_SCALAR)) {
 553             retval = newSVsv(*PL_stack_sp--);
 554         } else {
 555             retval = &PL_sv_undef;
 556         }
 557         LEAVE;
 558         POPSTACK;
 559         return retval;
 560     }
 561     if (AvFILL(av) < 0)
 562         return &PL_sv_undef;
 563     retval = AvARRAY(av)[AvFILLp(av)];
 564     AvARRAY(av)[AvFILLp(av)--] = &PL_sv_undef;
 565     if (SvSMAGICAL(av))
 566         mg_set((SV*)av);
 567     return retval;
 568 }
 569
 570 /*
 571 =for apidoc av_unshift
 572
 573 Unshift the given number of C<undef> values onto the beginning of the
 574 array.  The array will grow automatically to accommodate the addition.  You
 575 must then use C<av_store> to assign values to these new elements.
 576
 577 =cut
 578 */
 579
 580 void
 581 Perl_av_unshift(pTHX_ register AV *av, register I32 num)
 582 {
 583     dVAR;
 584     register I32 i;
 585     MAGIC* mg;
 586
 587     assert(av);
 588
 589     if (SvREADONLY(av))
 590         Perl_croak(aTHX_ PL_no_modify);
 591
 592     if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
 593         dSP;
 594         PUSHSTACKi(PERLSI_MAGIC);
 595         PUSHMARK(SP);
 596         EXTEND(SP,1+num);
 597         PUSHs(SvTIED_obj((SV*)av, mg));
 598         while (num-- > 0) {
 599             PUSHs(&PL_sv_undef);
 600         }
 601         PUTBACK;
 602         ENTER;
 603         call_method("UNSHIFT", G_SCALAR|G_DISCARD);
 604         LEAVE;
 605         POPSTACK;
 606         return;
 607     }
 608
 609     if (num <= 0)
 610       return;
 611     if (!AvREAL(av) && AvREIFY(av))
 612         av_reify(av);
 613     i = AvARRAY(av) - AvALLOC(av);
 614     if (i) {
 615         if (i > num)
 616             i = num;
 617         num -= i;
 618
 619         AvMAX(av) += i;
 620         AvFILLp(av) += i;
 621         AvARRAY(av) = AvARRAY(av) - i;
 622     }
 623     if (num) {
 624         register SV **ary;
 625         I32 slide;
 626         i = AvFILLp(av);
 627         /* Create extra elements */
 628         slide = i > 0 ? i : 0;
 629         num += slide;
 630         av_extend(av, i + num);
 631         AvFILLp(av) += num;
 632         ary = AvARRAY(av);
 633         Move(ary, ary + num, i + 1, SV*);
 634         do {
 635             ary[--num] = &PL_sv_undef;
 636         } while (num);
 637         /* Make extra elements into a buffer */
 638         AvMAX(av) -= slide;
 639         AvFILLp(av) -= slide;
 640         AvARRAY(av) = AvARRAY(av) + slide;
 641     }
 642 }
 643
 644 /*
 645 =for apidoc av_shift
 646
 647 Shifts an SV off the beginning of the array.
 648
 649 =cut
 650 */
 651
 652 SV *
 653 Perl_av_shift(pTHX_ register AV *av)
 654 {
 655     dVAR;
 656     SV *retval;
 657     MAGIC* mg;
 658
 659     assert(av);
 660
 661     if (SvREADONLY(av))
 662         Perl_croak(aTHX_ PL_no_modify);
 663     if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
 664         dSP;
 665         PUSHSTACKi(PERLSI_MAGIC);
 666         PUSHMARK(SP);
 667         XPUSHs(SvTIED_obj((SV*)av, mg));
 668         PUTBACK;
 669         ENTER;
 670         if (call_method("SHIFT", G_SCALAR)) {
 671             retval = newSVsv(*PL_stack_sp--);
 672         } else {
 673             retval = &PL_sv_undef;
 674         }
 675         LEAVE;
 676         POPSTACK;
 677         return retval;
 678     }
 679     if (AvFILL(av) < 0)
 680       return &PL_sv_undef;
 681     retval = *AvARRAY(av);
 682     if (AvREAL(av))
 683         *AvARRAY(av) = &PL_sv_undef;
 684     AvARRAY(av) = AvARRAY(av) + 1;
 685     AvMAX(av)--;
 686     AvFILLp(av)--;
 687     if (SvSMAGICAL(av))
 688         mg_set((SV*)av);
 689     return retval;
 690 }
 691
 692 /*
 693 =for apidoc av_len
 694
 695 Returns the highest index in the array.  The number of elements in the
 696 array is C<av_len(av) + 1>.  Returns -1 if the array is empty.
 697
 698 =cut
 699 */
 700
 701 I32
 702 Perl_av_len(pTHX_ register const AV *av)
 703 {
 704     assert(av);
 705     return AvFILL(av);
 706 }
 707
 708 /*
 709 =for apidoc av_fill
 710
 711 Set the highest index in the array to the given number, equivalent to
 712 Perl's C<$#array = $fill;>.
 713
 714 The number of elements in the an array will be C<fill + 1> after
 715 av_fill() returns.  If the array was previously shorter then the
 716 additional elements appended are set to C<PL_sv_undef>.  If the array
 717 was longer, then the excess elements are freed.  C<av_fill(av, -1)> is
 718 the same as C<av_clear(av)>.
 719
 720 =cut
 721 */
 722 void
 723 Perl_av_fill(pTHX_ register AV *av, I32 fill)
 724 {
 725     dVAR;
 726     MAGIC *mg;
 727
 728     assert(av);
 729
 730     if (fill < 0)
 731         fill = -1;
 732     if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
 733         dSP;
 734         ENTER;
 735         SAVETMPS;
 736         PUSHSTACKi(PERLSI_MAGIC);
 737         PUSHMARK(SP);
 738         EXTEND(SP,2);
 739         PUSHs(SvTIED_obj((SV*)av, mg));
 740         PUSHs(sv_2mortal(newSViv(fill+1)));
 741         PUTBACK;
 742         call_method("STORESIZE", G_SCALAR|G_DISCARD);
 743         POPSTACK;
 744         FREETMPS;
 745         LEAVE;
 746         return;
 747     }
 748     if (fill <= AvMAX(av)) {
 749         I32 key = AvFILLp(av);
 750         SV** const ary = AvARRAY(av);
 751
 752         if (AvREAL(av)) {
 753             while (key > fill) {
 754                 SvREFCNT_dec(ary[key]);
 755                 ary[key--] = &PL_sv_undef;
 756             }
 757         }
 758         else {
 759             while (key < fill)
 760                 ary[++key] = &PL_sv_undef;
 761         }
 762
 763         AvFILLp(av) = fill;
 764         if (SvSMAGICAL(av))
 765             mg_set((SV*)av);
 766     }
 767     else
 768         (void)av_store(av,fill,&PL_sv_undef);
 769 }
 770
 771 /*
 772 =for apidoc av_delete
 773
 774 Deletes the element indexed by C<key> from the array.  Returns the
 775 deleted element. If C<flags> equals C<G_DISCARD>, the element is freed
 776 and null is returned.
 777
 778 =cut
 779 */
 780 SV *
 781 Perl_av_delete(pTHX_ AV *av, I32 key, I32 flags)
 782 {
 783     dVAR;
 784     SV *sv;
 785
 786     assert(av);
 787
 788     if (SvREADONLY(av))
 789         Perl_croak(aTHX_ PL_no_modify);
 790
 791     if (SvRMAGICAL(av)) {
 792         const MAGIC * const tied_magic = mg_find((SV*)av, PERL_MAGIC_tied);
 793         if ((tied_magic || mg_find((SV*)av, PERL_MAGIC_regdata))) {
 794             /* Handle negative array indices 20020222 MJD */
 795             SV **svp;
 796             if (key < 0) {
 797                 unsigned adjust_index = 1;
 798                 if (tied_magic) {
 799                     SV * const * const negative_indices_glob =
 800                         hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *)av,
 801                                                          tied_magic))),
 802                                  NEGATIVE_INDICES_VAR, 16, 0);
 803                     if (negative_indices_glob
 804                         && SvTRUE(GvSV(*negative_indices_glob)))
 805                         adjust_index = 0;
 806                 }
 807                 if (adjust_index) {
 808                     key += AvFILL(av) + 1;
 809                     if (key < 0)
 810                         return NULL;
 811                 }
 812             }
 813             svp = av_fetch(av, key, TRUE);
 814             if (svp) {
 815                 sv = *svp;
 816                 mg_clear(sv);
 817                 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
 818                     sv_unmagic(sv, PERL_MAGIC_tiedelem); /* No longer an element */
 819                     return sv;
 820                 }
 821                 return NULL;
 822             }
 823         }
 824     }
 825
 826     if (key < 0) {
 827         key += AvFILL(av) + 1;
 828         if (key < 0)
 829             return NULL;
 830     }
 831
 832     if (key > AvFILLp(av))
 833         return NULL;
 834     else {
 835         if (!AvREAL(av) && AvREIFY(av))
 836             av_reify(av);
 837         sv = AvARRAY(av)[key];
 838         if (key == AvFILLp(av)) {
 839             AvARRAY(av)[key] = &PL_sv_undef;
 840             do {
 841                 AvFILLp(av)--;
 842             } while (--key >= 0 && AvARRAY(av)[key] == &PL_sv_undef);
 843         }
 844         else
 845             AvARRAY(av)[key] = &PL_sv_undef;
 846         if (SvSMAGICAL(av))
 847             mg_set((SV*)av);
 848     }
 849     if (flags & G_DISCARD) {
 850         SvREFCNT_dec(sv);
 851         sv = NULL;
 852     }
 853     else if (AvREAL(av))
 854         sv = sv_2mortal(sv);
 855     return sv;
 856 }
 857
 858 /*
 859 =for apidoc av_exists
 860
 861 Returns true if the element indexed by C<key> has been initialized.
 862
 863 This relies on the fact that uninitialized array elements are set to
 864 C<&PL_sv_undef>.
 865
 866 =cut
 867 */
 868 bool
 869 Perl_av_exists(pTHX_ AV *av, I32 key)
 870 {
 871     dVAR;
 872     assert(av);
 873
 874     if (SvRMAGICAL(av)) {
 875         const MAGIC * const tied_magic = mg_find((SV*)av, PERL_MAGIC_tied);
 876         if (tied_magic || mg_find((SV*)av, PERL_MAGIC_regdata)) {
 877             SV * const sv = sv_newmortal();
 878             MAGIC *mg;
 879             /* Handle negative array indices 20020222 MJD */
 880             if (key < 0) {
 881                 unsigned adjust_index = 1;
 882                 if (tied_magic) {
 883                     SV * const * const negative_indices_glob =
 884                         hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *)av,
 885                                                          tied_magic))),
 886                                  NEGATIVE_INDICES_VAR, 16, 0);
 887                     if (negative_indices_glob
 888                         && SvTRUE(GvSV(*negative_indices_glob)))
 889                         adjust_index = 0;
 890                 }
 891                 if (adjust_index) {
 892                     key += AvFILL(av) + 1;
 893                     if (key < 0)
 894                         return FALSE;
 895                 }
 896             }
 897
 898             mg_copy((SV*)av, sv, 0, key);
 899             mg = mg_find(sv, PERL_MAGIC_tiedelem);
 900             if (mg) {
 901                 magic_existspack(sv, mg);
 902                 return (bool)SvTRUE(sv);
 903             }
 904
 905         }
 906     }
 907
 908     if (key < 0) {
 909         key += AvFILL(av) + 1;
 910         if (key < 0)
 911             return FALSE;
 912     }
 913
 914     if (key <= AvFILLp(av) && AvARRAY(av)[key] != &PL_sv_undef
 915         && AvARRAY(av)[key])
 916     {
 917         return TRUE;
 918     }
 919     else
 920         return FALSE;
 921 }
 922
 923 SV **
 924 Perl_av_arylen_p(pTHX_ AV *av) {
 925     dVAR;
 926     MAGIC *mg;
 927
 928     assert(av);
 929
 930     mg = mg_find((SV*)av, PERL_MAGIC_arylen_p);
 931
 932     if (!mg) {
 933         mg = sv_magicext((SV*)av, 0, PERL_MAGIC_arylen_p, &PL_vtbl_arylen_p,
 934                          0, 0);
 935         assert(mg);
 936         /* sv_magicext won't set this for us because we pass in a NULL obj  */
 937         mg->mg_flags |= MGf_REFCOUNTED;
 938     }
 939     return &(mg->mg_obj);
 940 }
 941
 942 /*
 943  * Local variables:
 944  * c-indentation-style: bsd
 945  * c-basic-offset: 4
 946  * indent-tabs-mode: t
 947  * End:
 948  *
 949  * ex: set ts=8 sts=4 sw=4 noet:
 950  */