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