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                 New(2,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                 New(2,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     AvREAL_on(av);
 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     AvFLAGS(av) = AVf_REAL;
 386     if (size) {         /* `defined' was returning undef for size==0 anyway. */
 387         register SV** ary;
 388         register I32 i;
 389         New(4,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     New(4,ary,size+1,SV*);
 413     AvALLOC(av) = ary;
 414     Copy(strp,ary,size,SV*);
 415     AvFLAGS(av) = AVf_REIFY;
 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     /*SUPPRESS 560*/
 449
 450     if (SvREADONLY(av))
 451         Perl_croak(aTHX_ PL_no_modify);
 452
 453     /* Give any tie a chance to cleanup first */
 454     if (SvRMAGICAL(av))
 455         mg_clear((SV*)av);
 456
 457     if (AvMAX(av) < 0)
 458         return;
 459
 460     if (AvREAL(av)) {
 461         SV** ary = AvARRAY(av);
 462         key = AvFILLp(av) + 1;
 463         while (key) {
 464             SV * sv = ary[--key];
 465             /* undef the slot before freeing the value, because a
 466              * destructor might try to modify this arrray */
 467             ary[key] = &PL_sv_undef;
 468             SvREFCNT_dec(sv);
 469         }
 470     }
 471     if ((key = AvARRAY(av) - AvALLOC(av))) {
 472         AvMAX(av) += key;
 473         SvPV_set(av, (char*)AvALLOC(av));
 474     }
 475     AvFILLp(av) = -1;
 476
 477 }
 478
 479 /*
 480 =for apidoc av_undef
 481
 482 Undefines the array.  Frees the memory used by the array itself.
 483
 484 =cut
 485 */
 486
 487 void
 488 Perl_av_undef(pTHX_ register AV *av)
 489 {
 490     register I32 key;
 491
 492     if (!av)
 493         return;
 494     /*SUPPRESS 560*/
 495
 496     /* Give any tie a chance to cleanup first */
 497     if (SvTIED_mg((SV*)av, PERL_MAGIC_tied))
 498         av_fill(av, -1);   /* mg_clear() ? */
 499
 500     if (AvREAL(av)) {
 501         key = AvFILLp(av) + 1;
 502         while (key)
 503             SvREFCNT_dec(AvARRAY(av)[--key]);
 504     }
 505     Safefree(AvALLOC(av));
 506     AvALLOC(av) = 0;
 507     SvPV_set(av, (char*)0);
 508     AvMAX(av) = AvFILLp(av) = -1;
 509     if (AvARYLEN(av)) {
 510         SvREFCNT_dec(AvARYLEN(av));
 511         AvARYLEN(av) = 0;
 512     }
 513 }
 514
 515 /*
 516 =for apidoc av_push
 517
 518 Pushes an SV onto the end of the array.  The array will grow automatically
 519 to accommodate the addition.
 520
 521 =cut
 522 */
 523
 524 void
 525 Perl_av_push(pTHX_ register AV *av, SV *val)
 526 {
 527     dVAR;
 528     MAGIC *mg;
 529     if (!av)
 530         return;
 531     if (SvREADONLY(av))
 532         Perl_croak(aTHX_ PL_no_modify);
 533
 534     if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
 535         dSP;
 536         PUSHSTACKi(PERLSI_MAGIC);
 537         PUSHMARK(SP);
 538         EXTEND(SP,2);
 539         PUSHs(SvTIED_obj((SV*)av, mg));
 540         PUSHs(val);
 541         PUTBACK;
 542         ENTER;
 543         call_method("PUSH", G_SCALAR|G_DISCARD);
 544         LEAVE;
 545         POPSTACK;
 546         return;
 547     }
 548     av_store(av,AvFILLp(av)+1,val);
 549 }
 550
 551 /*
 552 =for apidoc av_pop
 553
 554 Pops an SV off the end of the array.  Returns C<&PL_sv_undef> if the array
 555 is empty.
 556
 557 =cut
 558 */
 559
 560 SV *
 561 Perl_av_pop(pTHX_ register AV *av)
 562 {
 563     dVAR;
 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     dVAR;
 610     register I32 i;
 611     register SV **ary;
 612     MAGIC* mg;
 613     I32 slide;
 614
 615     if (!av)
 616         return;
 617     if (SvREADONLY(av))
 618         Perl_croak(aTHX_ PL_no_modify);
 619
 620     if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
 621         dSP;
 622         PUSHSTACKi(PERLSI_MAGIC);
 623         PUSHMARK(SP);
 624         EXTEND(SP,1+num);
 625         PUSHs(SvTIED_obj((SV*)av, mg));
 626         while (num-- > 0) {
 627             PUSHs(&PL_sv_undef);
 628         }
 629         PUTBACK;
 630         ENTER;
 631         call_method("UNSHIFT", G_SCALAR|G_DISCARD);
 632         LEAVE;
 633         POPSTACK;
 634         return;
 635     }
 636
 637     if (num <= 0)
 638       return;
 639     if (!AvREAL(av) && AvREIFY(av))
 640         av_reify(av);
 641     i = AvARRAY(av) - AvALLOC(av);
 642     if (i) {
 643         if (i > num)
 644             i = num;
 645         num -= i;
 646
 647         AvMAX(av) += i;
 648         AvFILLp(av) += i;
 649         SvPV_set(av, (char*)(AvARRAY(av) - i));
 650     }
 651     if (num) {
 652         i = AvFILLp(av);
 653         /* Create extra elements */
 654         slide = i > 0 ? i : 0;
 655         num += slide;
 656         av_extend(av, i + num);
 657         AvFILLp(av) += num;
 658         ary = AvARRAY(av);
 659         Move(ary, ary + num, i + 1, SV*);
 660         do {
 661             ary[--num] = &PL_sv_undef;
 662         } while (num);
 663         /* Make extra elements into a buffer */
 664         AvMAX(av) -= slide;
 665         AvFILLp(av) -= slide;
 666         SvPV_set(av, (char*)(AvARRAY(av) + slide));
 667     }
 668 }
 669
 670 /*
 671 =for apidoc av_shift
 672
 673 Shifts an SV off the beginning of the array.
 674
 675 =cut
 676 */
 677
 678 SV *
 679 Perl_av_shift(pTHX_ register AV *av)
 680 {
 681     dVAR;
 682     SV *retval;
 683     MAGIC* mg;
 684
 685     if (!av)
 686         return &PL_sv_undef;
 687     if (SvREADONLY(av))
 688         Perl_croak(aTHX_ PL_no_modify);
 689     if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
 690         dSP;
 691         PUSHSTACKi(PERLSI_MAGIC);
 692         PUSHMARK(SP);
 693         XPUSHs(SvTIED_obj((SV*)av, mg));
 694         PUTBACK;
 695         ENTER;
 696         if (call_method("SHIFT", G_SCALAR)) {
 697             retval = newSVsv(*PL_stack_sp--);
 698         } else {
 699             retval = &PL_sv_undef;
 700         }
 701         LEAVE;
 702         POPSTACK;
 703         return retval;
 704     }
 705     if (AvFILL(av) < 0)
 706       return &PL_sv_undef;
 707     retval = *AvARRAY(av);
 708     if (AvREAL(av))
 709         *AvARRAY(av) = &PL_sv_undef;
 710     SvPV_set(av, (char*)(AvARRAY(av) + 1));
 711     AvMAX(av)--;
 712     AvFILLp(av)--;
 713     if (SvSMAGICAL(av))
 714         mg_set((SV*)av);
 715     return retval;
 716 }
 717
 718 /*
 719 =for apidoc av_len
 720
 721 Returns the highest index in the array.  Returns -1 if the array is
 722 empty.
 723
 724 =cut
 725 */
 726
 727 I32
 728 Perl_av_len(pTHX_ const register AV *av)
 729 {
 730     return AvFILL(av);
 731 }
 732
 733 /*
 734 =for apidoc av_fill
 735
 736 Ensure than an array has a given number of elements, equivalent to
 737 Perl's C<$#array = $fill;>.
 738
 739 =cut
 740 */
 741 void
 742 Perl_av_fill(pTHX_ register AV *av, I32 fill)
 743 {
 744     dVAR;
 745     MAGIC *mg;
 746     if (!av)
 747         Perl_croak(aTHX_ "panic: null array");
 748     if (fill < 0)
 749         fill = -1;
 750     if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
 751         dSP;
 752         ENTER;
 753         SAVETMPS;
 754         PUSHSTACKi(PERLSI_MAGIC);
 755         PUSHMARK(SP);
 756         EXTEND(SP,2);
 757         PUSHs(SvTIED_obj((SV*)av, mg));
 758         PUSHs(sv_2mortal(newSViv(fill+1)));
 759         PUTBACK;
 760         call_method("STORESIZE", G_SCALAR|G_DISCARD);
 761         POPSTACK;
 762         FREETMPS;
 763         LEAVE;
 764         return;
 765     }
 766     if (fill <= AvMAX(av)) {
 767         I32 key = AvFILLp(av);
 768         SV** ary = AvARRAY(av);
 769
 770         if (AvREAL(av)) {
 771             while (key > fill) {
 772                 SvREFCNT_dec(ary[key]);
 773                 ary[key--] = &PL_sv_undef;
 774             }
 775         }
 776         else {
 777             while (key < fill)
 778                 ary[++key] = &PL_sv_undef;
 779         }
 780
 781         AvFILLp(av) = fill;
 782         if (SvSMAGICAL(av))
 783             mg_set((SV*)av);
 784     }
 785     else
 786         (void)av_store(av,fill,&PL_sv_undef);
 787 }
 788
 789 /*
 790 =for apidoc av_delete
 791
 792 Deletes the element indexed by C<key> from the array.  Returns the
 793 deleted element. If C<flags> equals C<G_DISCARD>, the element is freed
 794 and null is returned.
 795
 796 =cut
 797 */
 798 SV *
 799 Perl_av_delete(pTHX_ AV *av, I32 key, I32 flags)
 800 {
 801     SV *sv;
 802
 803     if (!av)
 804         return Nullsv;
 805     if (SvREADONLY(av))
 806         Perl_croak(aTHX_ PL_no_modify);
 807
 808     if (SvRMAGICAL(av)) {
 809         const MAGIC * const tied_magic = mg_find((SV*)av, PERL_MAGIC_tied);
 810         if ((tied_magic || mg_find((SV*)av, PERL_MAGIC_regdata))) {
 811             /* Handle negative array indices 20020222 MJD */
 812             SV **svp;
 813             if (key < 0) {
 814                 unsigned adjust_index = 1;
 815                 if (tied_magic) {
 816                     SV **negative_indices_glob =
 817                         hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *)av,
 818                                                          tied_magic))),
 819                                  NEGATIVE_INDICES_VAR, 16, 0);
 820                     if (negative_indices_glob
 821                         && SvTRUE(GvSV(*negative_indices_glob)))
 822                         adjust_index = 0;
 823                 }
 824                 if (adjust_index) {
 825                     key += AvFILL(av) + 1;
 826                     if (key < 0)
 827                         return Nullsv;
 828                 }
 829             }
 830             svp = av_fetch(av, key, TRUE);
 831             if (svp) {
 832                 sv = *svp;
 833                 mg_clear(sv);
 834                 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
 835                     sv_unmagic(sv, PERL_MAGIC_tiedelem); /* No longer an element */
 836                     return sv;
 837                 }
 838                 return Nullsv;
 839             }
 840         }
 841     }
 842
 843     if (key < 0) {
 844         key += AvFILL(av) + 1;
 845         if (key < 0)
 846             return Nullsv;
 847     }
 848
 849     if (key > AvFILLp(av))
 850         return Nullsv;
 851     else {
 852         if (!AvREAL(av) && AvREIFY(av))
 853             av_reify(av);
 854         sv = AvARRAY(av)[key];
 855         if (key == AvFILLp(av)) {
 856             AvARRAY(av)[key] = &PL_sv_undef;
 857             do {
 858                 AvFILLp(av)--;
 859             } while (--key >= 0 && AvARRAY(av)[key] == &PL_sv_undef);
 860         }
 861         else
 862             AvARRAY(av)[key] = &PL_sv_undef;
 863         if (SvSMAGICAL(av))
 864             mg_set((SV*)av);
 865     }
 866     if (flags & G_DISCARD) {
 867         SvREFCNT_dec(sv);
 868         sv = Nullsv;
 869     }
 870     else if (AvREAL(av))
 871         sv = sv_2mortal(sv);
 872     return sv;
 873 }
 874
 875 /*
 876 =for apidoc av_exists
 877
 878 Returns true if the element indexed by C<key> has been initialized.
 879
 880 This relies on the fact that uninitialized array elements are set to
 881 C<&PL_sv_undef>.
 882
 883 =cut
 884 */
 885 bool
 886 Perl_av_exists(pTHX_ AV *av, I32 key)
 887 {
 888     if (!av)
 889         return FALSE;
 890
 891
 892     if (SvRMAGICAL(av)) {
 893         const MAGIC * const tied_magic = mg_find((SV*)av, PERL_MAGIC_tied);
 894         if (tied_magic || mg_find((SV*)av, PERL_MAGIC_regdata)) {
 895             SV *sv = sv_newmortal();
 896             MAGIC *mg;
 897             /* Handle negative array indices 20020222 MJD */
 898             if (key < 0) {
 899                 unsigned adjust_index = 1;
 900                 if (tied_magic) {
 901                     SV **negative_indices_glob =
 902                         hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *)av,
 903                                                          tied_magic))),
 904                                  NEGATIVE_INDICES_VAR, 16, 0);
 905                     if (negative_indices_glob
 906                         && SvTRUE(GvSV(*negative_indices_glob)))
 907                         adjust_index = 0;
 908                 }
 909                 if (adjust_index) {
 910                     key += AvFILL(av) + 1;
 911                     if (key < 0)
 912                         return FALSE;
 913                 }
 914             }
 915
 916             mg_copy((SV*)av, sv, 0, key);
 917             mg = mg_find(sv, PERL_MAGIC_tiedelem);
 918             if (mg) {
 919                 magic_existspack(sv, mg);
 920                 return (bool)SvTRUE(sv);
 921             }
 922
 923         }
 924     }
 925
 926     if (key < 0) {
 927         key += AvFILL(av) + 1;
 928         if (key < 0)
 929             return FALSE;
 930     }
 931
 932     if (key <= AvFILLp(av) && AvARRAY(av)[key] != &PL_sv_undef
 933         && AvARRAY(av)[key])
 934     {
 935         return TRUE;
 936     }
 937     else
 938         return FALSE;
 939 }
 940
 941 /*
 942  * Local variables:
 943  * c-indentation-style: bsd
 944  * c-basic-offset: 4
 945  * indent-tabs-mode: t
 946  * End:
 947  *
 948  * ex: set ts=8 sts=4 sw=4 noet:
 949  */