av.c

   1 /*    av.c
   2  *
   3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
   4  *    2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
   5  *
   6  *    You may distribute under the terms of either the GNU General Public
   7  *    License or the Artistic License, as specified in the README file.
   8  *
   9  */
  10
  11 /*
  12  * "...for the Entwives desired order, and plenty, and peace (by which they
  13  * meant that things should remain where they had set them)." --Treebeard
  14  */
  15
  16 /*
  17 =head1 Array Manipulation Functions
  18 */
  19
  20 #include "EXTERN.h"
  21 #define PERL_IN_AV_C
  22 #include "perl.h"
  23
  24 void
  25 Perl_av_reify(pTHX_ AV *av)
  26 {
  27     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             SvREFCNT_inc_simple_void_NN(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
  65     mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied);
  66     if (mg) {
  67         dSP;
  68         ENTER;
  69         SAVETMPS;
  70         PUSHSTACKi(PERLSI_MAGIC);
  71         PUSHMARK(SP);
  72         EXTEND(SP,2);
  73         PUSHs(SvTIED_obj((SV*)av, mg));
  74         PUSHs(sv_2mortal(newSViv(key+1)));
  75         PUTBACK;
  76         call_method("EXTEND", G_SCALAR|G_DISCARD);
  77         POPSTACK;
  78         FREETMPS;
  79         LEAVE;
  80         return;
  81     }
  82     if (key > AvMAX(av)) {
  83         SV** ary;
  84         I32 tmp;
  85         I32 newmax;
  86
  87         if (AvALLOC(av) != AvARRAY(av)) {
  88             ary = AvALLOC(av) + AvFILLp(av) + 1;
  89             tmp = AvARRAY(av) - AvALLOC(av);
  90             Move(AvARRAY(av), AvALLOC(av), AvFILLp(av)+1, SV*);
  91             AvMAX(av) += tmp;
  92             SvPV_set(av, (char*)AvALLOC(av));
  93             if (AvREAL(av)) {
  94                 while (tmp)
  95                     ary[--tmp] = &PL_sv_undef;
  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                 Newx(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                 Newx(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             SvPV_set(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
 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             SV *sv;
 198             if (key < 0) {
 199                 I32 adjust_index = 1;
 200                 if (tied_magic) {
 201                     /* Handle negative array indices 20020222 MJD */
 202                     SV * const * const negative_indices_glob =
 203                         hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *)av, tied_magic))),
 204                                 NEGATIVE_INDICES_VAR, 16, 0);
 205
 206                     if (negative_indices_glob && SvTRUE(GvSV(*negative_indices_glob)))
 207                         adjust_index = 0;
 208                 }
 209
 210                 if (adjust_index) {
 211                     key += AvFILL(av) + 1;
 212                     if (key < 0)
 213                         return NULL;
 214                 }
 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 NULL;
 230     }
 231
 232     if (key > AvFILLp(av)) {
 233         if (!lval)
 234             return NULL;
 235         return av_store(av,key,newSV(0));
 236     }
 237     if (AvARRAY(av)[key] == &PL_sv_undef) {
 238     emptyness:
 239         if (lval)
 240             return av_store(av,key,newSV(0));
 241         return NULL;
 242     }
 243     else if (AvREIFY(av)
 244              && (!AvARRAY(av)[key]      /* eg. @_ could have freed elts */
 245                  || SvIS_FREED(AvARRAY(av)[key]))) {
 246         AvARRAY(av)[key] = &PL_sv_undef;        /* 1/2 reify */
 247         goto emptyness;
 248     }
 249     return &AvARRAY(av)[key];
 250 }
 251
 252 /*
 253 =for apidoc av_store
 254
 255 Stores an SV in an array.  The array index is specified as C<key>.  The
 256 return value will be NULL if the operation failed or if the value did not
 257 need to be actually stored within the array (as in the case of tied
 258 arrays). Otherwise it can be dereferenced to get the original C<SV*>.  Note
 259 that the caller is responsible for suitably incrementing the reference
 260 count of C<val> before the call, and decrementing it if the function
 261 returned NULL.
 262
 263 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
 264 more information on how to use this function on tied arrays.
 265
 266 =cut
 267 */
 268
 269 SV**
 270 Perl_av_store(pTHX_ register AV *av, I32 key, SV *val)
 271 {
 272     SV** ary;
 273
 274     if (!av)
 275         return 0;
 276     /* S_regclass relies on being able to pass in a NULL sv
 277        (unicode_alternate may be NULL).
 278     */
 279
 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                 bool adjust_index = 1;
 289                 SV * const * const 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 NULL;
 306         }
 307     }
 308
 309
 310     if (key < 0) {
 311         key += AvFILL(av) + 1;
 312         if (key < 0)
 313             return NULL;
 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             const MAGIC* const 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 * const av = (AV*)newSV(0);
 359
 360     sv_upgrade((SV *)av, SVt_PVAV);
 361     /* sv_upgrade does AvREAL_only()  */
 362     AvALLOC(av) = 0;
 363     SvPV_set(av, NULL);
 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 * const av = (AV*)newSV(0);
 382
 383     sv_upgrade((SV *) av,SVt_PVAV);
 384     /* sv_upgrade does AvREAL_only()  */
 385     if (size) {         /* "defined" was returning undef for size==0 anyway. */
 386         register SV** ary;
 387         register I32 i;
 388         Newx(ary,size,SV*);
 389         AvALLOC(av) = ary;
 390         SvPV_set(av, (char*)ary);
 391         AvFILLp(av) = AvMAX(av) = size - 1;
 392         for (i = 0; i < size; i++) {
 393             assert (*strp);
 394             ary[i] = newSV(0);
 395             sv_setsv(ary[i], *strp);
 396             strp++;
 397         }
 398     }
 399     return av;
 400 }
 401
 402 /*
 403 =for apidoc av_clear
 404
 405 Clears an array, making it empty.  Does not free the memory used by the
 406 array itself.
 407
 408 =cut
 409 */
 410
 411 void
 412 Perl_av_clear(pTHX_ register AV *av)
 413 {
 414     I32 extra;
 415
 416 /* XXX Should av_clear really be NN? */
 417 #ifdef DEBUGGING
 418     if (SvREFCNT(av) == 0 && ckWARN_d(WARN_DEBUGGING)) {
 419         Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "Attempt to clear deleted array");
 420     }
 421 #endif
 422     if (!av)
 423         return;
 424
 425     if (SvREADONLY(av))
 426         Perl_croak(aTHX_ PL_no_modify);
 427
 428     /* Give any tie a chance to cleanup first */
 429     if (SvRMAGICAL(av))
 430         mg_clear((SV*)av);
 431
 432     if (AvMAX(av) < 0)
 433         return;
 434
 435     if (AvREAL(av)) {
 436         SV** const ary = AvARRAY(av);
 437         I32 index = AvFILLp(av) + 1;
 438         while (index) {
 439             SV * const sv = ary[--index];
 440             /* undef the slot before freeing the value, because a
 441              * destructor might try to modify this array */
 442             ary[index] = &PL_sv_undef;
 443             SvREFCNT_dec(sv);
 444         }
 445     }
 446     extra = AvARRAY(av) - AvALLOC(av);
 447     if (extra) {
 448         AvMAX(av) += extra;
 449         SvPV_set(av, (char*)AvALLOC(av));
 450     }
 451     AvFILLp(av) = -1;
 452
 453 }
 454
 455 /*
 456 =for apidoc av_undef
 457
 458 Undefines the array.  Frees the memory used by the array itself.
 459
 460 =cut
 461 */
 462
 463 void
 464 Perl_av_undef(pTHX_ register AV *av)
 465 {
 466     if (!av)
 467         return;
 468
 469     /* Give any tie a chance to cleanup first */
 470     if (SvTIED_mg((SV*)av, PERL_MAGIC_tied))
 471         av_fill(av, -1);   /* mg_clear() ? */
 472
 473     if (AvREAL(av)) {
 474         register I32 key = AvFILLp(av) + 1;
 475         while (key)
 476             SvREFCNT_dec(AvARRAY(av)[--key]);
 477     }
 478     Safefree(AvALLOC(av));
 479     AvALLOC(av) = NULL;
 480     SvPV_set(av, NULL);
 481     AvMAX(av) = AvFILLp(av) = -1;
 482     /* Need to check SvMAGICAL, as during global destruction it may be that
 483        AvARYLEN(av) has been freed before av, and hence the SvANY() pointer
 484        is now part of the linked list of SV heads, rather than pointing to
 485        the original body.  */
 486     /* FIXME - audit the code for other bugs like this one.  */
 487     if (AvARYLEN(av) && SvMAGICAL(AvARYLEN(av))) {
 488         MAGIC *mg = mg_find (AvARYLEN(av), PERL_MAGIC_arylen);
 489
 490         if (mg) {
 491             /* arylen scalar holds a pointer back to the array, but doesn't
 492                own a reference. Hence the we (the array) are about to go away
 493                with it still pointing at us. Clear its pointer, else it would
 494                be pointing at free memory. See the comment in sv_magic about
 495                reference loops, and why it can't own a reference to us.  */
 496             mg->mg_obj = 0;
 497         }
 498
 499         SvREFCNT_dec(AvARYLEN(av));
 500         AvARYLEN(av) = 0;
 501     }
 502 }
 503
 504 /*
 505 =for apidoc av_push
 506
 507 Pushes an SV onto the end of the array.  The array will grow automatically
 508 to accommodate the addition.
 509
 510 =cut
 511 */
 512
 513 void
 514 Perl_av_push(pTHX_ register AV *av, SV *val)
 515 {
 516     MAGIC *mg;
 517     if (!av)
 518         return;
 519     if (SvREADONLY(av))
 520         Perl_croak(aTHX_ PL_no_modify);
 521
 522     if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
 523         dSP;
 524         PUSHSTACKi(PERLSI_MAGIC);
 525         PUSHMARK(SP);
 526         EXTEND(SP,2);
 527         PUSHs(SvTIED_obj((SV*)av, mg));
 528         PUSHs(val);
 529         PUTBACK;
 530         ENTER;
 531         call_method("PUSH", G_SCALAR|G_DISCARD);
 532         LEAVE;
 533         POPSTACK;
 534         return;
 535     }
 536     av_store(av,AvFILLp(av)+1,val);
 537 }
 538
 539 /*
 540 =for apidoc av_pop
 541
 542 Pops an SV off the end of the array.  Returns C<&PL_sv_undef> if the array
 543 is empty.
 544
 545 =cut
 546 */
 547
 548 SV *
 549 Perl_av_pop(pTHX_ register AV *av)
 550 {
 551     SV *retval;
 552     MAGIC* mg;
 553
 554     if (!av)
 555       return &PL_sv_undef;
 556     if (SvREADONLY(av))
 557         Perl_croak(aTHX_ PL_no_modify);
 558     if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
 559         dSP;
 560         PUSHSTACKi(PERLSI_MAGIC);
 561         PUSHMARK(SP);
 562         XPUSHs(SvTIED_obj((SV*)av, mg));
 563         PUTBACK;
 564         ENTER;
 565         if (call_method("POP", G_SCALAR)) {
 566             retval = newSVsv(*PL_stack_sp--);
 567         } else {
 568             retval = &PL_sv_undef;
 569         }
 570         LEAVE;
 571         POPSTACK;
 572         return retval;
 573     }
 574     if (AvFILL(av) < 0)
 575         return &PL_sv_undef;
 576     retval = AvARRAY(av)[AvFILLp(av)];
 577     AvARRAY(av)[AvFILLp(av)--] = &PL_sv_undef;
 578     if (SvSMAGICAL(av))
 579         mg_set((SV*)av);
 580     return retval;
 581 }
 582
 583 /*
 584 =for apidoc av_unshift
 585
 586 Unshift the given number of C<undef> values onto the beginning of the
 587 array.  The array will grow automatically to accommodate the addition.  You
 588 must then use C<av_store> to assign values to these new elements.
 589
 590 =cut
 591 */
 592
 593 void
 594 Perl_av_unshift(pTHX_ register AV *av, register I32 num)
 595 {
 596     register I32 i;
 597     MAGIC* mg;
 598
 599     if (!av)
 600         return;
 601     if (SvREADONLY(av))
 602         Perl_croak(aTHX_ PL_no_modify);
 603
 604     if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
 605         dSP;
 606         PUSHSTACKi(PERLSI_MAGIC);
 607         PUSHMARK(SP);
 608         EXTEND(SP,1+num);
 609         PUSHs(SvTIED_obj((SV*)av, mg));
 610         while (num-- > 0) {
 611             PUSHs(&PL_sv_undef);
 612         }
 613         PUTBACK;
 614         ENTER;
 615         call_method("UNSHIFT", G_SCALAR|G_DISCARD);
 616         LEAVE;
 617         POPSTACK;
 618         return;
 619     }
 620
 621     if (num <= 0)
 622       return;
 623     if (!AvREAL(av) && AvREIFY(av))
 624         av_reify(av);
 625     i = AvARRAY(av) - AvALLOC(av);
 626     if (i) {
 627         if (i > num)
 628             i = num;
 629         num -= i;
 630
 631         AvMAX(av) += i;
 632         AvFILLp(av) += i;
 633         SvPV_set(av, (char*)(AvARRAY(av) - i));
 634     }
 635     if (num) {
 636         register SV **ary;
 637         I32 slide;
 638         i = AvFILLp(av);
 639         /* Create extra elements */
 640         slide = i > 0 ? i : 0;
 641         num += slide;
 642         av_extend(av, i + num);
 643         AvFILLp(av) += num;
 644         ary = AvARRAY(av);
 645         Move(ary, ary + num, i + 1, SV*);
 646         do {
 647             ary[--num] = &PL_sv_undef;
 648         } while (num);
 649         /* Make extra elements into a buffer */
 650         AvMAX(av) -= slide;
 651         AvFILLp(av) -= slide;
 652         SvPV_set(av, (char*)(AvARRAY(av) + slide));
 653     }
 654 }
 655
 656 /*
 657 =for apidoc av_shift
 658
 659 Shifts an SV off the beginning of the array.
 660
 661 =cut
 662 */
 663
 664 SV *
 665 Perl_av_shift(pTHX_ register AV *av)
 666 {
 667     SV *retval;
 668     MAGIC* mg;
 669
 670     if (!av)
 671         return &PL_sv_undef;
 672     if (SvREADONLY(av))
 673         Perl_croak(aTHX_ PL_no_modify);
 674     if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
 675         dSP;
 676         PUSHSTACKi(PERLSI_MAGIC);
 677         PUSHMARK(SP);
 678         XPUSHs(SvTIED_obj((SV*)av, mg));
 679         PUTBACK;
 680         ENTER;
 681         if (call_method("SHIFT", G_SCALAR)) {
 682             retval = newSVsv(*PL_stack_sp--);
 683         } else {
 684             retval = &PL_sv_undef;
 685         }
 686         LEAVE;
 687         POPSTACK;
 688         return retval;
 689     }
 690     if (AvFILL(av) < 0)
 691       return &PL_sv_undef;
 692     retval = *AvARRAY(av);
 693     if (AvREAL(av))
 694         *AvARRAY(av) = &PL_sv_undef;
 695     SvPV_set(av, (char*)(AvARRAY(av) + 1));
 696     AvMAX(av)--;
 697     AvFILLp(av)--;
 698     if (SvSMAGICAL(av))
 699         mg_set((SV*)av);
 700     return retval;
 701 }
 702
 703 /*
 704 =for apidoc av_len
 705
 706 Returns the highest index in the array.  Returns -1 if the array is
 707 empty.
 708
 709 =cut
 710 */
 711
 712 I32
 713 Perl_av_len(pTHX_ register AV *av)
 714 {
 715     return AvFILL(av);
 716 }
 717
 718 /*
 719 =for apidoc av_fill
 720
 721 Ensure than an array has a given number of elements, equivalent to
 722 Perl's C<$#array = $fill;>.
 723
 724 =cut
 725 */
 726 void
 727 Perl_av_fill(pTHX_ register AV *av, I32 fill)
 728 {
 729     MAGIC *mg;
 730     if (!av)
 731         Perl_croak(aTHX_ "panic: null array");
 732     if (fill < 0)
 733         fill = -1;
 734     if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
 735         dSP;
 736         ENTER;
 737         SAVETMPS;
 738         PUSHSTACKi(PERLSI_MAGIC);
 739         PUSHMARK(SP);
 740         EXTEND(SP,2);
 741         PUSHs(SvTIED_obj((SV*)av, mg));
 742         PUSHs(sv_2mortal(newSViv(fill+1)));
 743         PUTBACK;
 744         call_method("STORESIZE", G_SCALAR|G_DISCARD);
 745         POPSTACK;
 746         FREETMPS;
 747         LEAVE;
 748         return;
 749     }
 750     if (fill <= AvMAX(av)) {
 751         I32 key = AvFILLp(av);
 752         SV** const ary = AvARRAY(av);
 753
 754         if (AvREAL(av)) {
 755             while (key > fill) {
 756                 SvREFCNT_dec(ary[key]);
 757                 ary[key--] = &PL_sv_undef;
 758             }
 759         }
 760         else {
 761             while (key < fill)
 762                 ary[++key] = &PL_sv_undef;
 763         }
 764
 765         AvFILLp(av) = fill;
 766         if (SvSMAGICAL(av))
 767             mg_set((SV*)av);
 768     }
 769     else
 770         (void)av_store(av,fill,&PL_sv_undef);
 771 }
 772
 773 /*
 774 =for apidoc av_delete
 775
 776 Deletes the element indexed by C<key> from the array.  Returns the
 777 deleted element. If C<flags> equals C<G_DISCARD>, the element is freed
 778 and null is returned.
 779
 780 =cut
 781 */
 782 SV *
 783 Perl_av_delete(pTHX_ AV *av, I32 key, I32 flags)
 784 {
 785     SV *sv;
 786
 787     if (!av)
 788         return NULL;
 789     if (SvREADONLY(av))
 790         Perl_croak(aTHX_ PL_no_modify);
 791
 792     if (SvRMAGICAL(av)) {
 793         const MAGIC * const tied_magic = mg_find((SV*)av, PERL_MAGIC_tied);
 794         if ((tied_magic || mg_find((SV*)av, PERL_MAGIC_regdata))) {
 795             /* Handle negative array indices 20020222 MJD */
 796             SV **svp;
 797             if (key < 0) {
 798                 unsigned adjust_index = 1;
 799                 if (tied_magic) {
 800                     SV * const * const negative_indices_glob =
 801                         hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *)av,
 802                                                          tied_magic))),
 803                                  NEGATIVE_INDICES_VAR, 16, 0);
 804                     if (negative_indices_glob
 805                         && SvTRUE(GvSV(*negative_indices_glob)))
 806                         adjust_index = 0;
 807                 }
 808                 if (adjust_index) {
 809                     key += AvFILL(av) + 1;
 810                     if (key < 0)
 811                         return NULL;
 812                 }
 813             }
 814             svp = av_fetch(av, key, TRUE);
 815             if (svp) {
 816                 sv = *svp;
 817                 mg_clear(sv);
 818                 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
 819                     sv_unmagic(sv, PERL_MAGIC_tiedelem); /* No longer an element */
 820                     return sv;
 821                 }
 822                 return NULL;
 823             }
 824         }
 825     }
 826
 827     if (key < 0) {
 828         key += AvFILL(av) + 1;
 829         if (key < 0)
 830             return NULL;
 831     }
 832
 833     if (key > AvFILLp(av))
 834         return NULL;
 835     else {
 836         if (!AvREAL(av) && AvREIFY(av))
 837             av_reify(av);
 838         sv = AvARRAY(av)[key];
 839         if (key == AvFILLp(av)) {
 840             AvARRAY(av)[key] = &PL_sv_undef;
 841             do {
 842                 AvFILLp(av)--;
 843             } while (--key >= 0 && AvARRAY(av)[key] == &PL_sv_undef);
 844         }
 845         else
 846             AvARRAY(av)[key] = &PL_sv_undef;
 847         if (SvSMAGICAL(av))
 848             mg_set((SV*)av);
 849     }
 850     if (flags & G_DISCARD) {
 851         SvREFCNT_dec(sv);
 852         sv = NULL;
 853     }
 854     else if (AvREAL(av))
 855         sv = sv_2mortal(sv);
 856     return sv;
 857 }
 858
 859 /*
 860 =for apidoc av_exists
 861
 862 Returns true if the element indexed by C<key> has been initialized.
 863
 864 This relies on the fact that uninitialized array elements are set to
 865 C<&PL_sv_undef>.
 866
 867 =cut
 868 */
 869 bool
 870 Perl_av_exists(pTHX_ AV *av, I32 key)
 871 {
 872     if (!av)
 873         return FALSE;
 874
 875
 876     if (SvRMAGICAL(av)) {
 877         const MAGIC * const tied_magic = mg_find((SV*)av, PERL_MAGIC_tied);
 878         if (tied_magic || mg_find((SV*)av, PERL_MAGIC_regdata)) {
 879             SV * const sv = sv_newmortal();
 880             MAGIC *mg;
 881             /* Handle negative array indices 20020222 MJD */
 882             if (key < 0) {
 883                 unsigned adjust_index = 1;
 884                 if (tied_magic) {
 885                     SV * const * const negative_indices_glob =
 886                         hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *)av,
 887                                                          tied_magic))),
 888                                  NEGATIVE_INDICES_VAR, 16, 0);
 889                     if (negative_indices_glob
 890                         && SvTRUE(GvSV(*negative_indices_glob)))
 891                         adjust_index = 0;
 892                 }
 893                 if (adjust_index) {
 894                     key += AvFILL(av) + 1;
 895                     if (key < 0)
 896                         return FALSE;
 897                 }
 898             }
 899
 900             mg_copy((SV*)av, sv, 0, key);
 901             mg = mg_find(sv, PERL_MAGIC_tiedelem);
 902             if (mg) {
 903                 magic_existspack(sv, mg);
 904                 return (bool)SvTRUE(sv);
 905             }
 906
 907         }
 908     }
 909
 910     if (key < 0) {
 911         key += AvFILL(av) + 1;
 912         if (key < 0)
 913             return FALSE;
 914     }
 915
 916     if (key <= AvFILLp(av) && AvARRAY(av)[key] != &PL_sv_undef
 917         && AvARRAY(av)[key])
 918     {
 919         return TRUE;
 920     }
 921     else
 922         return FALSE;
 923 }
 924
 925 /* AVHV: Support for treating arrays as if they were hashes.  The
 926  * first element of the array should be a hash reference that maps
 927  * hash keys to array indices.
 928  */
 929
 930 STATIC I32
 931 S_avhv_index_sv(pTHX_ SV* sv)
 932 {
 933     I32 index = SvIV(sv);
 934     if (index < 1)
 935         Perl_croak(aTHX_ "Bad index while coercing array into hash");
 936     return index;
 937 }
 938
 939 STATIC I32
 940 S_avhv_index(pTHX_ AV *av, SV *keysv, U32 hash)
 941 {
 942     HV *keys;
 943     HE *he;
 944     STRLEN n_a;
 945
 946     keys = avhv_keys(av);
 947     he = hv_fetch_ent(keys, keysv, FALSE, hash);
 948     if (!he)
 949         Perl_croak(aTHX_ "No such pseudo-hash field \"%s\"", SvPV(keysv,n_a));
 950     return avhv_index_sv(HeVAL(he));
 951 }
 952
 953 HV*
 954 Perl_avhv_keys(pTHX_ AV *av)
 955 {
 956     SV **keysp = av_fetch(av, 0, FALSE);
 957     if (keysp) {
 958         SV *sv = *keysp;
 959         if (SvGMAGICAL(sv))
 960             mg_get(sv);
 961         if (SvROK(sv)) {
 962             if (ckWARN(WARN_DEPRECATED) && !sv_isa(sv, "pseudohash"))
 963                 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
 964                             "Pseudo-hashes are deprecated");
 965             sv = SvRV(sv);
 966             if (SvTYPE(sv) == SVt_PVHV)
 967                 return (HV*)sv;
 968         }
 969     }
 970     Perl_croak(aTHX_ "Can't coerce array into hash");
 971     return Nullhv;
 972 }
 973
 974 SV**
 975 Perl_avhv_store_ent(pTHX_ AV *av, SV *keysv, SV *val, U32 hash)
 976 {
 977     return av_store(av, avhv_index(av, keysv, hash), val);
 978 }
 979
 980 SV**
 981 Perl_avhv_fetch_ent(pTHX_ AV *av, SV *keysv, I32 lval, U32 hash)
 982 {
 983     return av_fetch(av, avhv_index(av, keysv, hash), lval);
 984 }
 985
 986 SV *
 987 Perl_avhv_delete_ent(pTHX_ AV *av, SV *keysv, I32 flags, U32 hash)
 988 {
 989     HV *keys = avhv_keys(av);
 990     HE *he;
 991
 992     he = hv_fetch_ent(keys, keysv, FALSE, hash);
 993     if (!he || !SvOK(HeVAL(he)))
 994         return Nullsv;
 995
 996     return av_delete(av, avhv_index_sv(HeVAL(he)), flags);
 997 }
 998
 999 /* Check for the existence of an element named by a given key.
1000  *
1001  */
1002 bool
1003 Perl_avhv_exists_ent(pTHX_ AV *av, SV *keysv, U32 hash)
1004 {
1005     HV *keys = avhv_keys(av);
1006     HE *he;
1007
1008     he = hv_fetch_ent(keys, keysv, FALSE, hash);
1009     if (!he || !SvOK(HeVAL(he)))
1010         return FALSE;
1011
1012     return av_exists(av, avhv_index_sv(HeVAL(he)));
1013 }
1014
1015 HE *
1016 Perl_avhv_iternext(pTHX_ AV *av)
1017 {
1018     HV *keys = avhv_keys(av);
1019     return hv_iternext(keys);
1020 }
1021
1022 SV *
1023 Perl_avhv_iterval(pTHX_ AV *av, register HE *entry)
1024 {
1025     SV *sv = hv_iterval(avhv_keys(av), entry);
1026     return *av_fetch(av, avhv_index_sv(sv), TRUE);
1027 }
1028
1029 /*
1030  * Local variables:
1031  * c-indentation-style: bsd
1032  * c-basic-offset: 4
1033  * indent-tabs-mode: t
1034  * End:
1035  *
1036  * ex: set ts=8 sts=4 sw=4 noet:
1037  */