av.c

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