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         magic_methcall(MUTABLE_SV(av), mg, "EXTEND", G_DISCARD, 1, arg1, NULL);
  80         return;
  81     }
  82     if (key > AvMAX(av)) {
  83         SV** ary;
  84         I32 tmp;
  85         I32 newmax;
  86
  87         if (AvALLOC(av) != AvARRAY(av)) {
  88             ary = AvALLOC(av) + AvFILLp(av) + 1;
  89             tmp = AvARRAY(av) - AvALLOC(av);
  90             Move(AvARRAY(av), AvALLOC(av), AvFILLp(av)+1, SV*);
  91             AvMAX(av) += tmp;
  92             AvARRAY(av) = AvALLOC(av);
  93             if (AvREAL(av)) {
  94                 while (tmp)
  95                     ary[--tmp] = &PL_sv_undef;
  96             }
  97             if (key > AvMAX(av) - 10) {
  98                 newmax = key + AvMAX(av);
  99                 goto resize;
 100             }
 101         }
 102         else {
 103 #ifdef PERL_MALLOC_WRAP
 104             static const char oom_array_extend[] =
 105               "Out of memory during array extend"; /* Duplicated in pp_hot.c */
 106 #endif
 107
 108             if (AvALLOC(av)) {
 109 #if !defined(STRANGE_MALLOC) && !defined(MYMALLOC)
 110                 MEM_SIZE bytes;
 111                 IV itmp;
 112 #endif
 113
 114 #ifdef Perl_safesysmalloc_size
 115                 /* Whilst it would be quite possible to move this logic around
 116                    (as I did in the SV code), so as to set AvMAX(av) early,
 117                    based on calling Perl_safesysmalloc_size() immediately after
 118                    allocation, I'm not convinced that it is a great idea here.
 119                    In an array we have to loop round setting everything to
 120                    &PL_sv_undef, which means writing to memory, potentially lots
 121                    of it, whereas for the SV buffer case we don't touch the
 122                    "bonus" memory. So there there is no cost in telling the
 123                    world about it, whereas here we have to do work before we can
 124                    tell the world about it, and that work involves writing to
 125                    memory that might never be read. So, I feel, better to keep
 126                    the current lazy system of only writing to it if our caller
 127                    has a need for more space. NWC  */
 128                 newmax = Perl_safesysmalloc_size((void*)AvALLOC(av)) /
 129                     sizeof(const SV *) - 1;
 130
 131                 if (key <= newmax)
 132                     goto resized;
 133 #endif
 134                 newmax = key + AvMAX(av) / 5;
 135               resize:
 136                 MEM_WRAP_CHECK_1(newmax+1, SV*, oom_array_extend);
 137 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
 138                 Renew(AvALLOC(av),newmax+1, SV*);
 139 #else
 140                 bytes = (newmax + 1) * sizeof(const SV *);
 141 #define MALLOC_OVERHEAD 16
 142                 itmp = MALLOC_OVERHEAD;
 143                 while ((MEM_SIZE)(itmp - MALLOC_OVERHEAD) < bytes)
 144                     itmp += itmp;
 145                 itmp -= MALLOC_OVERHEAD;
 146                 itmp /= sizeof(const SV *);
 147                 assert(itmp > newmax);
 148                 newmax = itmp - 1;
 149                 assert(newmax >= AvMAX(av));
 150                 Newx(ary, newmax+1, SV*);
 151                 Copy(AvALLOC(av), ary, AvMAX(av)+1, SV*);
 152                 if (AvMAX(av) > 64)
 153                     offer_nice_chunk(AvALLOC(av),
 154                                      (AvMAX(av)+1) * sizeof(const SV *));
 155                 else
 156                     Safefree(AvALLOC(av));
 157                 AvALLOC(av) = ary;
 158 #endif
 159 #ifdef Perl_safesysmalloc_size
 160               resized:
 161 #endif
 162                 ary = AvALLOC(av) + AvMAX(av) + 1;
 163                 tmp = newmax - AvMAX(av);
 164                 if (av == PL_curstack) {        /* Oops, grew stack (via av_store()?) */
 165                     PL_stack_sp = AvALLOC(av) + (PL_stack_sp - PL_stack_base);
 166                     PL_stack_base = AvALLOC(av);
 167                     PL_stack_max = PL_stack_base + newmax;
 168                 }
 169             }
 170             else {
 171                 newmax = key < 3 ? 3 : key;
 172                 MEM_WRAP_CHECK_1(newmax+1, SV*, oom_array_extend);
 173                 Newx(AvALLOC(av), newmax+1, SV*);
 174                 ary = AvALLOC(av) + 1;
 175                 tmp = newmax;
 176                 AvALLOC(av)[0] = &PL_sv_undef;  /* For the stacks */
 177             }
 178             if (AvREAL(av)) {
 179                 while (tmp)
 180                     ary[--tmp] = &PL_sv_undef;
 181             }
 182
 183             AvARRAY(av) = AvALLOC(av);
 184             AvMAX(av) = newmax;
 185         }
 186     }
 187 }
 188
 189 /*
 190 =for apidoc av_fetch
 191
 192 Returns the SV at the specified index in the array.  The C<key> is the
 193 index.  If C<lval> is set then the fetch will be part of a store.  Check
 194 that the return value is non-null before dereferencing it to a C<SV*>.
 195
 196 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
 197 more information on how to use this function on tied arrays.
 198
 199 =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(aTHX_ "%s", PL_no_modify);
 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;
 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 =cut
 380 */
 381
 382 AV *
 383 Perl_av_make(pTHX_ register I32 size, register SV **strp)
 384 {
 385     register AV * const av = MUTABLE_AV(newSV_type(SVt_PVAV));
 386     /* sv_upgrade does AvREAL_only()  */
 387     PERL_ARGS_ASSERT_AV_MAKE;
 388     assert(SvTYPE(av) == SVt_PVAV);
 389
 390     if (size) {         /* "defined" was returning undef for size==0 anyway. */
 391         register SV** ary;
 392         register I32 i;
 393         Newx(ary,size,SV*);
 394         AvALLOC(av) = ary;
 395         AvARRAY(av) = ary;
 396         AvFILLp(av) = AvMAX(av) = size - 1;
 397         for (i = 0; i < size; i++) {
 398             assert (*strp);
 399
 400             /* Don't let sv_setsv swipe, since our source array might
 401                have multiple references to the same temp scalar (e.g.
 402                from a list slice) */
 403
 404             ary[i] = newSV(0);
 405             sv_setsv_flags(ary[i], *strp,
 406                            SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
 407             strp++;
 408         }
 409     }
 410     return av;
 411 }
 412
 413 /*
 414 =for apidoc av_clear
 415
 416 Clears an array, making it empty.  Does not free the memory used by the
 417 array itself.
 418
 419 =cut
 420 */
 421
 422 void
 423 Perl_av_clear(pTHX_ register AV *av)
 424 {
 425     dVAR;
 426     I32 extra;
 427
 428     PERL_ARGS_ASSERT_AV_CLEAR;
 429     assert(SvTYPE(av) == SVt_PVAV);
 430
 431 #ifdef DEBUGGING
 432     if (SvREFCNT(av) == 0) {
 433         Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "Attempt to clear deleted array");
 434     }
 435 #endif
 436
 437     if (SvREADONLY(av))
 438         Perl_croak(aTHX_ "%s", PL_no_modify);
 439
 440     /* Give any tie a chance to cleanup first */
 441     if (SvRMAGICAL(av)) {
 442         const MAGIC* const mg = SvMAGIC(av);
 443         if (PL_delaymagic && mg && mg->mg_type == PERL_MAGIC_isa)
 444             PL_delaymagic |= DM_ARRAY;
 445         else
 446             mg_clear(MUTABLE_SV(av));
 447     }
 448
 449     if (AvMAX(av) < 0)
 450         return;
 451
 452     if (AvREAL(av)) {
 453         SV** const ary = AvARRAY(av);
 454         I32 index = AvFILLp(av) + 1;
 455         while (index) {
 456             SV * const sv = ary[--index];
 457             /* undef the slot before freeing the value, because a
 458              * destructor might try to modify this array */
 459             ary[index] = &PL_sv_undef;
 460             SvREFCNT_dec(sv);
 461         }
 462     }
 463     extra = AvARRAY(av) - AvALLOC(av);
 464     if (extra) {
 465         AvMAX(av) += extra;
 466         AvARRAY(av) = AvALLOC(av);
 467     }
 468     AvFILLp(av) = -1;
 469
 470 }
 471
 472 /*
 473 =for apidoc av_undef
 474
 475 Undefines the array.  Frees the memory used by the array itself.
 476
 477 =cut
 478 */
 479
 480 void
 481 Perl_av_undef(pTHX_ register AV *av)
 482 {
 483     PERL_ARGS_ASSERT_AV_UNDEF;
 484     assert(SvTYPE(av) == SVt_PVAV);
 485
 486     /* Give any tie a chance to cleanup first */
 487     if (SvTIED_mg((const SV *)av, PERL_MAGIC_tied))
 488         av_fill(av, -1);
 489
 490     if (AvREAL(av)) {
 491         register I32 key = AvFILLp(av) + 1;
 492         while (key)
 493             SvREFCNT_dec(AvARRAY(av)[--key]);
 494     }
 495
 496     Safefree(AvALLOC(av));
 497     AvALLOC(av) = NULL;
 498     AvARRAY(av) = NULL;
 499     AvMAX(av) = AvFILLp(av) = -1;
 500
 501     if(SvRMAGICAL(av)) mg_clear(MUTABLE_SV(av));
 502 }
 503
 504 /*
 505
 506 =for apidoc av_create_and_push
 507
 508 Push an SV onto the end of the array, creating the array if necessary.
 509 A small internal helper function to remove a commonly duplicated idiom.
 510
 511 =cut
 512 */
 513
 514 void
 515 Perl_av_create_and_push(pTHX_ AV **const avp, SV *const val)
 516 {
 517     PERL_ARGS_ASSERT_AV_CREATE_AND_PUSH;
 518
 519     if (!*avp)
 520         *avp = newAV();
 521     av_push(*avp, val);
 522 }
 523
 524 /*
 525 =for apidoc av_push
 526
 527 Pushes an SV onto the end of the array.  The array will grow automatically
 528 to accommodate the addition. Like C<av_store>, this takes ownership of one
 529 reference count.
 530
 531 =cut
 532 */
 533
 534 void
 535 Perl_av_push(pTHX_ register AV *av, SV *val)
 536 {
 537     dVAR;
 538     MAGIC *mg;
 539
 540     PERL_ARGS_ASSERT_AV_PUSH;
 541     assert(SvTYPE(av) == SVt_PVAV);
 542
 543     if (SvREADONLY(av))
 544         Perl_croak(aTHX_ "%s", PL_no_modify);
 545
 546     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
 547         magic_methcall(MUTABLE_SV(av), mg, "PUSH", G_DISCARD, 1, val, NULL);
 548         return;
 549     }
 550     av_store(av,AvFILLp(av)+1,val);
 551 }
 552
 553 /*
 554 =for apidoc av_pop
 555
 556 Pops an SV off the end of the array.  Returns C<&PL_sv_undef> if the array
 557 is empty.
 558
 559 =cut
 560 */
 561
 562 SV *
 563 Perl_av_pop(pTHX_ register AV *av)
 564 {
 565     dVAR;
 566     SV *retval;
 567     MAGIC* mg;
 568
 569     PERL_ARGS_ASSERT_AV_POP;
 570     assert(SvTYPE(av) == SVt_PVAV);
 571
 572     if (SvREADONLY(av))
 573         Perl_croak(aTHX_ "%s", PL_no_modify);
 574     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
 575         retval = magic_methcall(MUTABLE_SV(av), mg, "POP", 0, 0, NULL, NULL);
 576         if (retval)
 577             retval = newSVsv(retval);
 578         return retval;
 579     }
 580     if (AvFILL(av) < 0)
 581         return &PL_sv_undef;
 582     retval = AvARRAY(av)[AvFILLp(av)];
 583     AvARRAY(av)[AvFILLp(av)--] = &PL_sv_undef;
 584     if (SvSMAGICAL(av))
 585         mg_set(MUTABLE_SV(av));
 586     return retval;
 587 }
 588
 589 /*
 590
 591 =for apidoc av_create_and_unshift_one
 592
 593 Unshifts an SV onto the beginning of the array, creating the array if
 594 necessary.
 595 A small internal helper function to remove a commonly duplicated idiom.
 596
 597 =cut
 598 */
 599
 600 SV **
 601 Perl_av_create_and_unshift_one(pTHX_ AV **const avp, SV *const val)
 602 {
 603     PERL_ARGS_ASSERT_AV_CREATE_AND_UNSHIFT_ONE;
 604
 605     if (!*avp)
 606         *avp = newAV();
 607     av_unshift(*avp, 1);
 608     return av_store(*avp, 0, val);
 609 }
 610
 611 /*
 612 =for apidoc av_unshift
 613
 614 Unshift the given number of C<undef> values onto the beginning of the
 615 array.  The array will grow automatically to accommodate the addition.  You
 616 must then use C<av_store> to assign values to these new elements.
 617
 618 =cut
 619 */
 620
 621 void
 622 Perl_av_unshift(pTHX_ register AV *av, register I32 num)
 623 {
 624     dVAR;
 625     register I32 i;
 626     MAGIC* mg;
 627
 628     PERL_ARGS_ASSERT_AV_UNSHIFT;
 629     assert(SvTYPE(av) == SVt_PVAV);
 630
 631     if (SvREADONLY(av))
 632         Perl_croak(aTHX_ "%s", PL_no_modify);
 633
 634     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
 635         magic_methcall(MUTABLE_SV(av), mg, "UNSHIFT", G_DISCARD,
 636             -num, NULL, NULL);
 637         return;
 638     }
 639
 640     if (num <= 0)
 641       return;
 642     if (!AvREAL(av) && AvREIFY(av))
 643         av_reify(av);
 644     i = AvARRAY(av) - AvALLOC(av);
 645     if (i) {
 646         if (i > num)
 647             i = num;
 648         num -= i;
 649
 650         AvMAX(av) += i;
 651         AvFILLp(av) += i;
 652         AvARRAY(av) = AvARRAY(av) - i;
 653     }
 654     if (num) {
 655         register SV **ary;
 656         const I32 i = AvFILLp(av);
 657         /* Create extra elements */
 658         const I32 slide = i > 0 ? i : 0;
 659         num += slide;
 660         av_extend(av, i + num);
 661         AvFILLp(av) += num;
 662         ary = AvARRAY(av);
 663         Move(ary, ary + num, i + 1, SV*);
 664         do {
 665             ary[--num] = &PL_sv_undef;
 666         } while (num);
 667         /* Make extra elements into a buffer */
 668         AvMAX(av) -= slide;
 669         AvFILLp(av) -= slide;
 670         AvARRAY(av) = AvARRAY(av) + slide;
 671     }
 672 }
 673
 674 /*
 675 =for apidoc av_shift
 676
 677 Shifts an SV off the beginning of the array. Returns C<&PL_sv_undef> if the
 678 array is empty.
 679
 680 =cut
 681 */
 682
 683 SV *
 684 Perl_av_shift(pTHX_ register AV *av)
 685 {
 686     dVAR;
 687     SV *retval;
 688     MAGIC* mg;
 689
 690     PERL_ARGS_ASSERT_AV_SHIFT;
 691     assert(SvTYPE(av) == SVt_PVAV);
 692
 693     if (SvREADONLY(av))
 694         Perl_croak(aTHX_ "%s", PL_no_modify);
 695     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
 696         retval = magic_methcall(MUTABLE_SV(av), mg, "SHIFT", 0, 0, NULL, NULL);
 697         if (retval)
 698             retval = newSVsv(retval);
 699         return retval;
 700     }
 701     if (AvFILL(av) < 0)
 702       return &PL_sv_undef;
 703     retval = *AvARRAY(av);
 704     if (AvREAL(av))
 705         *AvARRAY(av) = &PL_sv_undef;
 706     AvARRAY(av) = AvARRAY(av) + 1;
 707     AvMAX(av)--;
 708     AvFILLp(av)--;
 709     if (SvSMAGICAL(av))
 710         mg_set(MUTABLE_SV(av));
 711     return retval;
 712 }
 713
 714 /*
 715 =for apidoc av_len
 716
 717 Returns the highest index in the array.  The number of elements in the
 718 array is C<av_len(av) + 1>.  Returns -1 if the array is empty.
 719
 720 =cut
 721 */
 722
 723 I32
 724 Perl_av_len(pTHX_ AV *av)
 725 {
 726     PERL_ARGS_ASSERT_AV_LEN;
 727     assert(SvTYPE(av) == SVt_PVAV);
 728
 729     return AvFILL(av);
 730 }
 731
 732 /*
 733 =for apidoc av_fill
 734
 735 Set the highest index in the array to the given number, equivalent to
 736 Perl's C<$#array = $fill;>.
 737
 738 The number of elements in the an array will be C<fill + 1> after
 739 av_fill() returns.  If the array was previously shorter then the
 740 additional elements appended are set to C<PL_sv_undef>.  If the array
 741 was longer, then the excess elements are freed.  C<av_fill(av, -1)> is
 742 the same as C<av_clear(av)>.
 743
 744 =cut
 745 */
 746 void
 747 Perl_av_fill(pTHX_ register AV *av, I32 fill)
 748 {
 749     dVAR;
 750     MAGIC *mg;
 751
 752     PERL_ARGS_ASSERT_AV_FILL;
 753     assert(SvTYPE(av) == SVt_PVAV);
 754
 755     if (fill < 0)
 756         fill = -1;
 757     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
 758         SV *arg1 = sv_newmortal();
 759         sv_setiv(arg1, (IV)(fill + 1));
 760         magic_methcall(MUTABLE_SV(av), mg, "STORESIZE", G_DISCARD,
 761                 1, arg1, NULL);
 762         return;
 763     }
 764     if (fill <= AvMAX(av)) {
 765         I32 key = AvFILLp(av);
 766         SV** const ary = AvARRAY(av);
 767
 768         if (AvREAL(av)) {
 769             while (key > fill) {
 770                 SvREFCNT_dec(ary[key]);
 771                 ary[key--] = &PL_sv_undef;
 772             }
 773         }
 774         else {
 775             while (key < fill)
 776                 ary[++key] = &PL_sv_undef;
 777         }
 778
 779         AvFILLp(av) = fill;
 780         if (SvSMAGICAL(av))
 781             mg_set(MUTABLE_SV(av));
 782     }
 783     else
 784         (void)av_store(av,fill,&PL_sv_undef);
 785 }
 786
 787 /*
 788 =for apidoc av_delete
 789
 790 Deletes the element indexed by C<key> from the array.  Returns the
 791 deleted element. If C<flags> equals C<G_DISCARD>, the element is freed
 792 and null is returned.
 793
 794 =cut
 795 */
 796 SV *
 797 Perl_av_delete(pTHX_ AV *av, I32 key, I32 flags)
 798 {
 799     dVAR;
 800     SV *sv;
 801
 802     PERL_ARGS_ASSERT_AV_DELETE;
 803     assert(SvTYPE(av) == SVt_PVAV);
 804
 805     if (SvREADONLY(av))
 806         Perl_croak(aTHX_ "%s", PL_no_modify);
 807
 808     if (SvRMAGICAL(av)) {
 809         const MAGIC * const tied_magic
 810             = mg_find((const SV *)av, PERL_MAGIC_tied);
 811         if ((tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata))) {
 812             /* Handle negative array indices 20020222 MJD */
 813             SV **svp;
 814             if (key < 0) {
 815                 unsigned adjust_index = 1;
 816                 if (tied_magic) {
 817                     SV * const * const negative_indices_glob =
 818                         hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av),
 819                                                          tied_magic))),
 820                                  NEGATIVE_INDICES_VAR, 16, 0);
 821                     if (negative_indices_glob
 822                         && SvTRUE(GvSV(*negative_indices_glob)))
 823                         adjust_index = 0;
 824                 }
 825                 if (adjust_index) {
 826                     key += AvFILL(av) + 1;
 827                     if (key < 0)
 828                         return NULL;
 829                 }
 830             }
 831             svp = av_fetch(av, key, TRUE);
 832             if (svp) {
 833                 sv = *svp;
 834                 mg_clear(sv);
 835                 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
 836                     sv_unmagic(sv, PERL_MAGIC_tiedelem); /* No longer an element */
 837                     return sv;
 838                 }
 839                 return NULL;
 840             }
 841         }
 842     }
 843
 844     if (key < 0) {
 845         key += AvFILL(av) + 1;
 846         if (key < 0)
 847             return NULL;
 848     }
 849
 850     if (key > AvFILLp(av))
 851         return NULL;
 852     else {
 853         if (!AvREAL(av) && AvREIFY(av))
 854             av_reify(av);
 855         sv = AvARRAY(av)[key];
 856         if (key == AvFILLp(av)) {
 857             AvARRAY(av)[key] = &PL_sv_undef;
 858             do {
 859                 AvFILLp(av)--;
 860             } while (--key >= 0 && AvARRAY(av)[key] == &PL_sv_undef);
 861         }
 862         else
 863             AvARRAY(av)[key] = &PL_sv_undef;
 864         if (SvSMAGICAL(av))
 865             mg_set(MUTABLE_SV(av));
 866     }
 867     if (flags & G_DISCARD) {
 868         SvREFCNT_dec(sv);
 869         sv = NULL;
 870     }
 871     else if (AvREAL(av))
 872         sv = sv_2mortal(sv);
 873     return sv;
 874 }
 875
 876 /*
 877 =for apidoc av_exists
 878
 879 Returns true if the element indexed by C<key> has been initialized.
 880
 881 This relies on the fact that uninitialized array elements are set to
 882 C<&PL_sv_undef>.
 883
 884 =cut
 885 */
 886 bool
 887 Perl_av_exists(pTHX_ AV *av, I32 key)
 888 {
 889     dVAR;
 890     PERL_ARGS_ASSERT_AV_EXISTS;
 891     assert(SvTYPE(av) == SVt_PVAV);
 892
 893     if (SvRMAGICAL(av)) {
 894         const MAGIC * const tied_magic
 895             = mg_find((const SV *)av, PERL_MAGIC_tied);
 896         if (tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata)) {
 897             SV * const sv = sv_newmortal();
 898             MAGIC *mg;
 899             /* Handle negative array indices 20020222 MJD */
 900             if (key < 0) {
 901                 unsigned adjust_index = 1;
 902                 if (tied_magic) {
 903                     SV * const * const negative_indices_glob =
 904                         hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av),
 905                                                          tied_magic))),
 906                                  NEGATIVE_INDICES_VAR, 16, 0);
 907                     if (negative_indices_glob
 908                         && SvTRUE(GvSV(*negative_indices_glob)))
 909                         adjust_index = 0;
 910                 }
 911                 if (adjust_index) {
 912                     key += AvFILL(av) + 1;
 913                     if (key < 0)
 914                         return FALSE;
 915                 }
 916             }
 917
 918             mg_copy(MUTABLE_SV(av), sv, 0, key);
 919             mg = mg_find(sv, PERL_MAGIC_tiedelem);
 920             if (mg) {
 921                 magic_existspack(sv, mg);
 922                 return cBOOL(SvTRUE(sv));
 923             }
 924
 925         }
 926     }
 927
 928     if (key < 0) {
 929         key += AvFILL(av) + 1;
 930         if (key < 0)
 931             return FALSE;
 932     }
 933
 934     if (key <= AvFILLp(av) && AvARRAY(av)[key] != &PL_sv_undef
 935         && AvARRAY(av)[key])
 936     {
 937         return TRUE;
 938     }
 939     else
 940         return FALSE;
 941 }
 942
 943 static MAGIC *
 944 S_get_aux_mg(pTHX_ AV *av) {
 945     dVAR;
 946     MAGIC *mg;
 947
 948     PERL_ARGS_ASSERT_GET_AUX_MG;
 949     assert(SvTYPE(av) == SVt_PVAV);
 950
 951     mg = mg_find((const SV *)av, PERL_MAGIC_arylen_p);
 952
 953     if (!mg) {
 954         mg = sv_magicext(MUTABLE_SV(av), 0, PERL_MAGIC_arylen_p,
 955                          &PL_vtbl_arylen_p, 0, 0);
 956         assert(mg);
 957         /* sv_magicext won't set this for us because we pass in a NULL obj  */
 958         mg->mg_flags |= MGf_REFCOUNTED;
 959     }
 960     return mg;
 961 }
 962
 963 SV **
 964 Perl_av_arylen_p(pTHX_ AV *av) {
 965     MAGIC *const mg = get_aux_mg(av);
 966
 967     PERL_ARGS_ASSERT_AV_ARYLEN_P;
 968     assert(SvTYPE(av) == SVt_PVAV);
 969
 970     return &(mg->mg_obj);
 971 }
 972
 973 IV *
 974 Perl_av_iter_p(pTHX_ AV *av) {
 975     MAGIC *const mg = get_aux_mg(av);
 976
 977     PERL_ARGS_ASSERT_AV_ITER_P;
 978     assert(SvTYPE(av) == SVt_PVAV);
 979
 980 #if IVSIZE == I32SIZE
 981     return (IV *)&(mg->mg_len);
 982 #else
 983     if (!mg->mg_ptr) {
 984         IV *temp;
 985         mg->mg_len = IVSIZE;
 986         Newxz(temp, 1, IV);
 987         mg->mg_ptr = (char *) temp;
 988     }
 989     return (IV *)mg->mg_ptr;
 990 #endif
 991 }
 992
 993 /*
 994  * Local variables:
 995  * c-indentation-style: bsd
 996  * c-basic-offset: 4
 997  * indent-tabs-mode: t
 998  * End:
 999  *
1000  * ex: set ts=8 sts=4 sw=4 noet:
1001  */