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                 if (AvMAX(av) > 64)
 154                     offer_nice_chunk(AvALLOC(av),
 155                                      (AvMAX(av)+1) * sizeof(const SV *));
 156                 else
 157                     Safefree(AvALLOC(av));
 158                 AvALLOC(av) = ary;
 159 #endif
 160 #ifdef Perl_safesysmalloc_size
 161               resized:
 162 #endif
 163                 ary = AvALLOC(av) + AvMAX(av) + 1;
 164                 tmp = newmax - AvMAX(av);
 165                 if (av == PL_curstack) {        /* Oops, grew stack (via av_store()?) */
 166                     PL_stack_sp = AvALLOC(av) + (PL_stack_sp - PL_stack_base);
 167                     PL_stack_base = AvALLOC(av);
 168                     PL_stack_max = PL_stack_base + newmax;
 169                 }
 170             }
 171             else {
 172                 newmax = key < 3 ? 3 : key;
 173                 MEM_WRAP_CHECK_1(newmax+1, SV*, oom_array_extend);
 174                 Newx(AvALLOC(av), newmax+1, SV*);
 175                 ary = AvALLOC(av) + 1;
 176                 tmp = newmax;
 177                 AvALLOC(av)[0] = &PL_sv_undef;  /* For the stacks */
 178             }
 179             if (AvREAL(av)) {
 180                 while (tmp)
 181                     ary[--tmp] = &PL_sv_undef;
 182             }
 183
 184             AvARRAY(av) = AvALLOC(av);
 185             AvMAX(av) = newmax;
 186         }
 187     }
 188 }
 189
 190 /*
 191 =for apidoc av_fetch
 192
 193 Returns the SV at the specified index in the array.  The C<key> is the
 194 index.  If C<lval> is set then the fetch will be part of a store.  Check
 195 that the return value is non-null before dereferencing it to a C<SV*>.
 196
 197 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
 198 more information on how to use this function on tied arrays.
 199
 200 =cut
 201 */
 202
 203 SV**
 204 Perl_av_fetch(pTHX_ register AV *av, I32 key, I32 lval)
 205 {
 206     dVAR;
 207
 208     PERL_ARGS_ASSERT_AV_FETCH;
 209     assert(SvTYPE(av) == SVt_PVAV);
 210
 211     if (SvRMAGICAL(av)) {
 212         const MAGIC * const tied_magic
 213             = mg_find((const SV *)av, PERL_MAGIC_tied);
 214         if (tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata)) {
 215             SV *sv;
 216             if (key < 0) {
 217                 I32 adjust_index = 1;
 218                 if (tied_magic) {
 219                     /* Handle negative array indices 20020222 MJD */
 220                     SV * const * const negative_indices_glob =
 221                         hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av),
 222                                                          tied_magic))),
 223                                 NEGATIVE_INDICES_VAR, 16, 0);
 224
 225                     if (negative_indices_glob && SvTRUE(GvSV(*negative_indices_glob)))
 226                         adjust_index = 0;
 227                 }
 228
 229                 if (adjust_index) {
 230                     key += AvFILL(av) + 1;
 231                     if (key < 0)
 232                         return NULL;
 233                 }
 234             }
 235
 236             sv = sv_newmortal();
 237             sv_upgrade(sv, SVt_PVLV);
 238             mg_copy(MUTABLE_SV(av), sv, 0, key);
 239             if (!tied_magic) /* for regdata, force leavesub to make copies */
 240                 SvTEMP_off(sv);
 241             LvTYPE(sv) = 't';
 242             LvTARG(sv) = sv; /* fake (SV**) */
 243             return &(LvTARG(sv));
 244         }
 245     }
 246
 247     if (key < 0) {
 248         key += AvFILL(av) + 1;
 249         if (key < 0)
 250             return NULL;
 251     }
 252
 253     if (key > AvFILLp(av)) {
 254         if (!lval)
 255             return NULL;
 256         return av_store(av,key,newSV(0));
 257     }
 258     if (AvARRAY(av)[key] == &PL_sv_undef) {
 259     emptyness:
 260         if (lval)
 261             return av_store(av,key,newSV(0));
 262         return NULL;
 263     }
 264     else if (AvREIFY(av)
 265              && (!AvARRAY(av)[key]      /* eg. @_ could have freed elts */
 266                  || SvIS_FREED(AvARRAY(av)[key]))) {
 267         AvARRAY(av)[key] = &PL_sv_undef;        /* 1/2 reify */
 268         goto emptyness;
 269     }
 270     return &AvARRAY(av)[key];
 271 }
 272
 273 /*
 274 =for apidoc av_store
 275
 276 Stores an SV in an array.  The array index is specified as C<key>.  The
 277 return value will be NULL if the operation failed or if the value did not
 278 need to be actually stored within the array (as in the case of tied
 279 arrays). Otherwise it can be dereferenced to get the original C<SV*>.  Note
 280 that the caller is responsible for suitably incrementing the reference
 281 count of C<val> before the call, and decrementing it if the function
 282 returned NULL.
 283
 284 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
 285 more information on how to use this function on tied arrays.
 286
 287 =cut
 288 */
 289
 290 SV**
 291 Perl_av_store(pTHX_ register AV *av, I32 key, SV *val)
 292 {
 293     dVAR;
 294     SV** ary;
 295
 296     PERL_ARGS_ASSERT_AV_STORE;
 297     assert(SvTYPE(av) == SVt_PVAV);
 298
 299     /* S_regclass relies on being able to pass in a NULL sv
 300        (unicode_alternate may be NULL).
 301     */
 302
 303     if (!val)
 304         val = &PL_sv_undef;
 305
 306     if (SvRMAGICAL(av)) {
 307         const MAGIC * const tied_magic = mg_find((const SV *)av, PERL_MAGIC_tied);
 308         if (tied_magic) {
 309             /* Handle negative array indices 20020222 MJD */
 310             if (key < 0) {
 311                 bool adjust_index = 1;
 312                 SV * const * const negative_indices_glob =
 313                     hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av),
 314                                                      tied_magic))),
 315                              NEGATIVE_INDICES_VAR, 16, 0);
 316                 if (negative_indices_glob
 317                     && SvTRUE(GvSV(*negative_indices_glob)))
 318                     adjust_index = 0;
 319                 if (adjust_index) {
 320                     key += AvFILL(av) + 1;
 321                     if (key < 0)
 322                         return 0;
 323                 }
 324             }
 325             if (val != &PL_sv_undef) {
 326                 mg_copy(MUTABLE_SV(av), val, 0, key);
 327             }
 328             return NULL;
 329         }
 330     }
 331
 332
 333     if (key < 0) {
 334         key += AvFILL(av) + 1;
 335         if (key < 0)
 336             return NULL;
 337     }
 338
 339     if (SvREADONLY(av) && key >= AvFILL(av))
 340         Perl_croak(aTHX_ "%s", PL_no_modify);
 341
 342     if (!AvREAL(av) && AvREIFY(av))
 343         av_reify(av);
 344     if (key > AvMAX(av))
 345         av_extend(av,key);
 346     ary = AvARRAY(av);
 347     if (AvFILLp(av) < key) {
 348         if (!AvREAL(av)) {
 349             if (av == PL_curstack && key > PL_stack_sp - PL_stack_base)
 350                 PL_stack_sp = PL_stack_base + key;      /* XPUSH in disguise */
 351             do {
 352                 ary[++AvFILLp(av)] = &PL_sv_undef;
 353             } while (AvFILLp(av) < key);
 354         }
 355         AvFILLp(av) = key;
 356     }
 357     else if (AvREAL(av))
 358         SvREFCNT_dec(ary[key]);
 359     ary[key] = val;
 360     if (SvSMAGICAL(av)) {
 361         const MAGIC* const mg = SvMAGIC(av);
 362         if (val != &PL_sv_undef) {
 363             sv_magic(val, MUTABLE_SV(av), toLOWER(mg->mg_type), 0, key);
 364         }
 365         if (PL_delaymagic && mg->mg_type == PERL_MAGIC_isa)
 366             PL_delaymagic |= DM_ARRAY;
 367         else
 368            mg_set(MUTABLE_SV(av));
 369     }
 370     return &ary[key];
 371 }
 372
 373 /*
 374 =for apidoc av_make
 375
 376 Creates a new AV and populates it with a list of SVs.  The SVs are copied
 377 into the array, so they may be freed after the call to av_make.  The new AV
 378 will have a reference count of 1.
 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(aTHX_ "%s", PL_no_modify);
 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;
 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. Like C<av_store>, this takes ownership of one
 530 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(aTHX_ "%s", PL_no_modify);
 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(aTHX_ "%s", PL_no_modify);
 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(aTHX_ "%s", PL_no_modify);
 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(aTHX_ "%s", PL_no_modify);
 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 =cut
 723 */
 724
 725 I32
 726 Perl_av_len(pTHX_ AV *av)
 727 {
 728     PERL_ARGS_ASSERT_AV_LEN;
 729     assert(SvTYPE(av) == SVt_PVAV);
 730
 731     return AvFILL(av);
 732 }
 733
 734 /*
 735 =for apidoc av_fill
 736
 737 Set the highest index in the array to the given number, equivalent to
 738 Perl's C<$#array = $fill;>.
 739
 740 The number of elements in the an array will be C<fill + 1> after
 741 av_fill() returns.  If the array was previously shorter then the
 742 additional elements appended are set to C<PL_sv_undef>.  If the array
 743 was longer, then the excess elements are freed.  C<av_fill(av, -1)> is
 744 the same as C<av_clear(av)>.
 745
 746 =cut
 747 */
 748 void
 749 Perl_av_fill(pTHX_ register AV *av, I32 fill)
 750 {
 751     dVAR;
 752     MAGIC *mg;
 753
 754     PERL_ARGS_ASSERT_AV_FILL;
 755     assert(SvTYPE(av) == SVt_PVAV);
 756
 757     if (fill < 0)
 758         fill = -1;
 759     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
 760         SV *arg1 = sv_newmortal();
 761         sv_setiv(arg1, (IV)(fill + 1));
 762         Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "STORESIZE", G_DISCARD,
 763                             1, arg1);
 764         return;
 765     }
 766     if (fill <= AvMAX(av)) {
 767         I32 key = AvFILLp(av);
 768         SV** const ary = AvARRAY(av);
 769
 770         if (AvREAL(av)) {
 771             while (key > fill) {
 772                 SvREFCNT_dec(ary[key]);
 773                 ary[key--] = &PL_sv_undef;
 774             }
 775         }
 776         else {
 777             while (key < fill)
 778                 ary[++key] = &PL_sv_undef;
 779         }
 780
 781         AvFILLp(av) = fill;
 782         if (SvSMAGICAL(av))
 783             mg_set(MUTABLE_SV(av));
 784     }
 785     else
 786         (void)av_store(av,fill,&PL_sv_undef);
 787 }
 788
 789 /*
 790 =for apidoc av_delete
 791
 792 Deletes the element indexed by C<key> from the array.  Returns the
 793 deleted element. If C<flags> equals C<G_DISCARD>, the element is freed
 794 and null is returned. Perl equivalent: C<my $elem = delete($myarray[$idx]);>
 795 for the non-C<G_DISCARD> version and a void-context C<delete($myarray[$idx]);>
 796 for the C<G_DISCARD> version.
 797
 798 =cut
 799 */
 800 SV *
 801 Perl_av_delete(pTHX_ AV *av, I32 key, I32 flags)
 802 {
 803     dVAR;
 804     SV *sv;
 805
 806     PERL_ARGS_ASSERT_AV_DELETE;
 807     assert(SvTYPE(av) == SVt_PVAV);
 808
 809     if (SvREADONLY(av))
 810         Perl_croak(aTHX_ "%s", PL_no_modify);
 811
 812     if (SvRMAGICAL(av)) {
 813         const MAGIC * const tied_magic
 814             = mg_find((const SV *)av, PERL_MAGIC_tied);
 815         if ((tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata))) {
 816             /* Handle negative array indices 20020222 MJD */
 817             SV **svp;
 818             if (key < 0) {
 819                 unsigned adjust_index = 1;
 820                 if (tied_magic) {
 821                     SV * const * const negative_indices_glob =
 822                         hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av),
 823                                                          tied_magic))),
 824                                  NEGATIVE_INDICES_VAR, 16, 0);
 825                     if (negative_indices_glob
 826                         && SvTRUE(GvSV(*negative_indices_glob)))
 827                         adjust_index = 0;
 828                 }
 829                 if (adjust_index) {
 830                     key += AvFILL(av) + 1;
 831                     if (key < 0)
 832                         return NULL;
 833                 }
 834             }
 835             svp = av_fetch(av, key, TRUE);
 836             if (svp) {
 837                 sv = *svp;
 838                 mg_clear(sv);
 839                 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
 840                     sv_unmagic(sv, PERL_MAGIC_tiedelem); /* No longer an element */
 841                     return sv;
 842                 }
 843                 return NULL;
 844             }
 845         }
 846     }
 847
 848     if (key < 0) {
 849         key += AvFILL(av) + 1;
 850         if (key < 0)
 851             return NULL;
 852     }
 853
 854     if (key > AvFILLp(av))
 855         return NULL;
 856     else {
 857         if (!AvREAL(av) && AvREIFY(av))
 858             av_reify(av);
 859         sv = AvARRAY(av)[key];
 860         if (key == AvFILLp(av)) {
 861             AvARRAY(av)[key] = &PL_sv_undef;
 862             do {
 863                 AvFILLp(av)--;
 864             } while (--key >= 0 && AvARRAY(av)[key] == &PL_sv_undef);
 865         }
 866         else
 867             AvARRAY(av)[key] = &PL_sv_undef;
 868         if (SvSMAGICAL(av))
 869             mg_set(MUTABLE_SV(av));
 870     }
 871     if (flags & G_DISCARD) {
 872         SvREFCNT_dec(sv);
 873         sv = NULL;
 874     }
 875     else if (AvREAL(av))
 876         sv = sv_2mortal(sv);
 877     return sv;
 878 }
 879
 880 /*
 881 =for apidoc av_exists
 882
 883 Returns true if the element indexed by C<key> has been initialized.
 884
 885 This relies on the fact that uninitialized array elements are set to
 886 C<&PL_sv_undef>.
 887
 888 =cut
 889 */
 890 bool
 891 Perl_av_exists(pTHX_ AV *av, I32 key)
 892 {
 893     dVAR;
 894     PERL_ARGS_ASSERT_AV_EXISTS;
 895     assert(SvTYPE(av) == SVt_PVAV);
 896
 897     if (SvRMAGICAL(av)) {
 898         const MAGIC * const tied_magic
 899             = mg_find((const SV *)av, PERL_MAGIC_tied);
 900         if (tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata)) {
 901             SV * const sv = sv_newmortal();
 902             MAGIC *mg;
 903             /* Handle negative array indices 20020222 MJD */
 904             if (key < 0) {
 905                 unsigned adjust_index = 1;
 906                 if (tied_magic) {
 907                     SV * const * const negative_indices_glob =
 908                         hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av),
 909                                                          tied_magic))),
 910                                  NEGATIVE_INDICES_VAR, 16, 0);
 911                     if (negative_indices_glob
 912                         && SvTRUE(GvSV(*negative_indices_glob)))
 913                         adjust_index = 0;
 914                 }
 915                 if (adjust_index) {
 916                     key += AvFILL(av) + 1;
 917                     if (key < 0)
 918                         return FALSE;
 919                 }
 920             }
 921
 922             mg_copy(MUTABLE_SV(av), sv, 0, key);
 923             mg = mg_find(sv, PERL_MAGIC_tiedelem);
 924             if (mg) {
 925                 magic_existspack(sv, mg);
 926                 return cBOOL(SvTRUE(sv));
 927             }
 928
 929         }
 930     }
 931
 932     if (key < 0) {
 933         key += AvFILL(av) + 1;
 934         if (key < 0)
 935             return FALSE;
 936     }
 937
 938     if (key <= AvFILLp(av) && AvARRAY(av)[key] != &PL_sv_undef
 939         && AvARRAY(av)[key])
 940     {
 941         return TRUE;
 942     }
 943     else
 944         return FALSE;
 945 }
 946
 947 static MAGIC *
 948 S_get_aux_mg(pTHX_ AV *av) {
 949     dVAR;
 950     MAGIC *mg;
 951
 952     PERL_ARGS_ASSERT_GET_AUX_MG;
 953     assert(SvTYPE(av) == SVt_PVAV);
 954
 955     mg = mg_find((const SV *)av, PERL_MAGIC_arylen_p);
 956
 957     if (!mg) {
 958         mg = sv_magicext(MUTABLE_SV(av), 0, PERL_MAGIC_arylen_p,
 959                          &PL_vtbl_arylen_p, 0, 0);
 960         assert(mg);
 961         /* sv_magicext won't set this for us because we pass in a NULL obj  */
 962         mg->mg_flags |= MGf_REFCOUNTED;
 963     }
 964     return mg;
 965 }
 966
 967 SV **
 968 Perl_av_arylen_p(pTHX_ AV *av) {
 969     MAGIC *const mg = get_aux_mg(av);
 970
 971     PERL_ARGS_ASSERT_AV_ARYLEN_P;
 972     assert(SvTYPE(av) == SVt_PVAV);
 973
 974     return &(mg->mg_obj);
 975 }
 976
 977 IV *
 978 Perl_av_iter_p(pTHX_ AV *av) {
 979     MAGIC *const mg = get_aux_mg(av);
 980
 981     PERL_ARGS_ASSERT_AV_ITER_P;
 982     assert(SvTYPE(av) == SVt_PVAV);
 983
 984 #if IVSIZE == I32SIZE
 985     return (IV *)&(mg->mg_len);
 986 #else
 987     if (!mg->mg_ptr) {
 988         IV *temp;
 989         mg->mg_len = IVSIZE;
 990         Newxz(temp, 1, IV);
 991         mg->mg_ptr = (char *) temp;
 992     }
 993     return (IV *)mg->mg_ptr;
 994 #endif
 995 }
 996
 997 /*
 998  * Local variables:
 999  * c-indentation-style: bsd
1000  * c-basic-offset: 4
1001  * indent-tabs-mode: t
1002  * End:
1003  *
1004  * ex: set ts=8 sts=4 sw=4 noet:
1005  */