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