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         dSP;
  78         ENTER;
  79         SAVETMPS;
  80         PUSHSTACKi(PERLSI_MAGIC);
  81         PUSHMARK(SP);
  82         EXTEND(SP,2);
  83         PUSHs(SvTIED_obj(MUTABLE_SV(av), mg));
  84         mPUSHi(key + 1);
  85         PUTBACK;
  86         call_method("EXTEND", G_SCALAR|G_DISCARD);
  87         POPSTACK;
  88         FREETMPS;
  89         LEAVE;
  90         return;
  91     }
  92     if (key > AvMAX(av)) {
  93         SV** ary;
  94         I32 tmp;
  95         I32 newmax;
  96
  97         if (AvALLOC(av) != AvARRAY(av)) {
  98             ary = AvALLOC(av) + AvFILLp(av) + 1;
  99             tmp = AvARRAY(av) - AvALLOC(av);
 100             Move(AvARRAY(av), AvALLOC(av), AvFILLp(av)+1, SV*);
 101             AvMAX(av) += tmp;
 102             AvARRAY(av) = AvALLOC(av);
 103             if (AvREAL(av)) {
 104                 while (tmp)
 105                     ary[--tmp] = &PL_sv_undef;
 106             }
 107             if (key > AvMAX(av) - 10) {
 108                 newmax = key + AvMAX(av);
 109                 goto resize;
 110             }
 111         }
 112         else {
 113 #ifdef PERL_MALLOC_WRAP
 114             static const char oom_array_extend[] =
 115               "Out of memory during array extend"; /* Duplicated in pp_hot.c */
 116 #endif
 117
 118             if (AvALLOC(av)) {
 119 #if !defined(STRANGE_MALLOC) && !defined(MYMALLOC)
 120                 MEM_SIZE bytes;
 121                 IV itmp;
 122 #endif
 123
 124 #ifdef Perl_safesysmalloc_size
 125                 /* Whilst it would be quite possible to move this logic around
 126                    (as I did in the SV code), so as to set AvMAX(av) early,
 127                    based on calling Perl_safesysmalloc_size() immediately after
 128                    allocation, I'm not convinced that it is a great idea here.
 129                    In an array we have to loop round setting everything to
 130                    &PL_sv_undef, which means writing to memory, potentially lots
 131                    of it, whereas for the SV buffer case we don't touch the
 132                    "bonus" memory. So there there is no cost in telling the
 133                    world about it, whereas here we have to do work before we can
 134                    tell the world about it, and that work involves writing to
 135                    memory that might never be read. So, I feel, better to keep
 136                    the current lazy system of only writing to it if our caller
 137                    has a need for more space. NWC  */
 138                 newmax = Perl_safesysmalloc_size((void*)AvALLOC(av)) /
 139                     sizeof(const SV *) - 1;
 140
 141                 if (key <= newmax)
 142                     goto resized;
 143 #endif
 144                 newmax = key + AvMAX(av) / 5;
 145               resize:
 146                 MEM_WRAP_CHECK_1(newmax+1, SV*, oom_array_extend);
 147 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
 148                 Renew(AvALLOC(av),newmax+1, SV*);
 149 #else
 150                 bytes = (newmax + 1) * sizeof(const SV *);
 151 #define MALLOC_OVERHEAD 16
 152                 itmp = MALLOC_OVERHEAD;
 153                 while ((MEM_SIZE)(itmp - MALLOC_OVERHEAD) < bytes)
 154                     itmp += itmp;
 155                 itmp -= MALLOC_OVERHEAD;
 156                 itmp /= sizeof(const SV *);
 157                 assert(itmp > newmax);
 158                 newmax = itmp - 1;
 159                 assert(newmax >= AvMAX(av));
 160                 Newx(ary, newmax+1, SV*);
 161                 Copy(AvALLOC(av), ary, AvMAX(av)+1, SV*);
 162                 if (AvMAX(av) > 64)
 163                     offer_nice_chunk(AvALLOC(av),
 164                                      (AvMAX(av)+1) * sizeof(const SV *));
 165                 else
 166                     Safefree(AvALLOC(av));
 167                 AvALLOC(av) = ary;
 168 #endif
 169 #ifdef Perl_safesysmalloc_size
 170               resized:
 171 #endif
 172                 ary = AvALLOC(av) + AvMAX(av) + 1;
 173                 tmp = newmax - AvMAX(av);
 174                 if (av == PL_curstack) {        /* Oops, grew stack (via av_store()?) */
 175                     PL_stack_sp = AvALLOC(av) + (PL_stack_sp - PL_stack_base);
 176                     PL_stack_base = AvALLOC(av);
 177                     PL_stack_max = PL_stack_base + newmax;
 178                 }
 179             }
 180             else {
 181                 newmax = key < 3 ? 3 : key;
 182                 MEM_WRAP_CHECK_1(newmax+1, SV*, oom_array_extend);
 183                 Newx(AvALLOC(av), newmax+1, SV*);
 184                 ary = AvALLOC(av) + 1;
 185                 tmp = newmax;
 186                 AvALLOC(av)[0] = &PL_sv_undef;  /* For the stacks */
 187             }
 188             if (AvREAL(av)) {
 189                 while (tmp)
 190                     ary[--tmp] = &PL_sv_undef;
 191             }
 192
 193             AvARRAY(av) = AvALLOC(av);
 194             AvMAX(av) = newmax;
 195         }
 196     }
 197 }
 198
 199 /*
 200 =for apidoc av_fetch
 201
 202 Returns the SV at the specified index in the array.  The C<key> is the
 203 index.  If C<lval> is set then the fetch will be part of a store.  Check
 204 that the return value is non-null before dereferencing it to a C<SV*>.
 205
 206 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
 207 more information on how to use this function on tied arrays.
 208
 209 =cut
 210 */
 211
 212 SV**
 213 Perl_av_fetch(pTHX_ register AV *av, I32 key, I32 lval)
 214 {
 215     dVAR;
 216
 217     PERL_ARGS_ASSERT_AV_FETCH;
 218     assert(SvTYPE(av) == SVt_PVAV);
 219
 220     if (SvRMAGICAL(av)) {
 221         const MAGIC * const tied_magic
 222             = mg_find((const SV *)av, PERL_MAGIC_tied);
 223         if (tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata)) {
 224             SV *sv;
 225             if (key < 0) {
 226                 I32 adjust_index = 1;
 227                 if (tied_magic) {
 228                     /* Handle negative array indices 20020222 MJD */
 229                     SV * const * const negative_indices_glob =
 230                         hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av),
 231                                                          tied_magic))),
 232                                 NEGATIVE_INDICES_VAR, 16, 0);
 233
 234                     if (negative_indices_glob && SvTRUE(GvSV(*negative_indices_glob)))
 235                         adjust_index = 0;
 236                 }
 237
 238                 if (adjust_index) {
 239                     key += AvFILL(av) + 1;
 240                     if (key < 0)
 241                         return NULL;
 242                 }
 243             }
 244
 245             sv = sv_newmortal();
 246             sv_upgrade(sv, SVt_PVLV);
 247             mg_copy(MUTABLE_SV(av), sv, 0, key);
 248             if (!tied_magic) /* for regdata, force leavesub to make copies */
 249                 SvTEMP_off(sv);
 250             LvTYPE(sv) = 't';
 251             LvTARG(sv) = sv; /* fake (SV**) */
 252             return &(LvTARG(sv));
 253         }
 254     }
 255
 256     if (key < 0) {
 257         key += AvFILL(av) + 1;
 258         if (key < 0)
 259             return NULL;
 260     }
 261
 262     if (key > AvFILLp(av)) {
 263         if (!lval)
 264             return NULL;
 265         return av_store(av,key,newSV(0));
 266     }
 267     if (AvARRAY(av)[key] == &PL_sv_undef) {
 268     emptyness:
 269         if (lval)
 270             return av_store(av,key,newSV(0));
 271         return NULL;
 272     }
 273     else if (AvREIFY(av)
 274              && (!AvARRAY(av)[key]      /* eg. @_ could have freed elts */
 275                  || SvIS_FREED(AvARRAY(av)[key]))) {
 276         AvARRAY(av)[key] = &PL_sv_undef;        /* 1/2 reify */
 277         goto emptyness;
 278     }
 279     return &AvARRAY(av)[key];
 280 }
 281
 282 /*
 283 =for apidoc av_store
 284
 285 Stores an SV in an array.  The array index is specified as C<key>.  The
 286 return value will be NULL if the operation failed or if the value did not
 287 need to be actually stored within the array (as in the case of tied
 288 arrays). Otherwise it can be dereferenced to get the original C<SV*>.  Note
 289 that the caller is responsible for suitably incrementing the reference
 290 count of C<val> before the call, and decrementing it if the function
 291 returned NULL.
 292
 293 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
 294 more information on how to use this function on tied arrays.
 295
 296 =cut
 297 */
 298
 299 SV**
 300 Perl_av_store(pTHX_ register AV *av, I32 key, SV *val)
 301 {
 302     dVAR;
 303     SV** ary;
 304
 305     PERL_ARGS_ASSERT_AV_STORE;
 306     assert(SvTYPE(av) == SVt_PVAV);
 307
 308     /* S_regclass relies on being able to pass in a NULL sv
 309        (unicode_alternate may be NULL).
 310     */
 311
 312     if (!val)
 313         val = &PL_sv_undef;
 314
 315     if (SvRMAGICAL(av)) {
 316         const MAGIC * const tied_magic = mg_find((const SV *)av, PERL_MAGIC_tied);
 317         if (tied_magic) {
 318             /* Handle negative array indices 20020222 MJD */
 319             if (key < 0) {
 320                 bool adjust_index = 1;
 321                 SV * const * const negative_indices_glob =
 322                     hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av),
 323                                                      tied_magic))),
 324                              NEGATIVE_INDICES_VAR, 16, 0);
 325                 if (negative_indices_glob
 326                     && SvTRUE(GvSV(*negative_indices_glob)))
 327                     adjust_index = 0;
 328                 if (adjust_index) {
 329                     key += AvFILL(av) + 1;
 330                     if (key < 0)
 331                         return 0;
 332                 }
 333             }
 334             if (val != &PL_sv_undef) {
 335                 mg_copy(MUTABLE_SV(av), val, 0, key);
 336             }
 337             return NULL;
 338         }
 339     }
 340
 341
 342     if (key < 0) {
 343         key += AvFILL(av) + 1;
 344         if (key < 0)
 345             return NULL;
 346     }
 347
 348     if (SvREADONLY(av) && key >= AvFILL(av))
 349         Perl_croak(aTHX_ "%s", PL_no_modify);
 350
 351     if (!AvREAL(av) && AvREIFY(av))
 352         av_reify(av);
 353     if (key > AvMAX(av))
 354         av_extend(av,key);
 355     ary = AvARRAY(av);
 356     if (AvFILLp(av) < key) {
 357         if (!AvREAL(av)) {
 358             if (av == PL_curstack && key > PL_stack_sp - PL_stack_base)
 359                 PL_stack_sp = PL_stack_base + key;      /* XPUSH in disguise */
 360             do {
 361                 ary[++AvFILLp(av)] = &PL_sv_undef;
 362             } while (AvFILLp(av) < key);
 363         }
 364         AvFILLp(av) = key;
 365     }
 366     else if (AvREAL(av))
 367         SvREFCNT_dec(ary[key]);
 368     ary[key] = val;
 369     if (SvSMAGICAL(av)) {
 370         const MAGIC* const mg = SvMAGIC(av);
 371         if (val != &PL_sv_undef) {
 372             sv_magic(val, MUTABLE_SV(av), toLOWER(mg->mg_type), 0, key);
 373         }
 374         if (PL_delaymagic && mg->mg_type == PERL_MAGIC_isa)
 375             PL_delaymagic |= DM_ARRAY;
 376         else
 377            mg_set(MUTABLE_SV(av));
 378     }
 379     return &ary[key];
 380 }
 381
 382 /*
 383 =for apidoc av_make
 384
 385 Creates a new AV and populates it with a list of SVs.  The SVs are copied
 386 into the array, so they may be freed after the call to av_make.  The new AV
 387 will have a reference count of 1.
 388
 389 =cut
 390 */
 391
 392 AV *
 393 Perl_av_make(pTHX_ register I32 size, register SV **strp)
 394 {
 395     register AV * const av = MUTABLE_AV(newSV_type(SVt_PVAV));
 396     /* sv_upgrade does AvREAL_only()  */
 397     PERL_ARGS_ASSERT_AV_MAKE;
 398     assert(SvTYPE(av) == SVt_PVAV);
 399
 400     if (size) {         /* "defined" was returning undef for size==0 anyway. */
 401         register SV** ary;
 402         register I32 i;
 403         Newx(ary,size,SV*);
 404         AvALLOC(av) = ary;
 405         AvARRAY(av) = ary;
 406         AvFILLp(av) = AvMAX(av) = size - 1;
 407         for (i = 0; i < size; i++) {
 408             assert (*strp);
 409
 410             /* Don't let sv_setsv swipe, since our source array might
 411                have multiple references to the same temp scalar (e.g.
 412                from a list slice) */
 413
 414             ary[i] = newSV(0);
 415             sv_setsv_flags(ary[i], *strp,
 416                            SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
 417             strp++;
 418         }
 419     }
 420     return av;
 421 }
 422
 423 /*
 424 =for apidoc av_clear
 425
 426 Clears an array, making it empty.  Does not free the memory used by the
 427 array itself.
 428
 429 =cut
 430 */
 431
 432 void
 433 Perl_av_clear(pTHX_ register AV *av)
 434 {
 435     dVAR;
 436     I32 extra;
 437
 438     PERL_ARGS_ASSERT_AV_CLEAR;
 439     assert(SvTYPE(av) == SVt_PVAV);
 440
 441 #ifdef DEBUGGING
 442     if (SvREFCNT(av) == 0) {
 443         Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "Attempt to clear deleted array");
 444     }
 445 #endif
 446
 447     if (SvREADONLY(av))
 448         Perl_croak(aTHX_ "%s", PL_no_modify);
 449
 450     /* Give any tie a chance to cleanup first */
 451     if (SvRMAGICAL(av)) {
 452         const MAGIC* const mg = SvMAGIC(av);
 453         if (PL_delaymagic && mg && mg->mg_type == PERL_MAGIC_isa)
 454             PL_delaymagic |= DM_ARRAY;
 455         else
 456             mg_clear(MUTABLE_SV(av));
 457     }
 458
 459     if (AvMAX(av) < 0)
 460         return;
 461
 462     if (AvREAL(av)) {
 463         SV** const ary = AvARRAY(av);
 464         I32 index = AvFILLp(av) + 1;
 465         while (index) {
 466             SV * const sv = ary[--index];
 467             /* undef the slot before freeing the value, because a
 468              * destructor might try to modify this array */
 469             ary[index] = &PL_sv_undef;
 470             SvREFCNT_dec(sv);
 471         }
 472     }
 473     extra = AvARRAY(av) - AvALLOC(av);
 474     if (extra) {
 475         AvMAX(av) += extra;
 476         AvARRAY(av) = AvALLOC(av);
 477     }
 478     AvFILLp(av) = -1;
 479
 480 }
 481
 482 /*
 483 =for apidoc av_undef
 484
 485 Undefines the array.  Frees the memory used by the array itself.
 486
 487 =cut
 488 */
 489
 490 void
 491 Perl_av_undef(pTHX_ register AV *av)
 492 {
 493     PERL_ARGS_ASSERT_AV_UNDEF;
 494     assert(SvTYPE(av) == SVt_PVAV);
 495
 496     /* Give any tie a chance to cleanup first */
 497     if (SvTIED_mg((const SV *)av, PERL_MAGIC_tied))
 498         av_fill(av, -1);
 499
 500     if (AvREAL(av)) {
 501         register I32 key = AvFILLp(av) + 1;
 502         while (key)
 503             SvREFCNT_dec(AvARRAY(av)[--key]);
 504     }
 505
 506     Safefree(AvALLOC(av));
 507     AvALLOC(av) = NULL;
 508     AvARRAY(av) = NULL;
 509     AvMAX(av) = AvFILLp(av) = -1;
 510
 511     if(SvRMAGICAL(av)) mg_clear(MUTABLE_SV(av));
 512 }
 513
 514 /*
 515
 516 =for apidoc av_create_and_push
 517
 518 Push an SV onto the end of the array, creating the array if necessary.
 519 A small internal helper function to remove a commonly duplicated idiom.
 520
 521 =cut
 522 */
 523
 524 void
 525 Perl_av_create_and_push(pTHX_ AV **const avp, SV *const val)
 526 {
 527     PERL_ARGS_ASSERT_AV_CREATE_AND_PUSH;
 528
 529     if (!*avp)
 530         *avp = newAV();
 531     av_push(*avp, val);
 532 }
 533
 534 /*
 535 =for apidoc av_push
 536
 537 Pushes an SV onto the end of the array.  The array will grow automatically
 538 to accommodate the addition. Like C<av_store>, this takes ownership of one
 539 reference count.
 540
 541 =cut
 542 */
 543
 544 void
 545 Perl_av_push(pTHX_ register AV *av, SV *val)
 546 {
 547     dVAR;
 548     MAGIC *mg;
 549
 550     PERL_ARGS_ASSERT_AV_PUSH;
 551     assert(SvTYPE(av) == SVt_PVAV);
 552
 553     if (SvREADONLY(av))
 554         Perl_croak(aTHX_ "%s", PL_no_modify);
 555
 556     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
 557         dSP;
 558         PUSHSTACKi(PERLSI_MAGIC);
 559         PUSHMARK(SP);
 560         EXTEND(SP,2);
 561         PUSHs(SvTIED_obj(MUTABLE_SV(av), mg));
 562         PUSHs(val);
 563         PUTBACK;
 564         ENTER;
 565         call_method("PUSH", G_SCALAR|G_DISCARD);
 566         LEAVE;
 567         POPSTACK;
 568         return;
 569     }
 570     av_store(av,AvFILLp(av)+1,val);
 571 }
 572
 573 /*
 574 =for apidoc av_pop
 575
 576 Pops an SV off the end of the array.  Returns C<&PL_sv_undef> if the array
 577 is empty.
 578
 579 =cut
 580 */
 581
 582 SV *
 583 Perl_av_pop(pTHX_ register AV *av)
 584 {
 585     dVAR;
 586     SV *retval;
 587     MAGIC* mg;
 588
 589     PERL_ARGS_ASSERT_AV_POP;
 590     assert(SvTYPE(av) == SVt_PVAV);
 591
 592     if (SvREADONLY(av))
 593         Perl_croak(aTHX_ "%s", PL_no_modify);
 594     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
 595         dSP;
 596         PUSHSTACKi(PERLSI_MAGIC);
 597         PUSHMARK(SP);
 598         XPUSHs(SvTIED_obj(MUTABLE_SV(av), mg));
 599         PUTBACK;
 600         ENTER;
 601         if (call_method("POP", G_SCALAR)) {
 602             retval = newSVsv(*PL_stack_sp--);
 603         } else {
 604             retval = &PL_sv_undef;
 605         }
 606         LEAVE;
 607         POPSTACK;
 608         return retval;
 609     }
 610     if (AvFILL(av) < 0)
 611         return &PL_sv_undef;
 612     retval = AvARRAY(av)[AvFILLp(av)];
 613     AvARRAY(av)[AvFILLp(av)--] = &PL_sv_undef;
 614     if (SvSMAGICAL(av))
 615         mg_set(MUTABLE_SV(av));
 616     return retval;
 617 }
 618
 619 /*
 620
 621 =for apidoc av_create_and_unshift_one
 622
 623 Unshifts an SV onto the beginning of the array, creating the array if
 624 necessary.
 625 A small internal helper function to remove a commonly duplicated idiom.
 626
 627 =cut
 628 */
 629
 630 SV **
 631 Perl_av_create_and_unshift_one(pTHX_ AV **const avp, SV *const val)
 632 {
 633     PERL_ARGS_ASSERT_AV_CREATE_AND_UNSHIFT_ONE;
 634
 635     if (!*avp)
 636         *avp = newAV();
 637     av_unshift(*avp, 1);
 638     return av_store(*avp, 0, val);
 639 }
 640
 641 /*
 642 =for apidoc av_unshift
 643
 644 Unshift the given number of C<undef> values onto the beginning of the
 645 array.  The array will grow automatically to accommodate the addition.  You
 646 must then use C<av_store> to assign values to these new elements.
 647
 648 =cut
 649 */
 650
 651 void
 652 Perl_av_unshift(pTHX_ register AV *av, register I32 num)
 653 {
 654     dVAR;
 655     register I32 i;
 656     MAGIC* mg;
 657
 658     PERL_ARGS_ASSERT_AV_UNSHIFT;
 659     assert(SvTYPE(av) == SVt_PVAV);
 660
 661     if (SvREADONLY(av))
 662         Perl_croak(aTHX_ "%s", PL_no_modify);
 663
 664     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
 665         dSP;
 666         PUSHSTACKi(PERLSI_MAGIC);
 667         PUSHMARK(SP);
 668         EXTEND(SP,1+num);
 669         PUSHs(SvTIED_obj(MUTABLE_SV(av), mg));
 670         while (num-- > 0) {
 671             PUSHs(&PL_sv_undef);
 672         }
 673         PUTBACK;
 674         ENTER;
 675         call_method("UNSHIFT", G_SCALAR|G_DISCARD);
 676         LEAVE;
 677         POPSTACK;
 678         return;
 679     }
 680
 681     if (num <= 0)
 682       return;
 683     if (!AvREAL(av) && AvREIFY(av))
 684         av_reify(av);
 685     i = AvARRAY(av) - AvALLOC(av);
 686     if (i) {
 687         if (i > num)
 688             i = num;
 689         num -= i;
 690
 691         AvMAX(av) += i;
 692         AvFILLp(av) += i;
 693         AvARRAY(av) = AvARRAY(av) - i;
 694     }
 695     if (num) {
 696         register SV **ary;
 697         const I32 i = AvFILLp(av);
 698         /* Create extra elements */
 699         const I32 slide = i > 0 ? i : 0;
 700         num += slide;
 701         av_extend(av, i + num);
 702         AvFILLp(av) += num;
 703         ary = AvARRAY(av);
 704         Move(ary, ary + num, i + 1, SV*);
 705         do {
 706             ary[--num] = &PL_sv_undef;
 707         } while (num);
 708         /* Make extra elements into a buffer */
 709         AvMAX(av) -= slide;
 710         AvFILLp(av) -= slide;
 711         AvARRAY(av) = AvARRAY(av) + slide;
 712     }
 713 }
 714
 715 /*
 716 =for apidoc av_shift
 717
 718 Shifts an SV off the beginning of the array. Returns C<&PL_sv_undef> if the
 719 array is empty.
 720
 721 =cut
 722 */
 723
 724 SV *
 725 Perl_av_shift(pTHX_ register AV *av)
 726 {
 727     dVAR;
 728     SV *retval;
 729     MAGIC* mg;
 730
 731     PERL_ARGS_ASSERT_AV_SHIFT;
 732     assert(SvTYPE(av) == SVt_PVAV);
 733
 734     if (SvREADONLY(av))
 735         Perl_croak(aTHX_ "%s", PL_no_modify);
 736     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
 737         dSP;
 738         PUSHSTACKi(PERLSI_MAGIC);
 739         PUSHMARK(SP);
 740         XPUSHs(SvTIED_obj(MUTABLE_SV(av), mg));
 741         PUTBACK;
 742         ENTER;
 743         if (call_method("SHIFT", G_SCALAR)) {
 744             retval = newSVsv(*PL_stack_sp--);
 745         } else {
 746             retval = &PL_sv_undef;
 747         }
 748         LEAVE;
 749         POPSTACK;
 750         return retval;
 751     }
 752     if (AvFILL(av) < 0)
 753       return &PL_sv_undef;
 754     retval = *AvARRAY(av);
 755     if (AvREAL(av))
 756         *AvARRAY(av) = &PL_sv_undef;
 757     AvARRAY(av) = AvARRAY(av) + 1;
 758     AvMAX(av)--;
 759     AvFILLp(av)--;
 760     if (SvSMAGICAL(av))
 761         mg_set(MUTABLE_SV(av));
 762     return retval;
 763 }
 764
 765 /*
 766 =for apidoc av_len
 767
 768 Returns the highest index in the array.  The number of elements in the
 769 array is C<av_len(av) + 1>.  Returns -1 if the array is empty.
 770
 771 =cut
 772 */
 773
 774 I32
 775 Perl_av_len(pTHX_ AV *av)
 776 {
 777     PERL_ARGS_ASSERT_AV_LEN;
 778     assert(SvTYPE(av) == SVt_PVAV);
 779
 780     return AvFILL(av);
 781 }
 782
 783 /*
 784 =for apidoc av_fill
 785
 786 Set the highest index in the array to the given number, equivalent to
 787 Perl's C<$#array = $fill;>.
 788
 789 The number of elements in the an array will be C<fill + 1> after
 790 av_fill() returns.  If the array was previously shorter then the
 791 additional elements appended are set to C<PL_sv_undef>.  If the array
 792 was longer, then the excess elements are freed.  C<av_fill(av, -1)> is
 793 the same as C<av_clear(av)>.
 794
 795 =cut
 796 */
 797 void
 798 Perl_av_fill(pTHX_ register AV *av, I32 fill)
 799 {
 800     dVAR;
 801     MAGIC *mg;
 802
 803     PERL_ARGS_ASSERT_AV_FILL;
 804     assert(SvTYPE(av) == SVt_PVAV);
 805
 806     if (fill < 0)
 807         fill = -1;
 808     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
 809         dSP;
 810         ENTER;
 811         SAVETMPS;
 812         PUSHSTACKi(PERLSI_MAGIC);
 813         PUSHMARK(SP);
 814         EXTEND(SP,2);
 815         PUSHs(SvTIED_obj(MUTABLE_SV(av), mg));
 816         mPUSHi(fill + 1);
 817         PUTBACK;
 818         call_method("STORESIZE", G_SCALAR|G_DISCARD);
 819         POPSTACK;
 820         FREETMPS;
 821         LEAVE;
 822         return;
 823     }
 824     if (fill <= AvMAX(av)) {
 825         I32 key = AvFILLp(av);
 826         SV** const ary = AvARRAY(av);
 827
 828         if (AvREAL(av)) {
 829             while (key > fill) {
 830                 SvREFCNT_dec(ary[key]);
 831                 ary[key--] = &PL_sv_undef;
 832             }
 833         }
 834         else {
 835             while (key < fill)
 836                 ary[++key] = &PL_sv_undef;
 837         }
 838
 839         AvFILLp(av) = fill;
 840         if (SvSMAGICAL(av))
 841             mg_set(MUTABLE_SV(av));
 842     }
 843     else
 844         (void)av_store(av,fill,&PL_sv_undef);
 845 }
 846
 847 /*
 848 =for apidoc av_delete
 849
 850 Deletes the element indexed by C<key> from the array.  Returns the
 851 deleted element. If C<flags> equals C<G_DISCARD>, the element is freed
 852 and null is returned.
 853
 854 =cut
 855 */
 856 SV *
 857 Perl_av_delete(pTHX_ AV *av, I32 key, I32 flags)
 858 {
 859     dVAR;
 860     SV *sv;
 861
 862     PERL_ARGS_ASSERT_AV_DELETE;
 863     assert(SvTYPE(av) == SVt_PVAV);
 864
 865     if (SvREADONLY(av))
 866         Perl_croak(aTHX_ "%s", PL_no_modify);
 867
 868     if (SvRMAGICAL(av)) {
 869         const MAGIC * const tied_magic
 870             = mg_find((const SV *)av, PERL_MAGIC_tied);
 871         if ((tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata))) {
 872             /* Handle negative array indices 20020222 MJD */
 873             SV **svp;
 874             if (key < 0) {
 875                 unsigned adjust_index = 1;
 876                 if (tied_magic) {
 877                     SV * const * const negative_indices_glob =
 878                         hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av),
 879                                                          tied_magic))),
 880                                  NEGATIVE_INDICES_VAR, 16, 0);
 881                     if (negative_indices_glob
 882                         && SvTRUE(GvSV(*negative_indices_glob)))
 883                         adjust_index = 0;
 884                 }
 885                 if (adjust_index) {
 886                     key += AvFILL(av) + 1;
 887                     if (key < 0)
 888                         return NULL;
 889                 }
 890             }
 891             svp = av_fetch(av, key, TRUE);
 892             if (svp) {
 893                 sv = *svp;
 894                 mg_clear(sv);
 895                 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
 896                     sv_unmagic(sv, PERL_MAGIC_tiedelem); /* No longer an element */
 897                     return sv;
 898                 }
 899                 return NULL;
 900             }
 901         }
 902     }
 903
 904     if (key < 0) {
 905         key += AvFILL(av) + 1;
 906         if (key < 0)
 907             return NULL;
 908     }
 909
 910     if (key > AvFILLp(av))
 911         return NULL;
 912     else {
 913         if (!AvREAL(av) && AvREIFY(av))
 914             av_reify(av);
 915         sv = AvARRAY(av)[key];
 916         if (key == AvFILLp(av)) {
 917             AvARRAY(av)[key] = &PL_sv_undef;
 918             do {
 919                 AvFILLp(av)--;
 920             } while (--key >= 0 && AvARRAY(av)[key] == &PL_sv_undef);
 921         }
 922         else
 923             AvARRAY(av)[key] = &PL_sv_undef;
 924         if (SvSMAGICAL(av))
 925             mg_set(MUTABLE_SV(av));
 926     }
 927     if (flags & G_DISCARD) {
 928         SvREFCNT_dec(sv);
 929         sv = NULL;
 930     }
 931     else if (AvREAL(av))
 932         sv = sv_2mortal(sv);
 933     return sv;
 934 }
 935
 936 /*
 937 =for apidoc av_exists
 938
 939 Returns true if the element indexed by C<key> has been initialized.
 940
 941 This relies on the fact that uninitialized array elements are set to
 942 C<&PL_sv_undef>.
 943
 944 =cut
 945 */
 946 bool
 947 Perl_av_exists(pTHX_ AV *av, I32 key)
 948 {
 949     dVAR;
 950     PERL_ARGS_ASSERT_AV_EXISTS;
 951     assert(SvTYPE(av) == SVt_PVAV);
 952
 953     if (SvRMAGICAL(av)) {
 954         const MAGIC * const tied_magic
 955             = mg_find((const SV *)av, PERL_MAGIC_tied);
 956         if (tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata)) {
 957             SV * const sv = sv_newmortal();
 958             MAGIC *mg;
 959             /* Handle negative array indices 20020222 MJD */
 960             if (key < 0) {
 961                 unsigned adjust_index = 1;
 962                 if (tied_magic) {
 963                     SV * const * const negative_indices_glob =
 964                         hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av),
 965                                                          tied_magic))),
 966                                  NEGATIVE_INDICES_VAR, 16, 0);
 967                     if (negative_indices_glob
 968                         && SvTRUE(GvSV(*negative_indices_glob)))
 969                         adjust_index = 0;
 970                 }
 971                 if (adjust_index) {
 972                     key += AvFILL(av) + 1;
 973                     if (key < 0)
 974                         return FALSE;
 975                 }
 976             }
 977
 978             mg_copy(MUTABLE_SV(av), sv, 0, key);
 979             mg = mg_find(sv, PERL_MAGIC_tiedelem);
 980             if (mg) {
 981                 magic_existspack(sv, mg);
 982                 return cBOOL(SvTRUE(sv));
 983             }
 984
 985         }
 986     }
 987
 988     if (key < 0) {
 989         key += AvFILL(av) + 1;
 990         if (key < 0)
 991             return FALSE;
 992     }
 993
 994     if (key <= AvFILLp(av) && AvARRAY(av)[key] != &PL_sv_undef
 995         && AvARRAY(av)[key])
 996     {
 997         return TRUE;
 998     }
 999     else
1000         return FALSE;
1001 }
1002
1003 static MAGIC *
1004 S_get_aux_mg(pTHX_ AV *av) {
1005     dVAR;
1006     MAGIC *mg;
1007
1008     PERL_ARGS_ASSERT_GET_AUX_MG;
1009     assert(SvTYPE(av) == SVt_PVAV);
1010
1011     mg = mg_find((const SV *)av, PERL_MAGIC_arylen_p);
1012
1013     if (!mg) {
1014         mg = sv_magicext(MUTABLE_SV(av), 0, PERL_MAGIC_arylen_p,
1015                          &PL_vtbl_arylen_p, 0, 0);
1016         assert(mg);
1017         /* sv_magicext won't set this for us because we pass in a NULL obj  */
1018         mg->mg_flags |= MGf_REFCOUNTED;
1019     }
1020     return mg;
1021 }
1022
1023 SV **
1024 Perl_av_arylen_p(pTHX_ AV *av) {
1025     MAGIC *const mg = get_aux_mg(av);
1026
1027     PERL_ARGS_ASSERT_AV_ARYLEN_P;
1028     assert(SvTYPE(av) == SVt_PVAV);
1029
1030     return &(mg->mg_obj);
1031 }
1032
1033 IV *
1034 Perl_av_iter_p(pTHX_ AV *av) {
1035     MAGIC *const mg = get_aux_mg(av);
1036
1037     PERL_ARGS_ASSERT_AV_ITER_P;
1038     assert(SvTYPE(av) == SVt_PVAV);
1039
1040 #if IVSIZE == I32SIZE
1041     return (IV *)&(mg->mg_len);
1042 #else
1043     if (!mg->mg_ptr) {
1044         IV *temp;
1045         mg->mg_len = IVSIZE;
1046         Newxz(temp, 1, IV);
1047         mg->mg_ptr = (char *) temp;
1048     }
1049     return (IV *)mg->mg_ptr;
1050 #endif
1051 }
1052
1053 /*
1054  * Local variables:
1055  * c-indentation-style: bsd
1056  * c-basic-offset: 4
1057  * indent-tabs-mode: t
1058  * End:
1059  *
1060  * ex: set ts=8 sts=4 sw=4 noet:
1061  */