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