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