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