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