av.c

   1 /*    av.c
   2  *
   3  *    Copyright (c) 1991-2002, 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_ packWARN(WARN_DEBUGGING), "av_reify called on tied array");
  34 #endif
  35     key = AvMAX(av) + 1;
  36     while (key > AvFILLp(av) + 1)
  37         AvARRAY(av)[--key] = &PL_sv_undef;
  38     while (key) {
  39         sv = 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 ((MEM_SIZE)(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_ packWARN(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)
 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     if (AvFILL(av) < 0)
 538         return &PL_sv_undef;
 539     retval = AvARRAY(av)[AvFILLp(av)];
 540     AvARRAY(av)[AvFILLp(av)--] = &PL_sv_undef;
 541     if (SvSMAGICAL(av))
 542         mg_set((SV*)av);
 543     return retval;
 544 }
 545
 546 /*
 547 =for apidoc av_unshift
 548
 549 Unshift the given number of C<undef> values onto the beginning of the
 550 array.  The array will grow automatically to accommodate the addition.  You
 551 must then use C<av_store> to assign values to these new elements.
 552
 553 =cut
 554 */
 555
 556 void
 557 Perl_av_unshift(pTHX_ register AV *av, register I32 num)
 558 {
 559     register I32 i;
 560     register SV **ary;
 561     MAGIC* mg;
 562     I32 slide;
 563
 564     if (!av)
 565         return;
 566     if (SvREADONLY(av))
 567         Perl_croak(aTHX_ PL_no_modify);
 568
 569     if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
 570         dSP;
 571         PUSHSTACKi(PERLSI_MAGIC);
 572         PUSHMARK(SP);
 573         EXTEND(SP,1+num);
 574         PUSHs(SvTIED_obj((SV*)av, mg));
 575         while (num-- > 0) {
 576             PUSHs(&PL_sv_undef);
 577         }
 578         PUTBACK;
 579         ENTER;
 580         call_method("UNSHIFT", G_SCALAR|G_DISCARD);
 581         LEAVE;
 582         POPSTACK;
 583         return;
 584     }
 585
 586     if (num <= 0)
 587       return;
 588     if (!AvREAL(av) && AvREIFY(av))
 589         av_reify(av);
 590     i = AvARRAY(av) - AvALLOC(av);
 591     if (i) {
 592         if (i > num)
 593             i = num;
 594         num -= i;
 595
 596         AvMAX(av) += i;
 597         AvFILLp(av) += i;
 598         SvPVX(av) = (char*)(AvARRAY(av) - i);
 599     }
 600     if (num) {
 601         i = AvFILLp(av);
 602         /* Create extra elements */
 603         slide = i > 0 ? i : 0;
 604         num += slide;
 605         av_extend(av, i + num);
 606         AvFILLp(av) += num;
 607         ary = AvARRAY(av);
 608         Move(ary, ary + num, i + 1, SV*);
 609         do {
 610             ary[--num] = &PL_sv_undef;
 611         } while (num);
 612         /* Make extra elements into a buffer */
 613         AvMAX(av) -= slide;
 614         AvFILLp(av) -= slide;
 615         SvPVX(av) = (char*)(AvARRAY(av) + slide);
 616     }
 617 }
 618
 619 /*
 620 =for apidoc av_shift
 621
 622 Shifts an SV off the beginning of the array.
 623
 624 =cut
 625 */
 626
 627 SV *
 628 Perl_av_shift(pTHX_ register AV *av)
 629 {
 630     SV *retval;
 631     MAGIC* mg;
 632
 633     if (!av)
 634         return &PL_sv_undef;
 635     if (SvREADONLY(av))
 636         Perl_croak(aTHX_ PL_no_modify);
 637     if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
 638         dSP;
 639         PUSHSTACKi(PERLSI_MAGIC);
 640         PUSHMARK(SP);
 641         XPUSHs(SvTIED_obj((SV*)av, mg));
 642         PUTBACK;
 643         ENTER;
 644         if (call_method("SHIFT", G_SCALAR)) {
 645             retval = newSVsv(*PL_stack_sp--);
 646         } else {
 647             retval = &PL_sv_undef;
 648         }
 649         LEAVE;
 650         POPSTACK;
 651         return retval;
 652     }
 653     if (AvFILL(av) < 0)
 654       return &PL_sv_undef;
 655     retval = *AvARRAY(av);
 656     if (AvREAL(av))
 657         *AvARRAY(av) = &PL_sv_undef;
 658     SvPVX(av) = (char*)(AvARRAY(av) + 1);
 659     AvMAX(av)--;
 660     AvFILLp(av)--;
 661     if (SvSMAGICAL(av))
 662         mg_set((SV*)av);
 663     return retval;
 664 }
 665
 666 /*
 667 =for apidoc av_len
 668
 669 Returns the highest index in the array.  Returns -1 if the array is
 670 empty.
 671
 672 =cut
 673 */
 674
 675 I32
 676 Perl_av_len(pTHX_ register AV *av)
 677 {
 678     return AvFILL(av);
 679 }
 680
 681 /*
 682 =for apidoc av_fill
 683
 684 Ensure than an array has a given number of elements, equivalent to
 685 Perl's C<$#array = $fill;>.
 686
 687 =cut
 688 */
 689 void
 690 Perl_av_fill(pTHX_ register AV *av, I32 fill)
 691 {
 692     MAGIC *mg;
 693     if (!av)
 694         Perl_croak(aTHX_ "panic: null array");
 695     if (fill < 0)
 696         fill = -1;
 697     if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
 698         dSP;
 699         ENTER;
 700         SAVETMPS;
 701         PUSHSTACKi(PERLSI_MAGIC);
 702         PUSHMARK(SP);
 703         EXTEND(SP,2);
 704         PUSHs(SvTIED_obj((SV*)av, mg));
 705         PUSHs(sv_2mortal(newSViv(fill+1)));
 706         PUTBACK;
 707         call_method("STORESIZE", G_SCALAR|G_DISCARD);
 708         POPSTACK;
 709         FREETMPS;
 710         LEAVE;
 711         return;
 712     }
 713     if (fill <= AvMAX(av)) {
 714         I32 key = AvFILLp(av);
 715         SV** ary = AvARRAY(av);
 716
 717         if (AvREAL(av)) {
 718             while (key > fill) {
 719                 SvREFCNT_dec(ary[key]);
 720                 ary[key--] = &PL_sv_undef;
 721             }
 722         }
 723         else {
 724             while (key < fill)
 725                 ary[++key] = &PL_sv_undef;
 726         }
 727
 728         AvFILLp(av) = fill;
 729         if (SvSMAGICAL(av))
 730             mg_set((SV*)av);
 731     }
 732     else
 733         (void)av_store(av,fill,&PL_sv_undef);
 734 }
 735
 736 /*
 737 =for apidoc av_delete
 738
 739 Deletes the element indexed by C<key> from the array.  Returns the
 740 deleted element. C<flags> is currently ignored.
 741
 742 =cut
 743 */
 744 SV *
 745 Perl_av_delete(pTHX_ AV *av, I32 key, I32 flags)
 746 {
 747     SV *sv;
 748
 749     if (!av)
 750         return Nullsv;
 751     if (SvREADONLY(av))
 752         Perl_croak(aTHX_ PL_no_modify);
 753     if (key < 0) {
 754         key += AvFILL(av) + 1;
 755         if (key < 0)
 756             return Nullsv;
 757     }
 758     if (SvRMAGICAL(av)) {
 759         SV **svp;
 760         if ((mg_find((SV*)av, PERL_MAGIC_tied) ||
 761                 mg_find((SV*)av, PERL_MAGIC_regdata))
 762             && (svp = av_fetch(av, key, TRUE)))
 763         {
 764             sv = *svp;
 765             mg_clear(sv);
 766             if (mg_find(sv, PERL_MAGIC_tiedelem)) {
 767                 sv_unmagic(sv, PERL_MAGIC_tiedelem);    /* No longer an element */
 768                 return sv;
 769             }
 770             return Nullsv;                      /* element cannot be deleted */
 771         }
 772     }
 773     if (key > AvFILLp(av))
 774         return Nullsv;
 775     else {
 776         sv = AvARRAY(av)[key];
 777         if (key == AvFILLp(av)) {
 778             AvARRAY(av)[key] = &PL_sv_undef;
 779             do {
 780                 AvFILLp(av)--;
 781             } while (--key >= 0 && AvARRAY(av)[key] == &PL_sv_undef);
 782         }
 783         else
 784             AvARRAY(av)[key] = &PL_sv_undef;
 785         if (SvSMAGICAL(av))
 786             mg_set((SV*)av);
 787     }
 788     if (flags & G_DISCARD) {
 789         SvREFCNT_dec(sv);
 790         sv = Nullsv;
 791     }
 792     return sv;
 793 }
 794
 795 /*
 796 =for apidoc av_exists
 797
 798 Returns true if the element indexed by C<key> has been initialized.
 799
 800 This relies on the fact that uninitialized array elements are set to
 801 C<&PL_sv_undef>.
 802
 803 =cut
 804 */
 805 bool
 806 Perl_av_exists(pTHX_ AV *av, I32 key)
 807 {
 808     if (!av)
 809         return FALSE;
 810     if (key < 0) {
 811         key += AvFILL(av) + 1;
 812         if (key < 0)
 813             return FALSE;
 814     }
 815     if (SvRMAGICAL(av)) {
 816         if (mg_find((SV*)av, PERL_MAGIC_tied) ||
 817                 mg_find((SV*)av, PERL_MAGIC_regdata))
 818         {
 819             SV *sv = sv_newmortal();
 820             MAGIC *mg;
 821
 822             mg_copy((SV*)av, sv, 0, key);
 823             mg = mg_find(sv, PERL_MAGIC_tiedelem);
 824             if (mg) {
 825                 magic_existspack(sv, mg);
 826                 return (bool)SvTRUE(sv);
 827             }
 828         }
 829     }
 830     if (key <= AvFILLp(av) && AvARRAY(av)[key] != &PL_sv_undef
 831         && AvARRAY(av)[key])
 832     {
 833         return TRUE;
 834     }
 835     else
 836         return FALSE;
 837 }
 838
 839 /* AVHV: Support for treating arrays as if they were hashes.  The
 840  * first element of the array should be a hash reference that maps
 841  * hash keys to array indices.
 842  */
 843
 844 STATIC I32
 845 S_avhv_index_sv(pTHX_ SV* sv)
 846 {
 847     I32 index = SvIV(sv);
 848     if (index < 1)
 849         Perl_croak(aTHX_ "Bad index while coercing array into hash");
 850     return index;
 851 }
 852
 853 STATIC I32
 854 S_avhv_index(pTHX_ AV *av, SV *keysv, U32 hash)
 855 {
 856     HV *keys;
 857     HE *he;
 858     STRLEN n_a;
 859
 860     keys = avhv_keys(av);
 861     he = hv_fetch_ent(keys, keysv, FALSE, hash);
 862     if (!he)
 863         Perl_croak(aTHX_ "No such pseudo-hash field \"%s\"", SvPV(keysv,n_a));
 864     return avhv_index_sv(HeVAL(he));
 865 }
 866
 867 HV*
 868 Perl_avhv_keys(pTHX_ AV *av)
 869 {
 870     SV **keysp = av_fetch(av, 0, FALSE);
 871     if (keysp) {
 872         SV *sv = *keysp;
 873         if (SvGMAGICAL(sv))
 874             mg_get(sv);
 875         if (SvROK(sv)) {
 876             sv = SvRV(sv);
 877             if (SvTYPE(sv) == SVt_PVHV)
 878                 return (HV*)sv;
 879         }
 880     }
 881     Perl_croak(aTHX_ "Can't coerce array into hash");
 882     return Nullhv;
 883 }
 884
 885 SV**
 886 Perl_avhv_store_ent(pTHX_ AV *av, SV *keysv, SV *val, U32 hash)
 887 {
 888     return av_store(av, avhv_index(av, keysv, hash), val);
 889 }
 890
 891 SV**
 892 Perl_avhv_fetch_ent(pTHX_ AV *av, SV *keysv, I32 lval, U32 hash)
 893 {
 894     return av_fetch(av, avhv_index(av, keysv, hash), lval);
 895 }
 896
 897 SV *
 898 Perl_avhv_delete_ent(pTHX_ AV *av, SV *keysv, I32 flags, U32 hash)
 899 {
 900     HV *keys = avhv_keys(av);
 901     HE *he;
 902
 903     he = hv_fetch_ent(keys, keysv, FALSE, hash);
 904     if (!he || !SvOK(HeVAL(he)))
 905         return Nullsv;
 906
 907     return av_delete(av, avhv_index_sv(HeVAL(he)), flags);
 908 }
 909
 910 /* Check for the existence of an element named by a given key.
 911  *
 912  */
 913 bool
 914 Perl_avhv_exists_ent(pTHX_ AV *av, SV *keysv, U32 hash)
 915 {
 916     HV *keys = avhv_keys(av);
 917     HE *he;
 918
 919     he = hv_fetch_ent(keys, keysv, FALSE, hash);
 920     if (!he || !SvOK(HeVAL(he)))
 921         return FALSE;
 922
 923     return av_exists(av, avhv_index_sv(HeVAL(he)));
 924 }
 925
 926 HE *
 927 Perl_avhv_iternext(pTHX_ AV *av)
 928 {
 929     HV *keys = avhv_keys(av);
 930     return hv_iternext(keys);
 931 }
 932
 933 SV *
 934 Perl_avhv_iterval(pTHX_ AV *av, register HE *entry)
 935 {
 936     SV *sv = hv_iterval(avhv_keys(av), entry);
 937     return *av_fetch(av, avhv_index_sv(sv), TRUE);
 938 }