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_len
 752
 753 Same as L</av_top_index>.  Note that, unlike what the name implies, it returns
 754 the highest index in the array, so to get the size of the array you need to use
 755 S<C<av_len(av) + 1>>.  This is unlike L</sv_len>, which returns what you would
 756 expect.
 757
 758 =cut
 759 */
 760
 761 SSize_t
 762 Perl_av_len(pTHX_ AV *av)
 763 {
 764     PERL_ARGS_ASSERT_AV_LEN;
 765
 766     return av_top_index(av);
 767 }
 768
 769 /*
 770 =for apidoc av_fill
 771
 772 Set the highest index in the array to the given number, equivalent to
 773 Perl's C<$#array = $fill;>.
 774
 775 The number of elements in the array will be C<fill + 1> after
 776 av_fill() returns.  If the array was previously shorter, then the
 777 additional elements appended are set to NULL.  If the array
 778 was longer, then the excess elements are freed.  C<av_fill(av, -1)> is
 779 the same as C<av_clear(av)>.
 780
 781 =cut
 782 */
 783 void
 784 Perl_av_fill(pTHX_ AV *av, SSize_t fill)
 785 {
 786     MAGIC *mg;
 787
 788     PERL_ARGS_ASSERT_AV_FILL;
 789     assert(SvTYPE(av) == SVt_PVAV);
 790
 791     if (fill < 0)
 792         fill = -1;
 793     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
 794         SV *arg1 = sv_newmortal();
 795         sv_setiv(arg1, (IV)(fill + 1));
 796         Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(STORESIZE), G_DISCARD,
 797                             1, arg1);
 798         return;
 799     }
 800     if (fill <= AvMAX(av)) {
 801         SSize_t key = AvFILLp(av);
 802         SV** const ary = AvARRAY(av);
 803
 804         if (AvREAL(av)) {
 805             while (key > fill) {
 806                 SvREFCNT_dec(ary[key]);
 807                 ary[key--] = NULL;
 808             }
 809         }
 810         else {
 811             while (key < fill)
 812                 ary[++key] = NULL;
 813         }
 814
 815         AvFILLp(av) = fill;
 816         if (SvSMAGICAL(av))
 817             mg_set(MUTABLE_SV(av));
 818     }
 819     else
 820         (void)av_store(av,fill,NULL);
 821 }
 822
 823 /*
 824 =for apidoc av_delete
 825
 826 Deletes the element indexed by C<key> from the array, makes the element mortal,
 827 and returns it.  If C<flags> equals C<G_DISCARD>, the element is freed and null
 828 is returned.  Perl equivalent: C<my $elem = delete($myarray[$idx]);> for the
 829 non-C<G_DISCARD> version and a void-context C<delete($myarray[$idx]);> for the
 830 C<G_DISCARD> version.
 831
 832 =cut
 833 */
 834 SV *
 835 Perl_av_delete(pTHX_ AV *av, SSize_t key, I32 flags)
 836 {
 837     SV *sv;
 838
 839     PERL_ARGS_ASSERT_AV_DELETE;
 840     assert(SvTYPE(av) == SVt_PVAV);
 841
 842     if (SvREADONLY(av))
 843         Perl_croak_no_modify();
 844
 845     if (SvRMAGICAL(av)) {
 846         const MAGIC * const tied_magic
 847             = mg_find((const SV *)av, PERL_MAGIC_tied);
 848         if ((tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata))) {
 849             SV **svp;
 850             if (key < 0) {
 851                 if (!S_adjust_index(aTHX_ av, tied_magic, &key))
 852                         return NULL;
 853             }
 854             svp = av_fetch(av, key, TRUE);
 855             if (svp) {
 856                 sv = *svp;
 857                 mg_clear(sv);
 858                 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
 859                     sv_unmagic(sv, PERL_MAGIC_tiedelem); /* No longer an element */
 860                     return sv;
 861                 }
 862                 return NULL;
 863             }
 864         }
 865     }
 866
 867     if (key < 0) {
 868         key += AvFILL(av) + 1;
 869         if (key < 0)
 870             return NULL;
 871     }
 872
 873     if (key > AvFILLp(av))
 874         return NULL;
 875     else {
 876         if (!AvREAL(av) && AvREIFY(av))
 877             av_reify(av);
 878         sv = AvARRAY(av)[key];
 879         AvARRAY(av)[key] = NULL;
 880         if (key == AvFILLp(av)) {
 881             do {
 882                 AvFILLp(av)--;
 883             } while (--key >= 0 && !AvARRAY(av)[key]);
 884         }
 885         if (SvSMAGICAL(av))
 886             mg_set(MUTABLE_SV(av));
 887     }
 888     if(sv != NULL) {
 889         if (flags & G_DISCARD) {
 890             SvREFCNT_dec_NN(sv);
 891             return NULL;
 892         }
 893         else if (AvREAL(av))
 894             sv_2mortal(sv);
 895     }
 896     return sv;
 897 }
 898
 899 /*
 900 =for apidoc av_exists
 901
 902 Returns true if the element indexed by C<key> has been initialized.
 903
 904 This relies on the fact that uninitialized array elements are set to
 905 NULL.
 906
 907 Perl equivalent: C<exists($myarray[$key])>.
 908
 909 =cut
 910 */
 911 bool
 912 Perl_av_exists(pTHX_ AV *av, SSize_t key)
 913 {
 914     PERL_ARGS_ASSERT_AV_EXISTS;
 915     assert(SvTYPE(av) == SVt_PVAV);
 916
 917     if (SvRMAGICAL(av)) {
 918         const MAGIC * const tied_magic
 919             = mg_find((const SV *)av, PERL_MAGIC_tied);
 920         const MAGIC * const regdata_magic
 921             = mg_find((const SV *)av, PERL_MAGIC_regdata);
 922         if (tied_magic || regdata_magic) {
 923             MAGIC *mg;
 924             /* Handle negative array indices 20020222 MJD */
 925             if (key < 0) {
 926                 if (!S_adjust_index(aTHX_ av, tied_magic, &key))
 927                         return FALSE;
 928             }
 929
 930             if(key >= 0 && regdata_magic) {
 931                 if (key <= AvFILL(av))
 932                     return TRUE;
 933                 else
 934                     return FALSE;
 935             }
 936             {
 937                 SV * const sv = sv_newmortal();
 938                 mg_copy(MUTABLE_SV(av), sv, 0, key);
 939                 mg = mg_find(sv, PERL_MAGIC_tiedelem);
 940                 if (mg) {
 941                     magic_existspack(sv, mg);
 942                     {
 943                         I32 retbool = SvTRUE_nomg_NN(sv);
 944                         return cBOOL(retbool);
 945                     }
 946                 }
 947             }
 948         }
 949     }
 950
 951     if (key < 0) {
 952         key += AvFILL(av) + 1;
 953         if (key < 0)
 954             return FALSE;
 955     }
 956
 957     if (key <= AvFILLp(av) && AvARRAY(av)[key])
 958     {
 959         return TRUE;
 960     }
 961     else
 962         return FALSE;
 963 }
 964
 965 static MAGIC *
 966 S_get_aux_mg(pTHX_ AV *av) {
 967     MAGIC *mg;
 968
 969     PERL_ARGS_ASSERT_GET_AUX_MG;
 970     assert(SvTYPE(av) == SVt_PVAV);
 971
 972     mg = mg_find((const SV *)av, PERL_MAGIC_arylen_p);
 973
 974     if (!mg) {
 975         mg = sv_magicext(MUTABLE_SV(av), 0, PERL_MAGIC_arylen_p,
 976                          &PL_vtbl_arylen_p, 0, 0);
 977         assert(mg);
 978         /* sv_magicext won't set this for us because we pass in a NULL obj  */
 979         mg->mg_flags |= MGf_REFCOUNTED;
 980     }
 981     return mg;
 982 }
 983
 984 SV **
 985 Perl_av_arylen_p(pTHX_ AV *av) {
 986     MAGIC *const mg = get_aux_mg(av);
 987
 988     PERL_ARGS_ASSERT_AV_ARYLEN_P;
 989     assert(SvTYPE(av) == SVt_PVAV);
 990
 991     return &(mg->mg_obj);
 992 }
 993
 994 IV *
 995 Perl_av_iter_p(pTHX_ AV *av) {
 996     MAGIC *const mg = get_aux_mg(av);
 997
 998     PERL_ARGS_ASSERT_AV_ITER_P;
 999     assert(SvTYPE(av) == SVt_PVAV);
1000
1001 #if IVSIZE == I32SIZE
1002     return (IV *)&(mg->mg_len);
1003 #else
1004     if (!mg->mg_ptr) {
1005         IV *temp;
1006         mg->mg_len = IVSIZE;
1007         Newxz(temp, 1, IV);
1008         mg->mg_ptr = (char *) temp;
1009     }
1010     return (IV *)mg->mg_ptr;
1011 #endif
1012 }
1013
1014 /*
1015  * Local variables:
1016  * c-indentation-style: bsd
1017  * c-basic-offset: 4
1018  * indent-tabs-mode: nil
1019  * End:
1020  *
1021  * ex: set ts=8 sts=4 sw=4 et:
1022  */