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