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     SSize_t 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, SSize_t 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, SSize_t 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         SSize_t tmp;
  97         SSize_t 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, SSize_t *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 && isGV(*negative_indices_glob)
 205              && SvTRUE(GvSV(*negative_indices_glob)))
 206                 adjust_index = 0;
 207         }
 208     }
 209
 210     if (adjust_index) {
 211         *keyp += AvFILL(av) + 1;
 212         if (*keyp < 0)
 213             return FALSE;
 214     }
 215     return TRUE;
 216 }
 217
 218 SV**
 219 Perl_av_fetch(pTHX_ AV *av, SSize_t key, I32 lval)
 220 {
 221     dVAR;
 222
 223     PERL_ARGS_ASSERT_AV_FETCH;
 224     assert(SvTYPE(av) == SVt_PVAV);
 225
 226     if (SvRMAGICAL(av)) {
 227         const MAGIC * const tied_magic
 228             = mg_find((const SV *)av, PERL_MAGIC_tied);
 229         if (tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata)) {
 230             SV *sv;
 231             if (key < 0) {
 232                 if (!S_adjust_index(aTHX_ av, tied_magic, &key))
 233                         return NULL;
 234             }
 235
 236             sv = sv_newmortal();
 237             sv_upgrade(sv, SVt_PVLV);
 238             mg_copy(MUTABLE_SV(av), sv, 0, key);
 239             if (!tied_magic) /* for regdata, force leavesub to make copies */
 240                 SvTEMP_off(sv);
 241             LvTYPE(sv) = 't';
 242             LvTARG(sv) = sv; /* fake (SV**) */
 243             return &(LvTARG(sv));
 244         }
 245     }
 246
 247     if (key < 0) {
 248         key += AvFILL(av) + 1;
 249         if (key < 0)
 250             return NULL;
 251     }
 252
 253     if (key > AvFILLp(av) || !AvARRAY(av)[key]) {
 254       emptyness:
 255         return lval ? av_store(av,key,newSV(0)) : NULL;
 256     }
 257
 258     if (AvREIFY(av)
 259              && (!AvARRAY(av)[key]      /* eg. @_ could have freed elts */
 260                  || SvIS_FREED(AvARRAY(av)[key]))) {
 261         AvARRAY(av)[key] = NULL;        /* 1/2 reify */
 262         goto emptyness;
 263     }
 264     return &AvARRAY(av)[key];
 265 }
 266
 267 /*
 268 =for apidoc av_store
 269
 270 Stores an SV in an array.  The array index is specified as C<key>.  The
 271 return value will be NULL if the operation failed or if the value did not
 272 need to be actually stored within the array (as in the case of tied
 273 arrays). Otherwise, it can be dereferenced
 274 to get the C<SV*> that was stored
 275 there (= C<val>)).
 276
 277 Note that the caller is responsible for suitably incrementing the reference
 278 count of C<val> before the call, and decrementing it if the function
 279 returned NULL.
 280
 281 Approximate Perl equivalent: C<$myarray[$key] = $val;>.
 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_ AV *av, SSize_t key, SV *val)
 291 {
 292     dVAR;
 293     SV** ary;
 294
 295     PERL_ARGS_ASSERT_AV_STORE;
 296     assert(SvTYPE(av) == SVt_PVAV);
 297
 298     /* S_regclass relies on being able to pass in a NULL sv
 299        (unicode_alternate may be NULL).
 300     */
 301
 302     if (SvRMAGICAL(av)) {
 303         const MAGIC * const tied_magic = mg_find((const SV *)av, PERL_MAGIC_tied);
 304         if (tied_magic) {
 305             if (key < 0) {
 306                 if (!S_adjust_index(aTHX_ av, tied_magic, &key))
 307                         return 0;
 308             }
 309             if (val) {
 310                 mg_copy(MUTABLE_SV(av), val, 0, key);
 311             }
 312             return NULL;
 313         }
 314     }
 315
 316
 317     if (key < 0) {
 318         key += AvFILL(av) + 1;
 319         if (key < 0)
 320             return NULL;
 321     }
 322
 323     if (SvREADONLY(av) && key >= AvFILL(av))
 324         Perl_croak_no_modify();
 325
 326     if (!AvREAL(av) && AvREIFY(av))
 327         av_reify(av);
 328     if (key > AvMAX(av))
 329         av_extend(av,key);
 330     ary = AvARRAY(av);
 331     if (AvFILLp(av) < key) {
 332         if (!AvREAL(av)) {
 333             if (av == PL_curstack && key > PL_stack_sp - PL_stack_base)
 334                 PL_stack_sp = PL_stack_base + key;      /* XPUSH in disguise */
 335             do {
 336                 ary[++AvFILLp(av)] = NULL;
 337             } while (AvFILLp(av) < key);
 338         }
 339         AvFILLp(av) = key;
 340     }
 341     else if (AvREAL(av))
 342         SvREFCNT_dec(ary[key]);
 343     ary[key] = val;
 344     if (SvSMAGICAL(av)) {
 345         const MAGIC *mg = SvMAGIC(av);
 346         bool set = TRUE;
 347         for (; mg; mg = mg->mg_moremagic) {
 348           if (!isUPPER(mg->mg_type)) continue;
 349           if (val) {
 350             sv_magic(val, MUTABLE_SV(av), toLOWER(mg->mg_type), 0, key);
 351           }
 352           if (PL_delaymagic && mg->mg_type == PERL_MAGIC_isa) {
 353             PL_delaymagic |= DM_ARRAY_ISA;
 354             set = FALSE;
 355           }
 356         }
 357         if (set)
 358            mg_set(MUTABLE_SV(av));
 359     }
 360     return &ary[key];
 361 }
 362
 363 /*
 364 =for apidoc av_make
 365
 366 Creates a new AV and populates it with a list of SVs.  The SVs are copied
 367 into the array, so they may be freed after the call to av_make.  The new AV
 368 will have a reference count of 1.
 369
 370 Perl equivalent: C<my @new_array = ($scalar1, $scalar2, $scalar3...);>
 371
 372 =cut
 373 */
 374
 375 AV *
 376 Perl_av_make(pTHX_ SSize_t size, SV **strp)
 377 {
 378     AV * const av = MUTABLE_AV(newSV_type(SVt_PVAV));
 379     /* sv_upgrade does AvREAL_only()  */
 380     PERL_ARGS_ASSERT_AV_MAKE;
 381     assert(SvTYPE(av) == SVt_PVAV);
 382
 383     if (size) {         /* "defined" was returning undef for size==0 anyway. */
 384         SV** ary;
 385         SSize_t i;
 386         Newx(ary,size,SV*);
 387         AvALLOC(av) = ary;
 388         AvARRAY(av) = ary;
 389         AvMAX(av) = size - 1;
 390         AvFILLp(av) = -1;
 391         ENTER;
 392         SAVEFREESV(av);
 393         for (i = 0; i < size; i++) {
 394             assert (*strp);
 395
 396             /* Don't let sv_setsv swipe, since our source array might
 397                have multiple references to the same temp scalar (e.g.
 398                from a list slice) */
 399
 400             SvGETMAGIC(*strp); /* before newSV, in case it dies */
 401             AvFILLp(av)++;
 402             ary[i] = newSV(0);
 403             sv_setsv_flags(ary[i], *strp,
 404                            SV_DO_COW_SVSETSV|SV_NOSTEAL);
 405             strp++;
 406         }
 407         SvREFCNT_inc_simple_void_NN(av);
 408         LEAVE;
 409     }
 410     return av;
 411 }
 412
 413 /*
 414 =for apidoc av_clear
 415
 416 Clears an array, making it empty.  Does not free the memory the av uses to
 417 store its list of scalars.  If any destructors are triggered as a result,
 418 the av itself may be freed when this function returns.
 419
 420 Perl equivalent: C<@myarray = ();>.
 421
 422 =cut
 423 */
 424
 425 void
 426 Perl_av_clear(pTHX_ AV *av)
 427 {
 428     dVAR;
 429     SSize_t extra;
 430     bool real;
 431
 432     PERL_ARGS_ASSERT_AV_CLEAR;
 433     assert(SvTYPE(av) == SVt_PVAV);
 434
 435 #ifdef DEBUGGING
 436     if (SvREFCNT(av) == 0) {
 437         Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "Attempt to clear deleted array");
 438     }
 439 #endif
 440
 441     if (SvREADONLY(av))
 442         Perl_croak_no_modify();
 443
 444     /* Give any tie a chance to cleanup first */
 445     if (SvRMAGICAL(av)) {
 446         const MAGIC* const mg = SvMAGIC(av);
 447         if (PL_delaymagic && mg && mg->mg_type == PERL_MAGIC_isa)
 448             PL_delaymagic |= DM_ARRAY_ISA;
 449         else
 450             mg_clear(MUTABLE_SV(av));
 451     }
 452
 453     if (AvMAX(av) < 0)
 454         return;
 455
 456     if ((real = !!AvREAL(av))) {
 457         SV** const ary = AvARRAY(av);
 458         SSize_t index = AvFILLp(av) + 1;
 459         ENTER;
 460         SAVEFREESV(SvREFCNT_inc_simple_NN(av));
 461         while (index) {
 462             SV * const sv = ary[--index];
 463             /* undef the slot before freeing the value, because a
 464              * destructor might try to modify this array */
 465             ary[index] = NULL;
 466             SvREFCNT_dec(sv);
 467         }
 468     }
 469     extra = AvARRAY(av) - AvALLOC(av);
 470     if (extra) {
 471         AvMAX(av) += extra;
 472         AvARRAY(av) = AvALLOC(av);
 473     }
 474     AvFILLp(av) = -1;
 475     if (real) LEAVE;
 476 }
 477
 478 /*
 479 =for apidoc av_undef
 480
 481 Undefines the array.  Frees the memory used by the av to store its list of
 482 scalars.  If any destructors are triggered as a result, the av itself may
 483 be freed.
 484
 485 =cut
 486 */
 487
 488 void
 489 Perl_av_undef(pTHX_ AV *av)
 490 {
 491     bool real;
 492
 493     PERL_ARGS_ASSERT_AV_UNDEF;
 494     assert(SvTYPE(av) == SVt_PVAV);
 495
 496     /* Give any tie a chance to cleanup first */
 497     if (SvTIED_mg((const SV *)av, PERL_MAGIC_tied))
 498         av_fill(av, -1);
 499
 500     if ((real = !!AvREAL(av))) {
 501         SSize_t key = AvFILLp(av) + 1;
 502         ENTER;
 503         SAVEFREESV(SvREFCNT_inc_simple_NN(av));
 504         while (key)
 505             SvREFCNT_dec(AvARRAY(av)[--key]);
 506     }
 507
 508     Safefree(AvALLOC(av));
 509     AvALLOC(av) = NULL;
 510     AvARRAY(av) = NULL;
 511     AvMAX(av) = AvFILLp(av) = -1;
 512
 513     if(SvRMAGICAL(av)) mg_clear(MUTABLE_SV(av));
 514     if(real) LEAVE;
 515 }
 516
 517 /*
 518
 519 =for apidoc av_create_and_push
 520
 521 Push an SV onto the end of the array, creating the array if necessary.
 522 A small internal helper function to remove a commonly duplicated idiom.
 523
 524 =cut
 525 */
 526
 527 void
 528 Perl_av_create_and_push(pTHX_ AV **const avp, SV *const val)
 529 {
 530     PERL_ARGS_ASSERT_AV_CREATE_AND_PUSH;
 531
 532     if (!*avp)
 533         *avp = newAV();
 534     av_push(*avp, val);
 535 }
 536
 537 /*
 538 =for apidoc av_push
 539
 540 Pushes an SV onto the end of the array.  The array will grow automatically
 541 to accommodate the addition.  This takes ownership of one reference count.
 542
 543 Perl equivalent: C<push @myarray, $elem;>.
 544
 545 =cut
 546 */
 547
 548 void
 549 Perl_av_push(pTHX_ AV *av, SV *val)
 550 {
 551     dVAR;
 552     MAGIC *mg;
 553
 554     PERL_ARGS_ASSERT_AV_PUSH;
 555     assert(SvTYPE(av) == SVt_PVAV);
 556
 557     if (SvREADONLY(av))
 558         Perl_croak_no_modify();
 559
 560     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
 561         Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(PUSH), G_DISCARD, 1,
 562                             val);
 563         return;
 564     }
 565     av_store(av,AvFILLp(av)+1,val);
 566 }
 567
 568 /*
 569 =for apidoc av_pop
 570
 571 Removes one SV from the end of the array, reducing its size by one and
 572 returning the SV (transferring control of one reference count) to the
 573 caller.  Returns C<&PL_sv_undef> if the array is empty.
 574
 575 Perl equivalent: C<pop(@myarray);>
 576
 577 =cut
 578 */
 579
 580 SV *
 581 Perl_av_pop(pTHX_ AV *av)
 582 {
 583     dVAR;
 584     SV *retval;
 585     MAGIC* mg;
 586
 587     PERL_ARGS_ASSERT_AV_POP;
 588     assert(SvTYPE(av) == SVt_PVAV);
 589
 590     if (SvREADONLY(av))
 591         Perl_croak_no_modify();
 592     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
 593         retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(POP), 0, 0);
 594         if (retval)
 595             retval = newSVsv(retval);
 596         return retval;
 597     }
 598     if (AvFILL(av) < 0)
 599         return &PL_sv_undef;
 600     retval = AvARRAY(av)[AvFILLp(av)];
 601     AvARRAY(av)[AvFILLp(av)--] = NULL;
 602     if (SvSMAGICAL(av))
 603         mg_set(MUTABLE_SV(av));
 604     return retval ? retval : &PL_sv_undef;
 605 }
 606
 607 /*
 608
 609 =for apidoc av_create_and_unshift_one
 610
 611 Unshifts an SV onto the beginning of the array, creating the array if
 612 necessary.
 613 A small internal helper function to remove a commonly duplicated idiom.
 614
 615 =cut
 616 */
 617
 618 SV **
 619 Perl_av_create_and_unshift_one(pTHX_ AV **const avp, SV *const val)
 620 {
 621     PERL_ARGS_ASSERT_AV_CREATE_AND_UNSHIFT_ONE;
 622
 623     if (!*avp)
 624         *avp = newAV();
 625     av_unshift(*avp, 1);
 626     return av_store(*avp, 0, val);
 627 }
 628
 629 /*
 630 =for apidoc av_unshift
 631
 632 Unshift the given number of C<undef> values onto the beginning of the
 633 array.  The array will grow automatically to accommodate the addition.  You
 634 must then use C<av_store> to assign values to these new elements.
 635
 636 Perl equivalent: C<unshift @myarray, ( (undef) x $n );>
 637
 638 =cut
 639 */
 640
 641 void
 642 Perl_av_unshift(pTHX_ AV *av, SSize_t num)
 643 {
 644     dVAR;
 645     SSize_t i;
 646     MAGIC* mg;
 647
 648     PERL_ARGS_ASSERT_AV_UNSHIFT;
 649     assert(SvTYPE(av) == SVt_PVAV);
 650
 651     if (SvREADONLY(av))
 652         Perl_croak_no_modify();
 653
 654     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
 655         Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(UNSHIFT),
 656                             G_DISCARD | G_UNDEF_FILL, num);
 657         return;
 658     }
 659
 660     if (num <= 0)
 661       return;
 662     if (!AvREAL(av) && AvREIFY(av))
 663         av_reify(av);
 664     i = AvARRAY(av) - AvALLOC(av);
 665     if (i) {
 666         if (i > num)
 667             i = num;
 668         num -= i;
 669
 670         AvMAX(av) += i;
 671         AvFILLp(av) += i;
 672         AvARRAY(av) = AvARRAY(av) - i;
 673     }
 674     if (num) {
 675         SV **ary;
 676         const SSize_t i = AvFILLp(av);
 677         /* Create extra elements */
 678         const SSize_t slide = i > 0 ? i : 0;
 679         num += slide;
 680         av_extend(av, i + num);
 681         AvFILLp(av) += num;
 682         ary = AvARRAY(av);
 683         Move(ary, ary + num, i + 1, SV*);
 684         do {
 685             ary[--num] = NULL;
 686         } while (num);
 687         /* Make extra elements into a buffer */
 688         AvMAX(av) -= slide;
 689         AvFILLp(av) -= slide;
 690         AvARRAY(av) = AvARRAY(av) + slide;
 691     }
 692 }
 693
 694 /*
 695 =for apidoc av_shift
 696
 697 Removes one SV from the start of the array, reducing its size by one and
 698 returning the SV (transferring control of one reference count) to the
 699 caller.  Returns C<&PL_sv_undef> if the array is empty.
 700
 701 Perl equivalent: C<shift(@myarray);>
 702
 703 =cut
 704 */
 705
 706 SV *
 707 Perl_av_shift(pTHX_ AV *av)
 708 {
 709     dVAR;
 710     SV *retval;
 711     MAGIC* mg;
 712
 713     PERL_ARGS_ASSERT_AV_SHIFT;
 714     assert(SvTYPE(av) == SVt_PVAV);
 715
 716     if (SvREADONLY(av))
 717         Perl_croak_no_modify();
 718     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
 719         retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(SHIFT), 0, 0);
 720         if (retval)
 721             retval = newSVsv(retval);
 722         return retval;
 723     }
 724     if (AvFILL(av) < 0)
 725       return &PL_sv_undef;
 726     retval = *AvARRAY(av);
 727     if (AvREAL(av))
 728         *AvARRAY(av) = NULL;
 729     AvARRAY(av) = AvARRAY(av) + 1;
 730     AvMAX(av)--;
 731     AvFILLp(av)--;
 732     if (SvSMAGICAL(av))
 733         mg_set(MUTABLE_SV(av));
 734     return retval ? retval : &PL_sv_undef;
 735 }
 736
 737 /*
 738 =for apidoc av_top_index
 739
 740 Returns the highest index in the array.  The number of elements in the
 741 array is C<av_top_index(av) + 1>.  Returns -1 if the array is empty.
 742
 743 The Perl equivalent for this is C<$#myarray>.
 744
 745 (A slightly shorter form is C<av_tindex>.)
 746
 747 =for apidoc av_len
 748
 749 Same as L</av_top_index>.  Returns the highest index in the array.  Note that the
 750 return value is +1 what its name implies it returns; and hence differs in
 751 meaning from what the similarly named L</sv_len> returns.
 752
 753 =cut
 754 */
 755
 756 SSize_t
 757 Perl_av_len(pTHX_ AV *av)
 758 {
 759     PERL_ARGS_ASSERT_AV_LEN;
 760
 761     return av_top_index(av);
 762 }
 763
 764 /*
 765 =for apidoc av_fill
 766
 767 Set the highest index in the array to the given number, equivalent to
 768 Perl's C<$#array = $fill;>.
 769
 770 The number of elements in the an array will be C<fill + 1> after
 771 av_fill() returns.  If the array was previously shorter, then the
 772 additional elements appended are set to NULL.  If the array
 773 was longer, then the excess elements are freed.  C<av_fill(av, -1)> is
 774 the same as C<av_clear(av)>.
 775
 776 =cut
 777 */
 778 void
 779 Perl_av_fill(pTHX_ AV *av, SSize_t fill)
 780 {
 781     dVAR;
 782     MAGIC *mg;
 783
 784     PERL_ARGS_ASSERT_AV_FILL;
 785     assert(SvTYPE(av) == SVt_PVAV);
 786
 787     if (fill < 0)
 788         fill = -1;
 789     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
 790         SV *arg1 = sv_newmortal();
 791         sv_setiv(arg1, (IV)(fill + 1));
 792         Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(STORESIZE), G_DISCARD,
 793                             1, arg1);
 794         return;
 795     }
 796     if (fill <= AvMAX(av)) {
 797         SSize_t key = AvFILLp(av);
 798         SV** const ary = AvARRAY(av);
 799
 800         if (AvREAL(av)) {
 801             while (key > fill) {
 802                 SvREFCNT_dec(ary[key]);
 803                 ary[key--] = NULL;
 804             }
 805         }
 806         else {
 807             while (key < fill)
 808                 ary[++key] = NULL;
 809         }
 810
 811         AvFILLp(av) = fill;
 812         if (SvSMAGICAL(av))
 813             mg_set(MUTABLE_SV(av));
 814     }
 815     else
 816         (void)av_store(av,fill,NULL);
 817 }
 818
 819 /*
 820 =for apidoc av_delete
 821
 822 Deletes the element indexed by C<key> from the array, makes the element mortal,
 823 and returns it.  If C<flags> equals C<G_DISCARD>, the element is freed and null
 824 is returned.  Perl equivalent: C<my $elem = delete($myarray[$idx]);> for the
 825 non-C<G_DISCARD> version and a void-context C<delete($myarray[$idx]);> for the
 826 C<G_DISCARD> version.
 827
 828 =cut
 829 */
 830 SV *
 831 Perl_av_delete(pTHX_ AV *av, SSize_t key, I32 flags)
 832 {
 833     dVAR;
 834     SV *sv;
 835
 836     PERL_ARGS_ASSERT_AV_DELETE;
 837     assert(SvTYPE(av) == SVt_PVAV);
 838
 839     if (SvREADONLY(av))
 840         Perl_croak_no_modify();
 841
 842     if (SvRMAGICAL(av)) {
 843         const MAGIC * const tied_magic
 844             = mg_find((const SV *)av, PERL_MAGIC_tied);
 845         if ((tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata))) {
 846             SV **svp;
 847             if (key < 0) {
 848                 if (!S_adjust_index(aTHX_ av, tied_magic, &key))
 849                         return NULL;
 850             }
 851             svp = av_fetch(av, key, TRUE);
 852             if (svp) {
 853                 sv = *svp;
 854                 mg_clear(sv);
 855                 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
 856                     sv_unmagic(sv, PERL_MAGIC_tiedelem); /* No longer an element */
 857                     return sv;
 858                 }
 859                 return NULL;
 860             }
 861         }
 862     }
 863
 864     if (key < 0) {
 865         key += AvFILL(av) + 1;
 866         if (key < 0)
 867             return NULL;
 868     }
 869
 870     if (key > AvFILLp(av))
 871         return NULL;
 872     else {
 873         if (!AvREAL(av) && AvREIFY(av))
 874             av_reify(av);
 875         sv = AvARRAY(av)[key];
 876         if (key == AvFILLp(av)) {
 877             AvARRAY(av)[key] = NULL;
 878             do {
 879                 AvFILLp(av)--;
 880             } while (--key >= 0 && !AvARRAY(av)[key]);
 881         }
 882         else
 883             AvARRAY(av)[key] = NULL;
 884         if (SvSMAGICAL(av))
 885             mg_set(MUTABLE_SV(av));
 886     }
 887     if (flags & G_DISCARD) {
 888         SvREFCNT_dec(sv);
 889         sv = NULL;
 890     }
 891     else if (AvREAL(av))
 892         sv = sv_2mortal(sv);
 893     return sv;
 894 }
 895
 896 /*
 897 =for apidoc av_exists
 898
 899 Returns true if the element indexed by C<key> has been initialized.
 900
 901 This relies on the fact that uninitialized array elements are set to
 902 NULL.
 903
 904 Perl equivalent: C<exists($myarray[$key])>.
 905
 906 =cut
 907 */
 908 bool
 909 Perl_av_exists(pTHX_ AV *av, SSize_t key)
 910 {
 911     dVAR;
 912     PERL_ARGS_ASSERT_AV_EXISTS;
 913     assert(SvTYPE(av) == SVt_PVAV);
 914
 915     if (SvRMAGICAL(av)) {
 916         const MAGIC * const tied_magic
 917             = mg_find((const SV *)av, PERL_MAGIC_tied);
 918         const MAGIC * const regdata_magic
 919             = mg_find((const SV *)av, PERL_MAGIC_regdata);
 920         if (tied_magic || regdata_magic) {
 921             MAGIC *mg;
 922             /* Handle negative array indices 20020222 MJD */
 923             if (key < 0) {
 924                 if (!S_adjust_index(aTHX_ av, tied_magic, &key))
 925                         return FALSE;
 926             }
 927
 928             if(key >= 0 && regdata_magic) {
 929                 if (key <= AvFILL(av))
 930                     return TRUE;
 931                 else
 932                     return FALSE;
 933             }
 934             {
 935                 SV * const sv = sv_newmortal();
 936                 mg_copy(MUTABLE_SV(av), sv, 0, key);
 937                 mg = mg_find(sv, PERL_MAGIC_tiedelem);
 938                 if (mg) {
 939                     magic_existspack(sv, mg);
 940                     {
 941                         I32 retbool = SvTRUE_nomg_NN(sv);
 942                         return cBOOL(retbool);
 943                     }
 944                 }
 945             }
 946         }
 947     }
 948
 949     if (key < 0) {
 950         key += AvFILL(av) + 1;
 951         if (key < 0)
 952             return FALSE;
 953     }
 954
 955     if (key <= AvFILLp(av) && AvARRAY(av)[key])
 956     {
 957         return TRUE;
 958     }
 959     else
 960         return FALSE;
 961 }
 962
 963 static MAGIC *
 964 S_get_aux_mg(pTHX_ AV *av) {
 965     dVAR;
 966     MAGIC *mg;
 967
 968     PERL_ARGS_ASSERT_GET_AUX_MG;
 969     assert(SvTYPE(av) == SVt_PVAV);
 970
 971     mg = mg_find((const SV *)av, PERL_MAGIC_arylen_p);
 972
 973     if (!mg) {
 974         mg = sv_magicext(MUTABLE_SV(av), 0, PERL_MAGIC_arylen_p,
 975                          &PL_vtbl_arylen_p, 0, 0);
 976         assert(mg);
 977         /* sv_magicext won't set this for us because we pass in a NULL obj  */
 978         mg->mg_flags |= MGf_REFCOUNTED;
 979     }
 980     return mg;
 981 }
 982
 983 SV **
 984 Perl_av_arylen_p(pTHX_ AV *av) {
 985     MAGIC *const mg = get_aux_mg(av);
 986
 987     PERL_ARGS_ASSERT_AV_ARYLEN_P;
 988     assert(SvTYPE(av) == SVt_PVAV);
 989
 990     return &(mg->mg_obj);
 991 }
 992
 993 IV *
 994 Perl_av_iter_p(pTHX_ AV *av) {
 995     MAGIC *const mg = get_aux_mg(av);
 996
 997     PERL_ARGS_ASSERT_AV_ITER_P;
 998     assert(SvTYPE(av) == SVt_PVAV);
 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: nil
1018  * End:
1019  *
1020  * ex: set ts=8 sts=4 sw=4 et:
1021  */