av.c

   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_make
 397
 398 Creates a new AV and populates it with a list (C<**strp>, length C<size>) of
 399 SVs.  A copy is made of each SV, so their refcounts are not changed.  The new
 400 AV will have a reference count of 1.
 401
 402 Perl equivalent: C<my @new_array = ($scalar1, $scalar2, $scalar3...);>
 403
 404 =cut
 405 */
 406
 407 AV *
 408 Perl_av_make(pTHX_ SSize_t size, SV **strp)
 409 {
 410     AV * const av = newAV();
 411     /* sv_upgrade does AvREAL_only()  */
 412     PERL_ARGS_ASSERT_AV_MAKE;
 413     assert(SvTYPE(av) == SVt_PVAV);
 414
 415     if (size) {         /* "defined" was returning undef for size==0 anyway. */
 416         SV** ary;
 417         SSize_t i;
 418         SSize_t orig_ix;
 419
 420         Newx(ary,size,SV*);
 421         AvALLOC(av) = ary;
 422         AvARRAY(av) = ary;
 423         AvMAX(av) = size - 1;
 424         /* avoid av being leaked if croak when calling magic below */
 425         EXTEND_MORTAL(1);
 426         PL_tmps_stack[++PL_tmps_ix] = (SV*)av;
 427         orig_ix = PL_tmps_ix;
 428
 429         for (i = 0; i < size; i++) {
 430             assert (*strp);
 431
 432             /* Don't let sv_setsv swipe, since our source array might
 433                have multiple references to the same temp scalar (e.g.
 434                from a list slice) */
 435
 436             SvGETMAGIC(*strp); /* before newSV, in case it dies */
 437             AvFILLp(av)++;
 438             ary[i] = newSV_type(SVt_NULL);
 439             sv_setsv_flags(ary[i], *strp,
 440                            SV_DO_COW_SVSETSV|SV_NOSTEAL);
 441             strp++;
 442         }
 443         /* disarm av's leak guard */
 444         if (LIKELY(PL_tmps_ix == orig_ix))
 445             PL_tmps_ix--;
 446         else
 447             PL_tmps_stack[orig_ix] = &PL_sv_undef;
 448     }
 449     return av;
 450 }
 451
 452 /*
 453 =for apidoc newAVav
 454
 455 Creates a new AV and populates it with values copied from an existing AV.  The
 456 new AV will have a reference count of 1, and will contain newly created SVs
 457 copied from the original SV.  The original source will remain unchanged.
 458
 459 Perl equivalent: C<my @new_array = @existing_array;>
 460
 461 =cut
 462 */
 463
 464 AV *
 465 Perl_newAVav(pTHX_ AV *oav)
 466 {
 467     PERL_ARGS_ASSERT_NEWAVAV;
 468
 469     Size_t count = av_count(oav);
 470
 471     if(UNLIKELY(!oav) || count == 0)
 472         return newAV();
 473
 474     AV *ret = newAV_alloc_x(count);
 475
 476     /* avoid ret being leaked if croak when calling magic below */
 477     EXTEND_MORTAL(1);
 478     PL_tmps_stack[++PL_tmps_ix] = (SV *)ret;
 479     SSize_t ret_at_tmps_ix = PL_tmps_ix;
 480
 481     Size_t i;
 482     if(LIKELY(!SvRMAGICAL(oav) && AvREAL(oav) && (SvTYPE(oav) == SVt_PVAV))) {
 483         for(i = 0; i < count; i++) {
 484             SV **svp = av_fetch_simple(oav, i, 0);
 485             av_push_simple(ret, svp ? newSVsv(*svp) : &PL_sv_undef);
 486         }
 487     } else {
 488         for(i = 0; i < count; i++) {
 489             SV **svp = av_fetch(oav, i, 0);
 490             av_push_simple(ret, svp ? newSVsv(*svp) : &PL_sv_undef);
 491         }
 492     }
 493
 494     /* disarm leak guard */
 495     if(LIKELY(PL_tmps_ix == ret_at_tmps_ix))
 496         PL_tmps_ix--;
 497     else
 498         PL_tmps_stack[ret_at_tmps_ix] = &PL_sv_undef;
 499
 500     return ret;
 501 }
 502
 503 /*
 504 =for apidoc newAVhv
 505
 506 Creates a new AV and populates it with keys and values copied from an existing
 507 HV.  The new AV will have a reference count of 1, and will contain newly
 508 created SVs copied from the original HV.  The original source will remain
 509 unchanged.
 510
 511 Perl equivalent: C<my @new_array = %existing_hash;>
 512
 513 =cut
 514 */
 515
 516 AV *
 517 Perl_newAVhv(pTHX_ HV *ohv)
 518 {
 519     PERL_ARGS_ASSERT_NEWAVHV;
 520
 521     if(UNLIKELY(!ohv))
 522         return newAV();
 523
 524     bool tied = SvRMAGICAL(ohv) && mg_find(MUTABLE_SV(ohv), PERL_MAGIC_tied);
 525
 526     Size_t nkeys = hv_iterinit(ohv);
 527     /* This number isn't perfect but it doesn't matter; it only has to be
 528      * close to make the initial allocation about the right size
 529      */
 530     AV *ret = newAV_alloc_xz(nkeys ? nkeys * 2 : 2);
 531
 532     /* avoid ret being leaked if croak when calling magic below */
 533     EXTEND_MORTAL(1);
 534     PL_tmps_stack[++PL_tmps_ix] = (SV *)ret;
 535     SSize_t ret_at_tmps_ix = PL_tmps_ix;
 536
 537
 538     HE *he;
 539     while((he = hv_iternext(ohv))) {
 540         if(tied) {
 541             av_push_simple(ret, newSVsv(hv_iterkeysv(he)));
 542             av_push_simple(ret, newSVsv(hv_iterval(ohv, he)));
 543         }
 544         else {
 545             av_push_simple(ret, newSVhek(HeKEY_hek(he)));
 546             av_push_simple(ret, HeVAL(he) ? newSVsv(HeVAL(he)) : &PL_sv_undef);
 547         }
 548     }
 549
 550     /* disarm leak guard */
 551     if(LIKELY(PL_tmps_ix == ret_at_tmps_ix))
 552         PL_tmps_ix--;
 553     else
 554         PL_tmps_stack[ret_at_tmps_ix] = &PL_sv_undef;
 555
 556     return ret;
 557 }
 558
 559 /*
 560 =for apidoc av_clear
 561
 562 Frees all the elements of an array, leaving it empty.
 563 The XS equivalent of C<@array = ()>.  See also L</av_undef>.
 564
 565 Note that it is possible that the actions of a destructor called directly
 566 or indirectly by freeing an element of the array could cause the reference
 567 count of the array itself to be reduced (e.g. by deleting an entry in the
 568 symbol table). So it is a possibility that the AV could have been freed
 569 (or even reallocated) on return from the call unless you hold a reference
 570 to it.
 571
 572 =cut
 573 */
 574
 575 void
 576 Perl_av_clear(pTHX_ AV *av)
 577 {
 578     SSize_t extra;
 579     bool real;
 580     SSize_t orig_ix = 0;
 581
 582     PERL_ARGS_ASSERT_AV_CLEAR;
 583     assert(SvTYPE(av) == SVt_PVAV);
 584
 585 #ifdef DEBUGGING
 586     if (SvREFCNT(av) == 0) {
 587         Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "Attempt to clear deleted array");
 588     }
 589 #endif
 590
 591     if (SvREADONLY(av))
 592         Perl_croak_no_modify();
 593
 594     /* Give any tie a chance to cleanup first */
 595     if (SvRMAGICAL(av)) {
 596         const MAGIC* const mg = SvMAGIC(av);
 597         if (PL_delaymagic && mg && mg->mg_type == PERL_MAGIC_isa)
 598             PL_delaymagic |= DM_ARRAY_ISA;
 599         else
 600             mg_clear(MUTABLE_SV(av));
 601     }
 602
 603     if (AvMAX(av) < 0)
 604         return;
 605
 606     if ((real = cBOOL(AvREAL(av)))) {
 607         SV** const ary = AvARRAY(av);
 608         SSize_t index = AvFILLp(av) + 1;
 609
 610         /* avoid av being freed when calling destructors below */
 611         EXTEND_MORTAL(1);
 612         PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(av);
 613         orig_ix = PL_tmps_ix;
 614
 615         while (index) {
 616             SV * const sv = ary[--index];
 617             /* undef the slot before freeing the value, because a
 618              * destructor might try to modify this array */
 619             ary[index] = NULL;
 620             SvREFCNT_dec(sv);
 621         }
 622     }
 623     extra = AvARRAY(av) - AvALLOC(av);
 624     if (extra) {
 625         AvMAX(av) += extra;
 626         AvARRAY(av) = AvALLOC(av);
 627     }
 628     AvFILLp(av) = -1;
 629     if (real) {
 630         /* disarm av's premature free guard */
 631         if (LIKELY(PL_tmps_ix == orig_ix))
 632             PL_tmps_ix--;
 633         else
 634             PL_tmps_stack[orig_ix] = &PL_sv_undef;
 635         SvREFCNT_dec_NN(av);
 636     }
 637 }
 638
 639 /*
 640 =for apidoc av_undef
 641
 642 Undefines the array. The XS equivalent of C<undef(@array)>.
 643
 644 As well as freeing all the elements of the array (like C<av_clear()>), this
 645 also frees the memory used by the av to store its list of scalars.
 646
 647 See L</av_clear> for a note about the array possibly being invalid on
 648 return.
 649
 650 =cut
 651 */
 652
 653 void
 654 Perl_av_undef(pTHX_ AV *av)
 655 {
 656     bool real;
 657     SSize_t orig_ix = PL_tmps_ix; /* silence bogus warning about possible unitialized use */
 658
 659     PERL_ARGS_ASSERT_AV_UNDEF;
 660     assert(SvTYPE(av) == SVt_PVAV);
 661
 662     /* Give any tie a chance to cleanup first */
 663     if (SvTIED_mg((const SV *)av, PERL_MAGIC_tied))
 664         av_fill(av, -1);
 665
 666     real = cBOOL(AvREAL(av));
 667     if (real) {
 668         SSize_t key = AvFILLp(av) + 1;
 669
 670         /* avoid av being freed when calling destructors below */
 671         EXTEND_MORTAL(1);
 672         PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(av);
 673         orig_ix = PL_tmps_ix;
 674
 675         while (key)
 676             SvREFCNT_dec(AvARRAY(av)[--key]);
 677     }
 678
 679     Safefree(AvALLOC(av));
 680     AvALLOC(av) = NULL;
 681     AvARRAY(av) = NULL;
 682     AvMAX(av) = AvFILLp(av) = -1;
 683
 684     if(SvRMAGICAL(av)) mg_clear(MUTABLE_SV(av));
 685     if (real) {
 686         /* disarm av's premature free guard */
 687         if (LIKELY(PL_tmps_ix == orig_ix))
 688             PL_tmps_ix--;
 689         else
 690             PL_tmps_stack[orig_ix] = &PL_sv_undef;
 691         SvREFCNT_dec_NN(av);
 692     }
 693 }
 694
 695 /*
 696
 697 =for apidoc av_create_and_push
 698
 699 Push an SV onto the end of the array, creating the array if necessary.
 700 A small internal helper function to remove a commonly duplicated idiom.
 701
 702 =cut
 703 */
 704
 705 void
 706 Perl_av_create_and_push(pTHX_ AV **const avp, SV *const val)
 707 {
 708     PERL_ARGS_ASSERT_AV_CREATE_AND_PUSH;
 709
 710     if (!*avp)
 711         *avp = newAV();
 712     av_push(*avp, val);
 713 }
 714
 715 /*
 716 =for apidoc av_push
 717
 718 Pushes an SV (transferring control of one reference count) onto the end of the
 719 array.  The array will grow automatically to accommodate the addition.
 720
 721 Perl equivalent: C<push @myarray, $val;>.
 722
 723 =cut
 724 */
 725
 726 void
 727 Perl_av_push(pTHX_ AV *av, SV *val)
 728 {
 729     MAGIC *mg;
 730
 731     PERL_ARGS_ASSERT_AV_PUSH;
 732     assert(SvTYPE(av) == SVt_PVAV);
 733
 734     if (SvREADONLY(av))
 735         Perl_croak_no_modify();
 736
 737     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
 738         Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(PUSH), G_DISCARD, 1,
 739                             val);
 740         return;
 741     }
 742     av_store(av,AvFILLp(av)+1,val);
 743 }
 744
 745 /*
 746 =for apidoc av_pop
 747
 748 Removes one SV from the end of the array, reducing its size by one and
 749 returning the SV (transferring control of one reference count) to the
 750 caller.  Returns C<&PL_sv_undef> if the array is empty.
 751
 752 Perl equivalent: C<pop(@myarray);>
 753
 754 =cut
 755 */
 756
 757 SV *
 758 Perl_av_pop(pTHX_ AV *av)
 759 {
 760     SV *retval;
 761     MAGIC* mg;
 762
 763     PERL_ARGS_ASSERT_AV_POP;
 764     assert(SvTYPE(av) == SVt_PVAV);
 765
 766     if (SvREADONLY(av))
 767         Perl_croak_no_modify();
 768     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
 769         retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(POP), 0, 0);
 770         if (retval)
 771             retval = newSVsv(retval);
 772         return retval;
 773     }
 774     if (AvFILL(av) < 0)
 775         return &PL_sv_undef;
 776     retval = AvARRAY(av)[AvFILLp(av)];
 777     AvARRAY(av)[AvFILLp(av)--] = NULL;
 778     if (SvSMAGICAL(av))
 779         mg_set(MUTABLE_SV(av));
 780     return retval ? retval : &PL_sv_undef;
 781 }
 782
 783 /*
 784
 785 =for apidoc av_create_and_unshift_one
 786
 787 Unshifts an SV onto the beginning of the array, creating the array if
 788 necessary.
 789 A small internal helper function to remove a commonly duplicated idiom.
 790
 791 =cut
 792 */
 793
 794 SV **
 795 Perl_av_create_and_unshift_one(pTHX_ AV **const avp, SV *const val)
 796 {
 797     PERL_ARGS_ASSERT_AV_CREATE_AND_UNSHIFT_ONE;
 798
 799     if (!*avp)
 800         *avp = newAV();
 801     av_unshift(*avp, 1);
 802     return av_store(*avp, 0, val);
 803 }
 804
 805 /*
 806 =for apidoc av_unshift
 807
 808 Unshift the given number of C<undef> values onto the beginning of the
 809 array.  The array will grow automatically to accommodate the addition.
 810
 811 Perl equivalent: S<C<unshift @myarray, ((undef) x $num);>>
 812
 813 =cut
 814 */
 815
 816 void
 817 Perl_av_unshift(pTHX_ AV *av, SSize_t num)
 818 {
 819     SSize_t i;
 820     MAGIC* mg;
 821
 822     PERL_ARGS_ASSERT_AV_UNSHIFT;
 823     assert(SvTYPE(av) == SVt_PVAV);
 824
 825     if (SvREADONLY(av))
 826         Perl_croak_no_modify();
 827
 828     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
 829         Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(UNSHIFT),
 830                             G_DISCARD | G_UNDEF_FILL, num);
 831         return;
 832     }
 833
 834     if (num <= 0)
 835       return;
 836     if (!AvREAL(av) && AvREIFY(av))
 837         av_reify(av);
 838     i = AvARRAY(av) - AvALLOC(av);
 839     if (i) {
 840         if (i > num)
 841             i = num;
 842         num -= i;
 843
 844         AvMAX(av) += i;
 845         AvFILLp(av) += i;
 846         AvARRAY(av) = AvARRAY(av) - i;
 847     }
 848     if (num) {
 849         SV **ary;
 850         const SSize_t i = AvFILLp(av);
 851         /* Create extra elements */
 852         const SSize_t slide = i > 0 ? i : 0;
 853         num += slide;
 854         av_extend(av, i + num);
 855         AvFILLp(av) += num;
 856         ary = AvARRAY(av);
 857         Move(ary, ary + num, i + 1, SV*);
 858         do {
 859             ary[--num] = NULL;
 860         } while (num);
 861         /* Make extra elements into a buffer */
 862         AvMAX(av) -= slide;
 863         AvFILLp(av) -= slide;
 864         AvARRAY(av) = AvARRAY(av) + slide;
 865     }
 866 }
 867
 868 /*
 869 =for apidoc av_shift
 870
 871 Removes one SV from the start of the array, reducing its size by one and
 872 returning the SV (transferring control of one reference count) to the
 873 caller.  Returns C<&PL_sv_undef> if the array is empty.
 874
 875 Perl equivalent: C<shift(@myarray);>
 876
 877 =cut
 878 */
 879
 880 SV *
 881 Perl_av_shift(pTHX_ AV *av)
 882 {
 883     SV *retval;
 884     MAGIC* mg;
 885
 886     PERL_ARGS_ASSERT_AV_SHIFT;
 887     assert(SvTYPE(av) == SVt_PVAV);
 888
 889     if (SvREADONLY(av))
 890         Perl_croak_no_modify();
 891     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
 892         retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(SHIFT), 0, 0);
 893         if (retval)
 894             retval = newSVsv(retval);
 895         return retval;
 896     }
 897     if (AvFILL(av) < 0)
 898       return &PL_sv_undef;
 899     retval = *AvARRAY(av);
 900     if (AvREAL(av))
 901         *AvARRAY(av) = NULL;
 902     AvARRAY(av) = AvARRAY(av) + 1;
 903     AvMAX(av)--;
 904     AvFILLp(av)--;
 905     if (SvSMAGICAL(av))
 906         mg_set(MUTABLE_SV(av));
 907     return retval ? retval : &PL_sv_undef;
 908 }
 909
 910 /*
 911 =for apidoc av_tindex
 912 =for apidoc_item av_top_index
 913
 914 These behave identically.
 915 If the array C<av> is empty, these return -1; otherwise they return the maximum
 916 value of the indices of all the array elements which are currently defined in
 917 C<av>.
 918
 919 They process 'get' magic.
 920
 921 The Perl equivalent for these is C<$#av>.
 922
 923 Use C<L</av_count>> to get the number of elements in an array.
 924
 925 =for apidoc av_len
 926
 927 Same as L</av_top_index>.  Note that, unlike what the name implies, it returns
 928 the maximum index in the array.  This is unlike L</sv_len>, which returns what
 929 you would expect.
 930
 931 B<To get the true number of elements in the array, instead use C<L</av_count>>>.
 932
 933 =cut
 934 */
 935
 936 SSize_t
 937 Perl_av_len(pTHX_ AV *av)
 938 {
 939     PERL_ARGS_ASSERT_AV_LEN;
 940
 941     return av_top_index(av);
 942 }
 943
 944 /*
 945 =for apidoc av_fill
 946
 947 Set the highest index in the array to the given number, equivalent to
 948 Perl's S<C<$#array = $fill;>>.
 949
 950 The number of elements in the array will be S<C<fill + 1>> after
 951 C<av_fill()> returns.  If the array was previously shorter, then the
 952 additional elements appended are set to NULL.  If the array
 953 was longer, then the excess elements are freed.  S<C<av_fill(av, -1)>> is
 954 the same as C<av_clear(av)>.
 955
 956 =cut
 957 */
 958 void
 959 Perl_av_fill(pTHX_ AV *av, SSize_t fill)
 960 {
 961     MAGIC *mg;
 962
 963     PERL_ARGS_ASSERT_AV_FILL;
 964     assert(SvTYPE(av) == SVt_PVAV);
 965
 966     if (fill < 0)
 967         fill = -1;
 968     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
 969         SV *arg1 = sv_newmortal();
 970         sv_setiv(arg1, (IV)(fill + 1));
 971         Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(STORESIZE), G_DISCARD,
 972                             1, arg1);
 973         return;
 974     }
 975     if (fill <= AvMAX(av)) {
 976         SSize_t key = AvFILLp(av);
 977         SV** const ary = AvARRAY(av);
 978
 979         if (AvREAL(av)) {
 980             while (key > fill) {
 981                 SvREFCNT_dec(ary[key]);
 982                 ary[key--] = NULL;
 983             }
 984         }
 985         else {
 986             while (key < fill)
 987                 ary[++key] = NULL;
 988         }
 989
 990         AvFILLp(av) = fill;
 991         if (SvSMAGICAL(av))
 992             mg_set(MUTABLE_SV(av));
 993     }
 994     else
 995         (void)av_store(av,fill,NULL);
 996 }
 997
 998 /*
 999 =for apidoc av_delete
1000
1001 Deletes the element indexed by C<key> from the array, makes the element
1002 mortal, and returns it.  If C<flags> equals C<G_DISCARD>, the element is
1003 freed and NULL is returned. NULL is also returned if C<key> is out of
1004 range.
1005
1006 Perl equivalent: S<C<splice(@myarray, $key, 1, undef)>> (with the
1007 C<splice> in void context if C<G_DISCARD> is present).
1008
1009 =cut
1010 */
1011 SV *
1012 Perl_av_delete(pTHX_ AV *av, SSize_t key, I32 flags)
1013 {
1014     SV *sv;
1015
1016     PERL_ARGS_ASSERT_AV_DELETE;
1017     assert(SvTYPE(av) == SVt_PVAV);
1018
1019     if (SvREADONLY(av))
1020         Perl_croak_no_modify();
1021
1022     if (SvRMAGICAL(av)) {
1023         const MAGIC * const tied_magic
1024             = mg_find((const SV *)av, PERL_MAGIC_tied);
1025         if ((tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata))) {
1026             SV **svp;
1027             if (key < 0) {
1028                 if (!S_adjust_index(aTHX_ av, tied_magic, &key))
1029                         return NULL;
1030             }
1031             svp = av_fetch(av, key, TRUE);
1032             if (svp) {
1033                 sv = *svp;
1034                 mg_clear(sv);
1035                 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
1036                     sv_unmagic(sv, PERL_MAGIC_tiedelem); /* No longer an element */
1037                     return sv;
1038                 }
1039                 return NULL;
1040             }
1041         }
1042     }
1043
1044     if (key < 0) {
1045         key += AvFILL(av) + 1;
1046         if (key < 0)
1047             return NULL;
1048     }
1049
1050     if (key > AvFILLp(av))
1051         return NULL;
1052     else {
1053         if (!AvREAL(av) && AvREIFY(av))
1054             av_reify(av);
1055         sv = AvARRAY(av)[key];
1056         AvARRAY(av)[key] = NULL;
1057         if (key == AvFILLp(av)) {
1058             do {
1059                 AvFILLp(av)--;
1060             } while (--key >= 0 && !AvARRAY(av)[key]);
1061         }
1062         if (SvSMAGICAL(av))
1063             mg_set(MUTABLE_SV(av));
1064     }
1065     if(sv != NULL) {
1066         if (flags & G_DISCARD) {
1067             SvREFCNT_dec_NN(sv);
1068             return NULL;
1069         }
1070         else if (AvREAL(av))
1071             sv_2mortal(sv);
1072     }
1073     return sv;
1074 }
1075
1076 /*
1077 =for apidoc av_exists
1078
1079 Returns true if the element indexed by C<key> has been initialized.
1080
1081 This relies on the fact that uninitialized array elements are set to
1082 C<NULL>.
1083
1084 Perl equivalent: C<exists($myarray[$key])>.
1085
1086 =cut
1087 */
1088 bool
1089 Perl_av_exists(pTHX_ AV *av, SSize_t key)
1090 {
1091     PERL_ARGS_ASSERT_AV_EXISTS;
1092     assert(SvTYPE(av) == SVt_PVAV);
1093
1094     if (SvRMAGICAL(av)) {
1095         const MAGIC * const tied_magic
1096             = mg_find((const SV *)av, PERL_MAGIC_tied);
1097         const MAGIC * const regdata_magic
1098             = mg_find((const SV *)av, PERL_MAGIC_regdata);
1099         if (tied_magic || regdata_magic) {
1100             MAGIC *mg;
1101             /* Handle negative array indices 20020222 MJD */
1102             if (key < 0) {
1103                 if (!S_adjust_index(aTHX_ av, tied_magic, &key))
1104                         return FALSE;
1105             }
1106
1107             if(key >= 0 && regdata_magic) {
1108                 if (key <= AvFILL(av))
1109                     return TRUE;
1110                 else
1111                     return FALSE;
1112             }
1113             {
1114                 SV * const sv = sv_newmortal();
1115                 mg_copy(MUTABLE_SV(av), sv, 0, key);
1116                 mg = mg_find(sv, PERL_MAGIC_tiedelem);
1117                 if (mg) {
1118                     magic_existspack(sv, mg);
1119                     {
1120                         I32 retbool = SvTRUE_nomg_NN(sv);
1121                         return cBOOL(retbool);
1122                     }
1123                 }
1124             }
1125         }
1126     }
1127
1128     if (key < 0) {
1129         key += AvFILL(av) + 1;
1130         if (key < 0)
1131             return FALSE;
1132     }
1133
1134     if (key <= AvFILLp(av) && AvARRAY(av)[key])
1135     {
1136         if (SvSMAGICAL(AvARRAY(av)[key])
1137          && mg_find(AvARRAY(av)[key], PERL_MAGIC_nonelem))
1138             return FALSE;
1139         return TRUE;
1140     }
1141     else
1142         return FALSE;
1143 }
1144
1145 static MAGIC *
1146 S_get_aux_mg(pTHX_ AV *av) {
1147     MAGIC *mg;
1148
1149     PERL_ARGS_ASSERT_GET_AUX_MG;
1150     assert(SvTYPE(av) == SVt_PVAV);
1151
1152     mg = mg_find((const SV *)av, PERL_MAGIC_arylen_p);
1153
1154     if (!mg) {
1155         mg = sv_magicext(MUTABLE_SV(av), 0, PERL_MAGIC_arylen_p,
1156                          &PL_vtbl_arylen_p, 0, 0);
1157         assert(mg);
1158         /* sv_magicext won't set this for us because we pass in a NULL obj  */
1159         mg->mg_flags |= MGf_REFCOUNTED;
1160     }
1161     return mg;
1162 }
1163
1164 SV **
1165 Perl_av_arylen_p(pTHX_ AV *av) {
1166     MAGIC *const mg = get_aux_mg(av);
1167
1168     PERL_ARGS_ASSERT_AV_ARYLEN_P;
1169     assert(SvTYPE(av) == SVt_PVAV);
1170
1171     return &(mg->mg_obj);
1172 }
1173
1174 IV *
1175 Perl_av_iter_p(pTHX_ AV *av) {
1176     MAGIC *const mg = get_aux_mg(av);
1177
1178     PERL_ARGS_ASSERT_AV_ITER_P;
1179     assert(SvTYPE(av) == SVt_PVAV);
1180
1181     if (sizeof(IV) == sizeof(SSize_t)) {
1182         return (IV *)&(mg->mg_len);
1183     } else {
1184         if (!mg->mg_ptr) {
1185             IV *temp;
1186             mg->mg_len = IVSIZE;
1187             Newxz(temp, 1, IV);
1188             mg->mg_ptr = (char *) temp;
1189         }
1190         return (IV *)mg->mg_ptr;
1191     }
1192 }
1193
1194 SV *
1195 Perl_av_nonelem(pTHX_ AV *av, SSize_t ix) {
1196     SV * const sv = newSV_type(SVt_NULL);
1197     PERL_ARGS_ASSERT_AV_NONELEM;
1198     if (!av_store(av,ix,sv))
1199         return sv_2mortal(sv); /* has tie magic */
1200     sv_magic(sv, NULL, PERL_MAGIC_nonelem, NULL, 0);
1201     return sv;
1202 }
1203
1204 /*
1205  * ex: set ts=8 sts=4 sw=4 et:
1206  */