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     AvFLAGS(av) = AVf_REAL;
 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     AvFLAGS(av) = AVf_REIFY;
 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     if (AvARYLEN(av)) {
 508         SvREFCNT_dec(AvARYLEN(av));
 509         AvARYLEN(av) = 0;
 510     }
 511 }
 512
 513 /*
 514 =for apidoc av_push
 515
 516 Pushes an SV onto the end of the array.  The array will grow automatically
 517 to accommodate the addition.
 518
 519 =cut
 520 */
 521
 522 void
 523 Perl_av_push(pTHX_ register AV *av, SV *val)
 524 {
 525     dVAR;
 526     MAGIC *mg;
 527     if (!av)
 528         return;
 529     if (SvREADONLY(av))
 530         Perl_croak(aTHX_ PL_no_modify);
 531
 532     if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
 533         dSP;
 534         PUSHSTACKi(PERLSI_MAGIC);
 535         PUSHMARK(SP);
 536         EXTEND(SP,2);
 537         PUSHs(SvTIED_obj((SV*)av, mg));
 538         PUSHs(val);
 539         PUTBACK;
 540         ENTER;
 541         call_method("PUSH", G_SCALAR|G_DISCARD);
 542         LEAVE;
 543         POPSTACK;
 544         return;
 545     }
 546     av_store(av,AvFILLp(av)+1,val);
 547 }
 548
 549 /*
 550 =for apidoc av_pop
 551
 552 Pops an SV off the end of the array.  Returns C<&PL_sv_undef> if the array
 553 is empty.
 554
 555 =cut
 556 */
 557
 558 SV *
 559 Perl_av_pop(pTHX_ register AV *av)
 560 {
 561     dVAR;
 562     SV *retval;
 563     MAGIC* mg;
 564
 565     if (!av)
 566       return &PL_sv_undef;
 567     if (SvREADONLY(av))
 568         Perl_croak(aTHX_ PL_no_modify);
 569     if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
 570         dSP;
 571         PUSHSTACKi(PERLSI_MAGIC);
 572         PUSHMARK(SP);
 573         XPUSHs(SvTIED_obj((SV*)av, mg));
 574         PUTBACK;
 575         ENTER;
 576         if (call_method("POP", G_SCALAR)) {
 577             retval = newSVsv(*PL_stack_sp--);
 578         } else {
 579             retval = &PL_sv_undef;
 580         }
 581         LEAVE;
 582         POPSTACK;
 583         return retval;
 584     }
 585     if (AvFILL(av) < 0)
 586         return &PL_sv_undef;
 587     retval = AvARRAY(av)[AvFILLp(av)];
 588     AvARRAY(av)[AvFILLp(av)--] = &PL_sv_undef;
 589     if (SvSMAGICAL(av))
 590         mg_set((SV*)av);
 591     return retval;
 592 }
 593
 594 /*
 595 =for apidoc av_unshift
 596
 597 Unshift the given number of C<undef> values onto the beginning of the
 598 array.  The array will grow automatically to accommodate the addition.  You
 599 must then use C<av_store> to assign values to these new elements.
 600
 601 =cut
 602 */
 603
 604 void
 605 Perl_av_unshift(pTHX_ register AV *av, register I32 num)
 606 {
 607     dVAR;
 608     register I32 i;
 609     MAGIC* mg;
 610
 611     if (!av)
 612         return;
 613     if (SvREADONLY(av))
 614         Perl_croak(aTHX_ PL_no_modify);
 615
 616     if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
 617         dSP;
 618         PUSHSTACKi(PERLSI_MAGIC);
 619         PUSHMARK(SP);
 620         EXTEND(SP,1+num);
 621         PUSHs(SvTIED_obj((SV*)av, mg));
 622         while (num-- > 0) {
 623             PUSHs(&PL_sv_undef);
 624         }
 625         PUTBACK;
 626         ENTER;
 627         call_method("UNSHIFT", G_SCALAR|G_DISCARD);
 628         LEAVE;
 629         POPSTACK;
 630         return;
 631     }
 632
 633     if (num <= 0)
 634       return;
 635     if (!AvREAL(av) && AvREIFY(av))
 636         av_reify(av);
 637     i = AvARRAY(av) - AvALLOC(av);
 638     if (i) {
 639         if (i > num)
 640             i = num;
 641         num -= i;
 642
 643         AvMAX(av) += i;
 644         AvFILLp(av) += i;
 645         SvPV_set(av, (char*)(AvARRAY(av) - i));
 646     }
 647     if (num) {
 648         register SV **ary;
 649         I32 slide;
 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         SvPV_set(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     dVAR;
 680     SV *retval;
 681     MAGIC* mg;
 682
 683     if (!av)
 684         return &PL_sv_undef;
 685     if (SvREADONLY(av))
 686         Perl_croak(aTHX_ PL_no_modify);
 687     if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
 688         dSP;
 689         PUSHSTACKi(PERLSI_MAGIC);
 690         PUSHMARK(SP);
 691         XPUSHs(SvTIED_obj((SV*)av, mg));
 692         PUTBACK;
 693         ENTER;
 694         if (call_method("SHIFT", G_SCALAR)) {
 695             retval = newSVsv(*PL_stack_sp--);
 696         } else {
 697             retval = &PL_sv_undef;
 698         }
 699         LEAVE;
 700         POPSTACK;
 701         return retval;
 702     }
 703     if (AvFILL(av) < 0)
 704       return &PL_sv_undef;
 705     retval = *AvARRAY(av);
 706     if (AvREAL(av))
 707         *AvARRAY(av) = &PL_sv_undef;
 708     SvPV_set(av, (char*)(AvARRAY(av) + 1));
 709     AvMAX(av)--;
 710     AvFILLp(av)--;
 711     if (SvSMAGICAL(av))
 712         mg_set((SV*)av);
 713     return retval;
 714 }
 715
 716 /*
 717 =for apidoc av_len
 718
 719 Returns the highest index in the array.  Returns -1 if the array is
 720 empty.
 721
 722 =cut
 723 */
 724
 725 I32
 726 Perl_av_len(pTHX_ const register AV *av)
 727 {
 728     return AvFILL(av);
 729 }
 730
 731 /*
 732 =for apidoc av_fill
 733
 734 Ensure than an array has a given number of elements, equivalent to
 735 Perl's C<$#array = $fill;>.
 736
 737 =cut
 738 */
 739 void
 740 Perl_av_fill(pTHX_ register AV *av, I32 fill)
 741 {
 742     dVAR;
 743     MAGIC *mg;
 744     if (!av)
 745         Perl_croak(aTHX_ "panic: null array");
 746     if (fill < 0)
 747         fill = -1;
 748     if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
 749         dSP;
 750         ENTER;
 751         SAVETMPS;
 752         PUSHSTACKi(PERLSI_MAGIC);
 753         PUSHMARK(SP);
 754         EXTEND(SP,2);
 755         PUSHs(SvTIED_obj((SV*)av, mg));
 756         PUSHs(sv_2mortal(newSViv(fill+1)));
 757         PUTBACK;
 758         call_method("STORESIZE", G_SCALAR|G_DISCARD);
 759         POPSTACK;
 760         FREETMPS;
 761         LEAVE;
 762         return;
 763     }
 764     if (fill <= AvMAX(av)) {
 765         I32 key = AvFILLp(av);
 766         SV** ary = AvARRAY(av);
 767
 768         if (AvREAL(av)) {
 769             while (key > fill) {
 770                 SvREFCNT_dec(ary[key]);
 771                 ary[key--] = &PL_sv_undef;
 772             }
 773         }
 774         else {
 775             while (key < fill)
 776                 ary[++key] = &PL_sv_undef;
 777         }
 778
 779         AvFILLp(av) = fill;
 780         if (SvSMAGICAL(av))
 781             mg_set((SV*)av);
 782     }
 783     else
 784         (void)av_store(av,fill,&PL_sv_undef);
 785 }
 786
 787 /*
 788 =for apidoc av_delete
 789
 790 Deletes the element indexed by C<key> from the array.  Returns the
 791 deleted element. If C<flags> equals C<G_DISCARD>, the element is freed
 792 and null is returned.
 793
 794 =cut
 795 */
 796 SV *
 797 Perl_av_delete(pTHX_ AV *av, I32 key, I32 flags)
 798 {
 799     SV *sv;
 800
 801     if (!av)
 802         return Nullsv;
 803     if (SvREADONLY(av))
 804         Perl_croak(aTHX_ PL_no_modify);
 805
 806     if (SvRMAGICAL(av)) {
 807         const MAGIC * const tied_magic = mg_find((SV*)av, PERL_MAGIC_tied);
 808         if ((tied_magic || mg_find((SV*)av, PERL_MAGIC_regdata))) {
 809             /* Handle negative array indices 20020222 MJD */
 810             SV **svp;
 811             if (key < 0) {
 812                 unsigned adjust_index = 1;
 813                 if (tied_magic) {
 814                     SV **negative_indices_glob =
 815                         hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *)av,
 816                                                          tied_magic))),
 817                                  NEGATIVE_INDICES_VAR, 16, 0);
 818                     if (negative_indices_glob
 819                         && SvTRUE(GvSV(*negative_indices_glob)))
 820                         adjust_index = 0;
 821                 }
 822                 if (adjust_index) {
 823                     key += AvFILL(av) + 1;
 824                     if (key < 0)
 825                         return Nullsv;
 826                 }
 827             }
 828             svp = av_fetch(av, key, TRUE);
 829             if (svp) {
 830                 sv = *svp;
 831                 mg_clear(sv);
 832                 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
 833                     sv_unmagic(sv, PERL_MAGIC_tiedelem); /* No longer an element */
 834                     return sv;
 835                 }
 836                 return Nullsv;
 837             }
 838         }
 839     }
 840
 841     if (key < 0) {
 842         key += AvFILL(av) + 1;
 843         if (key < 0)
 844             return Nullsv;
 845     }
 846
 847     if (key > AvFILLp(av))
 848         return Nullsv;
 849     else {
 850         if (!AvREAL(av) && AvREIFY(av))
 851             av_reify(av);
 852         sv = AvARRAY(av)[key];
 853         if (key == AvFILLp(av)) {
 854             AvARRAY(av)[key] = &PL_sv_undef;
 855             do {
 856                 AvFILLp(av)--;
 857             } while (--key >= 0 && AvARRAY(av)[key] == &PL_sv_undef);
 858         }
 859         else
 860             AvARRAY(av)[key] = &PL_sv_undef;
 861         if (SvSMAGICAL(av))
 862             mg_set((SV*)av);
 863     }
 864     if (flags & G_DISCARD) {
 865         SvREFCNT_dec(sv);
 866         sv = Nullsv;
 867     }
 868     else if (AvREAL(av))
 869         sv = sv_2mortal(sv);
 870     return sv;
 871 }
 872
 873 /*
 874 =for apidoc av_exists
 875
 876 Returns true if the element indexed by C<key> has been initialized.
 877
 878 This relies on the fact that uninitialized array elements are set to
 879 C<&PL_sv_undef>.
 880
 881 =cut
 882 */
 883 bool
 884 Perl_av_exists(pTHX_ AV *av, I32 key)
 885 {
 886     if (!av)
 887         return FALSE;
 888
 889
 890     if (SvRMAGICAL(av)) {
 891         const MAGIC * const tied_magic = mg_find((SV*)av, PERL_MAGIC_tied);
 892         if (tied_magic || mg_find((SV*)av, PERL_MAGIC_regdata)) {
 893             SV *sv = sv_newmortal();
 894             MAGIC *mg;
 895             /* Handle negative array indices 20020222 MJD */
 896             if (key < 0) {
 897                 unsigned adjust_index = 1;
 898                 if (tied_magic) {
 899                     SV **negative_indices_glob =
 900                         hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *)av,
 901                                                          tied_magic))),
 902                                  NEGATIVE_INDICES_VAR, 16, 0);
 903                     if (negative_indices_glob
 904                         && SvTRUE(GvSV(*negative_indices_glob)))
 905                         adjust_index = 0;
 906                 }
 907                 if (adjust_index) {
 908                     key += AvFILL(av) + 1;
 909                     if (key < 0)
 910                         return FALSE;
 911                 }
 912             }
 913
 914             mg_copy((SV*)av, sv, 0, key);
 915             mg = mg_find(sv, PERL_MAGIC_tiedelem);
 916             if (mg) {
 917                 magic_existspack(sv, mg);
 918                 return (bool)SvTRUE(sv);
 919             }
 920
 921         }
 922     }
 923
 924     if (key < 0) {
 925         key += AvFILL(av) + 1;
 926         if (key < 0)
 927             return FALSE;
 928     }
 929
 930     if (key <= AvFILLp(av) && AvARRAY(av)[key] != &PL_sv_undef
 931         && AvARRAY(av)[key])
 932     {
 933         return TRUE;
 934     }
 935     else
 936         return FALSE;
 937 }
 938
 939 /*
 940  * Local variables:
 941  * c-indentation-style: bsd
 942  * c-basic-offset: 4
 943  * indent-tabs-mode: t
 944  * End:
 945  *
 946  * ex: set ts=8 sts=4 sw=4 noet:
 947  */