av.c

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