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