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