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