av.c

   1 /*    av.c
   2  *
   3  *    Copyright (c) 1991-2001, 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, PERL_MAGIC_tied) && 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             (void)SvREFCNT_inc(sv);
  39     }
  40     key = AvARRAY(av) - AvALLOC(av);
  41     while (key)
  42         AvALLOC(av)[--key] = &PL_sv_undef;
  43     AvREIFY_off(av);
  44     AvREAL_on(av);
  45 }
  46
  47 /*
  48 =for apidoc av_extend
  49
  50 Pre-extend an array.  The C<key> is the index to which the array should be
  51 extended.
  52
  53 =cut
  54 */
  55
  56 void
  57 Perl_av_extend(pTHX_ AV *av, I32 key)
  58 {
  59     MAGIC *mg;
  60     if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
  61         dSP;
  62         ENTER;
  63         SAVETMPS;
  64         PUSHSTACKi(PERLSI_MAGIC);
  65         PUSHMARK(SP);
  66         EXTEND(SP,2);
  67         PUSHs(SvTIED_obj((SV*)av, mg));
  68         PUSHs(sv_2mortal(newSViv(key+1)));
  69         PUTBACK;
  70         call_method("EXTEND", G_SCALAR|G_DISCARD);
  71         POPSTACK;
  72         FREETMPS;
  73         LEAVE;
  74         return;
  75     }
  76     if (key > AvMAX(av)) {
  77         SV** ary;
  78         I32 tmp;
  79         I32 newmax;
  80
  81         if (AvALLOC(av) != AvARRAY(av)) {
  82             ary = AvALLOC(av) + AvFILLp(av) + 1;
  83             tmp = AvARRAY(av) - AvALLOC(av);
  84             Move(AvARRAY(av), AvALLOC(av), AvFILLp(av)+1, SV*);
  85             AvMAX(av) += tmp;
  86             SvPVX(av) = (char*)AvALLOC(av);
  87             if (AvREAL(av)) {
  88                 while (tmp)
  89                     ary[--tmp] = &PL_sv_undef;
  90             }
  91
  92             if (key > AvMAX(av) - 10) {
  93                 newmax = key + AvMAX(av);
  94                 goto resize;
  95             }
  96         }
  97         else {
  98             if (AvALLOC(av)) {
  99 #if !defined(STRANGE_MALLOC) && !defined(MYMALLOC)
 100                 MEM_SIZE bytes;
 101                 IV itmp;
 102 #endif
 103
 104 #if defined(MYMALLOC) && !defined(LEAKTEST)
 105                 newmax = malloced_size((void*)AvALLOC(av))/sizeof(SV*) - 1;
 106
 107                 if (key <= newmax)
 108                     goto resized;
 109 #endif
 110                 newmax = key + AvMAX(av) / 5;
 111               resize:
 112 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
 113                 Renew(AvALLOC(av),newmax+1, SV*);
 114 #else
 115                 bytes = (newmax + 1) * sizeof(SV*);
 116 #define MALLOC_OVERHEAD 16
 117                 itmp = MALLOC_OVERHEAD;
 118                 while (itmp - MALLOC_OVERHEAD < bytes)
 119                     itmp += itmp;
 120                 itmp -= MALLOC_OVERHEAD;
 121                 itmp /= sizeof(SV*);
 122                 assert(itmp > newmax);
 123                 newmax = itmp - 1;
 124                 assert(newmax >= AvMAX(av));
 125                 New(2,ary, newmax+1, SV*);
 126                 Copy(AvALLOC(av), ary, AvMAX(av)+1, SV*);
 127                 if (AvMAX(av) > 64)
 128                     offer_nice_chunk(AvALLOC(av), (AvMAX(av)+1) * sizeof(SV*));
 129                 else
 130                     Safefree(AvALLOC(av));
 131                 AvALLOC(av) = ary;
 132 #endif
 133 #if defined(MYMALLOC) && !defined(LEAKTEST)
 134               resized:
 135 #endif
 136                 ary = AvALLOC(av) + AvMAX(av) + 1;
 137                 tmp = newmax - AvMAX(av);
 138                 if (av == PL_curstack) {        /* Oops, grew stack (via av_store()?) */
 139                     PL_stack_sp = AvALLOC(av) + (PL_stack_sp - PL_stack_base);
 140                     PL_stack_base = AvALLOC(av);
 141                     PL_stack_max = PL_stack_base + newmax;
 142                 }
 143             }
 144             else {
 145                 newmax = key < 3 ? 3 : key;
 146                 New(2,AvALLOC(av), newmax+1, SV*);
 147                 ary = AvALLOC(av) + 1;
 148                 tmp = newmax;
 149                 AvALLOC(av)[0] = &PL_sv_undef;  /* For the stacks */
 150             }
 151             if (AvREAL(av)) {
 152                 while (tmp)
 153                     ary[--tmp] = &PL_sv_undef;
 154             }
 155
 156             SvPVX(av) = (char*)AvALLOC(av);
 157             AvMAX(av) = newmax;
 158         }
 159     }
 160 }
 161
 162 /*
 163 =for apidoc av_fetch
 164
 165 Returns the SV at the specified index in the array.  The C<key> is the
 166 index.  If C<lval> is set then the fetch will be part of a store.  Check
 167 that the return value is non-null before dereferencing it to a C<SV*>.
 168
 169 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
 170 more information on how to use this function on tied arrays.
 171
 172 =cut
 173 */
 174
 175 SV**
 176 Perl_av_fetch(pTHX_ register AV *av, I32 key, I32 lval)
 177 {
 178     SV *sv;
 179
 180     if (!av)
 181         return 0;
 182
 183     if (key < 0) {
 184         key += AvFILL(av) + 1;
 185         if (key < 0)
 186             return 0;
 187     }
 188
 189     if (SvRMAGICAL(av)) {
 190         if (mg_find((SV*)av, PERL_MAGIC_tied) ||
 191                 mg_find((SV*)av, PERL_MAGIC_regdata))
 192         {
 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, PERL_MAGIC_tied)) {
 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             if (av == PL_curstack && key > PL_stack_sp - PL_stack_base)
 276                 PL_stack_sp = PL_stack_base + key;      /* XPUSH in disguise */
 277             do
 278                 ary[++AvFILLp(av)] = &PL_sv_undef;
 279             while (AvFILLp(av) < key);
 280         }
 281         AvFILLp(av) = key;
 282     }
 283     else if (AvREAL(av))
 284         SvREFCNT_dec(ary[key]);
 285     ary[key] = val;
 286     if (SvSMAGICAL(av)) {
 287         if (val != &PL_sv_undef) {
 288             MAGIC* mg = SvMAGIC(av);
 289             sv_magic(val, (SV*)av, toLOWER(mg->mg_type), 0, key);
 290         }
 291         mg_set((SV*)av);
 292     }
 293     return &ary[key];
 294 }
 295
 296 /*
 297 =for apidoc newAV
 298
 299 Creates a new AV.  The reference count is set to 1.
 300
 301 =cut
 302 */
 303
 304 AV *
 305 Perl_newAV(pTHX)
 306 {
 307     register AV *av;
 308
 309     av = (AV*)NEWSV(3,0);
 310     sv_upgrade((SV *)av, SVt_PVAV);
 311     AvREAL_on(av);
 312     AvALLOC(av) = 0;
 313     SvPVX(av) = 0;
 314     AvMAX(av) = AvFILLp(av) = -1;
 315     return av;
 316 }
 317
 318 /*
 319 =for apidoc av_make
 320
 321 Creates a new AV and populates it with a list of SVs.  The SVs are copied
 322 into the array, so they may be freed after the call to av_make.  The new AV
 323 will have a reference count of 1.
 324
 325 =cut
 326 */
 327
 328 AV *
 329 Perl_av_make(pTHX_ register I32 size, register SV **strp)
 330 {
 331     register AV *av;
 332     register I32 i;
 333     register SV** ary;
 334
 335     av = (AV*)NEWSV(8,0);
 336     sv_upgrade((SV *) av,SVt_PVAV);
 337     AvFLAGS(av) = AVf_REAL;
 338     if (size) {         /* `defined' was returning undef for size==0 anyway. */
 339         New(4,ary,size,SV*);
 340         AvALLOC(av) = ary;
 341         SvPVX(av) = (char*)ary;
 342         AvFILLp(av) = size - 1;
 343         AvMAX(av) = size - 1;
 344         for (i = 0; i < size; i++) {
 345             assert (*strp);
 346             ary[i] = NEWSV(7,0);
 347             sv_setsv(ary[i], *strp);
 348             strp++;
 349         }
 350     }
 351     return av;
 352 }
 353
 354 AV *
 355 Perl_av_fake(pTHX_ register I32 size, register SV **strp)
 356 {
 357     register AV *av;
 358     register SV** ary;
 359
 360     av = (AV*)NEWSV(9,0);
 361     sv_upgrade((SV *)av, SVt_PVAV);
 362     New(4,ary,size+1,SV*);
 363     AvALLOC(av) = ary;
 364     Copy(strp,ary,size,SV*);
 365     AvFLAGS(av) = AVf_REIFY;
 366     SvPVX(av) = (char*)ary;
 367     AvFILLp(av) = size - 1;
 368     AvMAX(av) = size - 1;
 369     while (size--) {
 370         assert (*strp);
 371         SvTEMP_off(*strp);
 372         strp++;
 373     }
 374     return av;
 375 }
 376
 377 /*
 378 =for apidoc av_clear
 379
 380 Clears an array, making it empty.  Does not free the memory used by the
 381 array itself.
 382
 383 =cut
 384 */
 385
 386 void
 387 Perl_av_clear(pTHX_ register AV *av)
 388 {
 389     register I32 key;
 390     SV** ary;
 391
 392 #ifdef DEBUGGING
 393     if (SvREFCNT(av) == 0 && ckWARN_d(WARN_DEBUGGING)) {
 394         Perl_warner(aTHX_ WARN_DEBUGGING, "Attempt to clear deleted array");
 395     }
 396 #endif
 397     if (!av)
 398         return;
 399     /*SUPPRESS 560*/
 400
 401     if (SvREADONLY(av))
 402         Perl_croak(aTHX_ PL_no_modify);
 403
 404     /* Give any tie a chance to cleanup first */
 405     if (SvRMAGICAL(av))
 406         mg_clear((SV*)av);
 407
 408     if (AvMAX(av) < 0)
 409         return;
 410
 411     if (AvREAL(av)) {
 412         ary = AvARRAY(av);
 413         key = AvFILLp(av) + 1;
 414         while (key) {
 415             SvREFCNT_dec(ary[--key]);
 416             ary[key] = &PL_sv_undef;
 417         }
 418     }
 419     if ((key = AvARRAY(av) - AvALLOC(av))) {
 420         AvMAX(av) += key;
 421         SvPVX(av) = (char*)AvALLOC(av);
 422     }
 423     AvFILLp(av) = -1;
 424
 425 }
 426
 427 /*
 428 =for apidoc av_undef
 429
 430 Undefines the array.  Frees the memory used by the array itself.
 431
 432 =cut
 433 */
 434
 435 void
 436 Perl_av_undef(pTHX_ register AV *av)
 437 {
 438     register I32 key;
 439
 440     if (!av)
 441         return;
 442     /*SUPPRESS 560*/
 443
 444     /* Give any tie a chance to cleanup first */
 445     if (SvTIED_mg((SV*)av, PERL_MAGIC_tied))
 446         av_fill(av, -1);   /* mg_clear() ? */
 447
 448     if (AvREAL(av)) {
 449         key = AvFILLp(av) + 1;
 450         while (key)
 451             SvREFCNT_dec(AvARRAY(av)[--key]);
 452     }
 453     Safefree(AvALLOC(av));
 454     AvALLOC(av) = 0;
 455     SvPVX(av) = 0;
 456     AvMAX(av) = AvFILLp(av) = -1;
 457     if (AvARYLEN(av)) {
 458         SvREFCNT_dec(AvARYLEN(av));
 459         AvARYLEN(av) = 0;
 460     }
 461 }
 462
 463 /*
 464 =for apidoc av_push
 465
 466 Pushes an SV onto the end of the array.  The array will grow automatically
 467 to accommodate the addition.
 468
 469 =cut
 470 */
 471
 472 void
 473 Perl_av_push(pTHX_ register AV *av, SV *val)
 474 {
 475     MAGIC *mg;
 476     if (!av)
 477         return;
 478     if (SvREADONLY(av))
 479         Perl_croak(aTHX_ PL_no_modify);
 480
 481     if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
 482         dSP;
 483         PUSHSTACKi(PERLSI_MAGIC);
 484         PUSHMARK(SP);
 485         EXTEND(SP,2);
 486         PUSHs(SvTIED_obj((SV*)av, mg));
 487         PUSHs(val);
 488         PUTBACK;
 489         ENTER;
 490         call_method("PUSH", G_SCALAR|G_DISCARD);
 491         LEAVE;
 492         POPSTACK;
 493         return;
 494     }
 495     av_store(av,AvFILLp(av)+1,val);
 496 }
 497
 498 /*
 499 =for apidoc av_pop
 500
 501 Pops an SV off the end of the array.  Returns C<&PL_sv_undef> if the array
 502 is empty.
 503
 504 =cut
 505 */
 506
 507 SV *
 508 Perl_av_pop(pTHX_ register AV *av)
 509 {
 510     SV *retval;
 511     MAGIC* mg;
 512
 513     if (!av || AvFILL(av) < 0)
 514         return &PL_sv_undef;
 515     if (SvREADONLY(av))
 516         Perl_croak(aTHX_ PL_no_modify);
 517     if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
 518         dSP;
 519         PUSHSTACKi(PERLSI_MAGIC);
 520         PUSHMARK(SP);
 521         XPUSHs(SvTIED_obj((SV*)av, mg));
 522         PUTBACK;
 523         ENTER;
 524         if (call_method("POP", G_SCALAR)) {
 525             retval = newSVsv(*PL_stack_sp--);
 526         } else {
 527             retval = &PL_sv_undef;
 528         }
 529         LEAVE;
 530         POPSTACK;
 531         return retval;
 532     }
 533     retval = AvARRAY(av)[AvFILLp(av)];
 534     AvARRAY(av)[AvFILLp(av)--] = &PL_sv_undef;
 535     if (SvSMAGICAL(av))
 536         mg_set((SV*)av);
 537     return retval;
 538 }
 539
 540 /*
 541 =for apidoc av_unshift
 542
 543 Unshift the given number of C<undef> values onto the beginning of the
 544 array.  The array will grow automatically to accommodate the addition.  You
 545 must then use C<av_store> to assign values to these new elements.
 546
 547 =cut
 548 */
 549
 550 void
 551 Perl_av_unshift(pTHX_ register AV *av, register I32 num)
 552 {
 553     register I32 i;
 554     register SV **ary;
 555     MAGIC* mg;
 556     I32 slide;
 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, PERL_MAGIC_tied))) {
 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         /* Create extra elements */
 595         slide = i > 0 ? i : 0;
 596         num += slide;
 597         av_extend(av, i + num);
 598         AvFILLp(av) += num;
 599         ary = AvARRAY(av);
 600         Move(ary, ary + num, i + 1, SV*);
 601         do {
 602             ary[--num] = &PL_sv_undef;
 603         } while (num);
 604         /* Make extra elements into a buffer */
 605         AvMAX(av) -= slide;
 606         AvFILLp(av) -= slide;
 607         SvPVX(av) = (char*)(AvARRAY(av) + slide);
 608     }
 609 }
 610
 611 /*
 612 =for apidoc av_shift
 613
 614 Shifts an SV off the beginning of the array.
 615
 616 =cut
 617 */
 618
 619 SV *
 620 Perl_av_shift(pTHX_ register AV *av)
 621 {
 622     SV *retval;
 623     MAGIC* mg;
 624
 625     if (!av || AvFILL(av) < 0)
 626         return &PL_sv_undef;
 627     if (SvREADONLY(av))
 628         Perl_croak(aTHX_ PL_no_modify);
 629     if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
 630         dSP;
 631         PUSHSTACKi(PERLSI_MAGIC);
 632         PUSHMARK(SP);
 633         XPUSHs(SvTIED_obj((SV*)av, mg));
 634         PUTBACK;
 635         ENTER;
 636         if (call_method("SHIFT", G_SCALAR)) {
 637             retval = newSVsv(*PL_stack_sp--);
 638         } else {
 639             retval = &PL_sv_undef;
 640         }
 641         LEAVE;
 642         POPSTACK;
 643         return retval;
 644     }
 645     retval = *AvARRAY(av);
 646     if (AvREAL(av))
 647         *AvARRAY(av) = &PL_sv_undef;
 648     SvPVX(av) = (char*)(AvARRAY(av) + 1);
 649     AvMAX(av)--;
 650     AvFILLp(av)--;
 651     if (SvSMAGICAL(av))
 652         mg_set((SV*)av);
 653     return retval;
 654 }
 655
 656 /*
 657 =for apidoc av_len
 658
 659 Returns the highest index in the array.  Returns -1 if the array is
 660 empty.
 661
 662 =cut
 663 */
 664
 665 I32
 666 Perl_av_len(pTHX_ register AV *av)
 667 {
 668     return AvFILL(av);
 669 }
 670
 671 /*
 672 =for apidoc av_fill
 673
 674 Ensure than an array has a given number of elements, equivalent to
 675 Perl's C<$#array = $fill;>.
 676
 677 =cut
 678 */
 679 void
 680 Perl_av_fill(pTHX_ register AV *av, I32 fill)
 681 {
 682     MAGIC *mg;
 683     if (!av)
 684         Perl_croak(aTHX_ "panic: null array");
 685     if (fill < 0)
 686         fill = -1;
 687     if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
 688         dSP;
 689         ENTER;
 690         SAVETMPS;
 691         PUSHSTACKi(PERLSI_MAGIC);
 692         PUSHMARK(SP);
 693         EXTEND(SP,2);
 694         PUSHs(SvTIED_obj((SV*)av, mg));
 695         PUSHs(sv_2mortal(newSViv(fill+1)));
 696         PUTBACK;
 697         call_method("STORESIZE", G_SCALAR|G_DISCARD);
 698         POPSTACK;
 699         FREETMPS;
 700         LEAVE;
 701         return;
 702     }
 703     if (fill <= AvMAX(av)) {
 704         I32 key = AvFILLp(av);
 705         SV** ary = AvARRAY(av);
 706
 707         if (AvREAL(av)) {
 708             while (key > fill) {
 709                 SvREFCNT_dec(ary[key]);
 710                 ary[key--] = &PL_sv_undef;
 711             }
 712         }
 713         else {
 714             while (key < fill)
 715                 ary[++key] = &PL_sv_undef;
 716         }
 717
 718         AvFILLp(av) = fill;
 719         if (SvSMAGICAL(av))
 720             mg_set((SV*)av);
 721     }
 722     else
 723         (void)av_store(av,fill,&PL_sv_undef);
 724 }
 725
 726 /*
 727 =for apidoc av_delete
 728
 729 Deletes the element indexed by C<key> from the array.  Returns the
 730 deleted element. C<flags> is currently ignored.
 731
 732 =cut
 733 */
 734 SV *
 735 Perl_av_delete(pTHX_ AV *av, I32 key, I32 flags)
 736 {
 737     SV *sv;
 738
 739     if (!av)
 740         return Nullsv;
 741     if (SvREADONLY(av))
 742         Perl_croak(aTHX_ PL_no_modify);
 743     if (key < 0) {
 744         key += AvFILL(av) + 1;
 745         if (key < 0)
 746             return Nullsv;
 747     }
 748     if (SvRMAGICAL(av)) {
 749         SV **svp;
 750         if ((mg_find((SV*)av, PERL_MAGIC_tied) ||
 751                 mg_find((SV*)av, PERL_MAGIC_regdata))
 752             && (svp = av_fetch(av, key, TRUE)))
 753         {
 754             sv = *svp;
 755             mg_clear(sv);
 756             if (mg_find(sv, PERL_MAGIC_tiedelem)) {
 757                 sv_unmagic(sv, PERL_MAGIC_tiedelem);    /* No longer an element */
 758                 return sv;
 759             }
 760             return Nullsv;                      /* element cannot be deleted */
 761         }
 762     }
 763     if (key > AvFILLp(av))
 764         return Nullsv;
 765     else {
 766         sv = AvARRAY(av)[key];
 767         if (key == AvFILLp(av)) {
 768             do {
 769                 AvFILLp(av)--;
 770             } while (--key >= 0 && AvARRAY(av)[key] == &PL_sv_undef);
 771         }
 772         else
 773             AvARRAY(av)[key] = &PL_sv_undef;
 774         if (SvSMAGICAL(av))
 775             mg_set((SV*)av);
 776     }
 777     if (flags & G_DISCARD) {
 778         SvREFCNT_dec(sv);
 779         sv = Nullsv;
 780     }
 781     return sv;
 782 }
 783
 784 /*
 785 =for apidoc av_exists
 786
 787 Returns true if the element indexed by C<key> has been initialized.
 788
 789 This relies on the fact that uninitialized array elements are set to
 790 C<&PL_sv_undef>.
 791
 792 =cut
 793 */
 794 bool
 795 Perl_av_exists(pTHX_ AV *av, I32 key)
 796 {
 797     if (!av)
 798         return FALSE;
 799     if (key < 0) {
 800         key += AvFILL(av) + 1;
 801         if (key < 0)
 802             return FALSE;
 803     }
 804     if (SvRMAGICAL(av)) {
 805         if (mg_find((SV*)av, PERL_MAGIC_tied) ||
 806                 mg_find((SV*)av, PERL_MAGIC_regdata))
 807         {
 808             SV *sv = sv_newmortal();
 809             MAGIC *mg;
 810
 811             mg_copy((SV*)av, sv, 0, key);
 812             mg = mg_find(sv, PERL_MAGIC_tiedelem);
 813             if (mg) {
 814                 magic_existspack(sv, mg);
 815                 return SvTRUE(sv);
 816             }
 817         }
 818     }
 819     if (key <= AvFILLp(av) && AvARRAY(av)[key] != &PL_sv_undef
 820         && AvARRAY(av)[key])
 821     {
 822         return TRUE;
 823     }
 824     else
 825         return FALSE;
 826 }
 827
 828 /* AVHV: Support for treating arrays as if they were hashes.  The
 829  * first element of the array should be a hash reference that maps
 830  * hash keys to array indices.
 831  */
 832
 833 STATIC I32
 834 S_avhv_index_sv(pTHX_ SV* sv)
 835 {
 836     I32 index = SvIV(sv);
 837     if (index < 1)
 838         Perl_croak(aTHX_ "Bad index while coercing array into hash");
 839     return index;
 840 }
 841
 842 STATIC I32
 843 S_avhv_index(pTHX_ AV *av, SV *keysv, U32 hash)
 844 {
 845     HV *keys;
 846     HE *he;
 847     STRLEN n_a;
 848
 849     keys = avhv_keys(av);
 850     he = hv_fetch_ent(keys, keysv, FALSE, hash);
 851     if (!he)
 852         Perl_croak(aTHX_ "No such pseudo-hash field \"%s\"", SvPV(keysv,n_a));
 853     return avhv_index_sv(HeVAL(he));
 854 }
 855
 856 HV*
 857 Perl_avhv_keys(pTHX_ AV *av)
 858 {
 859     SV **keysp = av_fetch(av, 0, FALSE);
 860     if (keysp) {
 861         SV *sv = *keysp;
 862         if (SvGMAGICAL(sv))
 863             mg_get(sv);
 864         if (SvROK(sv)) {
 865             sv = SvRV(sv);
 866             if (SvTYPE(sv) == SVt_PVHV)
 867                 return (HV*)sv;
 868         }
 869     }
 870     Perl_croak(aTHX_ "Can't coerce array into hash");
 871     return Nullhv;
 872 }
 873
 874 SV**
 875 Perl_avhv_store_ent(pTHX_ AV *av, SV *keysv, SV *val, U32 hash)
 876 {
 877     return av_store(av, avhv_index(av, keysv, hash), val);
 878 }
 879
 880 SV**
 881 Perl_avhv_fetch_ent(pTHX_ AV *av, SV *keysv, I32 lval, U32 hash)
 882 {
 883     return av_fetch(av, avhv_index(av, keysv, hash), lval);
 884 }
 885
 886 SV *
 887 Perl_avhv_delete_ent(pTHX_ AV *av, SV *keysv, I32 flags, U32 hash)
 888 {
 889     HV *keys = avhv_keys(av);
 890     HE *he;
 891
 892     he = hv_fetch_ent(keys, keysv, FALSE, hash);
 893     if (!he || !SvOK(HeVAL(he)))
 894         return Nullsv;
 895
 896     return av_delete(av, avhv_index_sv(HeVAL(he)), flags);
 897 }
 898
 899 /* Check for the existence of an element named by a given key.
 900  *
 901  */
 902 bool
 903 Perl_avhv_exists_ent(pTHX_ AV *av, SV *keysv, U32 hash)
 904 {
 905     HV *keys = avhv_keys(av);
 906     HE *he;
 907
 908     he = hv_fetch_ent(keys, keysv, FALSE, hash);
 909     if (!he || !SvOK(HeVAL(he)))
 910         return FALSE;
 911
 912     return av_exists(av, avhv_index_sv(HeVAL(he)));
 913 }
 914
 915 HE *
 916 Perl_avhv_iternext(pTHX_ AV *av)
 917 {
 918     HV *keys = avhv_keys(av);
 919     return hv_iternext(keys);
 920 }
 921
 922 SV *
 923 Perl_avhv_iterval(pTHX_ AV *av, register HE *entry)
 924 {
 925     SV *sv = hv_iterval(avhv_keys(av), entry);
 926     return *av_fetch(av, avhv_index_sv(sv), TRUE);
 927 }