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                 New(2,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                 New(2,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     AvREAL_on(av);
 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     AvREAL_only(av);
 386     if (size) {         /* "defined" was returning undef for size==0 anyway. */
 387         register SV** ary;
 388         register I32 i;
 389         New(4,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     New(4,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     /*SUPPRESS 560*/
 449
 450     if (SvREADONLY(av))
 451         Perl_croak(aTHX_ PL_no_modify);
 452
 453     /* Give any tie a chance to cleanup first */
 454     if (SvRMAGICAL(av))
 455         mg_clear((SV*)av);
 456
 457     if (AvMAX(av) < 0)
 458         return;
 459
 460     if (AvREAL(av)) {
 461         SV** ary = AvARRAY(av);
 462         key = AvFILLp(av) + 1;
 463         while (key) {
 464             SV * sv = ary[--key];
 465             /* undef the slot before freeing the value, because a
 466              * destructor might try to modify this arrray */
 467             ary[key] = &PL_sv_undef;
 468             SvREFCNT_dec(sv);
 469         }
 470     }
 471     if ((key = AvARRAY(av) - AvALLOC(av))) {
 472         AvMAX(av) += key;
 473         SvPV_set(av, (char*)AvALLOC(av));
 474     }
 475     AvFILLp(av) = -1;
 476
 477 }
 478
 479 /*
 480 =for apidoc av_undef
 481
 482 Undefines the array.  Frees the memory used by the array itself.
 483
 484 =cut
 485 */
 486
 487 void
 488 Perl_av_undef(pTHX_ register AV *av)
 489 {
 490     if (!av)
 491         return;
 492     /*SUPPRESS 560*/
 493
 494     /* Give any tie a chance to cleanup first */
 495     if (SvTIED_mg((SV*)av, PERL_MAGIC_tied))
 496         av_fill(av, -1);   /* mg_clear() ? */
 497
 498     if (AvREAL(av)) {
 499         register I32 key = AvFILLp(av) + 1;
 500         while (key)
 501             SvREFCNT_dec(AvARRAY(av)[--key]);
 502     }
 503     Safefree(AvALLOC(av));
 504     AvALLOC(av) = 0;
 505     SvPV_set(av, (char*)0);
 506     AvMAX(av) = AvFILLp(av) = -1;
 507     /* It's in magic - it must already be gone.  */
 508     assert (!AvARYLEN(av));
 509 }
 510
 511 /*
 512 =for apidoc av_push
 513
 514 Pushes an SV onto the end of the array.  The array will grow automatically
 515 to accommodate the addition.
 516
 517 =cut
 518 */
 519
 520 void
 521 Perl_av_push(pTHX_ register AV *av, SV *val)
 522 {
 523     dVAR;
 524     MAGIC *mg;
 525     if (!av)
 526         return;
 527     if (SvREADONLY(av))
 528         Perl_croak(aTHX_ PL_no_modify);
 529
 530     if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
 531         dSP;
 532         PUSHSTACKi(PERLSI_MAGIC);
 533         PUSHMARK(SP);
 534         EXTEND(SP,2);
 535         PUSHs(SvTIED_obj((SV*)av, mg));
 536         PUSHs(val);
 537         PUTBACK;
 538         ENTER;
 539         call_method("PUSH", G_SCALAR|G_DISCARD);
 540         LEAVE;
 541         POPSTACK;
 542         return;
 543     }
 544     av_store(av,AvFILLp(av)+1,val);
 545 }
 546
 547 /*
 548 =for apidoc av_pop
 549
 550 Pops an SV off the end of the array.  Returns C<&PL_sv_undef> if the array
 551 is empty.
 552
 553 =cut
 554 */
 555
 556 SV *
 557 Perl_av_pop(pTHX_ register AV *av)
 558 {
 559     dVAR;
 560     SV *retval;
 561     MAGIC* mg;
 562
 563     if (!av)
 564       return &PL_sv_undef;
 565     if (SvREADONLY(av))
 566         Perl_croak(aTHX_ PL_no_modify);
 567     if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
 568         dSP;
 569         PUSHSTACKi(PERLSI_MAGIC);
 570         PUSHMARK(SP);
 571         XPUSHs(SvTIED_obj((SV*)av, mg));
 572         PUTBACK;
 573         ENTER;
 574         if (call_method("POP", G_SCALAR)) {
 575             retval = newSVsv(*PL_stack_sp--);
 576         } else {
 577             retval = &PL_sv_undef;
 578         }
 579         LEAVE;
 580         POPSTACK;
 581         return retval;
 582     }
 583     if (AvFILL(av) < 0)
 584         return &PL_sv_undef;
 585     retval = AvARRAY(av)[AvFILLp(av)];
 586     AvARRAY(av)[AvFILLp(av)--] = &PL_sv_undef;
 587     if (SvSMAGICAL(av))
 588         mg_set((SV*)av);
 589     return retval;
 590 }
 591
 592 /*
 593 =for apidoc av_unshift
 594
 595 Unshift the given number of C<undef> values onto the beginning of the
 596 array.  The array will grow automatically to accommodate the addition.  You
 597 must then use C<av_store> to assign values to these new elements.
 598
 599 =cut
 600 */
 601
 602 void
 603 Perl_av_unshift(pTHX_ register AV *av, register I32 num)
 604 {
 605     dVAR;
 606     register I32 i;
 607     MAGIC* mg;
 608
 609     if (!av)
 610         return;
 611     if (SvREADONLY(av))
 612         Perl_croak(aTHX_ PL_no_modify);
 613
 614     if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
 615         dSP;
 616         PUSHSTACKi(PERLSI_MAGIC);
 617         PUSHMARK(SP);
 618         EXTEND(SP,1+num);
 619         PUSHs(SvTIED_obj((SV*)av, mg));
 620         while (num-- > 0) {
 621             PUSHs(&PL_sv_undef);
 622         }
 623         PUTBACK;
 624         ENTER;
 625         call_method("UNSHIFT", G_SCALAR|G_DISCARD);
 626         LEAVE;
 627         POPSTACK;
 628         return;
 629     }
 630
 631     if (num <= 0)
 632       return;
 633     if (!AvREAL(av) && AvREIFY(av))
 634         av_reify(av);
 635     i = AvARRAY(av) - AvALLOC(av);
 636     if (i) {
 637         if (i > num)
 638             i = num;
 639         num -= i;
 640
 641         AvMAX(av) += i;
 642         AvFILLp(av) += i;
 643         SvPV_set(av, (char*)(AvARRAY(av) - i));
 644     }
 645     if (num) {
 646         register SV **ary;
 647         I32 slide;
 648         i = AvFILLp(av);
 649         /* Create extra elements */
 650         slide = i > 0 ? i : 0;
 651         num += slide;
 652         av_extend(av, i + num);
 653         AvFILLp(av) += num;
 654         ary = AvARRAY(av);
 655         Move(ary, ary + num, i + 1, SV*);
 656         do {
 657             ary[--num] = &PL_sv_undef;
 658         } while (num);
 659         /* Make extra elements into a buffer */
 660         AvMAX(av) -= slide;
 661         AvFILLp(av) -= slide;
 662         SvPV_set(av, (char*)(AvARRAY(av) + slide));
 663     }
 664 }
 665
 666 /*
 667 =for apidoc av_shift
 668
 669 Shifts an SV off the beginning of the array.
 670
 671 =cut
 672 */
 673
 674 SV *
 675 Perl_av_shift(pTHX_ register AV *av)
 676 {
 677     dVAR;
 678     SV *retval;
 679     MAGIC* mg;
 680
 681     if (!av)
 682         return &PL_sv_undef;
 683     if (SvREADONLY(av))
 684         Perl_croak(aTHX_ PL_no_modify);
 685     if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
 686         dSP;
 687         PUSHSTACKi(PERLSI_MAGIC);
 688         PUSHMARK(SP);
 689         XPUSHs(SvTIED_obj((SV*)av, mg));
 690         PUTBACK;
 691         ENTER;
 692         if (call_method("SHIFT", G_SCALAR)) {
 693             retval = newSVsv(*PL_stack_sp--);
 694         } else {
 695             retval = &PL_sv_undef;
 696         }
 697         LEAVE;
 698         POPSTACK;
 699         return retval;
 700     }
 701     if (AvFILL(av) < 0)
 702       return &PL_sv_undef;
 703     retval = *AvARRAY(av);
 704     if (AvREAL(av))
 705         *AvARRAY(av) = &PL_sv_undef;
 706     SvPV_set(av, (char*)(AvARRAY(av) + 1));
 707     AvMAX(av)--;
 708     AvFILLp(av)--;
 709     if (SvSMAGICAL(av))
 710         mg_set((SV*)av);
 711     return retval;
 712 }
 713
 714 /*
 715 =for apidoc av_len
 716
 717 Returns the highest index in the array.  Returns -1 if the array is
 718 empty.
 719
 720 =cut
 721 */
 722
 723 I32
 724 Perl_av_len(pTHX_ const register AV *av)
 725 {
 726     return AvFILL(av);
 727 }
 728
 729 /*
 730 =for apidoc av_fill
 731
 732 Ensure than an array has a given number of elements, equivalent to
 733 Perl's C<$#array = $fill;>.
 734
 735 =cut
 736 */
 737 void
 738 Perl_av_fill(pTHX_ register AV *av, I32 fill)
 739 {
 740     dVAR;
 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 }
 936
 937 SV **
 938 Perl_av_arylen_p(pTHX_ AV *av) {
 939     dVAR;
 940     MAGIC *mg = mg_find((SV*)av, PERL_MAGIC_arylen_p);
 941
 942     if (!mg) {
 943         mg = sv_magicext((SV*)av, 0, PERL_MAGIC_arylen_p, &PL_vtbl_arylen_p,
 944                          0, 0);
 945
 946         if (!mg) {
 947             Perl_die(aTHX_ "panic: av_arylen_p");
 948         }
 949         /* sv_magicext won't set this for us because we pass in a NULL obj  */
 950         mg->mg_flags |= MGf_REFCOUNTED;
 951     }
 952     return &(mg->mg_obj);
 953 }
 954
 955 /*
 956  * Local variables:
 957  * c-indentation-style: bsd
 958  * c-basic-offset: 4
 959  * indent-tabs-mode: t
 960  * End:
 961  *
 962  * ex: set ts=8 sts=4 sw=4 noet:
 963  */