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