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