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