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