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 #include "EXTERN.h" 19 #define PERL_IN_AV_C 20 #include "perl.h" 21 22 void 23 Perl_av_reify(pTHX_ AV *av) 24 { 25 SSize_t key; 26 27 PERL_ARGS_ASSERT_AV_REIFY; 28 assert(SvTYPE(av) == SVt_PVAV); 29 30 if (AvREAL(av)) 31 return; 32 #ifdef DEBUGGING 33 if (SvTIED_mg((const SV *)av, PERL_MAGIC_tied)) 34 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "av_reify called on tied array"); 35 #endif 36 key = AvMAX(av) + 1; 37 while (key > AvFILLp(av) + 1) 38 AvARRAY(av)[--key] = NULL; 39 while (key) { 40 SV * const sv = AvARRAY(av)[--key]; 41 if (sv != &PL_sv_undef) 42 SvREFCNT_inc_simple_void(sv); 43 } 44 key = AvARRAY(av) - AvALLOC(av); 45 while (key) 46 AvALLOC(av)[--key] = NULL; 47 AvREIFY_off(av); 48 AvREAL_on(av); 49 } 50 51 /* 52 =for apidoc av_extend 53 54 Pre-extend an array so that it is capable of storing values at indexes 55 C<0..key>. Thus C<av_extend(av,99)> guarantees that the array can store 100 56 elements, i.e. that C<av_store(av, 0, sv)> through C<av_store(av, 99, sv)> 57 on a plain array will work without any further memory allocation. 58 59 If the av argument is a tied array then will call the C<EXTEND> tied 60 array method with an argument of C<(key+1)>. 61 62 =cut 63 */ 64 65 void 66 Perl_av_extend(pTHX_ AV *av, SSize_t key) 67 { 68 MAGIC *mg; 69 70 PERL_ARGS_ASSERT_AV_EXTEND; 71 assert(SvTYPE(av) == SVt_PVAV); 72 73 mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied); 74 if (mg) { 75 SV *arg1 = sv_newmortal(); 76 /* NOTE: the API for av_extend() is NOT the same as the tie method EXTEND. 77 * 78 * The C function takes an *index* (assumes 0 indexed arrays) and ensures 79 * that the array is at least as large as the index provided. 80 * 81 * The tied array method EXTEND takes a *count* and ensures that the array 82 * is at least that many elements large. Thus we have to +1 the key when 83 * we call the tied method. 84 */ 85 sv_setiv(arg1, (IV)(key + 1)); 86 Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(EXTEND), G_DISCARD, 1, 87 arg1); 88 return; 89 } 90 av_extend_guts(av,key,&AvMAX(av),&AvALLOC(av),&AvARRAY(av)); 91 } 92 93 /* The guts of av_extend. *Not* for general use! */ 94 /* Also called directly from pp_assign, padlist_store, padnamelist_store */ 95 void 96 Perl_av_extend_guts(pTHX_ AV *av, SSize_t key, SSize_t *maxp, SV ***allocp, 97 SV ***arrayp) 98 { 99 PERL_ARGS_ASSERT_AV_EXTEND_GUTS; 100 101 if (key < -1) /* -1 is legal */ 102 Perl_croak(aTHX_ 103 "panic: av_extend_guts() negative count (%" IVdf ")", (IV)key); 104 105 if (key > *maxp) { 106 SSize_t ary_offset = *maxp + 1; 107 SSize_t to_null = 0; 108 SSize_t newmax = 0; 109 110 if (av && *allocp != *arrayp) { /* a shifted SV* array exists */ 111 to_null = *arrayp - *allocp; 112 *maxp += to_null; 113 ary_offset = AvFILLp(av) + 1; 114 115 Move(*arrayp, *allocp, AvFILLp(av)+1, SV*); 116 117 if (key > *maxp - 10) { 118 newmax = key + *maxp; 119 goto resize; 120 } 121 } else if (*allocp) { /* a full SV* array exists */ 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 NULL, 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 /* overflow-safe version of newmax = key + *maxp/5 */ 144 newmax = *maxp / 5; 145 newmax = (key > SSize_t_MAX - newmax) 146 ? SSize_t_MAX : key + newmax; 147 resize: 148 { 149 /* it should really be newmax+1 here, but if newmax 150 * happens to equal SSize_t_MAX, then newmax+1 is 151 * undefined. This means technically we croak one 152 * index lower than we should in theory; in practice 153 * its unlikely the system has SSize_t_MAX/sizeof(SV*) 154 * bytes to spare! */ 155 MEM_WRAP_CHECK_s(newmax, SV*, "Out of memory during array extend"); 156 } 157 #ifdef STRESS_REALLOC 158 { 159 SV ** const old_alloc = *allocp; 160 Newx(*allocp, newmax+1, SV*); 161 Copy(old_alloc, *allocp, *maxp + 1, SV*); 162 Safefree(old_alloc); 163 } 164 #else 165 Renew(*allocp,newmax+1, SV*); 166 #endif 167 #ifdef Perl_safesysmalloc_size 168 resized: 169 #endif 170 to_null += newmax - *maxp; 171 *maxp = newmax; 172 173 /* See GH#18014 for discussion of when this might be needed: */ 174 if (av == PL_curstack) { /* Oops, grew stack (via av_store()?) */ 175 PL_stack_sp = *allocp + (PL_stack_sp - PL_stack_base); 176 PL_stack_base = *allocp; 177 PL_stack_max = PL_stack_base + newmax; 178 } 179 } else { /* there is no SV* array yet */ 180 *maxp = key < 3 ? 3 : key; 181 { 182 /* see comment above about newmax+1*/ 183 MEM_WRAP_CHECK_s(*maxp, SV*, 184 "Out of memory during array extend"); 185 } 186 /* Newxz isn't used below because testing showed it to be slower 187 * than Newx+Zero (also slower than Newx + the previous while 188 * loop) for small arrays, which are very common in perl. */ 189 Newx(*allocp, *maxp+1, SV*); 190 /* Stacks require only the first element to be &PL_sv_undef 191 * (set elsewhere). However, since non-stack AVs are likely 192 * to dominate in modern production applications, stacks 193 * don't get any special treatment here. 194 * See https://github.com/Perl/perl5/pull/18690 for more detail */ 195 ary_offset = 0; 196 to_null = *maxp+1; 197 goto zero; 198 } 199 200 if (av && AvREAL(av)) { 201 zero: 202 Zero(*allocp + ary_offset,to_null,SV*); 203 } 204 205 *arrayp = *allocp; 206 } 207 } 208 209 /* 210 =for apidoc av_fetch 211 212 Returns the SV at the specified index in the array. The C<key> is the 213 index. If C<lval> is true, you are guaranteed to get a real SV back (in case 214 it wasn't real before), which you can then modify. Check that the return 215 value is non-NULL before dereferencing it to a C<SV*>. 216 217 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for 218 more information on how to use this function on tied arrays. 219 220 The rough perl equivalent is C<$myarray[$key]>. 221 222 =cut 223 */ 224 225 static bool 226 S_adjust_index(pTHX_ AV *av, const MAGIC *mg, SSize_t *keyp) 227 { 228 bool adjust_index = 1; 229 if (mg) { 230 /* Handle negative array indices 20020222 MJD */ 231 SV * const ref = SvTIED_obj(MUTABLE_SV(av), mg); 232 SvGETMAGIC(ref); 233 if (SvROK(ref) && SvOBJECT(SvRV(ref))) { 234 SV * const * const negative_indices_glob = 235 hv_fetchs(SvSTASH(SvRV(ref)), NEGATIVE_INDICES_VAR, 0); 236 237 if (negative_indices_glob && isGV(*negative_indices_glob) 238 && SvTRUE(GvSV(*negative_indices_glob))) 239 adjust_index = 0; 240 } 241 } 242 243 if (adjust_index) { 244 *keyp += AvFILL(av) + 1; 245 if (*keyp < 0) 246 return FALSE; 247 } 248 return TRUE; 249 } 250 251 SV** 252 Perl_av_fetch(pTHX_ AV *av, SSize_t key, I32 lval) 253 { 254 SSize_t neg; 255 SSize_t size; 256 257 PERL_ARGS_ASSERT_AV_FETCH; 258 assert(SvTYPE(av) == SVt_PVAV); 259 260 if (UNLIKELY(SvRMAGICAL(av))) { 261 const MAGIC * const tied_magic 262 = mg_find((const SV *)av, PERL_MAGIC_tied); 263 if (tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata)) { 264 SV *sv; 265 if (key < 0) { 266 if (!S_adjust_index(aTHX_ av, tied_magic, &key)) 267 return NULL; 268 } 269 270 sv = newSV_type_mortal(SVt_PVLV); 271 mg_copy(MUTABLE_SV(av), sv, 0, key); 272 if (!tied_magic) /* for regdata, force leavesub to make copies */ 273 SvTEMP_off(sv); 274 LvTYPE(sv) = 't'; 275 LvTARG(sv) = sv; /* fake (SV**) */ 276 return &(LvTARG(sv)); 277 } 278 } 279 280 neg = (key < 0); 281 size = AvFILLp(av) + 1; 282 key += neg * size; /* handle negative index without using branch */ 283 284 /* the cast from SSize_t to Size_t allows both (key < 0) and (key >= size) 285 * to be tested as a single condition */ 286 if ((Size_t)key >= (Size_t)size) { 287 if (UNLIKELY(neg)) 288 return NULL; 289 goto emptyness; 290 } 291 292 if (!AvARRAY(av)[key]) { 293 emptyness: 294 return lval ? av_store(av,key,newSV_type(SVt_NULL)) : NULL; 295 } 296 297 return &AvARRAY(av)[key]; 298 } 299 300 /* 301 =for apidoc av_store 302 303 Stores an SV in an array. The array index is specified as C<key>. The 304 return value will be C<NULL> if the operation failed or if the value did not 305 need to be actually stored within the array (as in the case of tied 306 arrays). Otherwise, it can be dereferenced 307 to get the C<SV*> that was stored 308 there (= C<val>)). 309 310 Note that the caller is responsible for suitably incrementing the reference 311 count of C<val> before the call, and decrementing it if the function 312 returned C<NULL>. 313 314 Approximate Perl equivalent: C<splice(@myarray, $key, 1, $val)>. 315 316 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for 317 more information on how to use this function on tied arrays. 318 319 =cut 320 */ 321 322 SV** 323 Perl_av_store(pTHX_ AV *av, SSize_t key, SV *val) 324 { 325 SV** ary; 326 327 PERL_ARGS_ASSERT_AV_STORE; 328 assert(SvTYPE(av) == SVt_PVAV); 329 330 /* S_regclass relies on being able to pass in a NULL sv 331 (unicode_alternate may be NULL). 332 */ 333 334 if (SvRMAGICAL(av)) { 335 const MAGIC * const tied_magic = mg_find((const SV *)av, PERL_MAGIC_tied); 336 if (tied_magic) { 337 if (key < 0) { 338 if (!S_adjust_index(aTHX_ av, tied_magic, &key)) 339 return 0; 340 } 341 if (val) { 342 mg_copy(MUTABLE_SV(av), val, 0, key); 343 } 344 return NULL; 345 } 346 } 347 348 349 if (key < 0) { 350 key += AvFILL(av) + 1; 351 if (key < 0) 352 return NULL; 353 } 354 355 if (SvREADONLY(av) && key >= AvFILL(av)) 356 Perl_croak_no_modify(); 357 358 if (!AvREAL(av) && AvREIFY(av)) 359 av_reify(av); 360 if (key > AvMAX(av)) 361 av_extend(av,key); 362 ary = AvARRAY(av); 363 if (AvFILLp(av) < key) { 364 if (!AvREAL(av)) { 365 if (av == PL_curstack && key > PL_stack_sp - PL_stack_base) 366 PL_stack_sp = PL_stack_base + key; /* XPUSH in disguise */ 367 do { 368 ary[++AvFILLp(av)] = NULL; 369 } while (AvFILLp(av) < key); 370 } 371 AvFILLp(av) = key; 372 } 373 else if (AvREAL(av)) 374 SvREFCNT_dec(ary[key]); 375 ary[key] = val; 376 if (SvSMAGICAL(av)) { 377 const MAGIC *mg = SvMAGIC(av); 378 bool set = TRUE; 379 for (; mg; mg = mg->mg_moremagic) { 380 if (!isUPPER(mg->mg_type)) continue; 381 if (val) { 382 sv_magic(val, MUTABLE_SV(av), toLOWER(mg->mg_type), 0, key); 383 } 384 if (PL_delaymagic && mg->mg_type == PERL_MAGIC_isa) { 385 PL_delaymagic |= DM_ARRAY_ISA; 386 set = FALSE; 387 } 388 } 389 if (set) 390 mg_set(MUTABLE_SV(av)); 391 } 392 return &ary[key]; 393 } 394 395 /* 396 =for apidoc av_new_alloc 397 398 This implements L<perlapi/C<newAV_alloc_x>> 399 and L<perlapi/C<newAV_alloc_xz>>, which are the public API for this 400 functionality. 401 402 Creates a new AV and allocates its SV* array. 403 404 This is similar to, but more efficient than doing: 405 406 AV *av = newAV(); 407 av_extend(av, key); 408 409 The size parameter is used to pre-allocate a SV* array large enough to 410 hold at least elements C<0..(size-1)>. C<size> must be at least 1. 411 412 The C<zeroflag> parameter controls whether or not the array is NULL 413 initialized. 414 415 =cut 416 */ 417 418 AV * 419 Perl_av_new_alloc(pTHX_ SSize_t size, bool zeroflag) 420 { 421 AV * const av = newAV(); 422 SV** ary; 423 PERL_ARGS_ASSERT_AV_NEW_ALLOC; 424 assert(size > 0); 425 426 Newx(ary, size, SV*); /* Newx performs the memwrap check */ 427 AvALLOC(av) = ary; 428 AvARRAY(av) = ary; 429 AvMAX(av) = size - 1; 430 431 if (zeroflag) 432 Zero(ary, size, SV*); 433 434 return av; 435 } 436 437 /* 438 =for apidoc av_make 439 440 Creates a new AV and populates it with a list (C<**strp>, length C<size>) of 441 SVs. A copy is made of each SV, so their refcounts are not changed. The new 442 AV will have a reference count of 1. 443 444 Perl equivalent: C<my @new_array = ($scalar1, $scalar2, $scalar3...);> 445 446 =cut 447 */ 448 449 AV * 450 Perl_av_make(pTHX_ SSize_t size, SV **strp) 451 { 452 AV * const av = newAV(); 453 /* sv_upgrade does AvREAL_only() */ 454 PERL_ARGS_ASSERT_AV_MAKE; 455 assert(SvTYPE(av) == SVt_PVAV); 456 457 if (size) { /* "defined" was returning undef for size==0 anyway. */ 458 SV** ary; 459 SSize_t i; 460 SSize_t orig_ix; 461 462 Newx(ary,size,SV*); 463 AvALLOC(av) = ary; 464 AvARRAY(av) = ary; 465 AvMAX(av) = size - 1; 466 /* avoid av being leaked if croak when calling magic below */ 467 EXTEND_MORTAL(1); 468 PL_tmps_stack[++PL_tmps_ix] = (SV*)av; 469 orig_ix = PL_tmps_ix; 470 471 for (i = 0; i < size; i++) { 472 assert (*strp); 473 474 /* Don't let sv_setsv swipe, since our source array might 475 have multiple references to the same temp scalar (e.g. 476 from a list slice) */ 477 478 SvGETMAGIC(*strp); /* before newSV, in case it dies */ 479 AvFILLp(av)++; 480 ary[i] = newSV_type(SVt_NULL); 481 sv_setsv_flags(ary[i], *strp, 482 SV_DO_COW_SVSETSV|SV_NOSTEAL); 483 strp++; 484 } 485 /* disarm av's leak guard */ 486 if (LIKELY(PL_tmps_ix == orig_ix)) 487 PL_tmps_ix--; 488 else 489 PL_tmps_stack[orig_ix] = &PL_sv_undef; 490 } 491 return av; 492 } 493 494 /* 495 =for apidoc av_clear 496 497 Frees all the elements of an array, leaving it empty. 498 The XS equivalent of C<@array = ()>. See also L</av_undef>. 499 500 Note that it is possible that the actions of a destructor called directly 501 or indirectly by freeing an element of the array could cause the reference 502 count of the array itself to be reduced (e.g. by deleting an entry in the 503 symbol table). So it is a possibility that the AV could have been freed 504 (or even reallocated) on return from the call unless you hold a reference 505 to it. 506 507 =cut 508 */ 509 510 void 511 Perl_av_clear(pTHX_ AV *av) 512 { 513 SSize_t extra; 514 bool real; 515 SSize_t orig_ix = 0; 516 517 PERL_ARGS_ASSERT_AV_CLEAR; 518 assert(SvTYPE(av) == SVt_PVAV); 519 520 #ifdef DEBUGGING 521 if (SvREFCNT(av) == 0) { 522 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "Attempt to clear deleted array"); 523 } 524 #endif 525 526 if (SvREADONLY(av)) 527 Perl_croak_no_modify(); 528 529 /* Give any tie a chance to cleanup first */ 530 if (SvRMAGICAL(av)) { 531 const MAGIC* const mg = SvMAGIC(av); 532 if (PL_delaymagic && mg && mg->mg_type == PERL_MAGIC_isa) 533 PL_delaymagic |= DM_ARRAY_ISA; 534 else 535 mg_clear(MUTABLE_SV(av)); 536 } 537 538 if (AvMAX(av) < 0) 539 return; 540 541 if ((real = cBOOL(AvREAL(av)))) { 542 SV** const ary = AvARRAY(av); 543 SSize_t index = AvFILLp(av) + 1; 544 545 /* avoid av being freed when calling destructors below */ 546 EXTEND_MORTAL(1); 547 PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(av); 548 orig_ix = PL_tmps_ix; 549 550 while (index) { 551 SV * const sv = ary[--index]; 552 /* undef the slot before freeing the value, because a 553 * destructor might try to modify this array */ 554 ary[index] = NULL; 555 SvREFCNT_dec(sv); 556 } 557 } 558 extra = AvARRAY(av) - AvALLOC(av); 559 if (extra) { 560 AvMAX(av) += extra; 561 AvARRAY(av) = AvALLOC(av); 562 } 563 AvFILLp(av) = -1; 564 if (real) { 565 /* disarm av's premature free guard */ 566 if (LIKELY(PL_tmps_ix == orig_ix)) 567 PL_tmps_ix--; 568 else 569 PL_tmps_stack[orig_ix] = &PL_sv_undef; 570 SvREFCNT_dec_NN(av); 571 } 572 } 573 574 /* 575 =for apidoc av_undef 576 577 Undefines the array. The XS equivalent of C<undef(@array)>. 578 579 As well as freeing all the elements of the array (like C<av_clear()>), this 580 also frees the memory used by the av to store its list of scalars. 581 582 See L</av_clear> for a note about the array possibly being invalid on 583 return. 584 585 =cut 586 */ 587 588 void 589 Perl_av_undef(pTHX_ AV *av) 590 { 591 bool real; 592 SSize_t orig_ix = PL_tmps_ix; /* silence bogus warning about possible unitialized use */ 593 594 PERL_ARGS_ASSERT_AV_UNDEF; 595 assert(SvTYPE(av) == SVt_PVAV); 596 597 /* Give any tie a chance to cleanup first */ 598 if (SvTIED_mg((const SV *)av, PERL_MAGIC_tied)) 599 av_fill(av, -1); 600 601 real = cBOOL(AvREAL(av)); 602 if (real) { 603 SSize_t key = AvFILLp(av) + 1; 604 605 /* avoid av being freed when calling destructors below */ 606 EXTEND_MORTAL(1); 607 PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(av); 608 orig_ix = PL_tmps_ix; 609 610 while (key) 611 SvREFCNT_dec(AvARRAY(av)[--key]); 612 } 613 614 Safefree(AvALLOC(av)); 615 AvALLOC(av) = NULL; 616 AvARRAY(av) = NULL; 617 AvMAX(av) = AvFILLp(av) = -1; 618 619 if(SvRMAGICAL(av)) mg_clear(MUTABLE_SV(av)); 620 if (real) { 621 /* disarm av's premature free guard */ 622 if (LIKELY(PL_tmps_ix == orig_ix)) 623 PL_tmps_ix--; 624 else 625 PL_tmps_stack[orig_ix] = &PL_sv_undef; 626 SvREFCNT_dec_NN(av); 627 } 628 } 629 630 /* 631 632 =for apidoc av_create_and_push 633 634 Push an SV onto the end of the array, creating the array if necessary. 635 A small internal helper function to remove a commonly duplicated idiom. 636 637 =cut 638 */ 639 640 void 641 Perl_av_create_and_push(pTHX_ AV **const avp, SV *const val) 642 { 643 PERL_ARGS_ASSERT_AV_CREATE_AND_PUSH; 644 645 if (!*avp) 646 *avp = newAV(); 647 av_push(*avp, val); 648 } 649 650 /* 651 =for apidoc av_push 652 653 Pushes an SV (transferring control of one reference count) onto the end of the 654 array. The array will grow automatically to accommodate the addition. 655 656 Perl equivalent: C<push @myarray, $val;>. 657 658 =cut 659 */ 660 661 void 662 Perl_av_push(pTHX_ AV *av, SV *val) 663 { 664 MAGIC *mg; 665 666 PERL_ARGS_ASSERT_AV_PUSH; 667 assert(SvTYPE(av) == SVt_PVAV); 668 669 if (SvREADONLY(av)) 670 Perl_croak_no_modify(); 671 672 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) { 673 Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(PUSH), G_DISCARD, 1, 674 val); 675 return; 676 } 677 av_store(av,AvFILLp(av)+1,val); 678 } 679 680 /* 681 =for apidoc av_pop 682 683 Removes one SV from the end of the array, reducing its size by one and 684 returning the SV (transferring control of one reference count) to the 685 caller. Returns C<&PL_sv_undef> if the array is empty. 686 687 Perl equivalent: C<pop(@myarray);> 688 689 =cut 690 */ 691 692 SV * 693 Perl_av_pop(pTHX_ AV *av) 694 { 695 SV *retval; 696 MAGIC* mg; 697 698 PERL_ARGS_ASSERT_AV_POP; 699 assert(SvTYPE(av) == SVt_PVAV); 700 701 if (SvREADONLY(av)) 702 Perl_croak_no_modify(); 703 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) { 704 retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(POP), 0, 0); 705 if (retval) 706 retval = newSVsv(retval); 707 return retval; 708 } 709 if (AvFILL(av) < 0) 710 return &PL_sv_undef; 711 retval = AvARRAY(av)[AvFILLp(av)]; 712 AvARRAY(av)[AvFILLp(av)--] = NULL; 713 if (SvSMAGICAL(av)) 714 mg_set(MUTABLE_SV(av)); 715 return retval ? retval : &PL_sv_undef; 716 } 717 718 /* 719 720 =for apidoc av_create_and_unshift_one 721 722 Unshifts an SV onto the beginning of the array, creating the array if 723 necessary. 724 A small internal helper function to remove a commonly duplicated idiom. 725 726 =cut 727 */ 728 729 SV ** 730 Perl_av_create_and_unshift_one(pTHX_ AV **const avp, SV *const val) 731 { 732 PERL_ARGS_ASSERT_AV_CREATE_AND_UNSHIFT_ONE; 733 734 if (!*avp) 735 *avp = newAV(); 736 av_unshift(*avp, 1); 737 return av_store(*avp, 0, val); 738 } 739 740 /* 741 =for apidoc av_unshift 742 743 Unshift the given number of C<undef> values onto the beginning of the 744 array. The array will grow automatically to accommodate the addition. 745 746 Perl equivalent: S<C<unshift @myarray, ((undef) x $num);>> 747 748 =cut 749 */ 750 751 void 752 Perl_av_unshift(pTHX_ AV *av, SSize_t num) 753 { 754 SSize_t i; 755 MAGIC* mg; 756 757 PERL_ARGS_ASSERT_AV_UNSHIFT; 758 assert(SvTYPE(av) == SVt_PVAV); 759 760 if (SvREADONLY(av)) 761 Perl_croak_no_modify(); 762 763 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) { 764 Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(UNSHIFT), 765 G_DISCARD | G_UNDEF_FILL, num); 766 return; 767 } 768 769 if (num <= 0) 770 return; 771 if (!AvREAL(av) && AvREIFY(av)) 772 av_reify(av); 773 i = AvARRAY(av) - AvALLOC(av); 774 if (i) { 775 if (i > num) 776 i = num; 777 num -= i; 778 779 AvMAX(av) += i; 780 AvFILLp(av) += i; 781 AvARRAY(av) = AvARRAY(av) - i; 782 } 783 if (num) { 784 SV **ary; 785 const SSize_t i = AvFILLp(av); 786 /* Create extra elements */ 787 const SSize_t slide = i > 0 ? i : 0; 788 num += slide; 789 av_extend(av, i + num); 790 AvFILLp(av) += num; 791 ary = AvARRAY(av); 792 Move(ary, ary + num, i + 1, SV*); 793 do { 794 ary[--num] = NULL; 795 } while (num); 796 /* Make extra elements into a buffer */ 797 AvMAX(av) -= slide; 798 AvFILLp(av) -= slide; 799 AvARRAY(av) = AvARRAY(av) + slide; 800 } 801 } 802 803 /* 804 =for apidoc av_shift 805 806 Removes one SV from the start of the array, reducing its size by one and 807 returning the SV (transferring control of one reference count) to the 808 caller. Returns C<&PL_sv_undef> if the array is empty. 809 810 Perl equivalent: C<shift(@myarray);> 811 812 =cut 813 */ 814 815 SV * 816 Perl_av_shift(pTHX_ AV *av) 817 { 818 SV *retval; 819 MAGIC* mg; 820 821 PERL_ARGS_ASSERT_AV_SHIFT; 822 assert(SvTYPE(av) == SVt_PVAV); 823 824 if (SvREADONLY(av)) 825 Perl_croak_no_modify(); 826 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) { 827 retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(SHIFT), 0, 0); 828 if (retval) 829 retval = newSVsv(retval); 830 return retval; 831 } 832 if (AvFILL(av) < 0) 833 return &PL_sv_undef; 834 retval = *AvARRAY(av); 835 if (AvREAL(av)) 836 *AvARRAY(av) = NULL; 837 AvARRAY(av) = AvARRAY(av) + 1; 838 AvMAX(av)--; 839 AvFILLp(av)--; 840 if (SvSMAGICAL(av)) 841 mg_set(MUTABLE_SV(av)); 842 return retval ? retval : &PL_sv_undef; 843 } 844 845 /* 846 =for apidoc av_tindex 847 =for apidoc_item av_top_index 848 849 These behave identically. 850 If the array C<av> is empty, these return -1; otherwise they return the maximum 851 value of the indices of all the array elements which are currently defined in 852 C<av>. 853 854 They process 'get' magic. 855 856 The Perl equivalent for these is C<$#av>. 857 858 Use C<L</av_count>> to get the number of elements in an array. 859 860 =for apidoc av_len 861 862 Same as L</av_top_index>. Note that, unlike what the name implies, it returns 863 the maximum index in the array. This is unlike L</sv_len>, which returns what 864 you would expect. 865 866 B<To get the true number of elements in the array, instead use C<L</av_count>>>. 867 868 =cut 869 */ 870 871 SSize_t 872 Perl_av_len(pTHX_ AV *av) 873 { 874 PERL_ARGS_ASSERT_AV_LEN; 875 876 return av_top_index(av); 877 } 878 879 /* 880 =for apidoc av_fill 881 882 Set the highest index in the array to the given number, equivalent to 883 Perl's S<C<$#array = $fill;>>. 884 885 The number of elements in the array will be S<C<fill + 1>> after 886 C<av_fill()> returns. If the array was previously shorter, then the 887 additional elements appended are set to NULL. If the array 888 was longer, then the excess elements are freed. S<C<av_fill(av, -1)>> is 889 the same as C<av_clear(av)>. 890 891 =cut 892 */ 893 void 894 Perl_av_fill(pTHX_ AV *av, SSize_t fill) 895 { 896 MAGIC *mg; 897 898 PERL_ARGS_ASSERT_AV_FILL; 899 assert(SvTYPE(av) == SVt_PVAV); 900 901 if (fill < 0) 902 fill = -1; 903 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) { 904 SV *arg1 = sv_newmortal(); 905 sv_setiv(arg1, (IV)(fill + 1)); 906 Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(STORESIZE), G_DISCARD, 907 1, arg1); 908 return; 909 } 910 if (fill <= AvMAX(av)) { 911 SSize_t key = AvFILLp(av); 912 SV** const ary = AvARRAY(av); 913 914 if (AvREAL(av)) { 915 while (key > fill) { 916 SvREFCNT_dec(ary[key]); 917 ary[key--] = NULL; 918 } 919 } 920 else { 921 while (key < fill) 922 ary[++key] = NULL; 923 } 924 925 AvFILLp(av) = fill; 926 if (SvSMAGICAL(av)) 927 mg_set(MUTABLE_SV(av)); 928 } 929 else 930 (void)av_store(av,fill,NULL); 931 } 932 933 /* 934 =for apidoc av_delete 935 936 Deletes the element indexed by C<key> from the array, makes the element 937 mortal, and returns it. If C<flags> equals C<G_DISCARD>, the element is 938 freed and NULL is returned. NULL is also returned if C<key> is out of 939 range. 940 941 Perl equivalent: S<C<splice(@myarray, $key, 1, undef)>> (with the 942 C<splice> in void context if C<G_DISCARD> is present). 943 944 =cut 945 */ 946 SV * 947 Perl_av_delete(pTHX_ AV *av, SSize_t key, I32 flags) 948 { 949 SV *sv; 950 951 PERL_ARGS_ASSERT_AV_DELETE; 952 assert(SvTYPE(av) == SVt_PVAV); 953 954 if (SvREADONLY(av)) 955 Perl_croak_no_modify(); 956 957 if (SvRMAGICAL(av)) { 958 const MAGIC * const tied_magic 959 = mg_find((const SV *)av, PERL_MAGIC_tied); 960 if ((tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata))) { 961 SV **svp; 962 if (key < 0) { 963 if (!S_adjust_index(aTHX_ av, tied_magic, &key)) 964 return NULL; 965 } 966 svp = av_fetch(av, key, TRUE); 967 if (svp) { 968 sv = *svp; 969 mg_clear(sv); 970 if (mg_find(sv, PERL_MAGIC_tiedelem)) { 971 sv_unmagic(sv, PERL_MAGIC_tiedelem); /* No longer an element */ 972 return sv; 973 } 974 return NULL; 975 } 976 } 977 } 978 979 if (key < 0) { 980 key += AvFILL(av) + 1; 981 if (key < 0) 982 return NULL; 983 } 984 985 if (key > AvFILLp(av)) 986 return NULL; 987 else { 988 if (!AvREAL(av) && AvREIFY(av)) 989 av_reify(av); 990 sv = AvARRAY(av)[key]; 991 AvARRAY(av)[key] = NULL; 992 if (key == AvFILLp(av)) { 993 do { 994 AvFILLp(av)--; 995 } while (--key >= 0 && !AvARRAY(av)[key]); 996 } 997 if (SvSMAGICAL(av)) 998 mg_set(MUTABLE_SV(av)); 999 } 1000 if(sv != NULL) { 1001 if (flags & G_DISCARD) { 1002 SvREFCNT_dec_NN(sv); 1003 return NULL; 1004 } 1005 else if (AvREAL(av)) 1006 sv_2mortal(sv); 1007 } 1008 return sv; 1009 } 1010 1011 /* 1012 =for apidoc av_exists 1013 1014 Returns true if the element indexed by C<key> has been initialized. 1015 1016 This relies on the fact that uninitialized array elements are set to 1017 C<NULL>. 1018 1019 Perl equivalent: C<exists($myarray[$key])>. 1020 1021 =cut 1022 */ 1023 bool 1024 Perl_av_exists(pTHX_ AV *av, SSize_t key) 1025 { 1026 PERL_ARGS_ASSERT_AV_EXISTS; 1027 assert(SvTYPE(av) == SVt_PVAV); 1028 1029 if (SvRMAGICAL(av)) { 1030 const MAGIC * const tied_magic 1031 = mg_find((const SV *)av, PERL_MAGIC_tied); 1032 const MAGIC * const regdata_magic 1033 = mg_find((const SV *)av, PERL_MAGIC_regdata); 1034 if (tied_magic || regdata_magic) { 1035 MAGIC *mg; 1036 /* Handle negative array indices 20020222 MJD */ 1037 if (key < 0) { 1038 if (!S_adjust_index(aTHX_ av, tied_magic, &key)) 1039 return FALSE; 1040 } 1041 1042 if(key >= 0 && regdata_magic) { 1043 if (key <= AvFILL(av)) 1044 return TRUE; 1045 else 1046 return FALSE; 1047 } 1048 { 1049 SV * const sv = sv_newmortal(); 1050 mg_copy(MUTABLE_SV(av), sv, 0, key); 1051 mg = mg_find(sv, PERL_MAGIC_tiedelem); 1052 if (mg) { 1053 magic_existspack(sv, mg); 1054 { 1055 I32 retbool = SvTRUE_nomg_NN(sv); 1056 return cBOOL(retbool); 1057 } 1058 } 1059 } 1060 } 1061 } 1062 1063 if (key < 0) { 1064 key += AvFILL(av) + 1; 1065 if (key < 0) 1066 return FALSE; 1067 } 1068 1069 if (key <= AvFILLp(av) && AvARRAY(av)[key]) 1070 { 1071 if (SvSMAGICAL(AvARRAY(av)[key]) 1072 && mg_find(AvARRAY(av)[key], PERL_MAGIC_nonelem)) 1073 return FALSE; 1074 return TRUE; 1075 } 1076 else 1077 return FALSE; 1078 } 1079 1080 static MAGIC * 1081 S_get_aux_mg(pTHX_ AV *av) { 1082 MAGIC *mg; 1083 1084 PERL_ARGS_ASSERT_GET_AUX_MG; 1085 assert(SvTYPE(av) == SVt_PVAV); 1086 1087 mg = mg_find((const SV *)av, PERL_MAGIC_arylen_p); 1088 1089 if (!mg) { 1090 mg = sv_magicext(MUTABLE_SV(av), 0, PERL_MAGIC_arylen_p, 1091 &PL_vtbl_arylen_p, 0, 0); 1092 assert(mg); 1093 /* sv_magicext won't set this for us because we pass in a NULL obj */ 1094 mg->mg_flags |= MGf_REFCOUNTED; 1095 } 1096 return mg; 1097 } 1098 1099 SV ** 1100 Perl_av_arylen_p(pTHX_ AV *av) { 1101 MAGIC *const mg = get_aux_mg(av); 1102 1103 PERL_ARGS_ASSERT_AV_ARYLEN_P; 1104 assert(SvTYPE(av) == SVt_PVAV); 1105 1106 return &(mg->mg_obj); 1107 } 1108 1109 IV * 1110 Perl_av_iter_p(pTHX_ AV *av) { 1111 MAGIC *const mg = get_aux_mg(av); 1112 1113 PERL_ARGS_ASSERT_AV_ITER_P; 1114 assert(SvTYPE(av) == SVt_PVAV); 1115 1116 if (sizeof(IV) == sizeof(SSize_t)) { 1117 return (IV *)&(mg->mg_len); 1118 } else { 1119 if (!mg->mg_ptr) { 1120 IV *temp; 1121 mg->mg_len = IVSIZE; 1122 Newxz(temp, 1, IV); 1123 mg->mg_ptr = (char *) temp; 1124 } 1125 return (IV *)mg->mg_ptr; 1126 } 1127 } 1128 1129 SV * 1130 Perl_av_nonelem(pTHX_ AV *av, SSize_t ix) { 1131 SV * const sv = newSV_type(SVt_NULL); 1132 PERL_ARGS_ASSERT_AV_NONELEM; 1133 if (!av_store(av,ix,sv)) 1134 return sv_2mortal(sv); /* has tie magic */ 1135 sv_magic(sv, NULL, PERL_MAGIC_nonelem, NULL, 0); 1136 return sv; 1137 } 1138 1139 /* 1140 * ex: set ts=8 sts=4 sw=4 et: 1141 */ 1142