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