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