av.c

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