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