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