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
 245     if (!av)
 246         return 0;
 247     if (!val)
 248         val = &PL_sv_undef;
 249
 250     if (key < 0) {
 251         key += AvFILL(av) + 1;
 252         if (key < 0)
 253             return 0;
 254     }
 255
 256     if (SvREADONLY(av) && key >= AvFILL(av))
 257         Perl_croak(aTHX_ PL_no_modify);
 258
 259     if (SvRMAGICAL(av)) {
 260         if (mg_find((SV*)av,'P')) {
 261             if (val != &PL_sv_undef) {
 262                 mg_copy((SV*)av, val, 0, key);
 263             }
 264             return 0;
 265         }
 266     }
 267
 268     if (!AvREAL(av) && AvREIFY(av))
 269         av_reify(av);
 270     if (key > AvMAX(av))
 271         av_extend(av,key);
 272     ary = AvARRAY(av);
 273     if (AvFILLp(av) < key) {
 274         if (!AvREAL(av)) {
 275             dTHR;
 276             if (av == PL_curstack && key > PL_stack_sp - PL_stack_base)
 277                 PL_stack_sp = PL_stack_base + key;      /* XPUSH in disguise */
 278             do
 279                 ary[++AvFILLp(av)] = &PL_sv_undef;
 280             while (AvFILLp(av) < key);
 281         }
 282         AvFILLp(av) = key;
 283     }
 284     else if (AvREAL(av))
 285         SvREFCNT_dec(ary[key]);
 286     ary[key] = val;
 287     if (SvSMAGICAL(av)) {
 288         if (val != &PL_sv_undef) {
 289             MAGIC* mg = SvMAGIC(av);
 290             sv_magic(val, (SV*)av, toLOWER(mg->mg_type), 0, key);
 291         }
 292         mg_set((SV*)av);
 293     }
 294     return &ary[key];
 295 }
 296
 297 /*
 298 =for apidoc newAV
 299
 300 Creates a new AV.  The reference count is set to 1.
 301
 302 =cut
 303 */
 304
 305 AV *
 306 Perl_newAV(pTHX)
 307 {
 308     register AV *av;
 309
 310     av = (AV*)NEWSV(3,0);
 311     sv_upgrade((SV *)av, SVt_PVAV);
 312     AvREAL_on(av);
 313     AvALLOC(av) = 0;
 314     SvPVX(av) = 0;
 315     AvMAX(av) = AvFILLp(av) = -1;
 316     return av;
 317 }
 318
 319 /*
 320 =for apidoc av_make
 321
 322 Creates a new AV and populates it with a list of SVs.  The SVs are copied
 323 into the array, so they may be freed after the call to av_make.  The new AV
 324 will have a reference count of 1.
 325
 326 =cut
 327 */
 328
 329 AV *
 330 Perl_av_make(pTHX_ register I32 size, register SV **strp)
 331 {
 332     register AV *av;
 333     register I32 i;
 334     register SV** ary;
 335
 336     av = (AV*)NEWSV(8,0);
 337     sv_upgrade((SV *) av,SVt_PVAV);
 338     AvFLAGS(av) = AVf_REAL;
 339     if (size) {         /* `defined' was returning undef for size==0 anyway. */
 340         New(4,ary,size,SV*);
 341         AvALLOC(av) = ary;
 342         SvPVX(av) = (char*)ary;
 343         AvFILLp(av) = size - 1;
 344         AvMAX(av) = size - 1;
 345         for (i = 0; i < size; i++) {
 346             assert (*strp);
 347             ary[i] = NEWSV(7,0);
 348             sv_setsv(ary[i], *strp);
 349             strp++;
 350         }
 351     }
 352     return av;
 353 }
 354
 355 AV *
 356 Perl_av_fake(pTHX_ register I32 size, register SV **strp)
 357 {
 358     register AV *av;
 359     register SV** ary;
 360
 361     av = (AV*)NEWSV(9,0);
 362     sv_upgrade((SV *)av, SVt_PVAV);
 363     New(4,ary,size+1,SV*);
 364     AvALLOC(av) = ary;
 365     Copy(strp,ary,size,SV*);
 366     AvFLAGS(av) = AVf_REIFY;
 367     SvPVX(av) = (char*)ary;
 368     AvFILLp(av) = size - 1;
 369     AvMAX(av) = size - 1;
 370     while (size--) {
 371         assert (*strp);
 372         SvTEMP_off(*strp);
 373         strp++;
 374     }
 375     return av;
 376 }
 377
 378 /*
 379 =for apidoc av_clear
 380
 381 Clears an array, making it empty.  Does not free the memory used by the
 382 array itself.
 383
 384 =cut
 385 */
 386
 387 void
 388 Perl_av_clear(pTHX_ register AV *av)
 389 {
 390     register I32 key;
 391     SV** ary;
 392
 393 #ifdef DEBUGGING
 394     if (SvREFCNT(av) == 0 && ckWARN_d(WARN_DEBUGGING)) {
 395         Perl_warner(aTHX_ WARN_DEBUGGING, "Attempt to clear deleted array");
 396     }
 397 #endif
 398     if (!av)
 399         return;
 400     /*SUPPRESS 560*/
 401
 402     if (SvREADONLY(av))
 403         Perl_croak(aTHX_ PL_no_modify);
 404
 405     /* Give any tie a chance to cleanup first */
 406     if (SvRMAGICAL(av))
 407         mg_clear((SV*)av);
 408
 409     if (AvMAX(av) < 0)
 410         return;
 411
 412     if (AvREAL(av)) {
 413         ary = AvARRAY(av);
 414         key = AvFILLp(av) + 1;
 415         while (key) {
 416             SvREFCNT_dec(ary[--key]);
 417             ary[key] = &PL_sv_undef;
 418         }
 419     }
 420     if ((key = AvARRAY(av) - AvALLOC(av))) {
 421         AvMAX(av) += key;
 422         SvPVX(av) = (char*)AvALLOC(av);
 423     }
 424     AvFILLp(av) = -1;
 425
 426 }
 427
 428 /*
 429 =for apidoc av_undef
 430
 431 Undefines the array.  Frees the memory used by the array itself.
 432
 433 =cut
 434 */
 435
 436 void
 437 Perl_av_undef(pTHX_ register AV *av)
 438 {
 439     register I32 key;
 440
 441     if (!av)
 442         return;
 443     /*SUPPRESS 560*/
 444
 445     /* Give any tie a chance to cleanup first */
 446     if (SvTIED_mg((SV*)av, 'P'))
 447         av_fill(av, -1);   /* mg_clear() ? */
 448
 449     if (AvREAL(av)) {
 450         key = AvFILLp(av) + 1;
 451         while (key)
 452             SvREFCNT_dec(AvARRAY(av)[--key]);
 453     }
 454     Safefree(AvALLOC(av));
 455     AvALLOC(av) = 0;
 456     SvPVX(av) = 0;
 457     AvMAX(av) = AvFILLp(av) = -1;
 458     if (AvARYLEN(av)) {
 459         SvREFCNT_dec(AvARYLEN(av));
 460         AvARYLEN(av) = 0;
 461     }
 462 }
 463
 464 /*
 465 =for apidoc av_push
 466
 467 Pushes an SV onto the end of the array.  The array will grow automatically
 468 to accommodate the addition.
 469
 470 =cut
 471 */
 472
 473 void
 474 Perl_av_push(pTHX_ register AV *av, SV *val)
 475 {
 476     MAGIC *mg;
 477     if (!av)
 478         return;
 479     if (SvREADONLY(av))
 480         Perl_croak(aTHX_ PL_no_modify);
 481
 482     if ((mg = SvTIED_mg((SV*)av, 'P'))) {
 483         dSP;
 484         PUSHSTACKi(PERLSI_MAGIC);
 485         PUSHMARK(SP);
 486         EXTEND(SP,2);
 487         PUSHs(SvTIED_obj((SV*)av, mg));
 488         PUSHs(val);
 489         PUTBACK;
 490         ENTER;
 491         call_method("PUSH", G_SCALAR|G_DISCARD);
 492         LEAVE;
 493         POPSTACK;
 494         return;
 495     }
 496     av_store(av,AvFILLp(av)+1,val);
 497 }
 498
 499 /*
 500 =for apidoc av_pop
 501
 502 Pops an SV off the end of the array.  Returns C<&PL_sv_undef> if the array
 503 is empty.
 504
 505 =cut
 506 */
 507
 508 SV *
 509 Perl_av_pop(pTHX_ register AV *av)
 510 {
 511     SV *retval;
 512     MAGIC* mg;
 513
 514     if (!av || AvFILL(av) < 0)
 515         return &PL_sv_undef;
 516     if (SvREADONLY(av))
 517         Perl_croak(aTHX_ PL_no_modify);
 518     if ((mg = SvTIED_mg((SV*)av, 'P'))) {
 519         dSP;
 520         PUSHSTACKi(PERLSI_MAGIC);
 521         PUSHMARK(SP);
 522         XPUSHs(SvTIED_obj((SV*)av, mg));
 523         PUTBACK;
 524         ENTER;
 525         if (call_method("POP", G_SCALAR)) {
 526             retval = newSVsv(*PL_stack_sp--);
 527         } else {
 528             retval = &PL_sv_undef;
 529         }
 530         LEAVE;
 531         POPSTACK;
 532         return retval;
 533     }
 534     retval = AvARRAY(av)[AvFILLp(av)];
 535     AvARRAY(av)[AvFILLp(av)--] = &PL_sv_undef;
 536     if (SvSMAGICAL(av))
 537         mg_set((SV*)av);
 538     return retval;
 539 }
 540
 541 /*
 542 =for apidoc av_unshift
 543
 544 Unshift the given number of C<undef> values onto the beginning of the
 545 array.  The array will grow automatically to accommodate the addition.  You
 546 must then use C<av_store> to assign values to these new elements.
 547
 548 =cut
 549 */
 550
 551 void
 552 Perl_av_unshift(pTHX_ register AV *av, register I32 num)
 553 {
 554     register I32 i;
 555     register SV **ary;
 556     MAGIC* mg;
 557
 558     if (!av || num <= 0)
 559         return;
 560     if (SvREADONLY(av))
 561         Perl_croak(aTHX_ PL_no_modify);
 562
 563     if ((mg = SvTIED_mg((SV*)av, 'P'))) {
 564         dSP;
 565         PUSHSTACKi(PERLSI_MAGIC);
 566         PUSHMARK(SP);
 567         EXTEND(SP,1+num);
 568         PUSHs(SvTIED_obj((SV*)av, mg));
 569         while (num-- > 0) {
 570             PUSHs(&PL_sv_undef);
 571         }
 572         PUTBACK;
 573         ENTER;
 574         call_method("UNSHIFT", G_SCALAR|G_DISCARD);
 575         LEAVE;
 576         POPSTACK;
 577         return;
 578     }
 579
 580     if (!AvREAL(av) && AvREIFY(av))
 581         av_reify(av);
 582     i = AvARRAY(av) - AvALLOC(av);
 583     if (i) {
 584         if (i > num)
 585             i = num;
 586         num -= i;
 587
 588         AvMAX(av) += i;
 589         AvFILLp(av) += i;
 590         SvPVX(av) = (char*)(AvARRAY(av) - i);
 591     }
 592     if (num) {
 593         i = AvFILLp(av);
 594         av_extend(av, i + num);
 595         AvFILLp(av) += num;
 596         ary = AvARRAY(av);
 597         Move(ary, ary + num, i + 1, SV*);
 598         do {
 599             ary[--num] = &PL_sv_undef;
 600         } while (num);
 601     }
 602 }
 603
 604 /*
 605 =for apidoc av_shift
 606
 607 Shifts an SV off the beginning of the array.
 608
 609 =cut
 610 */
 611
 612 SV *
 613 Perl_av_shift(pTHX_ register AV *av)
 614 {
 615     SV *retval;
 616     MAGIC* mg;
 617
 618     if (!av || AvFILL(av) < 0)
 619         return &PL_sv_undef;
 620     if (SvREADONLY(av))
 621         Perl_croak(aTHX_ PL_no_modify);
 622     if ((mg = SvTIED_mg((SV*)av, 'P'))) {
 623         dSP;
 624         PUSHSTACKi(PERLSI_MAGIC);
 625         PUSHMARK(SP);
 626         XPUSHs(SvTIED_obj((SV*)av, mg));
 627         PUTBACK;
 628         ENTER;
 629         if (call_method("SHIFT", G_SCALAR)) {
 630             retval = newSVsv(*PL_stack_sp--);
 631         } else {
 632             retval = &PL_sv_undef;
 633         }
 634         LEAVE;
 635         POPSTACK;
 636         return retval;
 637     }
 638     retval = *AvARRAY(av);
 639     if (AvREAL(av))
 640         *AvARRAY(av) = &PL_sv_undef;
 641     SvPVX(av) = (char*)(AvARRAY(av) + 1);
 642     AvMAX(av)--;
 643     AvFILLp(av)--;
 644     if (SvSMAGICAL(av))
 645         mg_set((SV*)av);
 646     return retval;
 647 }
 648
 649 /*
 650 =for apidoc av_len
 651
 652 Returns the highest index in the array.  Returns -1 if the array is
 653 empty.
 654
 655 =cut
 656 */
 657
 658 I32
 659 Perl_av_len(pTHX_ register AV *av)
 660 {
 661     return AvFILL(av);
 662 }
 663
 664 void
 665 Perl_av_fill(pTHX_ register AV *av, I32 fill)
 666 {
 667     MAGIC *mg;
 668     if (!av)
 669         Perl_croak(aTHX_ "panic: null array");
 670     if (fill < 0)
 671         fill = -1;
 672     if ((mg = SvTIED_mg((SV*)av, 'P'))) {
 673         dSP;
 674         ENTER;
 675         SAVETMPS;
 676         PUSHSTACKi(PERLSI_MAGIC);
 677         PUSHMARK(SP);
 678         EXTEND(SP,2);
 679         PUSHs(SvTIED_obj((SV*)av, mg));
 680         PUSHs(sv_2mortal(newSViv(fill+1)));
 681         PUTBACK;
 682         call_method("STORESIZE", G_SCALAR|G_DISCARD);
 683         POPSTACK;
 684         FREETMPS;
 685         LEAVE;
 686         return;
 687     }
 688     if (fill <= AvMAX(av)) {
 689         I32 key = AvFILLp(av);
 690         SV** ary = AvARRAY(av);
 691
 692         if (AvREAL(av)) {
 693             while (key > fill) {
 694                 SvREFCNT_dec(ary[key]);
 695                 ary[key--] = &PL_sv_undef;
 696             }
 697         }
 698         else {
 699             while (key < fill)
 700                 ary[++key] = &PL_sv_undef;
 701         }
 702
 703         AvFILLp(av) = fill;
 704         if (SvSMAGICAL(av))
 705             mg_set((SV*)av);
 706     }
 707     else
 708         (void)av_store(av,fill,&PL_sv_undef);
 709 }
 710
 711 SV *
 712 Perl_av_delete(pTHX_ AV *av, I32 key, I32 flags)
 713 {
 714     SV *sv;
 715
 716     if (!av)
 717         return Nullsv;
 718     if (SvREADONLY(av))
 719         Perl_croak(aTHX_ PL_no_modify);
 720     if (key < 0) {
 721         key += AvFILL(av) + 1;
 722         if (key < 0)
 723             return Nullsv;
 724     }
 725     if (SvRMAGICAL(av)) {
 726         SV **svp;
 727         if ((mg_find((SV*)av,'P') || mg_find((SV*)av,'D'))
 728             && (svp = av_fetch(av, key, TRUE)))
 729         {
 730             sv = *svp;
 731             mg_clear(sv);
 732             if (mg_find(sv, 'p')) {
 733                 sv_unmagic(sv, 'p');            /* No longer an element */
 734                 return sv;
 735             }
 736             return Nullsv;                      /* element cannot be deleted */
 737         }
 738     }
 739     if (key > AvFILLp(av))
 740         return Nullsv;
 741     else {
 742         sv = AvARRAY(av)[key];
 743         if (key == AvFILLp(av)) {
 744             do {
 745                 AvFILLp(av)--;
 746             } while (--key >= 0 && AvARRAY(av)[key] == &PL_sv_undef);
 747         }
 748         else
 749             AvARRAY(av)[key] = &PL_sv_undef;
 750         if (SvSMAGICAL(av))
 751             mg_set((SV*)av);
 752     }
 753     if (flags & G_DISCARD) {
 754         SvREFCNT_dec(sv);
 755         sv = Nullsv;
 756     }
 757     return sv;
 758 }
 759
 760 /*
 761  * This relies on the fact that uninitialized array elements
 762  * are set to &PL_sv_undef.
 763  */
 764
 765 bool
 766 Perl_av_exists(pTHX_ AV *av, I32 key)
 767 {
 768     if (!av)
 769         return FALSE;
 770     if (key < 0) {
 771         key += AvFILL(av) + 1;
 772         if (key < 0)
 773             return FALSE;
 774     }
 775     if (SvRMAGICAL(av)) {
 776         if (mg_find((SV*)av,'P') || mg_find((SV*)av,'D')) {
 777             SV *sv = sv_newmortal();
 778             mg_copy((SV*)av, sv, 0, key);
 779             magic_existspack(sv, mg_find(sv, 'p'));
 780             return SvTRUE(sv);
 781         }
 782     }
 783     if (key <= AvFILLp(av) && AvARRAY(av)[key] != &PL_sv_undef
 784         && AvARRAY(av)[key])
 785     {
 786         return TRUE;
 787     }
 788     else
 789         return FALSE;
 790 }
 791
 792 /* AVHV: Support for treating arrays as if they were hashes.  The
 793  * first element of the array should be a hash reference that maps
 794  * hash keys to array indices.
 795  */
 796
 797 STATIC I32
 798 S_avhv_index_sv(pTHX_ SV* sv)
 799 {
 800     I32 index = SvIV(sv);
 801     if (index < 1)
 802         Perl_croak(aTHX_ "Bad index while coercing array into hash");
 803     return index;
 804 }
 805
 806 STATIC I32
 807 S_avhv_index(pTHX_ AV *av, SV *keysv, U32 hash)
 808 {
 809     HV *keys;
 810     HE *he;
 811     STRLEN n_a;
 812
 813     keys = avhv_keys(av);
 814     he = hv_fetch_ent(keys, keysv, FALSE, hash);
 815     if (!he)
 816         Perl_croak(aTHX_ "No such pseudo-hash field \"%s\"", SvPV(keysv,n_a));
 817     return avhv_index_sv(HeVAL(he));
 818 }
 819
 820 HV*
 821 Perl_avhv_keys(pTHX_ AV *av)
 822 {
 823     SV **keysp = av_fetch(av, 0, FALSE);
 824     if (keysp) {
 825         SV *sv = *keysp;
 826         if (SvGMAGICAL(sv))
 827             mg_get(sv);
 828         if (SvROK(sv)) {
 829             sv = SvRV(sv);
 830             if (SvTYPE(sv) == SVt_PVHV)
 831                 return (HV*)sv;
 832         }
 833     }
 834     Perl_croak(aTHX_ "Can't coerce array into hash");
 835     return Nullhv;
 836 }
 837
 838 SV**
 839 Perl_avhv_store_ent(pTHX_ AV *av, SV *keysv, SV *val, U32 hash)
 840 {
 841     return av_store(av, avhv_index(av, keysv, hash), val);
 842 }
 843
 844 SV**
 845 Perl_avhv_fetch_ent(pTHX_ AV *av, SV *keysv, I32 lval, U32 hash)
 846 {
 847     return av_fetch(av, avhv_index(av, keysv, hash), lval);
 848 }
 849
 850 SV *
 851 Perl_avhv_delete_ent(pTHX_ AV *av, SV *keysv, I32 flags, U32 hash)
 852 {
 853     HV *keys = avhv_keys(av);
 854     HE *he;
 855
 856     he = hv_fetch_ent(keys, keysv, FALSE, hash);
 857     if (!he || !SvOK(HeVAL(he)))
 858         return Nullsv;
 859
 860     return av_delete(av, avhv_index_sv(HeVAL(he)), flags);
 861 }
 862
 863 /* Check for the existence of an element named by a given key.
 864  *
 865  */
 866 bool
 867 Perl_avhv_exists_ent(pTHX_ AV *av, SV *keysv, U32 hash)
 868 {
 869     HV *keys = avhv_keys(av);
 870     HE *he;
 871
 872     he = hv_fetch_ent(keys, keysv, FALSE, hash);
 873     if (!he || !SvOK(HeVAL(he)))
 874         return FALSE;
 875
 876     return av_exists(av, avhv_index_sv(HeVAL(he)));
 877 }
 878
 879 HE *
 880 Perl_avhv_iternext(pTHX_ AV *av)
 881 {
 882     HV *keys = avhv_keys(av);
 883     return hv_iternext(keys);
 884 }
 885
 886 SV *
 887 Perl_avhv_iterval(pTHX_ AV *av, register HE *entry)
 888 {
 889     SV *sv = hv_iterval(avhv_keys(av), entry);
 890     return *av_fetch(av, avhv_index_sv(sv), TRUE);
 891 }