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