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             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
 408             /* Don't let sv_setsv swipe, since our source array might
 409                have multiple references to the same temp scalar (e.g.
 410                from a list slice) */
 411
 412             ary[i] = newSV(0);
 413             sv_setsv_flags(ary[i], *strp,
 414                            SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
 415             strp++;
 416         }
 417     }
 418     return av;
 419 }
 420
 421 /*
 422 =for apidoc av_clear
 423
 424 Clears an array, making it empty.  Does not free the memory used by the
 425 array itself.
 426
 427 =cut
 428 */
 429
 430 void
 431 Perl_av_clear(pTHX_ register AV *av)
 432 {
 433     dVAR;
 434     I32 extra;
 435
 436     PERL_ARGS_ASSERT_AV_CLEAR;
 437     assert(SvTYPE(av) == SVt_PVAV);
 438
 439 #ifdef DEBUGGING
 440     if (SvREFCNT(av) == 0) {
 441         Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "Attempt to clear deleted array");
 442     }
 443 #endif
 444
 445     if (SvREADONLY(av))
 446         Perl_croak(aTHX_ "%s", PL_no_modify);
 447
 448     /* Give any tie a chance to cleanup first */
 449     if (SvRMAGICAL(av)) {
 450         const MAGIC* const mg = SvMAGIC(av);
 451         if (PL_delaymagic && mg && mg->mg_type == PERL_MAGIC_isa)
 452             PL_delaymagic |= DM_ARRAY;
 453         else
 454             mg_clear(MUTABLE_SV(av));
 455     }
 456
 457     if (AvMAX(av) < 0)
 458         return;
 459
 460     if (AvREAL(av)) {
 461         SV** const ary = AvARRAY(av);
 462         I32 index = AvFILLp(av) + 1;
 463         while (index) {
 464             SV * const sv = ary[--index];
 465             /* undef the slot before freeing the value, because a
 466              * destructor might try to modify this array */
 467             ary[index] = &PL_sv_undef;
 468             SvREFCNT_dec(sv);
 469         }
 470     }
 471     extra = AvARRAY(av) - AvALLOC(av);
 472     if (extra) {
 473         AvMAX(av) += extra;
 474         AvARRAY(av) = AvALLOC(av);
 475     }
 476     AvFILLp(av) = -1;
 477
 478 }
 479
 480 /*
 481 =for apidoc av_undef
 482
 483 Undefines the array.  Frees the memory used by the array itself.
 484
 485 =cut
 486 */
 487
 488 void
 489 Perl_av_undef(pTHX_ register AV *av)
 490 {
 491     PERL_ARGS_ASSERT_AV_UNDEF;
 492     assert(SvTYPE(av) == SVt_PVAV);
 493
 494     /* Give any tie a chance to cleanup first */
 495     if (SvTIED_mg((const SV *)av, PERL_MAGIC_tied))
 496         av_fill(av, -1);
 497
 498     if (AvREAL(av)) {
 499         register I32 key = AvFILLp(av) + 1;
 500         while (key)
 501             SvREFCNT_dec(AvARRAY(av)[--key]);
 502     }
 503
 504     Safefree(AvALLOC(av));
 505     AvALLOC(av) = NULL;
 506     AvARRAY(av) = NULL;
 507     AvMAX(av) = AvFILLp(av) = -1;
 508
 509     if(SvRMAGICAL(av)) mg_clear(MUTABLE_SV(av));
 510 }
 511
 512 /*
 513
 514 =for apidoc av_create_and_push
 515
 516 Push an SV onto the end of the array, creating the array if necessary.
 517 A small internal helper function to remove a commonly duplicated idiom.
 518
 519 =cut
 520 */
 521
 522 void
 523 Perl_av_create_and_push(pTHX_ AV **const avp, SV *const val)
 524 {
 525     PERL_ARGS_ASSERT_AV_CREATE_AND_PUSH;
 526
 527     if (!*avp)
 528         *avp = newAV();
 529     av_push(*avp, val);
 530 }
 531
 532 /*
 533 =for apidoc av_push
 534
 535 Pushes an SV onto the end of the array.  The array will grow automatically
 536 to accommodate the addition. Like C<av_store>, this takes ownership of one
 537 reference count.
 538
 539 =cut
 540 */
 541
 542 void
 543 Perl_av_push(pTHX_ register AV *av, SV *val)
 544 {
 545     dVAR;
 546     MAGIC *mg;
 547
 548     PERL_ARGS_ASSERT_AV_PUSH;
 549     assert(SvTYPE(av) == SVt_PVAV);
 550
 551     if (SvREADONLY(av))
 552         Perl_croak(aTHX_ "%s", PL_no_modify);
 553
 554     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
 555         dSP;
 556         PUSHSTACKi(PERLSI_MAGIC);
 557         PUSHMARK(SP);
 558         EXTEND(SP,2);
 559         PUSHs(SvTIED_obj(MUTABLE_SV(av), mg));
 560         PUSHs(val);
 561         PUTBACK;
 562         ENTER;
 563         call_method("PUSH", G_SCALAR|G_DISCARD);
 564         LEAVE;
 565         POPSTACK;
 566         return;
 567     }
 568     av_store(av,AvFILLp(av)+1,val);
 569 }
 570
 571 /*
 572 =for apidoc av_pop
 573
 574 Pops an SV off the end of the array.  Returns C<&PL_sv_undef> if the array
 575 is empty.
 576
 577 =cut
 578 */
 579
 580 SV *
 581 Perl_av_pop(pTHX_ register AV *av)
 582 {
 583     dVAR;
 584     SV *retval;
 585     MAGIC* mg;
 586
 587     PERL_ARGS_ASSERT_AV_POP;
 588     assert(SvTYPE(av) == SVt_PVAV);
 589
 590     if (SvREADONLY(av))
 591         Perl_croak(aTHX_ "%s", PL_no_modify);
 592     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
 593         dSP;
 594         PUSHSTACKi(PERLSI_MAGIC);
 595         PUSHMARK(SP);
 596         XPUSHs(SvTIED_obj(MUTABLE_SV(av), mg));
 597         PUTBACK;
 598         ENTER;
 599         if (call_method("POP", G_SCALAR)) {
 600             retval = newSVsv(*PL_stack_sp--);
 601         } else {
 602             retval = &PL_sv_undef;
 603         }
 604         LEAVE;
 605         POPSTACK;
 606         return retval;
 607     }
 608     if (AvFILL(av) < 0)
 609         return &PL_sv_undef;
 610     retval = AvARRAY(av)[AvFILLp(av)];
 611     AvARRAY(av)[AvFILLp(av)--] = &PL_sv_undef;
 612     if (SvSMAGICAL(av))
 613         mg_set(MUTABLE_SV(av));
 614     return retval;
 615 }
 616
 617 /*
 618
 619 =for apidoc av_create_and_unshift_one
 620
 621 Unshifts an SV onto the beginning of the array, creating the array if
 622 necessary.
 623 A small internal helper function to remove a commonly duplicated idiom.
 624
 625 =cut
 626 */
 627
 628 SV **
 629 Perl_av_create_and_unshift_one(pTHX_ AV **const avp, SV *const val)
 630 {
 631     PERL_ARGS_ASSERT_AV_CREATE_AND_UNSHIFT_ONE;
 632
 633     if (!*avp)
 634         *avp = newAV();
 635     av_unshift(*avp, 1);
 636     return av_store(*avp, 0, val);
 637 }
 638
 639 /*
 640 =for apidoc av_unshift
 641
 642 Unshift the given number of C<undef> values onto the beginning of the
 643 array.  The array will grow automatically to accommodate the addition.  You
 644 must then use C<av_store> to assign values to these new elements.
 645
 646 =cut
 647 */
 648
 649 void
 650 Perl_av_unshift(pTHX_ register AV *av, register I32 num)
 651 {
 652     dVAR;
 653     register I32 i;
 654     MAGIC* mg;
 655
 656     PERL_ARGS_ASSERT_AV_UNSHIFT;
 657     assert(SvTYPE(av) == SVt_PVAV);
 658
 659     if (SvREADONLY(av))
 660         Perl_croak(aTHX_ "%s", PL_no_modify);
 661
 662     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
 663         dSP;
 664         PUSHSTACKi(PERLSI_MAGIC);
 665         PUSHMARK(SP);
 666         EXTEND(SP,1+num);
 667         PUSHs(SvTIED_obj(MUTABLE_SV(av), mg));
 668         while (num-- > 0) {
 669             PUSHs(&PL_sv_undef);
 670         }
 671         PUTBACK;
 672         ENTER;
 673         call_method("UNSHIFT", G_SCALAR|G_DISCARD);
 674         LEAVE;
 675         POPSTACK;
 676         return;
 677     }
 678
 679     if (num <= 0)
 680       return;
 681     if (!AvREAL(av) && AvREIFY(av))
 682         av_reify(av);
 683     i = AvARRAY(av) - AvALLOC(av);
 684     if (i) {
 685         if (i > num)
 686             i = num;
 687         num -= i;
 688
 689         AvMAX(av) += i;
 690         AvFILLp(av) += i;
 691         AvARRAY(av) = AvARRAY(av) - i;
 692     }
 693     if (num) {
 694         register SV **ary;
 695         const I32 i = AvFILLp(av);
 696         /* Create extra elements */
 697         const I32 slide = i > 0 ? i : 0;
 698         num += slide;
 699         av_extend(av, i + num);
 700         AvFILLp(av) += num;
 701         ary = AvARRAY(av);
 702         Move(ary, ary + num, i + 1, SV*);
 703         do {
 704             ary[--num] = &PL_sv_undef;
 705         } while (num);
 706         /* Make extra elements into a buffer */
 707         AvMAX(av) -= slide;
 708         AvFILLp(av) -= slide;
 709         AvARRAY(av) = AvARRAY(av) + slide;
 710     }
 711 }
 712
 713 /*
 714 =for apidoc av_shift
 715
 716 Shifts an SV off the beginning of the array. Returns C<&PL_sv_undef> if the
 717 array is empty.
 718
 719 =cut
 720 */
 721
 722 SV *
 723 Perl_av_shift(pTHX_ register AV *av)
 724 {
 725     dVAR;
 726     SV *retval;
 727     MAGIC* mg;
 728
 729     PERL_ARGS_ASSERT_AV_SHIFT;
 730     assert(SvTYPE(av) == SVt_PVAV);
 731
 732     if (SvREADONLY(av))
 733         Perl_croak(aTHX_ "%s", PL_no_modify);
 734     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
 735         dSP;
 736         PUSHSTACKi(PERLSI_MAGIC);
 737         PUSHMARK(SP);
 738         XPUSHs(SvTIED_obj(MUTABLE_SV(av), mg));
 739         PUTBACK;
 740         ENTER;
 741         if (call_method("SHIFT", G_SCALAR)) {
 742             retval = newSVsv(*PL_stack_sp--);
 743         } else {
 744             retval = &PL_sv_undef;
 745         }
 746         LEAVE;
 747         POPSTACK;
 748         return retval;
 749     }
 750     if (AvFILL(av) < 0)
 751       return &PL_sv_undef;
 752     retval = *AvARRAY(av);
 753     if (AvREAL(av))
 754         *AvARRAY(av) = &PL_sv_undef;
 755     AvARRAY(av) = AvARRAY(av) + 1;
 756     AvMAX(av)--;
 757     AvFILLp(av)--;
 758     if (SvSMAGICAL(av))
 759         mg_set(MUTABLE_SV(av));
 760     return retval;
 761 }
 762
 763 /*
 764 =for apidoc av_len
 765
 766 Returns the highest index in the array.  The number of elements in the
 767 array is C<av_len(av) + 1>.  Returns -1 if the array is empty.
 768
 769 =cut
 770 */
 771
 772 I32
 773 Perl_av_len(pTHX_ AV *av)
 774 {
 775     PERL_ARGS_ASSERT_AV_LEN;
 776     assert(SvTYPE(av) == SVt_PVAV);
 777
 778     return AvFILL(av);
 779 }
 780
 781 /*
 782 =for apidoc av_fill
 783
 784 Set the highest index in the array to the given number, equivalent to
 785 Perl's C<$#array = $fill;>.
 786
 787 The number of elements in the an array will be C<fill + 1> after
 788 av_fill() returns.  If the array was previously shorter then the
 789 additional elements appended are set to C<PL_sv_undef>.  If the array
 790 was longer, then the excess elements are freed.  C<av_fill(av, -1)> is
 791 the same as C<av_clear(av)>.
 792
 793 =cut
 794 */
 795 void
 796 Perl_av_fill(pTHX_ register AV *av, I32 fill)
 797 {
 798     dVAR;
 799     MAGIC *mg;
 800
 801     PERL_ARGS_ASSERT_AV_FILL;
 802     assert(SvTYPE(av) == SVt_PVAV);
 803
 804     if (fill < 0)
 805         fill = -1;
 806     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
 807         dSP;
 808         ENTER;
 809         SAVETMPS;
 810         PUSHSTACKi(PERLSI_MAGIC);
 811         PUSHMARK(SP);
 812         EXTEND(SP,2);
 813         PUSHs(SvTIED_obj(MUTABLE_SV(av), mg));
 814         mPUSHi(fill + 1);
 815         PUTBACK;
 816         call_method("STORESIZE", G_SCALAR|G_DISCARD);
 817         POPSTACK;
 818         FREETMPS;
 819         LEAVE;
 820         return;
 821     }
 822     if (fill <= AvMAX(av)) {
 823         I32 key = AvFILLp(av);
 824         SV** const ary = AvARRAY(av);
 825
 826         if (AvREAL(av)) {
 827             while (key > fill) {
 828                 SvREFCNT_dec(ary[key]);
 829                 ary[key--] = &PL_sv_undef;
 830             }
 831         }
 832         else {
 833             while (key < fill)
 834                 ary[++key] = &PL_sv_undef;
 835         }
 836
 837         AvFILLp(av) = fill;
 838         if (SvSMAGICAL(av))
 839             mg_set(MUTABLE_SV(av));
 840     }
 841     else
 842         (void)av_store(av,fill,&PL_sv_undef);
 843 }
 844
 845 /*
 846 =for apidoc av_delete
 847
 848 Deletes the element indexed by C<key> from the array.  Returns the
 849 deleted element. If C<flags> equals C<G_DISCARD>, the element is freed
 850 and null is returned.
 851
 852 =cut
 853 */
 854 SV *
 855 Perl_av_delete(pTHX_ AV *av, I32 key, I32 flags)
 856 {
 857     dVAR;
 858     SV *sv;
 859
 860     PERL_ARGS_ASSERT_AV_DELETE;
 861     assert(SvTYPE(av) == SVt_PVAV);
 862
 863     if (SvREADONLY(av))
 864         Perl_croak(aTHX_ "%s", PL_no_modify);
 865
 866     if (SvRMAGICAL(av)) {
 867         const MAGIC * const tied_magic
 868             = mg_find((const SV *)av, PERL_MAGIC_tied);
 869         if ((tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata))) {
 870             /* Handle negative array indices 20020222 MJD */
 871             SV **svp;
 872             if (key < 0) {
 873                 unsigned adjust_index = 1;
 874                 if (tied_magic) {
 875                     SV * const * const negative_indices_glob =
 876                         hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av),
 877                                                          tied_magic))),
 878                                  NEGATIVE_INDICES_VAR, 16, 0);
 879                     if (negative_indices_glob
 880                         && SvTRUE(GvSV(*negative_indices_glob)))
 881                         adjust_index = 0;
 882                 }
 883                 if (adjust_index) {
 884                     key += AvFILL(av) + 1;
 885                     if (key < 0)
 886                         return NULL;
 887                 }
 888             }
 889             svp = av_fetch(av, key, TRUE);
 890             if (svp) {
 891                 sv = *svp;
 892                 mg_clear(sv);
 893                 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
 894                     sv_unmagic(sv, PERL_MAGIC_tiedelem); /* No longer an element */
 895                     return sv;
 896                 }
 897                 return NULL;
 898             }
 899         }
 900     }
 901
 902     if (key < 0) {
 903         key += AvFILL(av) + 1;
 904         if (key < 0)
 905             return NULL;
 906     }
 907
 908     if (key > AvFILLp(av))
 909         return NULL;
 910     else {
 911         if (!AvREAL(av) && AvREIFY(av))
 912             av_reify(av);
 913         sv = AvARRAY(av)[key];
 914         if (key == AvFILLp(av)) {
 915             AvARRAY(av)[key] = &PL_sv_undef;
 916             do {
 917                 AvFILLp(av)--;
 918             } while (--key >= 0 && AvARRAY(av)[key] == &PL_sv_undef);
 919         }
 920         else
 921             AvARRAY(av)[key] = &PL_sv_undef;
 922         if (SvSMAGICAL(av))
 923             mg_set(MUTABLE_SV(av));
 924     }
 925     if (flags & G_DISCARD) {
 926         SvREFCNT_dec(sv);
 927         sv = NULL;
 928     }
 929     else if (AvREAL(av))
 930         sv = sv_2mortal(sv);
 931     return sv;
 932 }
 933
 934 /*
 935 =for apidoc av_exists
 936
 937 Returns true if the element indexed by C<key> has been initialized.
 938
 939 This relies on the fact that uninitialized array elements are set to
 940 C<&PL_sv_undef>.
 941
 942 =cut
 943 */
 944 bool
 945 Perl_av_exists(pTHX_ AV *av, I32 key)
 946 {
 947     dVAR;
 948     PERL_ARGS_ASSERT_AV_EXISTS;
 949     assert(SvTYPE(av) == SVt_PVAV);
 950
 951     if (SvRMAGICAL(av)) {
 952         const MAGIC * const tied_magic
 953             = mg_find((const SV *)av, PERL_MAGIC_tied);
 954         if (tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata)) {
 955             SV * const sv = sv_newmortal();
 956             MAGIC *mg;
 957             /* Handle negative array indices 20020222 MJD */
 958             if (key < 0) {
 959                 unsigned adjust_index = 1;
 960                 if (tied_magic) {
 961                     SV * const * const negative_indices_glob =
 962                         hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av),
 963                                                          tied_magic))),
 964                                  NEGATIVE_INDICES_VAR, 16, 0);
 965                     if (negative_indices_glob
 966                         && SvTRUE(GvSV(*negative_indices_glob)))
 967                         adjust_index = 0;
 968                 }
 969                 if (adjust_index) {
 970                     key += AvFILL(av) + 1;
 971                     if (key < 0)
 972                         return FALSE;
 973                 }
 974             }
 975
 976             mg_copy(MUTABLE_SV(av), sv, 0, key);
 977             mg = mg_find(sv, PERL_MAGIC_tiedelem);
 978             if (mg) {
 979                 magic_existspack(sv, mg);
 980                 return (bool)SvTRUE(sv);
 981             }
 982
 983         }
 984     }
 985
 986     if (key < 0) {
 987         key += AvFILL(av) + 1;
 988         if (key < 0)
 989             return FALSE;
 990     }
 991
 992     if (key <= AvFILLp(av) && AvARRAY(av)[key] != &PL_sv_undef
 993         && AvARRAY(av)[key])
 994     {
 995         return TRUE;
 996     }
 997     else
 998         return FALSE;
 999 }
1000
1001 static MAGIC *
1002 S_get_aux_mg(pTHX_ AV *av) {
1003     dVAR;
1004     MAGIC *mg;
1005
1006     PERL_ARGS_ASSERT_GET_AUX_MG;
1007     assert(SvTYPE(av) == SVt_PVAV);
1008
1009     mg = mg_find((const SV *)av, PERL_MAGIC_arylen_p);
1010
1011     if (!mg) {
1012         mg = sv_magicext(MUTABLE_SV(av), 0, PERL_MAGIC_arylen_p,
1013                          &PL_vtbl_arylen_p, 0, 0);
1014         assert(mg);
1015         /* sv_magicext won't set this for us because we pass in a NULL obj  */
1016         mg->mg_flags |= MGf_REFCOUNTED;
1017     }
1018     return mg;
1019 }
1020
1021 SV **
1022 Perl_av_arylen_p(pTHX_ AV *av) {
1023     MAGIC *const mg = get_aux_mg(av);
1024
1025     PERL_ARGS_ASSERT_AV_ARYLEN_P;
1026     assert(SvTYPE(av) == SVt_PVAV);
1027
1028     return &(mg->mg_obj);
1029 }
1030
1031 IV *
1032 Perl_av_iter_p(pTHX_ AV *av) {
1033     MAGIC *const mg = get_aux_mg(av);
1034
1035     PERL_ARGS_ASSERT_AV_ITER_P;
1036     assert(SvTYPE(av) == SVt_PVAV);
1037
1038 #if IVSIZE == I32SIZE
1039     return (IV *)&(mg->mg_len);
1040 #else
1041     if (!mg->mg_ptr) {
1042         IV *temp;
1043         mg->mg_len = IVSIZE;
1044         Newxz(temp, 1, IV);
1045         mg->mg_ptr = (char *) temp;
1046     }
1047     return (IV *)mg->mg_ptr;
1048 #endif
1049 }
1050
1051 /*
1052  * Local variables:
1053  * c-indentation-style: bsd
1054  * c-basic-offset: 4
1055  * indent-tabs-mode: t
1056  * End:
1057  *
1058  * ex: set ts=8 sts=4 sw=4 noet:
1059  */