av.c

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