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