av.c

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