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