av.c

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