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