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[$idx]>.
 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     if (UNLIKELY(AvREIFY(av) && SvIS_FREED(AvARRAY(av)[key]))) {
 292         /* eg. @_ could have freed elts */
 293         AvARRAY(av)[key] = NULL;        /* 1/2 reify */
 294         goto emptyness;
 295     }
 296     return &AvARRAY(av)[key];
 297 }
 298
 299 /*
 300 =for apidoc av_store
 301
 302 Stores an SV in an array.  The array index is specified as C<key>.  The
 303 return value will be C<NULL> if the operation failed or if the value did not
 304 need to be actually stored within the array (as in the case of tied
 305 arrays).  Otherwise, it can be dereferenced
 306 to get the C<SV*> that was stored
 307 there (= C<val>)).
 308
 309 Note that the caller is responsible for suitably incrementing the reference
 310 count of C<val> before the call, and decrementing it if the function
 311 returned C<NULL>.
 312
 313 Approximate Perl equivalent: C<$myarray[$key] = $val;>.
 314
 315 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
 316 more information on how to use this function on tied arrays.
 317
 318 =cut
 319 */
 320
 321 SV**
 322 Perl_av_store(pTHX_ AV *av, SSize_t key, SV *val)
 323 {
 324     SV** ary;
 325
 326     PERL_ARGS_ASSERT_AV_STORE;
 327     assert(SvTYPE(av) == SVt_PVAV);
 328
 329     /* S_regclass relies on being able to pass in a NULL sv
 330        (unicode_alternate may be NULL).
 331     */
 332
 333     if (SvRMAGICAL(av)) {
 334         const MAGIC * const tied_magic = mg_find((const SV *)av, PERL_MAGIC_tied);
 335         if (tied_magic) {
 336             if (key < 0) {
 337                 if (!S_adjust_index(aTHX_ av, tied_magic, &key))
 338                         return 0;
 339             }
 340             if (val) {
 341                 mg_copy(MUTABLE_SV(av), val, 0, key);
 342             }
 343             return NULL;
 344         }
 345     }
 346
 347
 348     if (key < 0) {
 349         key += AvFILL(av) + 1;
 350         if (key < 0)
 351             return NULL;
 352     }
 353
 354     if (SvREADONLY(av) && key >= AvFILL(av))
 355         Perl_croak_no_modify();
 356
 357     if (!AvREAL(av) && AvREIFY(av))
 358         av_reify(av);
 359     if (key > AvMAX(av))
 360         av_extend(av,key);
 361     ary = AvARRAY(av);
 362     if (AvFILLp(av) < key) {
 363         if (!AvREAL(av)) {
 364             if (av == PL_curstack && key > PL_stack_sp - PL_stack_base)
 365                 PL_stack_sp = PL_stack_base + key;      /* XPUSH in disguise */
 366             do {
 367                 ary[++AvFILLp(av)] = NULL;
 368             } while (AvFILLp(av) < key);
 369         }
 370         AvFILLp(av) = key;
 371     }
 372     else if (AvREAL(av))
 373         SvREFCNT_dec(ary[key]);
 374     ary[key] = val;
 375     if (SvSMAGICAL(av)) {
 376         const MAGIC *mg = SvMAGIC(av);
 377         bool set = TRUE;
 378         for (; mg; mg = mg->mg_moremagic) {
 379           if (!isUPPER(mg->mg_type)) continue;
 380           if (val) {
 381             sv_magic(val, MUTABLE_SV(av), toLOWER(mg->mg_type), 0, key);
 382           }
 383           if (PL_delaymagic && mg->mg_type == PERL_MAGIC_isa) {
 384             PL_delaymagic |= DM_ARRAY_ISA;
 385             set = FALSE;
 386           }
 387         }
 388         if (set)
 389            mg_set(MUTABLE_SV(av));
 390     }
 391     return &ary[key];
 392 }
 393
 394 /*
 395 =for apidoc av_make
 396
 397 Creates a new AV and populates it with a list of SVs.  The SVs are copied
 398 into the array, so they may be freed after the call to C<av_make>.  The new AV
 399 will have a reference count of 1.
 400
 401 Perl equivalent: C<my @new_array = ($scalar1, $scalar2, $scalar3...);>
 402
 403 =cut
 404 */
 405
 406 AV *
 407 Perl_av_make(pTHX_ SSize_t size, SV **strp)
 408 {
 409     AV * const av = MUTABLE_AV(newSV_type(SVt_PVAV));
 410     /* sv_upgrade does AvREAL_only()  */
 411     PERL_ARGS_ASSERT_AV_MAKE;
 412     assert(SvTYPE(av) == SVt_PVAV);
 413
 414     if (size) {         /* "defined" was returning undef for size==0 anyway. */
 415         SV** ary;
 416         SSize_t i;
 417         Newx(ary,size,SV*);
 418         AvALLOC(av) = ary;
 419         AvARRAY(av) = ary;
 420         AvMAX(av) = size - 1;
 421         AvFILLp(av) = -1;
 422         ENTER;
 423         SAVEFREESV(av);
 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         SvREFCNT_inc_simple_void_NN(av);
 439         LEAVE;
 440     }
 441     return av;
 442 }
 443
 444 /*
 445 =for apidoc av_clear
 446
 447 Frees the all the elements of an array, leaving it empty.
 448 The XS equivalent of C<@array = ()>.  See also L</av_undef>.
 449
 450 Note that it is possible that the actions of a destructor called directly
 451 or indirectly by freeing an element of the array could cause the reference
 452 count of the array itself to be reduced (e.g. by deleting an entry in the
 453 symbol table). So it is a possibility that the AV could have been freed
 454 (or even reallocated) on return from the call unless you hold a reference
 455 to it.
 456
 457 =cut
 458 */
 459
 460 void
 461 Perl_av_clear(pTHX_ AV *av)
 462 {
 463     SSize_t extra;
 464     bool real;
 465
 466     PERL_ARGS_ASSERT_AV_CLEAR;
 467     assert(SvTYPE(av) == SVt_PVAV);
 468
 469 #ifdef DEBUGGING
 470     if (SvREFCNT(av) == 0) {
 471         Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "Attempt to clear deleted array");
 472     }
 473 #endif
 474
 475     if (SvREADONLY(av))
 476         Perl_croak_no_modify();
 477
 478     /* Give any tie a chance to cleanup first */
 479     if (SvRMAGICAL(av)) {
 480         const MAGIC* const mg = SvMAGIC(av);
 481         if (PL_delaymagic && mg && mg->mg_type == PERL_MAGIC_isa)
 482             PL_delaymagic |= DM_ARRAY_ISA;
 483         else
 484             mg_clear(MUTABLE_SV(av));
 485     }
 486
 487     if (AvMAX(av) < 0)
 488         return;
 489
 490     if ((real = !!AvREAL(av))) {
 491         SV** const ary = AvARRAY(av);
 492         SSize_t index = AvFILLp(av) + 1;
 493         ENTER;
 494         SAVEFREESV(SvREFCNT_inc_simple_NN(av));
 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) LEAVE;
 510 }
 511
 512 /*
 513 =for apidoc av_undef
 514
 515 Undefines the array. The XS equivalent of C<undef(@array)>.
 516
 517 As well as freeing all the elements of the array (like C<av_clear()>), this
 518 also frees the memory used by the av to store its list of scalars.
 519
 520 See L</av_clear> for a note about the array possibly being invalid on
 521 return.
 522
 523 =cut
 524 */
 525
 526 void
 527 Perl_av_undef(pTHX_ AV *av)
 528 {
 529     bool real;
 530
 531     PERL_ARGS_ASSERT_AV_UNDEF;
 532     assert(SvTYPE(av) == SVt_PVAV);
 533
 534     /* Give any tie a chance to cleanup first */
 535     if (SvTIED_mg((const SV *)av, PERL_MAGIC_tied))
 536         av_fill(av, -1);
 537
 538     if ((real = !!AvREAL(av))) {
 539         SSize_t key = AvFILLp(av) + 1;
 540         ENTER;
 541         SAVEFREESV(SvREFCNT_inc_simple_NN(av));
 542         while (key)
 543             SvREFCNT_dec(AvARRAY(av)[--key]);
 544     }
 545
 546     Safefree(AvALLOC(av));
 547     AvALLOC(av) = NULL;
 548     AvARRAY(av) = NULL;
 549     AvMAX(av) = AvFILLp(av) = -1;
 550
 551     if(SvRMAGICAL(av)) mg_clear(MUTABLE_SV(av));
 552     if(real) LEAVE;
 553 }
 554
 555 /*
 556
 557 =for apidoc av_create_and_push
 558
 559 Push an SV onto the end of the array, creating the array if necessary.
 560 A small internal helper function to remove a commonly duplicated idiom.
 561
 562 =cut
 563 */
 564
 565 void
 566 Perl_av_create_and_push(pTHX_ AV **const avp, SV *const val)
 567 {
 568     PERL_ARGS_ASSERT_AV_CREATE_AND_PUSH;
 569
 570     if (!*avp)
 571         *avp = newAV();
 572     av_push(*avp, val);
 573 }
 574
 575 /*
 576 =for apidoc av_push
 577
 578 Pushes an SV (transferring control of one reference count) onto the end of the
 579 array.  The array will grow automatically to accommodate the addition.
 580
 581 Perl equivalent: C<push @myarray, $elem;>.
 582
 583 =cut
 584 */
 585
 586 void
 587 Perl_av_push(pTHX_ AV *av, SV *val)
 588 {
 589     MAGIC *mg;
 590
 591     PERL_ARGS_ASSERT_AV_PUSH;
 592     assert(SvTYPE(av) == SVt_PVAV);
 593
 594     if (SvREADONLY(av))
 595         Perl_croak_no_modify();
 596
 597     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
 598         Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(PUSH), G_DISCARD, 1,
 599                             val);
 600         return;
 601     }
 602     av_store(av,AvFILLp(av)+1,val);
 603 }
 604
 605 /*
 606 =for apidoc av_pop
 607
 608 Removes one SV from the end of the array, reducing its size by one and
 609 returning the SV (transferring control of one reference count) to the
 610 caller.  Returns C<&PL_sv_undef> if the array is empty.
 611
 612 Perl equivalent: C<pop(@myarray);>
 613
 614 =cut
 615 */
 616
 617 SV *
 618 Perl_av_pop(pTHX_ AV *av)
 619 {
 620     SV *retval;
 621     MAGIC* mg;
 622
 623     PERL_ARGS_ASSERT_AV_POP;
 624     assert(SvTYPE(av) == SVt_PVAV);
 625
 626     if (SvREADONLY(av))
 627         Perl_croak_no_modify();
 628     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
 629         retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(POP), 0, 0);
 630         if (retval)
 631             retval = newSVsv(retval);
 632         return retval;
 633     }
 634     if (AvFILL(av) < 0)
 635         return &PL_sv_undef;
 636     retval = AvARRAY(av)[AvFILLp(av)];
 637     AvARRAY(av)[AvFILLp(av)--] = NULL;
 638     if (SvSMAGICAL(av))
 639         mg_set(MUTABLE_SV(av));
 640     return retval ? retval : &PL_sv_undef;
 641 }
 642
 643 /*
 644
 645 =for apidoc av_create_and_unshift_one
 646
 647 Unshifts an SV onto the beginning of the array, creating the array if
 648 necessary.
 649 A small internal helper function to remove a commonly duplicated idiom.
 650
 651 =cut
 652 */
 653
 654 SV **
 655 Perl_av_create_and_unshift_one(pTHX_ AV **const avp, SV *const val)
 656 {
 657     PERL_ARGS_ASSERT_AV_CREATE_AND_UNSHIFT_ONE;
 658
 659     if (!*avp)
 660         *avp = newAV();
 661     av_unshift(*avp, 1);
 662     return av_store(*avp, 0, val);
 663 }
 664
 665 /*
 666 =for apidoc av_unshift
 667
 668 Unshift the given number of C<undef> values onto the beginning of the
 669 array.  The array will grow automatically to accommodate the addition.  You
 670 must then use C<av_store> to assign values to these new elements.
 671
 672 Perl equivalent: S<C<unshift @myarray, ( (undef) x $n );>>
 673
 674 =cut
 675 */
 676
 677 void
 678 Perl_av_unshift(pTHX_ AV *av, SSize_t num)
 679 {
 680     SSize_t i;
 681     MAGIC* mg;
 682
 683     PERL_ARGS_ASSERT_AV_UNSHIFT;
 684     assert(SvTYPE(av) == SVt_PVAV);
 685
 686     if (SvREADONLY(av))
 687         Perl_croak_no_modify();
 688
 689     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
 690         Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(UNSHIFT),
 691                             G_DISCARD | G_UNDEF_FILL, num);
 692         return;
 693     }
 694
 695     if (num <= 0)
 696       return;
 697     if (!AvREAL(av) && AvREIFY(av))
 698         av_reify(av);
 699     i = AvARRAY(av) - AvALLOC(av);
 700     if (i) {
 701         if (i > num)
 702             i = num;
 703         num -= i;
 704
 705         AvMAX(av) += i;
 706         AvFILLp(av) += i;
 707         AvARRAY(av) = AvARRAY(av) - i;
 708     }
 709     if (num) {
 710         SV **ary;
 711         const SSize_t i = AvFILLp(av);
 712         /* Create extra elements */
 713         const SSize_t slide = i > 0 ? i : 0;
 714         num += slide;
 715         av_extend(av, i + num);
 716         AvFILLp(av) += num;
 717         ary = AvARRAY(av);
 718         Move(ary, ary + num, i + 1, SV*);
 719         do {
 720             ary[--num] = NULL;
 721         } while (num);
 722         /* Make extra elements into a buffer */
 723         AvMAX(av) -= slide;
 724         AvFILLp(av) -= slide;
 725         AvARRAY(av) = AvARRAY(av) + slide;
 726     }
 727 }
 728
 729 /*
 730 =for apidoc av_shift
 731
 732 Removes one SV from the start of the array, reducing its size by one and
 733 returning the SV (transferring control of one reference count) to the
 734 caller.  Returns C<&PL_sv_undef> if the array is empty.
 735
 736 Perl equivalent: C<shift(@myarray);>
 737
 738 =cut
 739 */
 740
 741 SV *
 742 Perl_av_shift(pTHX_ AV *av)
 743 {
 744     SV *retval;
 745     MAGIC* mg;
 746
 747     PERL_ARGS_ASSERT_AV_SHIFT;
 748     assert(SvTYPE(av) == SVt_PVAV);
 749
 750     if (SvREADONLY(av))
 751         Perl_croak_no_modify();
 752     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
 753         retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(SHIFT), 0, 0);
 754         if (retval)
 755             retval = newSVsv(retval);
 756         return retval;
 757     }
 758     if (AvFILL(av) < 0)
 759       return &PL_sv_undef;
 760     retval = *AvARRAY(av);
 761     if (AvREAL(av))
 762         *AvARRAY(av) = NULL;
 763     AvARRAY(av) = AvARRAY(av) + 1;
 764     AvMAX(av)--;
 765     AvFILLp(av)--;
 766     if (SvSMAGICAL(av))
 767         mg_set(MUTABLE_SV(av));
 768     return retval ? retval : &PL_sv_undef;
 769 }
 770
 771 /*
 772 =for apidoc av_top_index
 773
 774 Returns the highest index in the array.  The number of elements in the
 775 array is S<C<av_top_index(av) + 1>>.  Returns -1 if the array is empty.
 776
 777 The Perl equivalent for this is C<$#myarray>.
 778
 779 (A slightly shorter form is C<av_tindex>.)
 780
 781 =for apidoc av_len
 782
 783 Same as L</av_top_index>.  Note that, unlike what the name implies, it returns
 784 the highest index in the array, so to get the size of the array you need to use
 785 S<C<av_len(av) + 1>>.  This is unlike L</sv_len>, which returns what you would
 786 expect.
 787
 788 =cut
 789 */
 790
 791 SSize_t
 792 Perl_av_len(pTHX_ AV *av)
 793 {
 794     PERL_ARGS_ASSERT_AV_LEN;
 795
 796     return av_top_index(av);
 797 }
 798
 799 /*
 800 =for apidoc av_fill
 801
 802 Set the highest index in the array to the given number, equivalent to
 803 Perl's S<C<$#array = $fill;>>.
 804
 805 The number of elements in the array will be S<C<fill + 1>> after
 806 C<av_fill()> returns.  If the array was previously shorter, then the
 807 additional elements appended are set to NULL.  If the array
 808 was longer, then the excess elements are freed.  S<C<av_fill(av, -1)>> is
 809 the same as C<av_clear(av)>.
 810
 811 =cut
 812 */
 813 void
 814 Perl_av_fill(pTHX_ AV *av, SSize_t fill)
 815 {
 816     MAGIC *mg;
 817
 818     PERL_ARGS_ASSERT_AV_FILL;
 819     assert(SvTYPE(av) == SVt_PVAV);
 820
 821     if (fill < 0)
 822         fill = -1;
 823     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
 824         SV *arg1 = sv_newmortal();
 825         sv_setiv(arg1, (IV)(fill + 1));
 826         Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(STORESIZE), G_DISCARD,
 827                             1, arg1);
 828         return;
 829     }
 830     if (fill <= AvMAX(av)) {
 831         SSize_t key = AvFILLp(av);
 832         SV** const ary = AvARRAY(av);
 833
 834         if (AvREAL(av)) {
 835             while (key > fill) {
 836                 SvREFCNT_dec(ary[key]);
 837                 ary[key--] = NULL;
 838             }
 839         }
 840         else {
 841             while (key < fill)
 842                 ary[++key] = NULL;
 843         }
 844
 845         AvFILLp(av) = fill;
 846         if (SvSMAGICAL(av))
 847             mg_set(MUTABLE_SV(av));
 848     }
 849     else
 850         (void)av_store(av,fill,NULL);
 851 }
 852
 853 /*
 854 =for apidoc av_delete
 855
 856 Deletes the element indexed by C<key> from the array, makes the element mortal,
 857 and returns it.  If C<flags> equals C<G_DISCARD>, the element is freed and null
 858 is returned.  Perl equivalent: S<C<my $elem = delete($myarray[$idx]);>> for the
 859 non-C<G_DISCARD> version and a void-context S<C<delete($myarray[$idx]);>> for the
 860 C<G_DISCARD> version.
 861
 862 =cut
 863 */
 864 SV *
 865 Perl_av_delete(pTHX_ AV *av, SSize_t key, I32 flags)
 866 {
 867     SV *sv;
 868
 869     PERL_ARGS_ASSERT_AV_DELETE;
 870     assert(SvTYPE(av) == SVt_PVAV);
 871
 872     if (SvREADONLY(av))
 873         Perl_croak_no_modify();
 874
 875     if (SvRMAGICAL(av)) {
 876         const MAGIC * const tied_magic
 877             = mg_find((const SV *)av, PERL_MAGIC_tied);
 878         if ((tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata))) {
 879             SV **svp;
 880             if (key < 0) {
 881                 if (!S_adjust_index(aTHX_ av, tied_magic, &key))
 882                         return NULL;
 883             }
 884             svp = av_fetch(av, key, TRUE);
 885             if (svp) {
 886                 sv = *svp;
 887                 mg_clear(sv);
 888                 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
 889                     sv_unmagic(sv, PERL_MAGIC_tiedelem); /* No longer an element */
 890                     return sv;
 891                 }
 892                 return NULL;
 893             }
 894         }
 895     }
 896
 897     if (key < 0) {
 898         key += AvFILL(av) + 1;
 899         if (key < 0)
 900             return NULL;
 901     }
 902
 903     if (key > AvFILLp(av))
 904         return NULL;
 905     else {
 906         if (!AvREAL(av) && AvREIFY(av))
 907             av_reify(av);
 908         sv = AvARRAY(av)[key];
 909         AvARRAY(av)[key] = NULL;
 910         if (key == AvFILLp(av)) {
 911             do {
 912                 AvFILLp(av)--;
 913             } while (--key >= 0 && !AvARRAY(av)[key]);
 914         }
 915         if (SvSMAGICAL(av))
 916             mg_set(MUTABLE_SV(av));
 917     }
 918     if(sv != NULL) {
 919         if (flags & G_DISCARD) {
 920             SvREFCNT_dec_NN(sv);
 921             return NULL;
 922         }
 923         else if (AvREAL(av))
 924             sv_2mortal(sv);
 925     }
 926     return sv;
 927 }
 928
 929 /*
 930 =for apidoc av_exists
 931
 932 Returns true if the element indexed by C<key> has been initialized.
 933
 934 This relies on the fact that uninitialized array elements are set to
 935 C<NULL>.
 936
 937 Perl equivalent: C<exists($myarray[$key])>.
 938
 939 =cut
 940 */
 941 bool
 942 Perl_av_exists(pTHX_ AV *av, SSize_t key)
 943 {
 944     PERL_ARGS_ASSERT_AV_EXISTS;
 945     assert(SvTYPE(av) == SVt_PVAV);
 946
 947     if (SvRMAGICAL(av)) {
 948         const MAGIC * const tied_magic
 949             = mg_find((const SV *)av, PERL_MAGIC_tied);
 950         const MAGIC * const regdata_magic
 951             = mg_find((const SV *)av, PERL_MAGIC_regdata);
 952         if (tied_magic || regdata_magic) {
 953             MAGIC *mg;
 954             /* Handle negative array indices 20020222 MJD */
 955             if (key < 0) {
 956                 if (!S_adjust_index(aTHX_ av, tied_magic, &key))
 957                         return FALSE;
 958             }
 959
 960             if(key >= 0 && regdata_magic) {
 961                 if (key <= AvFILL(av))
 962                     return TRUE;
 963                 else
 964                     return FALSE;
 965             }
 966             {
 967                 SV * const sv = sv_newmortal();
 968                 mg_copy(MUTABLE_SV(av), sv, 0, key);
 969                 mg = mg_find(sv, PERL_MAGIC_tiedelem);
 970                 if (mg) {
 971                     magic_existspack(sv, mg);
 972                     {
 973                         I32 retbool = SvTRUE_nomg_NN(sv);
 974                         return cBOOL(retbool);
 975                     }
 976                 }
 977             }
 978         }
 979     }
 980
 981     if (key < 0) {
 982         key += AvFILL(av) + 1;
 983         if (key < 0)
 984             return FALSE;
 985     }
 986
 987     if (key <= AvFILLp(av) && AvARRAY(av)[key])
 988     {
 989         return TRUE;
 990     }
 991     else
 992         return FALSE;
 993 }
 994
 995 static MAGIC *
 996 S_get_aux_mg(pTHX_ AV *av) {
 997     MAGIC *mg;
 998
 999     PERL_ARGS_ASSERT_GET_AUX_MG;
1000     assert(SvTYPE(av) == SVt_PVAV);
1001
1002     mg = mg_find((const SV *)av, PERL_MAGIC_arylen_p);
1003
1004     if (!mg) {
1005         mg = sv_magicext(MUTABLE_SV(av), 0, PERL_MAGIC_arylen_p,
1006                          &PL_vtbl_arylen_p, 0, 0);
1007         assert(mg);
1008         /* sv_magicext won't set this for us because we pass in a NULL obj  */
1009         mg->mg_flags |= MGf_REFCOUNTED;
1010     }
1011     return mg;
1012 }
1013
1014 SV **
1015 Perl_av_arylen_p(pTHX_ AV *av) {
1016     MAGIC *const mg = get_aux_mg(av);
1017
1018     PERL_ARGS_ASSERT_AV_ARYLEN_P;
1019     assert(SvTYPE(av) == SVt_PVAV);
1020
1021     return &(mg->mg_obj);
1022 }
1023
1024 IV *
1025 Perl_av_iter_p(pTHX_ AV *av) {
1026     MAGIC *const mg = get_aux_mg(av);
1027
1028     PERL_ARGS_ASSERT_AV_ITER_P;
1029     assert(SvTYPE(av) == SVt_PVAV);
1030
1031 #if IVSIZE == I32SIZE
1032     return (IV *)&(mg->mg_len);
1033 #else
1034     if (!mg->mg_ptr) {
1035         IV *temp;
1036         mg->mg_len = IVSIZE;
1037         Newxz(temp, 1, IV);
1038         mg->mg_ptr = (char *) temp;
1039     }
1040     return (IV *)mg->mg_ptr;
1041 #endif
1042 }
1043
1044 /*
1045  * ex: set ts=8 sts=4 sw=4 et:
1046  */