av.c

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