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