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