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 if (key) 46 Zero(AvALLOC(av), key, SV*); 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; /* Start NULL initialization 107 * from this element */ 108 SSize_t to_null = 0; /* How many elements to Zero */ 109 SSize_t newmax = 0; 110 111 if (av && *allocp != *arrayp) { /* a shifted SV* array exists */ 112 113 /* to_null will contain the number of elements currently 114 * shifted and about to be unshifted. If the array has not 115 * been shifted to the maximum possible extent, this will be 116 * a smaller number than (*maxp - AvFILLp(av)). */ 117 to_null = *arrayp - *allocp; 118 119 *maxp += to_null; 120 ary_offset = AvFILLp(av) + 1; 121 122 Move(*arrayp, *allocp, AvFILLp(av)+1, SV*); 123 124 if (key > *maxp - 10) { 125 newmax = key + *maxp; 126 127 /* Zero everything above AvFILLp(av), which could be more 128 * elements than have actually been shifted. If we don't 129 * do this, trailing elements at the end of the resized 130 * array may not be correctly initialized. */ 131 to_null = *maxp - AvFILLp(av); 132 133 goto resize; 134 } 135 } else if (*allocp) { /* a full SV* array exists */ 136 137 #ifdef Perl_safesysmalloc_size 138 /* Whilst it would be quite possible to move this logic around 139 (as I did in the SV code), so as to set AvMAX(av) early, 140 based on calling Perl_safesysmalloc_size() immediately after 141 allocation, I'm not convinced that it is a great idea here. 142 In an array we have to loop round setting everything to 143 NULL, which means writing to memory, potentially lots 144 of it, whereas for the SV buffer case we don't touch the 145 "bonus" memory. So there there is no cost in telling the 146 world about it, whereas here we have to do work before we can 147 tell the world about it, and that work involves writing to 148 memory that might never be read. So, I feel, better to keep 149 the current lazy system of only writing to it if our caller 150 has a need for more space. NWC */ 151 newmax = Perl_safesysmalloc_size((void*)*allocp) / 152 sizeof(const SV *) - 1; 153 154 if (key <= newmax) 155 goto resized; 156 #endif 157 /* overflow-safe version of newmax = key + *maxp/5 */ 158 newmax = *maxp / 5; 159 newmax = (key > SSize_t_MAX - newmax) 160 ? SSize_t_MAX : key + newmax; 161 resize: 162 { 163 /* it should really be newmax+1 here, but if newmax 164 * happens to equal SSize_t_MAX, then newmax+1 is 165 * undefined. This means technically we croak one 166 * index lower than we should in theory; in practice 167 * its unlikely the system has SSize_t_MAX/sizeof(SV*) 168 * bytes to spare! */ 169 MEM_WRAP_CHECK_s(newmax, SV*, "Out of memory during array extend"); 170 } 171 #ifdef STRESS_REALLOC 172 { 173 SV ** const old_alloc = *allocp; 174 Newx(*allocp, newmax+1, SV*); 175 Copy(old_alloc, *allocp, *maxp + 1, SV*); 176 Safefree(old_alloc); 177 } 178 #else 179 Renew(*allocp,newmax+1, SV*); 180 #endif 181 #ifdef Perl_safesysmalloc_size 182 resized: 183 #endif 184 to_null += newmax - *maxp; /* Initialize all new elements 185 * (newmax - *maxp) in addition to 186 * any previously specified */ 187 *maxp = newmax; 188 189 /* See GH#18014 for discussion of when this might be needed: */ 190 if (av == PL_curstack) { /* Oops, grew stack (via av_store()?) */ 191 PL_stack_sp = *allocp + (PL_stack_sp - PL_stack_base); 192 PL_stack_base = *allocp; 193 PL_stack_max = PL_stack_base + newmax; 194 } 195 } else { /* there is no SV* array yet */ 196 *maxp = key < PERL_ARRAY_NEW_MIN_KEY ? 197 PERL_ARRAY_NEW_MIN_KEY : key; 198 { 199 /* see comment above about newmax+1*/ 200 MEM_WRAP_CHECK_s(*maxp, SV*, 201 "Out of memory during array extend"); 202 } 203 /* Newxz isn't used below because testing showed it to be slower 204 * than Newx+Zero (also slower than Newx + the previous while 205 * loop) for small arrays, which are very common in perl. */ 206 Newx(*allocp, *maxp+1, SV*); 207 /* Stacks require only the first element to be &PL_sv_undef 208 * (set elsewhere). However, since non-stack AVs are likely 209 * to dominate in modern production applications, stacks 210 * don't get any special treatment here. 211 * See https://github.com/Perl/perl5/pull/18690 for more detail */ 212 ary_offset = 0; 213 to_null = *maxp+1; /* Initialize all new array elements */ 214 goto zero; 215 } 216 217 if (av && AvREAL(av)) { 218 zero: 219 Zero(*allocp + ary_offset,to_null,SV*); 220 } 221 222 *arrayp = *allocp; 223 } 224 } 225 226 /* 227 =for apidoc av_fetch 228 229 Returns the SV at the specified index in the array. The C<key> is the 230 index. If C<lval> is true, you are guaranteed to get a real SV back (in case 231 it wasn't real before), which you can then modify. Check that the return 232 value is non-NULL before dereferencing it to a C<SV*>. 233 234 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for 235 more information on how to use this function on tied arrays. 236 237 The rough perl equivalent is C<$myarray[$key]>. 238 239 =cut 240 */ 241 242 static bool 243 S_adjust_index(pTHX_ AV *av, const MAGIC *mg, SSize_t *keyp) 244 { 245 bool adjust_index = 1; 246 if (mg) { 247 /* Handle negative array indices 20020222 MJD */ 248 SV * const ref = SvTIED_obj(MUTABLE_SV(av), mg); 249 SvGETMAGIC(ref); 250 if (SvROK(ref) && SvOBJECT(SvRV(ref))) { 251 SV * const * const negative_indices_glob = 252 hv_fetchs(SvSTASH(SvRV(ref)), NEGATIVE_INDICES_VAR, 0); 253 254 if (negative_indices_glob && isGV(*negative_indices_glob) 255 && SvTRUE(GvSV(*negative_indices_glob))) 256 adjust_index = 0; 257 } 258 } 259 260 if (adjust_index) { 261 *keyp += AvFILL(av) + 1; 262 if (*keyp < 0) 263 return FALSE; 264 } 265 return TRUE; 266 } 267 268 SV** 269 Perl_av_fetch(pTHX_ AV *av, SSize_t key, I32 lval) 270 { 271 SSize_t neg; 272 SSize_t size; 273 274 PERL_ARGS_ASSERT_AV_FETCH; 275 assert(SvTYPE(av) == SVt_PVAV); 276 277 if (UNLIKELY(SvRMAGICAL(av))) { 278 const MAGIC * const tied_magic 279 = mg_find((const SV *)av, PERL_MAGIC_tied); 280 if (tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata)) { 281 SV *sv; 282 if (key < 0) { 283 if (!S_adjust_index(aTHX_ av, tied_magic, &key)) 284 return NULL; 285 } 286 287 sv = newSV_type_mortal(SVt_PVLV); 288 mg_copy(MUTABLE_SV(av), sv, 0, key); 289 if (!tied_magic) /* for regdata, force leavesub to make copies */ 290 SvTEMP_off(sv); 291 LvTYPE(sv) = 't'; 292 LvTARG(sv) = sv; /* fake (SV**) */ 293 return &(LvTARG(sv)); 294 } 295 } 296 297 neg = (key < 0); 298 size = AvFILLp(av) + 1; 299 key += neg * size; /* handle negative index without using branch */ 300 301 /* the cast from SSize_t to Size_t allows both (key < 0) and (key >= size) 302 * to be tested as a single condition */ 303 if ((Size_t)key >= (Size_t)size) { 304 if (UNLIKELY(neg)) 305 return NULL; 306 goto emptiness; 307 } 308 309 if (!AvARRAY(av)[key]) { 310 emptiness: 311 return lval ? av_store(av,key,newSV_type(SVt_NULL)) : NULL; 312 } 313 314 return &AvARRAY(av)[key]; 315 } 316 317 /* 318 =for apidoc av_store 319 320 Stores an SV in an array. The array index is specified as C<key>. The 321 return value will be C<NULL> if the operation failed or if the value did not 322 need to be actually stored within the array (as in the case of tied 323 arrays). Otherwise, it can be dereferenced 324 to get the C<SV*> that was stored 325 there (= C<val>)). 326 327 Note that the caller is responsible for suitably incrementing the reference 328 count of C<val> before the call, and decrementing it if the function 329 returned C<NULL>. 330 331 Approximate Perl equivalent: C<splice(@myarray, $key, 1, $val)>. 332 333 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for 334 more information on how to use this function on tied arrays. 335 336 =cut 337 */ 338 339 SV** 340 Perl_av_store(pTHX_ AV *av, SSize_t key, SV *val) 341 { 342 SV** ary; 343 344 PERL_ARGS_ASSERT_AV_STORE; 345 assert(SvTYPE(av) == SVt_PVAV); 346 347 /* S_regclass relies on being able to pass in a NULL sv 348 (unicode_alternate may be NULL). 349 */ 350 351 if (SvRMAGICAL(av)) { 352 const MAGIC * const tied_magic = mg_find((const SV *)av, PERL_MAGIC_tied); 353 if (tied_magic) { 354 if (key < 0) { 355 if (!S_adjust_index(aTHX_ av, tied_magic, &key)) 356 return 0; 357 } 358 if (val) { 359 mg_copy(MUTABLE_SV(av), val, 0, key); 360 } 361 return NULL; 362 } 363 } 364 365 366 if (key < 0) { 367 key += AvFILL(av) + 1; 368 if (key < 0) 369 return NULL; 370 } 371 372 if (SvREADONLY(av) && key >= AvFILL(av)) 373 Perl_croak_no_modify(); 374 375 if (!AvREAL(av) && AvREIFY(av)) 376 av_reify(av); 377 if (key > AvMAX(av)) 378 av_extend(av,key); 379 ary = AvARRAY(av); 380 if (AvFILLp(av) < key) { 381 if (!AvREAL(av)) { 382 if (av == PL_curstack && key > PL_stack_sp - PL_stack_base) 383 PL_stack_sp = PL_stack_base + key; /* XPUSH in disguise */ 384 do { 385 ary[++AvFILLp(av)] = NULL; 386 } while (AvFILLp(av) < key); 387 } 388 AvFILLp(av) = key; 389 } 390 else if (AvREAL(av)) 391 SvREFCNT_dec(ary[key]); 392 393 /* store the val into the AV before we call magic so that the magic can 394 * "see" the new value. Especially set magic on the AV itself. */ 395 ary[key] = val; 396 397 if (SvSMAGICAL(av)) { 398 const MAGIC *mg = SvMAGIC(av); 399 bool set = TRUE; 400 /* We have to increment the refcount on val before we call any magic, 401 * as it is now stored in the AV (just before this block), we will 402 * then call the magic handlers which might die/Perl_croak, and 403 * longjmp up the stack to the most recent exception trap. Which means 404 * the caller code that would be expected to handle the refcount 405 * increment likely would never be executed, leading to a double free. 406 * This can happen in a case like 407 * 408 * @ary = (1); 409 * 410 * or this: 411 * 412 * if (av_store(av,n,sv)) SvREFCNT_inc(sv); 413 * 414 * where @ary/av has set magic applied to it which can die. In the 415 * first case the sv representing 1 would be mortalized, so when the 416 * set magic threw an exception it would be freed as part of the 417 * normal stack unwind. However this leaves the av structure still 418 * holding a valid visible pointer to the now freed value. In practice 419 * the next SV created will reuse the same reference, but without the 420 * refcount to account for the previous ownership and we end up with 421 * warnings about a totally different variable being double freed in 422 * the form of "attempt to free unreferenced variable" 423 * warnings/errors. 424 * 425 * https://github.com/Perl/perl5/issues/20675 426 * 427 * Arguably the API for av_store is broken in the face of magic. Instead 428 * av_store should be responsible for the refcount increment, and only 429 * not do it when specifically told to do so (eg, when storing an 430 * otherwise unreferenced scalar into an AV). 431 */ 432 SvREFCNT_inc(val); /* see comment above */ 433 for (; mg; mg = mg->mg_moremagic) { 434 if (!isUPPER(mg->mg_type)) continue; 435 if (val) { 436 sv_magic(val, MUTABLE_SV(av), toLOWER(mg->mg_type), 0, key); 437 } 438 if (PL_delaymagic && mg->mg_type == PERL_MAGIC_isa) { 439 PL_delaymagic |= DM_ARRAY_ISA; 440 set = FALSE; 441 } 442 } 443 if (set) 444 mg_set(MUTABLE_SV(av)); 445 /* And now we are done the magic, we have to decrement it back as the av_store() api 446 * says the caller is responsible for the refcount increment, assuming 447 * av_store returns true. */ 448 SvREFCNT_dec(val); 449 } 450 return &ary[key]; 451 } 452 453 /* 454 =for apidoc av_make 455 456 Creates a new AV and populates it with a list (C<**strp>, length C<size>) of 457 SVs. A copy is made of each SV, so their refcounts are not changed. The new 458 AV will have a reference count of 1. 459 460 Perl equivalent: C<my @new_array = ($scalar1, $scalar2, $scalar3...);> 461 462 =cut 463 */ 464 465 AV * 466 Perl_av_make(pTHX_ SSize_t size, SV **strp) 467 { 468 AV * const av = newAV(); 469 /* sv_upgrade does AvREAL_only() */ 470 PERL_ARGS_ASSERT_AV_MAKE; 471 assert(SvTYPE(av) == SVt_PVAV); 472 473 if (size) { /* "defined" was returning undef for size==0 anyway. */ 474 SV** ary; 475 SSize_t i; 476 SSize_t orig_ix; 477 478 Newx(ary,size,SV*); 479 AvALLOC(av) = ary; 480 AvARRAY(av) = ary; 481 AvMAX(av) = size - 1; 482 /* avoid av being leaked if croak when calling magic below */ 483 EXTEND_MORTAL(1); 484 PL_tmps_stack[++PL_tmps_ix] = (SV*)av; 485 orig_ix = PL_tmps_ix; 486 487 for (i = 0; i < size; i++) { 488 assert (*strp); 489 490 /* Don't let sv_setsv swipe, since our source array might 491 have multiple references to the same temp scalar (e.g. 492 from a list slice) */ 493 494 SvGETMAGIC(*strp); /* before newSV, in case it dies */ 495 AvFILLp(av)++; 496 ary[i] = newSV_type(SVt_NULL); 497 sv_setsv_flags(ary[i], *strp, 498 SV_DO_COW_SVSETSV|SV_NOSTEAL); 499 strp++; 500 } 501 /* disarm av's leak guard */ 502 if (LIKELY(PL_tmps_ix == orig_ix)) 503 PL_tmps_ix--; 504 else 505 PL_tmps_stack[orig_ix] = &PL_sv_undef; 506 } 507 return av; 508 } 509 510 /* 511 =for apidoc newAVav 512 513 Creates a new AV and populates it with values copied from an existing AV. The 514 new AV will have a reference count of 1, and will contain newly created SVs 515 copied from the original SV. The original source will remain unchanged. 516 517 Perl equivalent: C<my @new_array = @existing_array;> 518 519 =cut 520 */ 521 522 AV * 523 Perl_newAVav(pTHX_ AV *oav) 524 { 525 PERL_ARGS_ASSERT_NEWAVAV; 526 527 Size_t count = av_count(oav); 528 529 if(UNLIKELY(!oav) || count == 0) 530 return newAV(); 531 532 AV *ret = newAV_alloc_x(count); 533 534 /* avoid ret being leaked if croak when calling magic below */ 535 EXTEND_MORTAL(1); 536 PL_tmps_stack[++PL_tmps_ix] = (SV *)ret; 537 SSize_t ret_at_tmps_ix = PL_tmps_ix; 538 539 Size_t i; 540 if(LIKELY(!SvRMAGICAL(oav) && AvREAL(oav) && (SvTYPE(oav) == SVt_PVAV))) { 541 for(i = 0; i < count; i++) { 542 SV **svp = av_fetch_simple(oav, i, 0); 543 av_push_simple(ret, svp ? newSVsv(*svp) : &PL_sv_undef); 544 } 545 } else { 546 for(i = 0; i < count; i++) { 547 SV **svp = av_fetch(oav, i, 0); 548 av_push_simple(ret, svp ? newSVsv(*svp) : &PL_sv_undef); 549 } 550 } 551 552 /* disarm leak guard */ 553 if(LIKELY(PL_tmps_ix == ret_at_tmps_ix)) 554 PL_tmps_ix--; 555 else 556 PL_tmps_stack[ret_at_tmps_ix] = &PL_sv_undef; 557 558 return ret; 559 } 560 561 /* 562 =for apidoc newAVhv 563 564 Creates a new AV and populates it with keys and values copied from an existing 565 HV. The new AV will have a reference count of 1, and will contain newly 566 created SVs copied from the original HV. The original source will remain 567 unchanged. 568 569 Perl equivalent: C<my @new_array = %existing_hash;> 570 571 =cut 572 */ 573 574 AV * 575 Perl_newAVhv(pTHX_ HV *ohv) 576 { 577 PERL_ARGS_ASSERT_NEWAVHV; 578 579 if(UNLIKELY(!ohv)) 580 return newAV(); 581 582 bool tied = SvRMAGICAL(ohv) && mg_find(MUTABLE_SV(ohv), PERL_MAGIC_tied); 583 584 Size_t nkeys = hv_iterinit(ohv); 585 /* This number isn't perfect but it doesn't matter; it only has to be 586 * close to make the initial allocation about the right size 587 */ 588 AV *ret = newAV_alloc_xz(nkeys ? nkeys * 2 : 2); 589 590 /* avoid ret being leaked if croak when calling magic below */ 591 EXTEND_MORTAL(1); 592 PL_tmps_stack[++PL_tmps_ix] = (SV *)ret; 593 SSize_t ret_at_tmps_ix = PL_tmps_ix; 594 595 596 HE *he; 597 while((he = hv_iternext(ohv))) { 598 if(tied) { 599 av_push_simple(ret, newSVsv(hv_iterkeysv(he))); 600 av_push_simple(ret, newSVsv(hv_iterval(ohv, he))); 601 } 602 else { 603 av_push_simple(ret, newSVhek(HeKEY_hek(he))); 604 av_push_simple(ret, HeVAL(he) ? newSVsv(HeVAL(he)) : &PL_sv_undef); 605 } 606 } 607 608 /* disarm leak guard */ 609 if(LIKELY(PL_tmps_ix == ret_at_tmps_ix)) 610 PL_tmps_ix--; 611 else 612 PL_tmps_stack[ret_at_tmps_ix] = &PL_sv_undef; 613 614 return ret; 615 } 616 617 /* 618 =for apidoc av_clear 619 620 Frees all the elements of an array, leaving it empty. 621 The XS equivalent of C<@array = ()>. See also L</av_undef>. 622 623 Note that it is possible that the actions of a destructor called directly 624 or indirectly by freeing an element of the array could cause the reference 625 count of the array itself to be reduced (e.g. by deleting an entry in the 626 symbol table). So it is a possibility that the AV could have been freed 627 (or even reallocated) on return from the call unless you hold a reference 628 to it. 629 630 =cut 631 */ 632 633 void 634 Perl_av_clear(pTHX_ AV *av) 635 { 636 bool real; 637 SSize_t orig_ix = 0; 638 639 PERL_ARGS_ASSERT_AV_CLEAR; 640 assert(SvTYPE(av) == SVt_PVAV); 641 642 #ifdef DEBUGGING 643 if (SvREFCNT(av) == 0) { 644 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "Attempt to clear deleted array"); 645 } 646 #endif 647 648 if (SvREADONLY(av)) 649 Perl_croak_no_modify(); 650 651 /* Give any tie a chance to cleanup first */ 652 if (SvRMAGICAL(av)) { 653 const MAGIC* const mg = SvMAGIC(av); 654 if (PL_delaymagic && mg && mg->mg_type == PERL_MAGIC_isa) 655 PL_delaymagic |= DM_ARRAY_ISA; 656 else 657 mg_clear(MUTABLE_SV(av)); 658 } 659 660 if (AvMAX(av) < 0) 661 return; 662 663 if ((real = cBOOL(AvREAL(av)))) { 664 SV** const ary = AvARRAY(av); 665 SSize_t index = AvFILLp(av) + 1; 666 667 /* avoid av being freed when calling destructors below */ 668 EXTEND_MORTAL(1); 669 PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(av); 670 orig_ix = PL_tmps_ix; 671 672 while (index) { 673 SV * const sv = ary[--index]; 674 /* undef the slot before freeing the value, because a 675 * destructor might try to modify this array */ 676 ary[index] = NULL; 677 SvREFCNT_dec(sv); 678 } 679 } 680 AvFILLp(av) = -1; 681 av_remove_offset(av); 682 683 if (real) { 684 /* disarm av's premature free guard */ 685 if (LIKELY(PL_tmps_ix == orig_ix)) 686 PL_tmps_ix--; 687 else 688 PL_tmps_stack[orig_ix] = &PL_sv_undef; 689 SvREFCNT_dec_NN(av); 690 } 691 } 692 693 /* 694 =for apidoc av_undef 695 696 Undefines the array. The XS equivalent of C<undef(@array)>. 697 698 As well as freeing all the elements of the array (like C<av_clear()>), this 699 also frees the memory used by the av to store its list of scalars. 700 701 See L</av_clear> for a note about the array possibly being invalid on 702 return. 703 704 =cut 705 */ 706 707 void 708 Perl_av_undef(pTHX_ AV *av) 709 { 710 bool real; 711 SSize_t orig_ix = PL_tmps_ix; /* silence bogus warning about possible uninitialized use */ 712 713 PERL_ARGS_ASSERT_AV_UNDEF; 714 assert(SvTYPE(av) == SVt_PVAV); 715 716 /* Give any tie a chance to cleanup first */ 717 if (SvTIED_mg((const SV *)av, PERL_MAGIC_tied)) 718 av_fill(av, -1); 719 720 real = cBOOL(AvREAL(av)); 721 if (real) { 722 SSize_t key = AvFILLp(av) + 1; 723 724 /* avoid av being freed when calling destructors below */ 725 EXTEND_MORTAL(1); 726 PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(av); 727 orig_ix = PL_tmps_ix; 728 729 while (key) 730 SvREFCNT_dec(AvARRAY(av)[--key]); 731 } 732 733 Safefree(AvALLOC(av)); 734 AvALLOC(av) = NULL; 735 AvARRAY(av) = NULL; 736 AvMAX(av) = AvFILLp(av) = -1; 737 738 if(SvRMAGICAL(av)) mg_clear(MUTABLE_SV(av)); 739 if (real) { 740 /* disarm av's premature free guard */ 741 if (LIKELY(PL_tmps_ix == orig_ix)) 742 PL_tmps_ix--; 743 else 744 PL_tmps_stack[orig_ix] = &PL_sv_undef; 745 SvREFCNT_dec_NN(av); 746 } 747 } 748 749 /* 750 751 =for apidoc av_create_and_push 752 753 Push an SV onto the end of the array, creating the array if necessary. 754 A small internal helper function to remove a commonly duplicated idiom. 755 756 =cut 757 */ 758 759 void 760 Perl_av_create_and_push(pTHX_ AV **const avp, SV *const val) 761 { 762 PERL_ARGS_ASSERT_AV_CREATE_AND_PUSH; 763 764 if (!*avp) 765 *avp = newAV(); 766 av_push(*avp, val); 767 } 768 769 /* 770 =for apidoc av_push 771 772 Pushes an SV (transferring control of one reference count) onto the end of the 773 array. The array will grow automatically to accommodate the addition. 774 775 Perl equivalent: C<push @myarray, $val;>. 776 777 =cut 778 */ 779 780 void 781 Perl_av_push(pTHX_ AV *av, SV *val) 782 { 783 MAGIC *mg; 784 785 PERL_ARGS_ASSERT_AV_PUSH; 786 assert(SvTYPE(av) == SVt_PVAV); 787 788 if (SvREADONLY(av)) 789 Perl_croak_no_modify(); 790 791 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) { 792 Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(PUSH), G_DISCARD, 1, 793 val); 794 return; 795 } 796 av_store(av,AvFILLp(av)+1,val); 797 } 798 799 /* 800 =for apidoc av_pop 801 802 Removes one SV from the end of the array, reducing its size by one and 803 returning the SV (transferring control of one reference count) to the 804 caller. Returns C<&PL_sv_undef> if the array is empty. 805 806 Perl equivalent: C<pop(@myarray);> 807 808 =cut 809 */ 810 811 SV * 812 Perl_av_pop(pTHX_ AV *av) 813 { 814 SV *retval; 815 MAGIC* mg; 816 817 PERL_ARGS_ASSERT_AV_POP; 818 assert(SvTYPE(av) == SVt_PVAV); 819 820 if (SvREADONLY(av)) 821 Perl_croak_no_modify(); 822 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) { 823 retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(POP), 0, 0); 824 if (retval) 825 retval = newSVsv(retval); 826 return retval; 827 } 828 if (AvFILL(av) < 0) 829 return &PL_sv_undef; 830 retval = AvARRAY(av)[AvFILLp(av)]; 831 AvARRAY(av)[AvFILLp(av)--] = NULL; 832 if (SvSMAGICAL(av)) 833 mg_set(MUTABLE_SV(av)); 834 return retval ? retval : &PL_sv_undef; 835 } 836 837 /* 838 839 =for apidoc av_create_and_unshift_one 840 841 Unshifts an SV onto the beginning of the array, creating the array if 842 necessary. 843 A small internal helper function to remove a commonly duplicated idiom. 844 845 =cut 846 */ 847 848 SV ** 849 Perl_av_create_and_unshift_one(pTHX_ AV **const avp, SV *const val) 850 { 851 PERL_ARGS_ASSERT_AV_CREATE_AND_UNSHIFT_ONE; 852 853 if (!*avp) 854 *avp = newAV(); 855 av_unshift(*avp, 1); 856 return av_store(*avp, 0, val); 857 } 858 859 /* 860 =for apidoc av_unshift 861 862 Unshift the given number of C<undef> values onto the beginning of the 863 array. The array will grow automatically to accommodate the addition. 864 865 Perl equivalent: S<C<unshift @myarray, ((undef) x $num);>> 866 867 =cut 868 */ 869 870 void 871 Perl_av_unshift(pTHX_ AV *av, SSize_t num) 872 { 873 SSize_t i; 874 MAGIC* mg; 875 876 PERL_ARGS_ASSERT_AV_UNSHIFT; 877 assert(SvTYPE(av) == SVt_PVAV); 878 879 if (SvREADONLY(av)) 880 Perl_croak_no_modify(); 881 882 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) { 883 Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(UNSHIFT), 884 G_DISCARD | G_UNDEF_FILL, num); 885 return; 886 } 887 888 if (num <= 0) 889 return; 890 if (!AvREAL(av) && AvREIFY(av)) 891 av_reify(av); 892 i = AvARRAY(av) - AvALLOC(av); 893 if (i) { 894 if (i > num) 895 i = num; 896 num -= i; 897 898 AvMAX(av) += i; 899 AvFILLp(av) += i; 900 AvARRAY(av) = AvARRAY(av) - i; 901 #ifdef PERL_RC_STACK 902 Zero(AvARRAY(av), i, SV*); 903 #endif 904 } 905 if (num) { 906 SV **ary; 907 const SSize_t i = AvFILLp(av); 908 /* Create extra elements */ 909 const SSize_t slide = i > 0 ? i : 0; 910 num += slide; 911 av_extend(av, i + num); 912 AvFILLp(av) += num; 913 ary = AvARRAY(av); 914 Move(ary, ary + num, i + 1, SV*); 915 do { 916 ary[--num] = NULL; 917 } while (num); 918 /* Make extra elements into a buffer */ 919 AvMAX(av) -= slide; 920 AvFILLp(av) -= slide; 921 AvARRAY(av) = AvARRAY(av) + slide; 922 } 923 } 924 925 /* 926 =for apidoc av_shift 927 928 Removes one SV from the start of the array, reducing its size by one and 929 returning the SV (transferring control of one reference count) to the 930 caller. Returns C<&PL_sv_undef> if the array is empty. 931 932 Perl equivalent: C<shift(@myarray);> 933 934 =cut 935 */ 936 937 SV * 938 Perl_av_shift(pTHX_ AV *av) 939 { 940 SV *retval; 941 MAGIC* mg; 942 943 PERL_ARGS_ASSERT_AV_SHIFT; 944 assert(SvTYPE(av) == SVt_PVAV); 945 946 if (SvREADONLY(av)) 947 Perl_croak_no_modify(); 948 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) { 949 retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(SHIFT), 0, 0); 950 if (retval) 951 retval = newSVsv(retval); 952 return retval; 953 } 954 if (AvFILL(av) < 0) 955 return &PL_sv_undef; 956 retval = *AvARRAY(av); 957 #ifndef PERL_RC_STACK 958 if (AvREAL(av)) 959 *AvARRAY(av) = NULL; 960 #endif 961 AvARRAY(av) = AvARRAY(av) + 1; 962 AvMAX(av)--; 963 AvFILLp(av)--; 964 if (SvSMAGICAL(av)) 965 mg_set(MUTABLE_SV(av)); 966 return retval ? retval : &PL_sv_undef; 967 } 968 969 /* 970 =for apidoc av_tindex 971 =for apidoc_item av_top_index 972 973 These behave identically. 974 If the array C<av> is empty, these return -1; otherwise they return the maximum 975 value of the indices of all the array elements which are currently defined in 976 C<av>. 977 978 They process 'get' magic. 979 980 The Perl equivalent for these is C<$#av>. 981 982 Use C<L</av_count>> to get the number of elements in an array. 983 984 =for apidoc av_len 985 986 Same as L</av_top_index>. Note that, unlike what the name implies, it returns 987 the maximum index in the array. This is unlike L</sv_len>, which returns what 988 you would expect. 989 990 B<To get the true number of elements in the array, instead use C<L</av_count>>>. 991 992 =cut 993 */ 994 995 SSize_t 996 Perl_av_len(pTHX_ AV *av) 997 { 998 PERL_ARGS_ASSERT_AV_LEN; 999 1000 return av_top_index(av); 1001 } 1002 1003 /* 1004 =for apidoc av_fill 1005 1006 Set the highest index in the array to the given number, equivalent to 1007 Perl's S<C<$#array = $fill;>>. 1008 1009 The number of elements in the array will be S<C<fill + 1>> after 1010 C<av_fill()> returns. If the array was previously shorter, then the 1011 additional elements appended are set to NULL. If the array 1012 was longer, then the excess elements are freed. S<C<av_fill(av, -1)>> is 1013 the same as C<av_clear(av)>. 1014 1015 =cut 1016 */ 1017 void 1018 Perl_av_fill(pTHX_ AV *av, SSize_t fill) 1019 { 1020 MAGIC *mg; 1021 1022 PERL_ARGS_ASSERT_AV_FILL; 1023 assert(SvTYPE(av) == SVt_PVAV); 1024 1025 if (fill < 0) 1026 fill = -1; 1027 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) { 1028 SV *arg1 = sv_newmortal(); 1029 sv_setiv(arg1, (IV)(fill + 1)); 1030 Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(STORESIZE), G_DISCARD, 1031 1, arg1); 1032 return; 1033 } 1034 if (fill <= AvMAX(av)) { 1035 SSize_t key = AvFILLp(av); 1036 SV** const ary = AvARRAY(av); 1037 1038 if (AvREAL(av)) { 1039 while (key > fill) { 1040 SvREFCNT_dec(ary[key]); 1041 ary[key--] = NULL; 1042 } 1043 } 1044 else { 1045 while (key < fill) 1046 ary[++key] = NULL; 1047 } 1048 1049 AvFILLp(av) = fill; 1050 if (SvSMAGICAL(av)) 1051 mg_set(MUTABLE_SV(av)); 1052 } 1053 else 1054 (void)av_store(av,fill,NULL); 1055 } 1056 1057 /* 1058 =for apidoc av_delete 1059 1060 Deletes the element indexed by C<key> from the array, makes the element 1061 mortal, and returns it. If C<flags> equals C<G_DISCARD>, the element is 1062 freed and NULL is returned. NULL is also returned if C<key> is out of 1063 range. 1064 1065 Perl equivalent: S<C<splice(@myarray, $key, 1, undef)>> (with the 1066 C<splice> in void context if C<G_DISCARD> is present). 1067 1068 =cut 1069 */ 1070 SV * 1071 Perl_av_delete(pTHX_ AV *av, SSize_t key, I32 flags) 1072 { 1073 SV *sv; 1074 1075 PERL_ARGS_ASSERT_AV_DELETE; 1076 assert(SvTYPE(av) == SVt_PVAV); 1077 1078 if (SvREADONLY(av)) 1079 Perl_croak_no_modify(); 1080 1081 if (SvRMAGICAL(av)) { 1082 const MAGIC * const tied_magic 1083 = mg_find((const SV *)av, PERL_MAGIC_tied); 1084 if ((tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata))) { 1085 SV **svp; 1086 if (key < 0) { 1087 if (!S_adjust_index(aTHX_ av, tied_magic, &key)) 1088 return NULL; 1089 } 1090 svp = av_fetch(av, key, TRUE); 1091 if (svp) { 1092 sv = *svp; 1093 mg_clear(sv); 1094 if (mg_find(sv, PERL_MAGIC_tiedelem)) { 1095 sv_unmagic(sv, PERL_MAGIC_tiedelem); /* No longer an element */ 1096 return sv; 1097 } 1098 return NULL; 1099 } 1100 } 1101 } 1102 1103 if (key < 0) { 1104 key += AvFILL(av) + 1; 1105 if (key < 0) 1106 return NULL; 1107 } 1108 1109 if (key > AvFILLp(av)) 1110 return NULL; 1111 else { 1112 if (!AvREAL(av) && AvREIFY(av)) 1113 av_reify(av); 1114 sv = AvARRAY(av)[key]; 1115 AvARRAY(av)[key] = NULL; 1116 if (key == AvFILLp(av)) { 1117 do { 1118 AvFILLp(av)--; 1119 } while (--key >= 0 && !AvARRAY(av)[key]); 1120 } 1121 if (SvSMAGICAL(av)) 1122 mg_set(MUTABLE_SV(av)); 1123 } 1124 if(sv != NULL) { 1125 if (flags & G_DISCARD) { 1126 SvREFCNT_dec_NN(sv); 1127 return NULL; 1128 } 1129 else if (AvREAL(av)) 1130 sv_2mortal(sv); 1131 } 1132 return sv; 1133 } 1134 1135 /* 1136 =for apidoc av_exists 1137 1138 Returns true if the element indexed by C<key> has been initialized. 1139 1140 This relies on the fact that uninitialized array elements are set to 1141 C<NULL>. 1142 1143 Perl equivalent: C<exists($myarray[$key])>. 1144 1145 =cut 1146 */ 1147 bool 1148 Perl_av_exists(pTHX_ AV *av, SSize_t key) 1149 { 1150 PERL_ARGS_ASSERT_AV_EXISTS; 1151 assert(SvTYPE(av) == SVt_PVAV); 1152 1153 if (SvRMAGICAL(av)) { 1154 const MAGIC * const tied_magic 1155 = mg_find((const SV *)av, PERL_MAGIC_tied); 1156 const MAGIC * const regdata_magic 1157 = mg_find((const SV *)av, PERL_MAGIC_regdata); 1158 if (tied_magic || regdata_magic) { 1159 MAGIC *mg; 1160 /* Handle negative array indices 20020222 MJD */ 1161 if (key < 0) { 1162 if (!S_adjust_index(aTHX_ av, tied_magic, &key)) 1163 return FALSE; 1164 } 1165 1166 if(key >= 0 && regdata_magic) { 1167 if (key <= AvFILL(av)) 1168 return TRUE; 1169 else 1170 return FALSE; 1171 } 1172 { 1173 SV * const sv = sv_newmortal(); 1174 mg_copy(MUTABLE_SV(av), sv, 0, key); 1175 mg = mg_find(sv, PERL_MAGIC_tiedelem); 1176 if (mg) { 1177 magic_existspack(sv, mg); 1178 { 1179 I32 retbool = SvTRUE_nomg_NN(sv); 1180 return cBOOL(retbool); 1181 } 1182 } 1183 } 1184 } 1185 } 1186 1187 if (key < 0) { 1188 key += AvFILL(av) + 1; 1189 if (key < 0) 1190 return FALSE; 1191 } 1192 1193 if (key <= AvFILLp(av) && AvARRAY(av)[key]) 1194 { 1195 if (SvSMAGICAL(AvARRAY(av)[key]) 1196 && mg_find(AvARRAY(av)[key], PERL_MAGIC_nonelem)) 1197 return FALSE; 1198 return TRUE; 1199 } 1200 else 1201 return FALSE; 1202 } 1203 1204 static MAGIC * 1205 S_get_aux_mg(pTHX_ AV *av) { 1206 MAGIC *mg; 1207 1208 PERL_ARGS_ASSERT_GET_AUX_MG; 1209 assert(SvTYPE(av) == SVt_PVAV); 1210 1211 mg = mg_find((const SV *)av, PERL_MAGIC_arylen_p); 1212 1213 if (!mg) { 1214 mg = sv_magicext(MUTABLE_SV(av), 0, PERL_MAGIC_arylen_p, 1215 &PL_vtbl_arylen_p, 0, 0); 1216 assert(mg); 1217 /* sv_magicext won't set this for us because we pass in a NULL obj */ 1218 mg->mg_flags |= MGf_REFCOUNTED; 1219 } 1220 return mg; 1221 } 1222 1223 SV ** 1224 Perl_av_arylen_p(pTHX_ AV *av) { 1225 MAGIC *const mg = get_aux_mg(av); 1226 1227 PERL_ARGS_ASSERT_AV_ARYLEN_P; 1228 assert(SvTYPE(av) == SVt_PVAV); 1229 1230 return &(mg->mg_obj); 1231 } 1232 1233 IV * 1234 Perl_av_iter_p(pTHX_ AV *av) { 1235 MAGIC *const mg = get_aux_mg(av); 1236 1237 PERL_ARGS_ASSERT_AV_ITER_P; 1238 assert(SvTYPE(av) == SVt_PVAV); 1239 1240 if (sizeof(IV) == sizeof(SSize_t)) { 1241 return (IV *)&(mg->mg_len); 1242 } else { 1243 if (!mg->mg_ptr) { 1244 IV *temp; 1245 mg->mg_len = IVSIZE; 1246 Newxz(temp, 1, IV); 1247 mg->mg_ptr = (char *) temp; 1248 } 1249 return (IV *)mg->mg_ptr; 1250 } 1251 } 1252 1253 SV * 1254 Perl_av_nonelem(pTHX_ AV *av, SSize_t ix) { 1255 SV * const sv = newSV_type(SVt_NULL); 1256 PERL_ARGS_ASSERT_AV_NONELEM; 1257 if (!av_store(av,ix,sv)) 1258 return sv_2mortal(sv); /* has tie magic */ 1259 sv_magic(sv, NULL, PERL_MAGIC_nonelem, NULL, 0); 1260 return sv; 1261 } 1262 1263 /* 1264 * ex: set ts=8 sts=4 sw=4 et: 1265 */ 1266