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