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