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