LXR perl/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, 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
  24void
  25Perl_av_reify(pTHX_ AV *av)
  26{
  27    dVAR;
  28    I32 key;
  29
  30    assert(av);
  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
  57Pre-extend an array.  The C<key> is the index to which the array should be
  58extended.
  59
  60=cut
  61*/
  62
  63void
  64Perl_av_extend(pTHX_ AV *av, I32 key)
  65{
  66    dVAR;
  67    MAGIC *mg;
  68
  69    assert(av);
  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        PUSHs(sv_2mortal(newSViv(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
 183Returns the SV at the specified index in the array.  The C<key> is the
 184index.  If C<lval> is set then the fetch will be part of a store.  Check
 185that the return value is non-null before dereferencing it to a C<SV*>.
 186
 187See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
 188more information on how to use this function on tied arrays. 
 189
 190=cut
 191*/
 192
 193SV**
 194Perl_av_fetch(pTHX_ register AV *av, I32 key, I32 lval)
 195{
 196    dVAR;
 197
 198    assert(av);
 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
 261Stores an SV in an array.  The array index is specified as C<key>.  The
 262return value will be NULL if the operation failed or if the value did not
 263need to be actually stored within the array (as in the case of tied
 264arrays). Otherwise it can be dereferenced to get the original C<SV*>.  Note
 265that the caller is responsible for suitably incrementing the reference
 266count of C<val> before the call, and decrementing it if the function
 267returned NULL.
 268
 269See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
 270more information on how to use this function on tied arrays.
 271
 272=cut
 273*/
 274
 275SV**
 276Perl_av_store(pTHX_ register AV *av, I32 key, SV *val)
 277{
 278    dVAR;
 279    SV** ary;
 280
 281    assert(av);
 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        if (val != &PL_sv_undef) {
 346            const MAGIC* const mg = SvMAGIC(av);
 347            sv_magic(val, (SV*)av, toLOWER(mg->mg_type), 0, key);
 348        }
 349        mg_set((SV*)av);
 350    }
 351    return &ary[key];
 352}
 353
 354/*
 355=for apidoc newAV
 356
 357Creates a new AV.  The reference count is set to 1.
 358
 359=cut
 360*/
 361
 362AV *
 363Perl_newAV(pTHX)
 364{
 365    register AV * const av = (AV*)newSV_type(SVt_PVAV);
 366    /* sv_upgrade does AvREAL_only()  */
 367    AvALLOC(av) = 0;
 368    AvARRAY(av) = NULL;
 369    AvMAX(av) = AvFILLp(av) = -1;
 370    return av;
 371}
 372
 373/*
 374=for apidoc av_make
 375
 376Creates a new AV and populates it with a list of SVs.  The SVs are copied
 377into the array, so they may be freed after the call to av_make.  The new AV
 378will have a reference count of 1.
 379
 380=cut
 381*/
 382
 383AV *
 384Perl_av_make(pTHX_ register I32 size, register SV **strp)
 385{
 386    register AV * const av = (AV*)newSV_type(SVt_PVAV);
 387    /* sv_upgrade does AvREAL_only()  */
 388    if (size) {         /* "defined" was returning undef for size==0 anyway. */
 389        register SV** ary;
 390        register I32 i;
 391        Newx(ary,size,SV*);
 392        AvALLOC(av) = ary;
 393        AvARRAY(av) = ary;
 394        AvFILLp(av) = AvMAX(av) = size - 1;
 395        for (i = 0; i < size; i++) {
 396            assert (*strp);
 397            ary[i] = newSV(0);
 398            sv_setsv(ary[i], *strp);
 399            strp++;
 400        }
 401    }
 402    return av;
 403}
 404
 405/*
 406=for apidoc av_clear
 407
 408Clears an array, making it empty.  Does not free the memory used by the
 409array itself.
 410
 411=cut
 412*/
 413
 414void
 415Perl_av_clear(pTHX_ register AV *av)
 416{
 417    dVAR;
 418    I32 extra;
 419
 420    assert(av);
 421#ifdef DEBUGGING
 422    if (SvREFCNT(av) == 0 && ckWARN_d(WARN_DEBUGGING)) {
 423        Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "Attempt to clear deleted array");
 424    }
 425#endif
 426
 427    if (SvREADONLY(av))
 428        Perl_croak(aTHX_ PL_no_modify);
 429
 430    /* Give any tie a chance to cleanup first */
 431    if (SvRMAGICAL(av))
 432        mg_clear((SV*)av); 
 433
 434    if (AvMAX(av) < 0)
 435        return;
 436
 437    if (AvREAL(av)) {
 438        SV** const ary = AvARRAY(av);
 439        I32 index = AvFILLp(av) + 1;
 440        while (index) {
 441            SV * const sv = ary[--index];
 442            /* undef the slot before freeing the value, because a
 443             * destructor might try to modify this array */
 444            ary[index] = &PL_sv_undef;
 445            SvREFCNT_dec(sv);
 446        }
 447    }
 448    extra = AvARRAY(av) - AvALLOC(av);
 449    if (extra) {
 450        AvMAX(av) += extra;
 451        AvARRAY(av) = AvALLOC(av);
 452    }
 453    AvFILLp(av) = -1;
 454
 455}
 456
 457/*
 458=for apidoc av_undef
 459
 460Undefines the array.  Frees the memory used by the array itself.
 461
 462=cut
 463*/
 464
 465void
 466Perl_av_undef(pTHX_ register AV *av)
 467{
 468    assert(av);
 469
 470    /* Give any tie a chance to cleanup first */
 471    if (SvTIED_mg((SV*)av, PERL_MAGIC_tied)) 
 472        av_fill(av, -1);
 473
 474    if (AvREAL(av)) {
 475        register I32 key = AvFILLp(av) + 1;
 476        while (key)
 477            SvREFCNT_dec(AvARRAY(av)[--key]);
 478    }
 479
 480    Safefree(AvALLOC(av));
 481    AvALLOC(av) = NULL;
 482    AvARRAY(av) = NULL;
 483    AvMAX(av) = AvFILLp(av) = -1;
 484
 485    if(SvRMAGICAL(av)) mg_clear((SV*)av);
 486}
 487
 488/*
 489
 490=for apidoc av_create_and_push
 491
 492Push an SV onto the end of the array, creating the array if necessary.
 493A small internal helper function to remove a commonly duplicated idiom.
 494
 495=cut
 496*/
 497
 498void
 499Perl_av_create_and_push(pTHX_ AV **const avp, SV *const val)
 500{
 501    if (!*avp)
 502        *avp = newAV();
 503    av_push(*avp, val);
 504}
 505
 506/*
 507=for apidoc av_push
 508
 509Pushes an SV onto the end of the array.  The array will grow automatically
 510to accommodate the addition.
 511
 512=cut
 513*/
 514
 515void
 516Perl_av_push(pTHX_ register AV *av, SV *val)
 517{             
 518    dVAR;
 519    MAGIC *mg;
 520    assert(av);
 521
 522    if (SvREADONLY(av))
 523        Perl_croak(aTHX_ PL_no_modify);
 524
 525    if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
 526        dSP;
 527        PUSHSTACKi(PERLSI_MAGIC);
 528        PUSHMARK(SP);
 529        EXTEND(SP,2);
 530        PUSHs(SvTIED_obj((SV*)av, mg));
 531        PUSHs(val);
 532        PUTBACK;
 533        ENTER;
 534        call_method("PUSH", G_SCALAR|G_DISCARD);
 535        LEAVE;
 536        POPSTACK;
 537        return;
 538    }
 539    av_store(av,AvFILLp(av)+1,val);
 540}
 541
 542/*
 543=for apidoc av_pop
 544
 545Pops an SV off the end of the array.  Returns C<&PL_sv_undef> if the array
 546is empty.
 547
 548=cut
 549*/
 550
 551SV *
 552Perl_av_pop(pTHX_ register AV *av)
 553{
 554    dVAR;
 555    SV *retval;
 556    MAGIC* mg;
 557
 558    assert(av);
 559
 560    if (SvREADONLY(av))
 561        Perl_croak(aTHX_ PL_no_modify);
 562    if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
 563        dSP;    
 564        PUSHSTACKi(PERLSI_MAGIC);
 565        PUSHMARK(SP);
 566        XPUSHs(SvTIED_obj((SV*)av, mg));
 567        PUTBACK;
 568        ENTER;
 569        if (call_method("POP", G_SCALAR)) {
 570            retval = newSVsv(*PL_stack_sp--);    
 571        } else {    
 572            retval = &PL_sv_undef;
 573        }
 574        LEAVE;
 575        POPSTACK;
 576        return retval;
 577    }
 578    if (AvFILL(av) < 0)
 579        return &PL_sv_undef;
 580    retval = AvARRAY(av)[AvFILLp(av)];
 581    AvARRAY(av)[AvFILLp(av)--] = &PL_sv_undef;
 582    if (SvSMAGICAL(av))
 583        mg_set((SV*)av);
 584    return retval;
 585}
 586
 587/*
 588
 589=for apidoc av_create_and_unshift_one
 590
 591Unshifts an SV onto the beginning of the array, creating the array if
 592necessary.
 593A small internal helper function to remove a commonly duplicated idiom.
 594
 595=cut
 596*/
 597
 598SV **
 599Perl_av_create_and_unshift_one(pTHX_ AV **const avp, SV *const val)
 600{
 601    if (!*avp)
 602        *avp = newAV();
 603    av_unshift(*avp, 1);
 604    return av_store(*avp, 0, val);
 605}
 606
 607/*
 608=for apidoc av_unshift
 609
 610Unshift the given number of C<undef> values onto the beginning of the
 611array.  The array will grow automatically to accommodate the addition.  You
 612must then use C<av_store> to assign values to these new elements.
 613
 614=cut
 615*/
 616
 617void
 618Perl_av_unshift(pTHX_ register AV *av, register I32 num)
 619{
 620    dVAR;
 621    register I32 i;
 622    MAGIC* mg;
 623
 624    assert(av);
 625
 626    if (SvREADONLY(av))
 627        Perl_croak(aTHX_ PL_no_modify);
 628
 629    if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
 630        dSP;
 631        PUSHSTACKi(PERLSI_MAGIC);
 632        PUSHMARK(SP);
 633        EXTEND(SP,1+num);
 634        PUSHs(SvTIED_obj((SV*)av, mg));
 635        while (num-- > 0) {
 636            PUSHs(&PL_sv_undef);
 637        }
 638        PUTBACK;
 639        ENTER;
 640        call_method("UNSHIFT", G_SCALAR|G_DISCARD);
 641        LEAVE;
 642        POPSTACK;
 643        return;
 644    }
 645
 646    if (num <= 0)
 647      return;
 648    if (!AvREAL(av) && AvREIFY(av))
 649        av_reify(av);
 650    i = AvARRAY(av) - AvALLOC(av);
 651    if (i) {
 652        if (i > num)
 653            i = num;
 654        num -= i;
 655    
 656        AvMAX(av) += i;
 657        AvFILLp(av) += i;
 658        AvARRAY(av) = AvARRAY(av) - i;
 659    }
 660    if (num) {
 661        register SV **ary;
 662        const I32 i = AvFILLp(av);
 663        /* Create extra elements */
 664        const I32 slide = i > 0 ? i : 0;
 665        num += slide;
 666        av_extend(av, i + num);
 667        AvFILLp(av) += num;
 668        ary = AvARRAY(av);
 669        Move(ary, ary + num, i + 1, SV*);
 670        do {
 671            ary[--num] = &PL_sv_undef;
 672        } while (num);
 673        /* Make extra elements into a buffer */
 674        AvMAX(av) -= slide;
 675        AvFILLp(av) -= slide;
 676        AvARRAY(av) = AvARRAY(av) + slide;
 677    }
 678}
 679
 680/*
 681=for apidoc av_shift
 682
 683Shifts an SV off the beginning of the array.
 684
 685=cut
 686*/
 687
 688SV *
 689Perl_av_shift(pTHX_ register AV *av)
 690{
 691    dVAR;
 692    SV *retval;
 693    MAGIC* mg;
 694
 695    assert(av);
 696
 697    if (SvREADONLY(av))
 698        Perl_croak(aTHX_ PL_no_modify);
 699    if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
 700        dSP;
 701        PUSHSTACKi(PERLSI_MAGIC);
 702        PUSHMARK(SP);
 703        XPUSHs(SvTIED_obj((SV*)av, mg));
 704        PUTBACK;
 705        ENTER;
 706        if (call_method("SHIFT", G_SCALAR)) {
 707            retval = newSVsv(*PL_stack_sp--);            
 708        } else {    
 709            retval = &PL_sv_undef;
 710        }     
 711        LEAVE;
 712        POPSTACK;
 713        return retval;
 714    }
 715    if (AvFILL(av) < 0)
 716      return &PL_sv_undef;
 717    retval = *AvARRAY(av);
 718    if (AvREAL(av))
 719        *AvARRAY(av) = &PL_sv_undef;
 720    AvARRAY(av) = AvARRAY(av) + 1;
 721    AvMAX(av)--;
 722    AvFILLp(av)--;
 723    if (SvSMAGICAL(av))
 724        mg_set((SV*)av);
 725    return retval;
 726}
 727
 728/*
 729=for apidoc av_len
 730
 731Returns the highest index in the array.  The number of elements in the
 732array is C<av_len(av) + 1>.  Returns -1 if the array is empty.
 733
 734=cut
 735*/
 736
 737I32
 738Perl_av_len(pTHX_ register const AV *av)
 739{
 740    assert(av);
 741    return AvFILL(av);
 742}
 743
 744/*
 745=for apidoc av_fill
 746
 747Set the highest index in the array to the given number, equivalent to
 748Perl's C<$#array = $fill;>.
 749
 750The number of elements in the an array will be C<fill + 1> after
 751av_fill() returns.  If the array was previously shorter then the
 752additional elements appended are set to C<PL_sv_undef>.  If the array
 753was longer, then the excess elements are freed.  C<av_fill(av, -1)> is
 754the same as C<av_clear(av)>.
 755
 756=cut
 757*/
 758void
 759Perl_av_fill(pTHX_ register AV *av, I32 fill)
 760{
 761    dVAR;
 762    MAGIC *mg;
 763
 764    assert(av);
 765
 766    if (fill < 0)
 767        fill = -1;
 768    if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
 769        dSP;            
 770        ENTER;
 771        SAVETMPS;
 772        PUSHSTACKi(PERLSI_MAGIC);
 773        PUSHMARK(SP);
 774        EXTEND(SP,2);
 775        PUSHs(SvTIED_obj((SV*)av, mg));
 776        PUSHs(sv_2mortal(newSViv(fill+1)));
 777        PUTBACK;
 778        call_method("STORESIZE", G_SCALAR|G_DISCARD);
 779        POPSTACK;
 780        FREETMPS;
 781        LEAVE;
 782        return;
 783    }
 784    if (fill <= AvMAX(av)) {
 785        I32 key = AvFILLp(av);
 786        SV** const ary = AvARRAY(av);
 787
 788        if (AvREAL(av)) {
 789            while (key > fill) {
 790                SvREFCNT_dec(ary[key]);
 791                ary[key--] = &PL_sv_undef;
 792            }
 793        }
 794        else {
 795            while (key < fill)
 796                ary[++key] = &PL_sv_undef;
 797        }
 798            
 799        AvFILLp(av) = fill;
 800        if (SvSMAGICAL(av))
 801            mg_set((SV*)av);
 802    }
 803    else
 804        (void)av_store(av,fill,&PL_sv_undef);
 805}
 806
 807/*
 808=for apidoc av_delete
 809
 810Deletes the element indexed by C<key> from the array.  Returns the
 811deleted element. If C<flags> equals C<G_DISCARD>, the element is freed
 812and null is returned.
 813
 814=cut
 815*/
 816SV *
 817Perl_av_delete(pTHX_ AV *av, I32 key, I32 flags)
 818{
 819    dVAR;
 820    SV *sv;
 821
 822    assert(av);
 823
 824    if (SvREADONLY(av))
 825        Perl_croak(aTHX_ PL_no_modify);
 826
 827    if (SvRMAGICAL(av)) {
 828        const MAGIC * const tied_magic = mg_find((SV*)av, PERL_MAGIC_tied);
 829        if ((tied_magic || mg_find((SV*)av, PERL_MAGIC_regdata))) {
 830            /* Handle negative array indices 20020222 MJD */
 831            SV **svp;
 832            if (key < 0) {
 833                unsigned adjust_index = 1;
 834                if (tied_magic) {
 835                    SV * const * const negative_indices_glob =
 836                        hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *)av, 
 837                                                         tied_magic))), 
 838                                 NEGATIVE_INDICES_VAR, 16, 0);
 839                    if (negative_indices_glob
 840                        && SvTRUE(GvSV(*negative_indices_glob)))
 841                        adjust_index = 0;
 842                }
 843                if (adjust_index) {
 844                    key += AvFILL(av) + 1;
 845                    if (key < 0)
 846                        return NULL;
 847                }
 848            }
 849            svp = av_fetch(av, key, TRUE);
 850            if (svp) {
 851                sv = *svp;
 852                mg_clear(sv);
 853                if (mg_find(sv, PERL_MAGIC_tiedelem)) {
 854                    sv_unmagic(sv, PERL_MAGIC_tiedelem); /* No longer an element */
 855                    return sv;
 856                }
 857                return NULL;
 858            }
 859        }
 860    }
 861
 862    if (key < 0) {
 863        key += AvFILL(av) + 1;
 864        if (key < 0)
 865            return NULL;
 866    }
 867
 868    if (key > AvFILLp(av))
 869        return NULL;
 870    else {
 871        if (!AvREAL(av) && AvREIFY(av))
 872            av_reify(av);
 873        sv = AvARRAY(av)[key];
 874        if (key == AvFILLp(av)) {
 875            AvARRAY(av)[key] = &PL_sv_undef;
 876            do {
 877                AvFILLp(av)--;
 878            } while (--key >= 0 && AvARRAY(av)[key] == &PL_sv_undef);
 879        }
 880        else
 881            AvARRAY(av)[key] = &PL_sv_undef;
 882        if (SvSMAGICAL(av))
 883            mg_set((SV*)av);
 884    }
 885    if (flags & G_DISCARD) {
 886        SvREFCNT_dec(sv);
 887        sv = NULL;
 888    }
 889    else if (AvREAL(av))
 890        sv = sv_2mortal(sv);
 891    return sv;
 892}
 893
 894/*
 895=for apidoc av_exists
 896
 897Returns true if the element indexed by C<key> has been initialized.
 898
 899This relies on the fact that uninitialized array elements are set to
 900C<&PL_sv_undef>.
 901
 902=cut
 903*/
 904bool
 905Perl_av_exists(pTHX_ AV *av, I32 key)
 906{
 907    dVAR;
 908    assert(av);
 909
 910    if (SvRMAGICAL(av)) {
 911        const MAGIC * const tied_magic = mg_find((SV*)av, PERL_MAGIC_tied);
 912        if (tied_magic || mg_find((SV*)av, PERL_MAGIC_regdata)) {
 913            SV * const sv = sv_newmortal();
 914            MAGIC *mg;
 915            /* Handle negative array indices 20020222 MJD */
 916            if (key < 0) {
 917                unsigned adjust_index = 1;
 918                if (tied_magic) {
 919                    SV * const * const negative_indices_glob =
 920                        hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *)av, 
 921                                                         tied_magic))), 
 922                                 NEGATIVE_INDICES_VAR, 16, 0);
 923                    if (negative_indices_glob
 924                        && SvTRUE(GvSV(*negative_indices_glob)))
 925                        adjust_index = 0;
 926                }
 927                if (adjust_index) {
 928                    key += AvFILL(av) + 1;
 929                    if (key < 0)
 930                        return FALSE;
 931                }
 932            }
 933
 934            mg_copy((SV*)av, sv, 0, key);
 935            mg = mg_find(sv, PERL_MAGIC_tiedelem);
 936            if (mg) {
 937                magic_existspack(sv, mg);
 938                return (bool)SvTRUE(sv);
 939            }
 940
 941        }
 942    }
 943
 944    if (key < 0) {
 945        key += AvFILL(av) + 1;
 946        if (key < 0)
 947            return FALSE;
 948    }
 949
 950    if (key <= AvFILLp(av) && AvARRAY(av)[key] != &PL_sv_undef
 951        && AvARRAY(av)[key])
 952    {
 953        return TRUE;
 954    }
 955    else
 956        return FALSE;
 957}
 958
 959SV **
 960Perl_av_arylen_p(pTHX_ AV *av) {
 961    dVAR;
 962    MAGIC *mg;
 963
 964    assert(av);
 965
 966    mg = mg_find((SV*)av, PERL_MAGIC_arylen_p);
 967
 968    if (!mg) {
 969        mg = sv_magicext((SV*)av, 0, PERL_MAGIC_arylen_p, &PL_vtbl_arylen_p,
 970                         0, 0);
 971        assert(mg);
 972        /* sv_magicext won't set this for us because we pass in a NULL obj  */
 973        mg->mg_flags |= MGf_REFCOUNTED;
 974    }
 975    return &(mg->mg_obj);
 976}
 977
 978/*
 979 * Local variables:
 980 * c-indentation-style: bsd
 981 * c-basic-offset: 4
 982 * indent-tabs-mode: t
 983 * End:
 984 *
 985 * ex: set ts=8 sts=4 sw=4 noet:
 986 */
 987