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