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