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