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         Newx(ary,size,SV*);
 413         AvALLOC(av) = ary;
 414         AvARRAY(av) = ary;
 415         AvMAX(av) = size - 1;
 416         AvFILLp(av) = -1;
 417         ENTER;
 418         SAVEFREESV(av);
 419         for (i = 0; i < size; i++) {
 420             assert (*strp);
 421
 422             /* Don't let sv_setsv swipe, since our source array might
 423                have multiple references to the same temp scalar (e.g.
 424                from a list slice) */
 425
 426             SvGETMAGIC(*strp); /* before newSV, in case it dies */
 427             AvFILLp(av)++;
 428             ary[i] = newSV(0);
 429             sv_setsv_flags(ary[i], *strp,
 430                            SV_DO_COW_SVSETSV|SV_NOSTEAL);
 431             strp++;
 432         }
 433         SvREFCNT_inc_simple_void_NN(av);
 434         LEAVE;
 435     }
 436     return av;
 437 }
 438
 439 /*
 440 =for apidoc av_clear
 441
 442 Frees the all the elements of an array, leaving it empty.
 443 The XS equivalent of C<@array = ()>.  See also L</av_undef>.
 444
 445 Note that it is possible that the actions of a destructor called directly
 446 or indirectly by freeing an element of the array could cause the reference
 447 count of the array itself to be reduced (e.g. by deleting an entry in the
 448 symbol table). So it is a possibility that the AV could have been freed
 449 (or even reallocated) on return from the call unless you hold a reference
 450 to it.
 451
 452 =cut
 453 */
 454
 455 void
 456 Perl_av_clear(pTHX_ AV *av)
 457 {
 458     SSize_t extra;
 459     bool real;
 460
 461     PERL_ARGS_ASSERT_AV_CLEAR;
 462     assert(SvTYPE(av) == SVt_PVAV);
 463
 464 #ifdef DEBUGGING
 465     if (SvREFCNT(av) == 0) {
 466         Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "Attempt to clear deleted array");
 467     }
 468 #endif
 469
 470     if (SvREADONLY(av))
 471         Perl_croak_no_modify();
 472
 473     /* Give any tie a chance to cleanup first */
 474     if (SvRMAGICAL(av)) {
 475         const MAGIC* const mg = SvMAGIC(av);
 476         if (PL_delaymagic && mg && mg->mg_type == PERL_MAGIC_isa)
 477             PL_delaymagic |= DM_ARRAY_ISA;
 478         else
 479             mg_clear(MUTABLE_SV(av));
 480     }
 481
 482     if (AvMAX(av) < 0)
 483         return;
 484
 485     if ((real = !!AvREAL(av))) {
 486         SV** const ary = AvARRAY(av);
 487         SSize_t index = AvFILLp(av) + 1;
 488         ENTER;
 489         SAVEFREESV(SvREFCNT_inc_simple_NN(av));
 490         while (index) {
 491             SV * const sv = ary[--index];
 492             /* undef the slot before freeing the value, because a
 493              * destructor might try to modify this array */
 494             ary[index] = NULL;
 495             SvREFCNT_dec(sv);
 496         }
 497     }
 498     extra = AvARRAY(av) - AvALLOC(av);
 499     if (extra) {
 500         AvMAX(av) += extra;
 501         AvARRAY(av) = AvALLOC(av);
 502     }
 503     AvFILLp(av) = -1;
 504     if (real) LEAVE;
 505 }
 506
 507 /*
 508 =for apidoc av_undef
 509
 510 Undefines the array. The XS equivalent of C<undef(@array)>.
 511
 512 As well as freeing all the elements of the array (like C<av_clear()>), this
 513 also frees the memory used by the av to store its list of scalars.
 514
 515 See L</av_clear> for a note about the array possibly being invalid on
 516 return.
 517
 518 =cut
 519 */
 520
 521 void
 522 Perl_av_undef(pTHX_ AV *av)
 523 {
 524     bool real;
 525
 526     PERL_ARGS_ASSERT_AV_UNDEF;
 527     assert(SvTYPE(av) == SVt_PVAV);
 528
 529     /* Give any tie a chance to cleanup first */
 530     if (SvTIED_mg((const SV *)av, PERL_MAGIC_tied))
 531         av_fill(av, -1);
 532
 533     if ((real = !!AvREAL(av))) {
 534         SSize_t key = AvFILLp(av) + 1;
 535         ENTER;
 536         SAVEFREESV(SvREFCNT_inc_simple_NN(av));
 537         while (key)
 538             SvREFCNT_dec(AvARRAY(av)[--key]);
 539     }
 540
 541     Safefree(AvALLOC(av));
 542     AvALLOC(av) = NULL;
 543     AvARRAY(av) = NULL;
 544     AvMAX(av) = AvFILLp(av) = -1;
 545
 546     if(SvRMAGICAL(av)) mg_clear(MUTABLE_SV(av));
 547     if(real) LEAVE;
 548 }
 549
 550 /*
 551
 552 =for apidoc av_create_and_push
 553
 554 Push an SV onto the end of the array, creating the array if necessary.
 555 A small internal helper function to remove a commonly duplicated idiom.
 556
 557 =cut
 558 */
 559
 560 void
 561 Perl_av_create_and_push(pTHX_ AV **const avp, SV *const val)
 562 {
 563     PERL_ARGS_ASSERT_AV_CREATE_AND_PUSH;
 564
 565     if (!*avp)
 566         *avp = newAV();
 567     av_push(*avp, val);
 568 }
 569
 570 /*
 571 =for apidoc av_push
 572
 573 Pushes an SV (transferring control of one reference count) onto the end of the
 574 array.  The array will grow automatically to accommodate the addition.
 575
 576 Perl equivalent: C<push @myarray, $val;>.
 577
 578 =cut
 579 */
 580
 581 void
 582 Perl_av_push(pTHX_ AV *av, SV *val)
 583 {
 584     MAGIC *mg;
 585
 586     PERL_ARGS_ASSERT_AV_PUSH;
 587     assert(SvTYPE(av) == SVt_PVAV);
 588
 589     if (SvREADONLY(av))
 590         Perl_croak_no_modify();
 591
 592     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
 593         Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(PUSH), G_DISCARD, 1,
 594                             val);
 595         return;
 596     }
 597     av_store(av,AvFILLp(av)+1,val);
 598 }
 599
 600 /*
 601 =for apidoc av_pop
 602
 603 Removes one SV from the end of the array, reducing its size by one and
 604 returning the SV (transferring control of one reference count) to the
 605 caller.  Returns C<&PL_sv_undef> if the array is empty.
 606
 607 Perl equivalent: C<pop(@myarray);>
 608
 609 =cut
 610 */
 611
 612 SV *
 613 Perl_av_pop(pTHX_ AV *av)
 614 {
 615     SV *retval;
 616     MAGIC* mg;
 617
 618     PERL_ARGS_ASSERT_AV_POP;
 619     assert(SvTYPE(av) == SVt_PVAV);
 620
 621     if (SvREADONLY(av))
 622         Perl_croak_no_modify();
 623     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
 624         retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(POP), 0, 0);
 625         if (retval)
 626             retval = newSVsv(retval);
 627         return retval;
 628     }
 629     if (AvFILL(av) < 0)
 630         return &PL_sv_undef;
 631     retval = AvARRAY(av)[AvFILLp(av)];
 632     AvARRAY(av)[AvFILLp(av)--] = NULL;
 633     if (SvSMAGICAL(av))
 634         mg_set(MUTABLE_SV(av));
 635     return retval ? retval : &PL_sv_undef;
 636 }
 637
 638 /*
 639
 640 =for apidoc av_create_and_unshift_one
 641
 642 Unshifts an SV onto the beginning of the array, creating the array if
 643 necessary.
 644 A small internal helper function to remove a commonly duplicated idiom.
 645
 646 =cut
 647 */
 648
 649 SV **
 650 Perl_av_create_and_unshift_one(pTHX_ AV **const avp, SV *const val)
 651 {
 652     PERL_ARGS_ASSERT_AV_CREATE_AND_UNSHIFT_ONE;
 653
 654     if (!*avp)
 655         *avp = newAV();
 656     av_unshift(*avp, 1);
 657     return av_store(*avp, 0, val);
 658 }
 659
 660 /*
 661 =for apidoc av_unshift
 662
 663 Unshift the given number of C<undef> values onto the beginning of the
 664 array.  The array will grow automatically to accommodate the addition.
 665
 666 Perl equivalent: S<C<unshift @myarray, ((undef) x $num);>>
 667
 668 =cut
 669 */
 670
 671 void
 672 Perl_av_unshift(pTHX_ AV *av, SSize_t num)
 673 {
 674     SSize_t i;
 675     MAGIC* mg;
 676
 677     PERL_ARGS_ASSERT_AV_UNSHIFT;
 678     assert(SvTYPE(av) == SVt_PVAV);
 679
 680     if (SvREADONLY(av))
 681         Perl_croak_no_modify();
 682
 683     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
 684         Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(UNSHIFT),
 685                             G_DISCARD | G_UNDEF_FILL, num);
 686         return;
 687     }
 688
 689     if (num <= 0)
 690       return;
 691     if (!AvREAL(av) && AvREIFY(av))
 692         av_reify(av);
 693     i = AvARRAY(av) - AvALLOC(av);
 694     if (i) {
 695         if (i > num)
 696             i = num;
 697         num -= i;
 698
 699         AvMAX(av) += i;
 700         AvFILLp(av) += i;
 701         AvARRAY(av) = AvARRAY(av) - i;
 702     }
 703     if (num) {
 704         SV **ary;
 705         const SSize_t i = AvFILLp(av);
 706         /* Create extra elements */
 707         const SSize_t slide = i > 0 ? i : 0;
 708         num += slide;
 709         av_extend(av, i + num);
 710         AvFILLp(av) += num;
 711         ary = AvARRAY(av);
 712         Move(ary, ary + num, i + 1, SV*);
 713         do {
 714             ary[--num] = NULL;
 715         } while (num);
 716         /* Make extra elements into a buffer */
 717         AvMAX(av) -= slide;
 718         AvFILLp(av) -= slide;
 719         AvARRAY(av) = AvARRAY(av) + slide;
 720     }
 721 }
 722
 723 /*
 724 =for apidoc av_shift
 725
 726 Removes one SV from the start of the array, reducing its size by one and
 727 returning the SV (transferring control of one reference count) to the
 728 caller.  Returns C<&PL_sv_undef> if the array is empty.
 729
 730 Perl equivalent: C<shift(@myarray);>
 731
 732 =cut
 733 */
 734
 735 SV *
 736 Perl_av_shift(pTHX_ AV *av)
 737 {
 738     SV *retval;
 739     MAGIC* mg;
 740
 741     PERL_ARGS_ASSERT_AV_SHIFT;
 742     assert(SvTYPE(av) == SVt_PVAV);
 743
 744     if (SvREADONLY(av))
 745         Perl_croak_no_modify();
 746     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
 747         retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(SHIFT), 0, 0);
 748         if (retval)
 749             retval = newSVsv(retval);
 750         return retval;
 751     }
 752     if (AvFILL(av) < 0)
 753       return &PL_sv_undef;
 754     retval = *AvARRAY(av);
 755     if (AvREAL(av))
 756         *AvARRAY(av) = NULL;
 757     AvARRAY(av) = AvARRAY(av) + 1;
 758     AvMAX(av)--;
 759     AvFILLp(av)--;
 760     if (SvSMAGICAL(av))
 761         mg_set(MUTABLE_SV(av));
 762     return retval ? retval : &PL_sv_undef;
 763 }
 764
 765 /*
 766 =for apidoc av_top_index
 767
 768 Returns the highest index in the array.  The number of elements in the
 769 array is S<C<av_top_index(av) + 1>>.  Returns -1 if the array is empty.
 770
 771 The Perl equivalent for this is C<$#myarray>.
 772
 773 (A slightly shorter form is C<av_tindex>.)
 774
 775 =for apidoc av_len
 776
 777 Same as L</av_top_index>.  Note that, unlike what the name implies, it returns
 778 the highest index in the array, so to get the size of the array you need to use
 779 S<C<av_len(av) + 1>>.  This is unlike L</sv_len>, which returns what you would
 780 expect.
 781
 782 =cut
 783 */
 784
 785 SSize_t
 786 Perl_av_len(pTHX_ AV *av)
 787 {
 788     PERL_ARGS_ASSERT_AV_LEN;
 789
 790     return av_top_index(av);
 791 }
 792
 793 /*
 794 =for apidoc av_fill
 795
 796 Set the highest index in the array to the given number, equivalent to
 797 Perl's S<C<$#array = $fill;>>.
 798
 799 The number of elements in the array will be S<C<fill + 1>> after
 800 C<av_fill()> returns.  If the array was previously shorter, then the
 801 additional elements appended are set to NULL.  If the array
 802 was longer, then the excess elements are freed.  S<C<av_fill(av, -1)>> is
 803 the same as C<av_clear(av)>.
 804
 805 =cut
 806 */
 807 void
 808 Perl_av_fill(pTHX_ AV *av, SSize_t fill)
 809 {
 810     MAGIC *mg;
 811
 812     PERL_ARGS_ASSERT_AV_FILL;
 813     assert(SvTYPE(av) == SVt_PVAV);
 814
 815     if (fill < 0)
 816         fill = -1;
 817     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
 818         SV *arg1 = sv_newmortal();
 819         sv_setiv(arg1, (IV)(fill + 1));
 820         Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(STORESIZE), G_DISCARD,
 821                             1, arg1);
 822         return;
 823     }
 824     if (fill <= AvMAX(av)) {
 825         SSize_t key = AvFILLp(av);
 826         SV** const ary = AvARRAY(av);
 827
 828         if (AvREAL(av)) {
 829             while (key > fill) {
 830                 SvREFCNT_dec(ary[key]);
 831                 ary[key--] = NULL;
 832             }
 833         }
 834         else {
 835             while (key < fill)
 836                 ary[++key] = NULL;
 837         }
 838
 839         AvFILLp(av) = fill;
 840         if (SvSMAGICAL(av))
 841             mg_set(MUTABLE_SV(av));
 842     }
 843     else
 844         (void)av_store(av,fill,NULL);
 845 }
 846
 847 /*
 848 =for apidoc av_delete
 849
 850 Deletes the element indexed by C<key> from the array, makes the element
 851 mortal, and returns it.  If C<flags> equals C<G_DISCARD>, the element is
 852 freed and NULL is returned. NULL is also returned if C<key> is out of
 853 range.
 854
 855 Perl equivalent: S<C<splice(@myarray, $key, 1, undef)>> (with the
 856 C<splice> in void context if C<G_DISCARD> is present).
 857
 858 =cut
 859 */
 860 SV *
 861 Perl_av_delete(pTHX_ AV *av, SSize_t key, I32 flags)
 862 {
 863     SV *sv;
 864
 865     PERL_ARGS_ASSERT_AV_DELETE;
 866     assert(SvTYPE(av) == SVt_PVAV);
 867
 868     if (SvREADONLY(av))
 869         Perl_croak_no_modify();
 870
 871     if (SvRMAGICAL(av)) {
 872         const MAGIC * const tied_magic
 873             = mg_find((const SV *)av, PERL_MAGIC_tied);
 874         if ((tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata))) {
 875             SV **svp;
 876             if (key < 0) {
 877                 if (!S_adjust_index(aTHX_ av, tied_magic, &key))
 878                         return NULL;
 879             }
 880             svp = av_fetch(av, key, TRUE);
 881             if (svp) {
 882                 sv = *svp;
 883                 mg_clear(sv);
 884                 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
 885                     sv_unmagic(sv, PERL_MAGIC_tiedelem); /* No longer an element */
 886                     return sv;
 887                 }
 888                 return NULL;
 889             }
 890         }
 891     }
 892
 893     if (key < 0) {
 894         key += AvFILL(av) + 1;
 895         if (key < 0)
 896             return NULL;
 897     }
 898
 899     if (key > AvFILLp(av))
 900         return NULL;
 901     else {
 902         if (!AvREAL(av) && AvREIFY(av))
 903             av_reify(av);
 904         sv = AvARRAY(av)[key];
 905         AvARRAY(av)[key] = NULL;
 906         if (key == AvFILLp(av)) {
 907             do {
 908                 AvFILLp(av)--;
 909             } while (--key >= 0 && !AvARRAY(av)[key]);
 910         }
 911         if (SvSMAGICAL(av))
 912             mg_set(MUTABLE_SV(av));
 913     }
 914     if(sv != NULL) {
 915         if (flags & G_DISCARD) {
 916             SvREFCNT_dec_NN(sv);
 917             return NULL;
 918         }
 919         else if (AvREAL(av))
 920             sv_2mortal(sv);
 921     }
 922     return sv;
 923 }
 924
 925 /*
 926 =for apidoc av_exists
 927
 928 Returns true if the element indexed by C<key> has been initialized.
 929
 930 This relies on the fact that uninitialized array elements are set to
 931 C<NULL>.
 932
 933 Perl equivalent: C<exists($myarray[$key])>.
 934
 935 =cut
 936 */
 937 bool
 938 Perl_av_exists(pTHX_ AV *av, SSize_t key)
 939 {
 940     PERL_ARGS_ASSERT_AV_EXISTS;
 941     assert(SvTYPE(av) == SVt_PVAV);
 942
 943     if (SvRMAGICAL(av)) {
 944         const MAGIC * const tied_magic
 945             = mg_find((const SV *)av, PERL_MAGIC_tied);
 946         const MAGIC * const regdata_magic
 947             = mg_find((const SV *)av, PERL_MAGIC_regdata);
 948         if (tied_magic || regdata_magic) {
 949             MAGIC *mg;
 950             /* Handle negative array indices 20020222 MJD */
 951             if (key < 0) {
 952                 if (!S_adjust_index(aTHX_ av, tied_magic, &key))
 953                         return FALSE;
 954             }
 955
 956             if(key >= 0 && regdata_magic) {
 957                 if (key <= AvFILL(av))
 958                     return TRUE;
 959                 else
 960                     return FALSE;
 961             }
 962             {
 963                 SV * const sv = sv_newmortal();
 964                 mg_copy(MUTABLE_SV(av), sv, 0, key);
 965                 mg = mg_find(sv, PERL_MAGIC_tiedelem);
 966                 if (mg) {
 967                     magic_existspack(sv, mg);
 968                     {
 969                         I32 retbool = SvTRUE_nomg_NN(sv);
 970                         return cBOOL(retbool);
 971                     }
 972                 }
 973             }
 974         }
 975     }
 976
 977     if (key < 0) {
 978         key += AvFILL(av) + 1;
 979         if (key < 0)
 980             return FALSE;
 981     }
 982
 983     if (key <= AvFILLp(av) && AvARRAY(av)[key])
 984     {
 985         return TRUE;
 986     }
 987     else
 988         return FALSE;
 989 }
 990
 991 static MAGIC *
 992 S_get_aux_mg(pTHX_ AV *av) {
 993     MAGIC *mg;
 994
 995     PERL_ARGS_ASSERT_GET_AUX_MG;
 996     assert(SvTYPE(av) == SVt_PVAV);
 997
 998     mg = mg_find((const SV *)av, PERL_MAGIC_arylen_p);
 999
1000     if (!mg) {
1001         mg = sv_magicext(MUTABLE_SV(av), 0, PERL_MAGIC_arylen_p,
1002                          &PL_vtbl_arylen_p, 0, 0);
1003         assert(mg);
1004         /* sv_magicext won't set this for us because we pass in a NULL obj  */
1005         mg->mg_flags |= MGf_REFCOUNTED;
1006     }
1007     return mg;
1008 }
1009
1010 SV **
1011 Perl_av_arylen_p(pTHX_ AV *av) {
1012     MAGIC *const mg = get_aux_mg(av);
1013
1014     PERL_ARGS_ASSERT_AV_ARYLEN_P;
1015     assert(SvTYPE(av) == SVt_PVAV);
1016
1017     return &(mg->mg_obj);
1018 }
1019
1020 IV *
1021 Perl_av_iter_p(pTHX_ AV *av) {
1022     MAGIC *const mg = get_aux_mg(av);
1023
1024     PERL_ARGS_ASSERT_AV_ITER_P;
1025     assert(SvTYPE(av) == SVt_PVAV);
1026
1027 #if IVSIZE == I32SIZE
1028     return (IV *)&(mg->mg_len);
1029 #else
1030     if (!mg->mg_ptr) {
1031         IV *temp;
1032         mg->mg_len = IVSIZE;
1033         Newxz(temp, 1, IV);
1034         mg->mg_ptr = (char *) temp;
1035     }
1036     return (IV *)mg->mg_ptr;
1037 #endif
1038 }
1039
1040 /*
1041  * ex: set ts=8 sts=4 sw=4 et:
1042  */