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     assert(av);
  66
  67     MAGIC * const mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied);
  68     if (mg) {
  69         dSP;
  70         ENTER;
  71         SAVETMPS;
  72         PUSHSTACKi(PERLSI_MAGIC);
  73         PUSHMARK(SP);
  74         EXTEND(SP,2);
  75         PUSHs(SvTIED_obj((SV*)av, mg));
  76         PUSHs(sv_2mortal(newSViv(key+1)));
  77         PUTBACK;
  78         call_method("EXTEND", G_SCALAR|G_DISCARD);
  79         POPSTACK;
  80         FREETMPS;
  81         LEAVE;
  82         return;
  83     }
  84     if (key > AvMAX(av)) {
  85         SV** ary;
  86         I32 tmp;
  87         I32 newmax;
  88
  89         if (AvALLOC(av) != AvARRAY(av)) {
  90             ary = AvALLOC(av) + AvFILLp(av) + 1;
  91             tmp = AvARRAY(av) - AvALLOC(av);
  92             Move(AvARRAY(av), AvALLOC(av), AvFILLp(av)+1, SV*);
  93             AvMAX(av) += tmp;
  94             SvPV_set(av, (char*)AvALLOC(av));
  95             if (AvREAL(av)) {
  96                 while (tmp)
  97                     ary[--tmp] = &PL_sv_undef;
  98             }
  99             if (key > AvMAX(av) - 10) {
 100                 newmax = key + AvMAX(av);
 101                 goto resize;
 102             }
 103         }
 104         else {
 105 #ifdef PERL_MALLOC_WRAP
 106             static const char oom_array_extend[] =
 107               "Out of memory during array extend"; /* Duplicated in pp_hot.c */
 108 #endif
 109
 110             if (AvALLOC(av)) {
 111 #if !defined(STRANGE_MALLOC) && !defined(MYMALLOC)
 112                 MEM_SIZE bytes;
 113                 IV itmp;
 114 #endif
 115
 116 #ifdef MYMALLOC
 117                 newmax = malloced_size((void*)AvALLOC(av))/sizeof(SV*) - 1;
 118
 119                 if (key <= newmax)
 120                     goto resized;
 121 #endif
 122                 newmax = key + AvMAX(av) / 5;
 123               resize:
 124                 MEM_WRAP_CHECK_1(newmax+1, SV*, oom_array_extend);
 125 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
 126                 Renew(AvALLOC(av),newmax+1, SV*);
 127 #else
 128                 bytes = (newmax + 1) * sizeof(SV*);
 129 #define MALLOC_OVERHEAD 16
 130                 itmp = MALLOC_OVERHEAD;
 131                 while ((MEM_SIZE)(itmp - MALLOC_OVERHEAD) < bytes)
 132                     itmp += itmp;
 133                 itmp -= MALLOC_OVERHEAD;
 134                 itmp /= sizeof(SV*);
 135                 assert(itmp > newmax);
 136                 newmax = itmp - 1;
 137                 assert(newmax >= AvMAX(av));
 138                 Newx(ary, newmax+1, SV*);
 139                 Copy(AvALLOC(av), ary, AvMAX(av)+1, SV*);
 140                 if (AvMAX(av) > 64)
 141                     offer_nice_chunk(AvALLOC(av), (AvMAX(av)+1) * sizeof(SV*));
 142                 else
 143                     Safefree(AvALLOC(av));
 144                 AvALLOC(av) = ary;
 145 #endif
 146 #ifdef MYMALLOC
 147               resized:
 148 #endif
 149                 ary = AvALLOC(av) + AvMAX(av) + 1;
 150                 tmp = newmax - AvMAX(av);
 151                 if (av == PL_curstack) {        /* Oops, grew stack (via av_store()?) */
 152                     PL_stack_sp = AvALLOC(av) + (PL_stack_sp - PL_stack_base);
 153                     PL_stack_base = AvALLOC(av);
 154                     PL_stack_max = PL_stack_base + newmax;
 155                 }
 156             }
 157             else {
 158                 newmax = key < 3 ? 3 : key;
 159                 MEM_WRAP_CHECK_1(newmax+1, SV*, oom_array_extend);
 160                 Newx(AvALLOC(av), newmax+1, SV*);
 161                 ary = AvALLOC(av) + 1;
 162                 tmp = newmax;
 163                 AvALLOC(av)[0] = &PL_sv_undef;  /* For the stacks */
 164             }
 165             if (AvREAL(av)) {
 166                 while (tmp)
 167                     ary[--tmp] = &PL_sv_undef;
 168             }
 169
 170             SvPV_set(av, (char*)AvALLOC(av));
 171             AvMAX(av) = newmax;
 172         }
 173     }
 174 }
 175
 176 /*
 177 =for apidoc av_fetch
 178
 179 Returns the SV at the specified index in the array.  The C<key> is the
 180 index.  If C<lval> is set then the fetch will be part of a store.  Check
 181 that the return value is non-null before dereferencing it to a C<SV*>.
 182
 183 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
 184 more information on how to use this function on tied arrays.
 185
 186 =cut
 187 */
 188
 189 SV**
 190 Perl_av_fetch(pTHX_ register AV *av, I32 key, I32 lval)
 191 {
 192     SV *sv;
 193
 194     assert(av);
 195
 196     if (SvRMAGICAL(av)) {
 197         const MAGIC * const tied_magic = mg_find((SV*)av, PERL_MAGIC_tied);
 198         if (tied_magic || mg_find((SV*)av, PERL_MAGIC_regdata)) {
 199             U32 adjust_index = 1;
 200
 201             if (tied_magic && key < 0) {
 202                 /* Handle negative array indices 20020222 MJD */
 203                 SV * const * const negative_indices_glob =
 204                     hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *)av,
 205                                                      tied_magic))),
 206                              NEGATIVE_INDICES_VAR, 16, 0);
 207
 208                 if (negative_indices_glob
 209                     && SvTRUE(GvSV(*negative_indices_glob)))
 210                     adjust_index = 0;
 211             }
 212
 213             if (key < 0 && adjust_index) {
 214                 key += AvFILL(av) + 1;
 215                 if (key < 0)
 216                     return 0;
 217             }
 218
 219             sv = sv_newmortal();
 220             sv_upgrade(sv, SVt_PVLV);
 221             mg_copy((SV*)av, sv, 0, key);
 222             LvTYPE(sv) = 't';
 223             LvTARG(sv) = sv; /* fake (SV**) */
 224             return &(LvTARG(sv));
 225         }
 226     }
 227
 228     if (key < 0) {
 229         key += AvFILL(av) + 1;
 230         if (key < 0)
 231             return 0;
 232     }
 233
 234     if (key > AvFILLp(av)) {
 235         if (!lval)
 236             return 0;
 237         sv = NEWSV(5,0);
 238         return av_store(av,key,sv);
 239     }
 240     if (AvARRAY(av)[key] == &PL_sv_undef) {
 241     emptyness:
 242         if (lval) {
 243             sv = NEWSV(6,0);
 244             return av_store(av,key,sv);
 245         }
 246         return 0;
 247     }
 248     else if (AvREIFY(av)
 249              && (!AvARRAY(av)[key]      /* eg. @_ could have freed elts */
 250                  || SvIS_FREED(AvARRAY(av)[key]))) {
 251         AvARRAY(av)[key] = &PL_sv_undef;        /* 1/2 reify */
 252         goto emptyness;
 253     }
 254     return &AvARRAY(av)[key];
 255 }
 256
 257 /*
 258 =for apidoc av_store
 259
 260 Stores an SV in an array.  The array index is specified as C<key>.  The
 261 return value will be NULL if the operation failed or if the value did not
 262 need to be actually stored within the array (as in the case of tied
 263 arrays). Otherwise it can be dereferenced to get the original C<SV*>.  Note
 264 that the caller is responsible for suitably incrementing the reference
 265 count of C<val> before the call, and decrementing it if the function
 266 returned NULL.
 267
 268 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
 269 more information on how to use this function on tied arrays.
 270
 271 =cut
 272 */
 273
 274 SV**
 275 Perl_av_store(pTHX_ register AV *av, I32 key, SV *val)
 276 {
 277     SV** ary;
 278
 279     assert(av);
 280
 281     if (!val)
 282         val = &PL_sv_undef;
 283
 284     if (SvRMAGICAL(av)) {
 285         const MAGIC * const tied_magic = mg_find((SV*)av, PERL_MAGIC_tied);
 286         if (tied_magic) {
 287             /* Handle negative array indices 20020222 MJD */
 288             if (key < 0) {
 289                 unsigned adjust_index = 1;
 290                 SV * const * const negative_indices_glob =
 291                     hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *)av,
 292                                                      tied_magic))),
 293                              NEGATIVE_INDICES_VAR, 16, 0);
 294                 if (negative_indices_glob
 295                     && SvTRUE(GvSV(*negative_indices_glob)))
 296                     adjust_index = 0;
 297                 if (adjust_index) {
 298                     key += AvFILL(av) + 1;
 299                     if (key < 0)
 300                         return 0;
 301                 }
 302             }
 303             if (val != &PL_sv_undef) {
 304                 mg_copy((SV*)av, val, 0, key);
 305             }
 306             return 0;
 307         }
 308     }
 309
 310
 311     if (key < 0) {
 312         key += AvFILL(av) + 1;
 313         if (key < 0)
 314             return 0;
 315     }
 316
 317     if (SvREADONLY(av) && key >= AvFILL(av))
 318         Perl_croak(aTHX_ PL_no_modify);
 319
 320     if (!AvREAL(av) && AvREIFY(av))
 321         av_reify(av);
 322     if (key > AvMAX(av))
 323         av_extend(av,key);
 324     ary = AvARRAY(av);
 325     if (AvFILLp(av) < key) {
 326         if (!AvREAL(av)) {
 327             if (av == PL_curstack && key > PL_stack_sp - PL_stack_base)
 328                 PL_stack_sp = PL_stack_base + key;      /* XPUSH in disguise */
 329             do
 330                 ary[++AvFILLp(av)] = &PL_sv_undef;
 331             while (AvFILLp(av) < key);
 332         }
 333         AvFILLp(av) = key;
 334     }
 335     else if (AvREAL(av))
 336         SvREFCNT_dec(ary[key]);
 337     ary[key] = val;
 338     if (SvSMAGICAL(av)) {
 339         if (val != &PL_sv_undef) {
 340             const MAGIC* const mg = SvMAGIC(av);
 341             sv_magic(val, (SV*)av, toLOWER(mg->mg_type), 0, key);
 342         }
 343         mg_set((SV*)av);
 344     }
 345     return &ary[key];
 346 }
 347
 348 /*
 349 =for apidoc newAV
 350
 351 Creates a new AV.  The reference count is set to 1.
 352
 353 =cut
 354 */
 355
 356 AV *
 357 Perl_newAV(pTHX)
 358 {
 359     register AV * const av = (AV*)NEWSV(3,0);
 360
 361     sv_upgrade((SV *)av, SVt_PVAV);
 362     /* sv_upgrade does AvREAL_only()  */
 363     AvALLOC(av) = 0;
 364     SvPV_set(av, (char*)0);
 365     AvMAX(av) = AvFILLp(av) = -1;
 366     return av;
 367 }
 368
 369 /*
 370 =for apidoc av_make
 371
 372 Creates a new AV and populates it with a list of SVs.  The SVs are copied
 373 into the array, so they may be freed after the call to av_make.  The new AV
 374 will have a reference count of 1.
 375
 376 =cut
 377 */
 378
 379 AV *
 380 Perl_av_make(pTHX_ register I32 size, register SV **strp)
 381 {
 382     register AV * const av = (AV*)NEWSV(8,0);
 383
 384     sv_upgrade((SV *) av,SVt_PVAV);
 385     /* sv_upgrade does AvREAL_only()  */
 386     if (size) {         /* "defined" was returning undef for size==0 anyway. */
 387         register SV** ary;
 388         register I32 i;
 389         Newx(ary,size,SV*);
 390         AvALLOC(av) = ary;
 391         SvPV_set(av, (char*)ary);
 392         AvFILLp(av) = size - 1;
 393         AvMAX(av) = size - 1;
 394         for (i = 0; i < size; i++) {
 395             assert (*strp);
 396             ary[i] = NEWSV(7,0);
 397             sv_setsv(ary[i], *strp);
 398             strp++;
 399         }
 400     }
 401     return av;
 402 }
 403
 404 /*
 405 =for apidoc av_clear
 406
 407 Clears an array, making it empty.  Does not free the memory used by the
 408 array itself.
 409
 410 =cut
 411 */
 412
 413 void
 414 Perl_av_clear(pTHX_ register AV *av)
 415 {
 416     register I32 key;
 417
 418     assert(av);
 419
 420 /* XXX Should av_clear really be NN? */
 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  */