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         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
 357 Creates a new AV.  The reference count is set to 1.
 358
 359 =cut
 360 */
 361
 362 AV *
 363 Perl_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
 376 Creates a new AV and populates it with a list of SVs.  The SVs are copied
 377 into the array, so they may be freed after the call to av_make.  The new AV
 378 will have a reference count of 1.
 379
 380 =cut
 381 */
 382
 383 AV *
 384 Perl_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
 408 Clears an array, making it empty.  Does not free the memory used by the
 409 array itself.
 410
 411 =cut
 412 */
 413
 414 void
 415 Perl_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
 460 Undefines the array.  Frees the memory used by the array itself.
 461
 462 =cut
 463 */
 464
 465 void
 466 Perl_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
 492 Push an SV onto the end of the array, creating the array if necessary.
 493 A small internal helper function to remove a commonly duplicated idiom.
 494
 495 =cut
 496 */
 497
 498 void
 499 Perl_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
 509 Pushes an SV onto the end of the array.  The array will grow automatically
 510 to accommodate the addition.
 511
 512 =cut
 513 */
 514
 515 void
 516 Perl_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
 545 Pops an SV off the end of the array.  Returns C<&PL_sv_undef> if the array
 546 is empty.
 547
 548 =cut
 549 */
 550
 551 SV *
 552 Perl_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
 591 Unshifts an SV onto the beginning of the array, creating the array if
 592 necessary.
 593 A small internal helper function to remove a commonly duplicated idiom.
 594
 595 =cut
 596 */
 597
 598 SV **
 599 Perl_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
 610 Unshift the given number of C<undef> values onto the beginning of the
 611 array.  The array will grow automatically to accommodate the addition.  You
 612 must then use C<av_store> to assign values to these new elements.
 613
 614 =cut
 615 */
 616
 617 void
 618 Perl_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
 683 Shifts an SV off the beginning of the array.
 684
 685 =cut
 686 */
 687
 688 SV *
 689 Perl_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
 731 Returns the highest index in the array.  The number of elements in the
 732 array is C<av_len(av) + 1>.  Returns -1 if the array is empty.
 733
 734 =cut
 735 */
 736
 737 I32
 738 Perl_av_len(pTHX_ register const AV *av)
 739 {
 740     assert(av);
 741     return AvFILL(av);
 742 }
 743
 744 /*
 745 =for apidoc av_fill
 746
 747 Set the highest index in the array to the given number, equivalent to
 748 Perl's C<$#array = $fill;>.
 749
 750 The number of elements in the an array will be C<fill + 1> after
 751 av_fill() returns.  If the array was previously shorter then the
 752 additional elements appended are set to C<PL_sv_undef>.  If the array
 753 was longer, then the excess elements are freed.  C<av_fill(av, -1)> is
 754 the same as C<av_clear(av)>.
 755
 756 =cut
 757 */
 758 void
 759 Perl_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
 810 Deletes the element indexed by C<key> from the array.  Returns the
 811 deleted element. If C<flags> equals C<G_DISCARD>, the element is freed
 812 and null is returned.
 813
 814 =cut
 815 */
 816 SV *
 817 Perl_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
 897 Returns true if the element indexed by C<key> has been initialized.
 898
 899 This relies on the fact that uninitialized array elements are set to
 900 C<&PL_sv_undef>.
 901
 902 =cut
 903 */
 904 bool
 905 Perl_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
 959 SV **
 960 Perl_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  */