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     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
 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     /* Need to check SvMAGICAL, as during global destruction it may be that
 506        AvARYLEN(av) has been freed before av, and hence the SvANY() pointer
 507        is now part of the linked list of SV heads, rather than pointing to
 508        the original body.  */
 509     /* FIXME - audit the code for other bugs like this one.  */
 510     if (AvARYLEN(av) && SvMAGICAL(AvARYLEN(av))) {
 511         MAGIC *mg = mg_find (AvARYLEN(av), PERL_MAGIC_arylen);
 512
 513         if (mg) {
 514             /* arylen scalar holds a pointer back to the array, but doesn't
 515                own a reference. Hence the we (the array) are about to go away
 516                with it still pointing at us. Clear its pointer, else it would
 517                be pointing at free memory. See the comment in sv_magic about
 518                reference loops, and why it can't own a reference to us.  */
 519             mg->mg_obj = 0;
 520         }
 521
 522         SvREFCNT_dec(AvARYLEN(av));
 523         AvARYLEN(av) = 0;
 524     }
 525 }
 526
 527 /*
 528 =for apidoc av_push
 529
 530 Pushes an SV onto the end of the array.  The array will grow automatically
 531 to accommodate the addition.
 532
 533 =cut
 534 */
 535
 536 void
 537 Perl_av_push(pTHX_ register AV *av, SV *val)
 538 {
 539     MAGIC *mg;
 540     if (!av)
 541         return;
 542     if (SvREADONLY(av))
 543         Perl_croak(aTHX_ PL_no_modify);
 544
 545     if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
 546         dSP;
 547         PUSHSTACKi(PERLSI_MAGIC);
 548         PUSHMARK(SP);
 549         EXTEND(SP,2);
 550         PUSHs(SvTIED_obj((SV*)av, mg));
 551         PUSHs(val);
 552         PUTBACK;
 553         ENTER;
 554         call_method("PUSH", G_SCALAR|G_DISCARD);
 555         LEAVE;
 556         POPSTACK;
 557         return;
 558     }
 559     av_store(av,AvFILLp(av)+1,val);
 560 }
 561
 562 /*
 563 =for apidoc av_pop
 564
 565 Pops an SV off the end of the array.  Returns C<&PL_sv_undef> if the array
 566 is empty.
 567
 568 =cut
 569 */
 570
 571 SV *
 572 Perl_av_pop(pTHX_ register AV *av)
 573 {
 574     SV *retval;
 575     MAGIC* mg;
 576
 577     if (!av)
 578       return &PL_sv_undef;
 579     if (SvREADONLY(av))
 580         Perl_croak(aTHX_ PL_no_modify);
 581     if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
 582         dSP;
 583         PUSHSTACKi(PERLSI_MAGIC);
 584         PUSHMARK(SP);
 585         XPUSHs(SvTIED_obj((SV*)av, mg));
 586         PUTBACK;
 587         ENTER;
 588         if (call_method("POP", G_SCALAR)) {
 589             retval = newSVsv(*PL_stack_sp--);
 590         } else {
 591             retval = &PL_sv_undef;
 592         }
 593         LEAVE;
 594         POPSTACK;
 595         return retval;
 596     }
 597     if (AvFILL(av) < 0)
 598         return &PL_sv_undef;
 599     retval = AvARRAY(av)[AvFILLp(av)];
 600     AvARRAY(av)[AvFILLp(av)--] = &PL_sv_undef;
 601     if (SvSMAGICAL(av))
 602         mg_set((SV*)av);
 603     return retval;
 604 }
 605
 606 /*
 607 =for apidoc av_unshift
 608
 609 Unshift the given number of C<undef> values onto the beginning of the
 610 array.  The array will grow automatically to accommodate the addition.  You
 611 must then use C<av_store> to assign values to these new elements.
 612
 613 =cut
 614 */
 615
 616 void
 617 Perl_av_unshift(pTHX_ register AV *av, register I32 num)
 618 {
 619     register I32 i;
 620     MAGIC* mg;
 621
 622     if (!av)
 623         return;
 624     if (SvREADONLY(av))
 625         Perl_croak(aTHX_ PL_no_modify);
 626
 627     if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
 628         dSP;
 629         PUSHSTACKi(PERLSI_MAGIC);
 630         PUSHMARK(SP);
 631         EXTEND(SP,1+num);
 632         PUSHs(SvTIED_obj((SV*)av, mg));
 633         while (num-- > 0) {
 634             PUSHs(&PL_sv_undef);
 635         }
 636         PUTBACK;
 637         ENTER;
 638         call_method("UNSHIFT", G_SCALAR|G_DISCARD);
 639         LEAVE;
 640         POPSTACK;
 641         return;
 642     }
 643
 644     if (num <= 0)
 645       return;
 646     if (!AvREAL(av) && AvREIFY(av))
 647         av_reify(av);
 648     i = AvARRAY(av) - AvALLOC(av);
 649     if (i) {
 650         if (i > num)
 651             i = num;
 652         num -= i;
 653
 654         AvMAX(av) += i;
 655         AvFILLp(av) += i;
 656         SvPV_set(av, (char*)(AvARRAY(av) - i));
 657     }
 658     if (num) {
 659         register SV **ary;
 660         I32 slide;
 661         i = AvFILLp(av);
 662         /* Create extra elements */
 663         slide = i > 0 ? i : 0;
 664         num += slide;
 665         av_extend(av, i + num);
 666         AvFILLp(av) += num;
 667         ary = AvARRAY(av);
 668         Move(ary, ary + num, i + 1, SV*);
 669         do {
 670             ary[--num] = &PL_sv_undef;
 671         } while (num);
 672         /* Make extra elements into a buffer */
 673         AvMAX(av) -= slide;
 674         AvFILLp(av) -= slide;
 675         SvPV_set(av, (char*)(AvARRAY(av) + slide));
 676     }
 677 }
 678
 679 /*
 680 =for apidoc av_shift
 681
 682 Shifts an SV off the beginning of the array.
 683
 684 =cut
 685 */
 686
 687 SV *
 688 Perl_av_shift(pTHX_ register AV *av)
 689 {
 690     SV *retval;
 691     MAGIC* mg;
 692
 693     if (!av)
 694         return &PL_sv_undef;
 695     if (SvREADONLY(av))
 696         Perl_croak(aTHX_ PL_no_modify);
 697     if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
 698         dSP;
 699         PUSHSTACKi(PERLSI_MAGIC);
 700         PUSHMARK(SP);
 701         XPUSHs(SvTIED_obj((SV*)av, mg));
 702         PUTBACK;
 703         ENTER;
 704         if (call_method("SHIFT", G_SCALAR)) {
 705             retval = newSVsv(*PL_stack_sp--);
 706         } else {
 707             retval = &PL_sv_undef;
 708         }
 709         LEAVE;
 710         POPSTACK;
 711         return retval;
 712     }
 713     if (AvFILL(av) < 0)
 714       return &PL_sv_undef;
 715     retval = *AvARRAY(av);
 716     if (AvREAL(av))
 717         *AvARRAY(av) = &PL_sv_undef;
 718     SvPV_set(av, (char*)(AvARRAY(av) + 1));
 719     AvMAX(av)--;
 720     AvFILLp(av)--;
 721     if (SvSMAGICAL(av))
 722         mg_set((SV*)av);
 723     return retval;
 724 }
 725
 726 /*
 727 =for apidoc av_len
 728
 729 Returns the highest index in the array.  Returns -1 if the array is
 730 empty.
 731
 732 =cut
 733 */
 734
 735 I32
 736 Perl_av_len(pTHX_ register AV *av)
 737 {
 738     return AvFILL(av);
 739 }
 740
 741 /*
 742 =for apidoc av_fill
 743
 744 Ensure than an array has a given number of elements, equivalent to
 745 Perl's C<$#array = $fill;>.
 746
 747 =cut
 748 */
 749 void
 750 Perl_av_fill(pTHX_ register AV *av, I32 fill)
 751 {
 752     MAGIC *mg;
 753     if (!av)
 754         Perl_croak(aTHX_ "panic: null array");
 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         PUSHs(sv_2mortal(newSViv(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** 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     SV *sv;
 809
 810     if (!av)
 811         return Nullsv;
 812     if (SvREADONLY(av))
 813         Perl_croak(aTHX_ PL_no_modify);
 814
 815     if (SvRMAGICAL(av)) {
 816         const MAGIC * const tied_magic = mg_find((SV*)av, PERL_MAGIC_tied);
 817         if ((tied_magic || mg_find((SV*)av, PERL_MAGIC_regdata))) {
 818             /* Handle negative array indices 20020222 MJD */
 819             SV **svp;
 820             if (key < 0) {
 821                 unsigned adjust_index = 1;
 822                 if (tied_magic) {
 823                     SV **negative_indices_glob =
 824                         hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *)av,
 825                                                          tied_magic))),
 826                                  NEGATIVE_INDICES_VAR, 16, 0);
 827                     if (negative_indices_glob
 828                         && SvTRUE(GvSV(*negative_indices_glob)))
 829                         adjust_index = 0;
 830                 }
 831                 if (adjust_index) {
 832                     key += AvFILL(av) + 1;
 833                     if (key < 0)
 834                         return Nullsv;
 835                 }
 836             }
 837             svp = av_fetch(av, key, TRUE);
 838             if (svp) {
 839                 sv = *svp;
 840                 mg_clear(sv);
 841                 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
 842                     sv_unmagic(sv, PERL_MAGIC_tiedelem); /* No longer an element */
 843                     return sv;
 844                 }
 845                 return Nullsv;
 846             }
 847         }
 848     }
 849
 850     if (key < 0) {
 851         key += AvFILL(av) + 1;
 852         if (key < 0)
 853             return Nullsv;
 854     }
 855
 856     if (key > AvFILLp(av))
 857         return Nullsv;
 858     else {
 859         if (!AvREAL(av) && AvREIFY(av))
 860             av_reify(av);
 861         sv = AvARRAY(av)[key];
 862         if (key == AvFILLp(av)) {
 863             AvARRAY(av)[key] = &PL_sv_undef;
 864             do {
 865                 AvFILLp(av)--;
 866             } while (--key >= 0 && AvARRAY(av)[key] == &PL_sv_undef);
 867         }
 868         else
 869             AvARRAY(av)[key] = &PL_sv_undef;
 870         if (SvSMAGICAL(av))
 871             mg_set((SV*)av);
 872     }
 873     if (flags & G_DISCARD) {
 874         SvREFCNT_dec(sv);
 875         sv = Nullsv;
 876     }
 877     else if (AvREAL(av))
 878         sv = sv_2mortal(sv);
 879     return sv;
 880 }
 881
 882 /*
 883 =for apidoc av_exists
 884
 885 Returns true if the element indexed by C<key> has been initialized.
 886
 887 This relies on the fact that uninitialized array elements are set to
 888 C<&PL_sv_undef>.
 889
 890 =cut
 891 */
 892 bool
 893 Perl_av_exists(pTHX_ AV *av, I32 key)
 894 {
 895     if (!av)
 896         return FALSE;
 897
 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 *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 **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 /* AVHV: Support for treating arrays as if they were hashes.  The
 949  * first element of the array should be a hash reference that maps
 950  * hash keys to array indices.
 951  */
 952
 953 STATIC I32
 954 S_avhv_index_sv(pTHX_ SV* sv)
 955 {
 956     I32 index = SvIV(sv);
 957     if (index < 1)
 958         Perl_croak(aTHX_ "Bad index while coercing array into hash");
 959     return index;
 960 }
 961
 962 STATIC I32
 963 S_avhv_index(pTHX_ AV *av, SV *keysv, U32 hash)
 964 {
 965     HV *keys;
 966     HE *he;
 967     STRLEN n_a;
 968
 969     keys = avhv_keys(av);
 970     he = hv_fetch_ent(keys, keysv, FALSE, hash);
 971     if (!he)
 972         Perl_croak(aTHX_ "No such pseudo-hash field \"%s\"", SvPV(keysv,n_a));
 973     return avhv_index_sv(HeVAL(he));
 974 }
 975
 976 HV*
 977 Perl_avhv_keys(pTHX_ AV *av)
 978 {
 979     SV **keysp = av_fetch(av, 0, FALSE);
 980     if (keysp) {
 981         SV *sv = *keysp;
 982         if (SvGMAGICAL(sv))
 983             mg_get(sv);
 984         if (SvROK(sv)) {
 985             if (ckWARN(WARN_DEPRECATED) && !sv_isa(sv, "pseudohash"))
 986                 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
 987                             "Pseudo-hashes are deprecated");
 988             sv = SvRV(sv);
 989             if (SvTYPE(sv) == SVt_PVHV)
 990                 return (HV*)sv;
 991         }
 992     }
 993     Perl_croak(aTHX_ "Can't coerce array into hash");
 994     return Nullhv;
 995 }
 996
 997 SV**
 998 Perl_avhv_store_ent(pTHX_ AV *av, SV *keysv, SV *val, U32 hash)
 999 {
1000     return av_store(av, avhv_index(av, keysv, hash), val);
1001 }
1002
1003 SV**
1004 Perl_avhv_fetch_ent(pTHX_ AV *av, SV *keysv, I32 lval, U32 hash)
1005 {
1006     return av_fetch(av, avhv_index(av, keysv, hash), lval);
1007 }
1008
1009 SV *
1010 Perl_avhv_delete_ent(pTHX_ AV *av, SV *keysv, I32 flags, U32 hash)
1011 {
1012     HV *keys = avhv_keys(av);
1013     HE *he;
1014
1015     he = hv_fetch_ent(keys, keysv, FALSE, hash);
1016     if (!he || !SvOK(HeVAL(he)))
1017         return Nullsv;
1018
1019     return av_delete(av, avhv_index_sv(HeVAL(he)), flags);
1020 }
1021
1022 /* Check for the existence of an element named by a given key.
1023  *
1024  */
1025 bool
1026 Perl_avhv_exists_ent(pTHX_ AV *av, SV *keysv, U32 hash)
1027 {
1028     HV *keys = avhv_keys(av);
1029     HE *he;
1030
1031     he = hv_fetch_ent(keys, keysv, FALSE, hash);
1032     if (!he || !SvOK(HeVAL(he)))
1033         return FALSE;
1034
1035     return av_exists(av, avhv_index_sv(HeVAL(he)));
1036 }
1037
1038 HE *
1039 Perl_avhv_iternext(pTHX_ AV *av)
1040 {
1041     HV *keys = avhv_keys(av);
1042     return hv_iternext(keys);
1043 }
1044
1045 SV *
1046 Perl_avhv_iterval(pTHX_ AV *av, register HE *entry)
1047 {
1048     SV *sv = hv_iterval(avhv_keys(av), entry);
1049     return *av_fetch(av, avhv_index_sv(sv), TRUE);
1050 }
1051
1052 /*
1053  * Local variables:
1054  * c-indentation-style: bsd
1055  * c-basic-offset: 4
1056  * indent-tabs-mode: t
1057  * End:
1058  *
1059  * ex: set ts=8 sts=4 sw=4 noet:
1060  */