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