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