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