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