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 SV**
 215 Perl_av_fetch(pTHX_ register AV *av, I32 key, I32 lval)
 216 {
 217     dVAR;
 218
 219     PERL_ARGS_ASSERT_AV_FETCH;
 220     assert(SvTYPE(av) == SVt_PVAV);
 221
 222     if (SvRMAGICAL(av)) {
 223         const MAGIC * const tied_magic
 224             = mg_find((const SV *)av, PERL_MAGIC_tied);
 225         if (tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata)) {
 226             SV *sv;
 227             if (key < 0) {
 228                 I32 adjust_index = 1;
 229                 if (tied_magic) {
 230                     /* Handle negative array indices 20020222 MJD */
 231                     SV * const * const negative_indices_glob =
 232                         hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av),
 233                                                          tied_magic))),
 234                                 NEGATIVE_INDICES_VAR, 16, 0);
 235
 236                     if (negative_indices_glob && SvTRUE(GvSV(*negative_indices_glob)))
 237                         adjust_index = 0;
 238                 }
 239
 240                 if (adjust_index) {
 241                     key += AvFILL(av) + 1;
 242                     if (key < 0)
 243                         return NULL;
 244                 }
 245             }
 246
 247             sv = sv_newmortal();
 248             sv_upgrade(sv, SVt_PVLV);
 249             mg_copy(MUTABLE_SV(av), sv, 0, key);
 250             if (!tied_magic) /* for regdata, force leavesub to make copies */
 251                 SvTEMP_off(sv);
 252             LvTYPE(sv) = 't';
 253             LvTARG(sv) = sv; /* fake (SV**) */
 254             return &(LvTARG(sv));
 255         }
 256     }
 257
 258     if (key < 0) {
 259         key += AvFILL(av) + 1;
 260         if (key < 0)
 261             return NULL;
 262     }
 263
 264     if (key > AvFILLp(av) || AvARRAY(av)[key] == &PL_sv_undef) {
 265       emptyness:
 266         return lval ? av_store(av,key,newSV(0)) : NULL;
 267     }
 268
 269     if (AvREIFY(av)
 270              && (!AvARRAY(av)[key]      /* eg. @_ could have freed elts */
 271                  || SvIS_FREED(AvARRAY(av)[key]))) {
 272         AvARRAY(av)[key] = &PL_sv_undef;        /* 1/2 reify */
 273         goto emptyness;
 274     }
 275     return &AvARRAY(av)[key];
 276 }
 277
 278 /*
 279 =for apidoc av_store
 280
 281 Stores an SV in an array.  The array index is specified as C<key>.  The
 282 return value will be NULL if the operation failed or if the value did not
 283 need to be actually stored within the array (as in the case of tied
 284 arrays). Otherwise, it can be dereferenced
 285 to get the C<SV*> that was stored
 286 there (= C<val>)).
 287
 288 Note that the caller is responsible for suitably incrementing the reference
 289 count of C<val> before the call, and decrementing it if the function
 290 returned NULL.
 291
 292 Approximate Perl equivalent: C<$myarray[$key] = $val;>.
 293
 294 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
 295 more information on how to use this function on tied arrays.
 296
 297 =cut
 298 */
 299
 300 SV**
 301 Perl_av_store(pTHX_ register AV *av, I32 key, SV *val)
 302 {
 303     dVAR;
 304     SV** ary;
 305
 306     PERL_ARGS_ASSERT_AV_STORE;
 307     assert(SvTYPE(av) == SVt_PVAV);
 308
 309     /* S_regclass relies on being able to pass in a NULL sv
 310        (unicode_alternate may be NULL).
 311     */
 312
 313     if (!val)
 314         val = &PL_sv_undef;
 315
 316     if (SvRMAGICAL(av)) {
 317         const MAGIC * const tied_magic = mg_find((const SV *)av, PERL_MAGIC_tied);
 318         if (tied_magic) {
 319             /* Handle negative array indices 20020222 MJD */
 320             if (key < 0) {
 321                 bool adjust_index = 1;
 322                 SV * const * const negative_indices_glob =
 323                     hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av),
 324                                                      tied_magic))),
 325                              NEGATIVE_INDICES_VAR, 16, 0);
 326                 if (negative_indices_glob
 327                     && SvTRUE(GvSV(*negative_indices_glob)))
 328                     adjust_index = 0;
 329                 if (adjust_index) {
 330                     key += AvFILL(av) + 1;
 331                     if (key < 0)
 332                         return 0;
 333                 }
 334             }
 335             if (val != &PL_sv_undef) {
 336                 mg_copy(MUTABLE_SV(av), val, 0, key);
 337             }
 338             return NULL;
 339         }
 340     }
 341
 342
 343     if (key < 0) {
 344         key += AvFILL(av) + 1;
 345         if (key < 0)
 346             return NULL;
 347     }
 348
 349     if (SvREADONLY(av) && key >= AvFILL(av))
 350         Perl_croak_no_modify(aTHX);
 351
 352     if (!AvREAL(av) && AvREIFY(av))
 353         av_reify(av);
 354     if (key > AvMAX(av))
 355         av_extend(av,key);
 356     ary = AvARRAY(av);
 357     if (AvFILLp(av) < key) {
 358         if (!AvREAL(av)) {
 359             if (av == PL_curstack && key > PL_stack_sp - PL_stack_base)
 360                 PL_stack_sp = PL_stack_base + key;      /* XPUSH in disguise */
 361             do {
 362                 ary[++AvFILLp(av)] = &PL_sv_undef;
 363             } while (AvFILLp(av) < key);
 364         }
 365         AvFILLp(av) = key;
 366     }
 367     else if (AvREAL(av))
 368         SvREFCNT_dec(ary[key]);
 369     ary[key] = val;
 370     if (SvSMAGICAL(av)) {
 371         const MAGIC *mg = SvMAGIC(av);
 372         bool set = TRUE;
 373         for (; mg; mg = mg->mg_moremagic) {
 374           if (!isUPPER(mg->mg_type)) continue;
 375           if (val != &PL_sv_undef) {
 376             sv_magic(val, MUTABLE_SV(av), toLOWER(mg->mg_type), 0, key);
 377           }
 378           if (PL_delaymagic && mg->mg_type == PERL_MAGIC_isa) {
 379             PL_delaymagic |= DM_ARRAY_ISA;
 380             set = FALSE;
 381           }
 382         }
 383         if (set)
 384            mg_set(MUTABLE_SV(av));
 385     }
 386     return &ary[key];
 387 }
 388
 389 /*
 390 =for apidoc av_make
 391
 392 Creates a new AV and populates it with a list of SVs.  The SVs are copied
 393 into the array, so they may be freed after the call to av_make.  The new AV
 394 will have a reference count of 1.
 395
 396 Perl equivalent: C<my @new_array = ($scalar1, $scalar2, $scalar3...);>
 397
 398 =cut
 399 */
 400
 401 AV *
 402 Perl_av_make(pTHX_ register I32 size, register SV **strp)
 403 {
 404     AV * const av = MUTABLE_AV(newSV_type(SVt_PVAV));
 405     /* sv_upgrade does AvREAL_only()  */
 406     PERL_ARGS_ASSERT_AV_MAKE;
 407     assert(SvTYPE(av) == SVt_PVAV);
 408
 409     if (size) {         /* "defined" was returning undef for size==0 anyway. */
 410         SV** ary;
 411         I32 i;
 412         Newx(ary,size,SV*);
 413         AvALLOC(av) = ary;
 414         AvARRAY(av) = ary;
 415         AvFILLp(av) = AvMAX(av) = size - 1;
 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             ary[i] = newSV(0);
 424             sv_setsv_flags(ary[i], *strp,
 425                            SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
 426             strp++;
 427         }
 428     }
 429     return av;
 430 }
 431
 432 /*
 433 =for apidoc av_clear
 434
 435 Clears an array, making it empty.  Does not free the memory the av uses to
 436 store its list of scalars.  If any destructors are triggered as a result,
 437 the av itself may be freed when this function returns.
 438
 439 Perl equivalent: C<@myarray = ();>.
 440
 441 =cut
 442 */
 443
 444 void
 445 Perl_av_clear(pTHX_ register AV *av)
 446 {
 447     dVAR;
 448     I32 extra;
 449     bool real;
 450
 451     PERL_ARGS_ASSERT_AV_CLEAR;
 452     assert(SvTYPE(av) == SVt_PVAV);
 453
 454 #ifdef DEBUGGING
 455     if (SvREFCNT(av) == 0) {
 456         Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "Attempt to clear deleted array");
 457     }
 458 #endif
 459
 460     if (SvREADONLY(av))
 461         Perl_croak_no_modify(aTHX);
 462
 463     /* Give any tie a chance to cleanup first */
 464     if (SvRMAGICAL(av)) {
 465         const MAGIC* const mg = SvMAGIC(av);
 466         if (PL_delaymagic && mg && mg->mg_type == PERL_MAGIC_isa)
 467             PL_delaymagic |= DM_ARRAY_ISA;
 468         else
 469             mg_clear(MUTABLE_SV(av));
 470     }
 471
 472     if (AvMAX(av) < 0)
 473         return;
 474
 475     if ((real = !!AvREAL(av))) {
 476         SV** const ary = AvARRAY(av);
 477         I32 index = AvFILLp(av) + 1;
 478         ENTER;
 479         SAVEFREESV(SvREFCNT_inc_simple_NN(av));
 480         while (index) {
 481             SV * const sv = ary[--index];
 482             /* undef the slot before freeing the value, because a
 483              * destructor might try to modify this array */
 484             ary[index] = &PL_sv_undef;
 485             SvREFCNT_dec(sv);
 486         }
 487     }
 488     extra = AvARRAY(av) - AvALLOC(av);
 489     if (extra) {
 490         AvMAX(av) += extra;
 491         AvARRAY(av) = AvALLOC(av);
 492     }
 493     AvFILLp(av) = -1;
 494     if (real) LEAVE;
 495 }
 496
 497 /*
 498 =for apidoc av_undef
 499
 500 Undefines the array.  Frees the memory used by the av to store its list of
 501 scalars.  If any destructors are triggered as a result, the av itself may
 502 be freed.
 503
 504 =cut
 505 */
 506
 507 void
 508 Perl_av_undef(pTHX_ register AV *av)
 509 {
 510     bool real;
 511
 512     PERL_ARGS_ASSERT_AV_UNDEF;
 513     assert(SvTYPE(av) == SVt_PVAV);
 514
 515     /* Give any tie a chance to cleanup first */
 516     if (SvTIED_mg((const SV *)av, PERL_MAGIC_tied))
 517         av_fill(av, -1);
 518
 519     if ((real = !!AvREAL(av))) {
 520         I32 key = AvFILLp(av) + 1;
 521         ENTER;
 522         SAVEFREESV(SvREFCNT_inc_simple_NN(av));
 523         while (key)
 524             SvREFCNT_dec(AvARRAY(av)[--key]);
 525     }
 526
 527     Safefree(AvALLOC(av));
 528     AvALLOC(av) = NULL;
 529     AvARRAY(av) = NULL;
 530     AvMAX(av) = AvFILLp(av) = -1;
 531
 532     if(SvRMAGICAL(av)) mg_clear(MUTABLE_SV(av));
 533     if(real) LEAVE;
 534 }
 535
 536 /*
 537
 538 =for apidoc av_create_and_push
 539
 540 Push an SV onto the end of the array, creating the array if necessary.
 541 A small internal helper function to remove a commonly duplicated idiom.
 542
 543 =cut
 544 */
 545
 546 void
 547 Perl_av_create_and_push(pTHX_ AV **const avp, SV *const val)
 548 {
 549     PERL_ARGS_ASSERT_AV_CREATE_AND_PUSH;
 550
 551     if (!*avp)
 552         *avp = newAV();
 553     av_push(*avp, val);
 554 }
 555
 556 /*
 557 =for apidoc av_push
 558
 559 Pushes an SV onto the end of the array.  The array will grow automatically
 560 to accommodate the addition.  This takes ownership of one reference count.
 561
 562 Perl equivalent: C<push @myarray, $elem;>.
 563
 564 =cut
 565 */
 566
 567 void
 568 Perl_av_push(pTHX_ register AV *av, SV *val)
 569 {
 570     dVAR;
 571     MAGIC *mg;
 572
 573     PERL_ARGS_ASSERT_AV_PUSH;
 574     assert(SvTYPE(av) == SVt_PVAV);
 575
 576     if (SvREADONLY(av))
 577         Perl_croak_no_modify(aTHX);
 578
 579     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
 580         Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "PUSH", G_DISCARD, 1,
 581                             val);
 582         return;
 583     }
 584     av_store(av,AvFILLp(av)+1,val);
 585 }
 586
 587 /*
 588 =for apidoc av_pop
 589
 590 Pops an SV off the end of the array.  Returns C<&PL_sv_undef> if the array
 591 is empty.
 592
 593 Perl equivalent: C<pop(@myarray);>
 594
 595 =cut
 596 */
 597
 598 SV *
 599 Perl_av_pop(pTHX_ register AV *av)
 600 {
 601     dVAR;
 602     SV *retval;
 603     MAGIC* mg;
 604
 605     PERL_ARGS_ASSERT_AV_POP;
 606     assert(SvTYPE(av) == SVt_PVAV);
 607
 608     if (SvREADONLY(av))
 609         Perl_croak_no_modify(aTHX);
 610     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
 611         retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "POP", 0, 0);
 612         if (retval)
 613             retval = newSVsv(retval);
 614         return retval;
 615     }
 616     if (AvFILL(av) < 0)
 617         return &PL_sv_undef;
 618     retval = AvARRAY(av)[AvFILLp(av)];
 619     AvARRAY(av)[AvFILLp(av)--] = &PL_sv_undef;
 620     if (SvSMAGICAL(av))
 621         mg_set(MUTABLE_SV(av));
 622     return retval;
 623 }
 624
 625 /*
 626
 627 =for apidoc av_create_and_unshift_one
 628
 629 Unshifts an SV onto the beginning of the array, creating the array if
 630 necessary.
 631 A small internal helper function to remove a commonly duplicated idiom.
 632
 633 =cut
 634 */
 635
 636 SV **
 637 Perl_av_create_and_unshift_one(pTHX_ AV **const avp, SV *const val)
 638 {
 639     PERL_ARGS_ASSERT_AV_CREATE_AND_UNSHIFT_ONE;
 640
 641     if (!*avp)
 642         *avp = newAV();
 643     av_unshift(*avp, 1);
 644     return av_store(*avp, 0, val);
 645 }
 646
 647 /*
 648 =for apidoc av_unshift
 649
 650 Unshift the given number of C<undef> values onto the beginning of the
 651 array.  The array will grow automatically to accommodate the addition.  You
 652 must then use C<av_store> to assign values to these new elements.
 653
 654 Perl equivalent: C<unshift @myarray, ( (undef) x $n );>
 655
 656 =cut
 657 */
 658
 659 void
 660 Perl_av_unshift(pTHX_ register AV *av, register I32 num)
 661 {
 662     dVAR;
 663     I32 i;
 664     MAGIC* mg;
 665
 666     PERL_ARGS_ASSERT_AV_UNSHIFT;
 667     assert(SvTYPE(av) == SVt_PVAV);
 668
 669     if (SvREADONLY(av))
 670         Perl_croak_no_modify(aTHX);
 671
 672     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
 673         Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "UNSHIFT",
 674                             G_DISCARD | G_UNDEF_FILL, num);
 675         return;
 676     }
 677
 678     if (num <= 0)
 679       return;
 680     if (!AvREAL(av) && AvREIFY(av))
 681         av_reify(av);
 682     i = AvARRAY(av) - AvALLOC(av);
 683     if (i) {
 684         if (i > num)
 685             i = num;
 686         num -= i;
 687
 688         AvMAX(av) += i;
 689         AvFILLp(av) += i;
 690         AvARRAY(av) = AvARRAY(av) - i;
 691     }
 692     if (num) {
 693         SV **ary;
 694         const I32 i = AvFILLp(av);
 695         /* Create extra elements */
 696         const I32 slide = i > 0 ? i : 0;
 697         num += slide;
 698         av_extend(av, i + num);
 699         AvFILLp(av) += num;
 700         ary = AvARRAY(av);
 701         Move(ary, ary + num, i + 1, SV*);
 702         do {
 703             ary[--num] = &PL_sv_undef;
 704         } while (num);
 705         /* Make extra elements into a buffer */
 706         AvMAX(av) -= slide;
 707         AvFILLp(av) -= slide;
 708         AvARRAY(av) = AvARRAY(av) + slide;
 709     }
 710 }
 711
 712 /*
 713 =for apidoc av_shift
 714
 715 Shifts an SV off the beginning of the
 716 array.  Returns C<&PL_sv_undef> if the
 717 array is empty.
 718
 719 Perl equivalent: C<shift(@myarray);>
 720
 721 =cut
 722 */
 723
 724 SV *
 725 Perl_av_shift(pTHX_ register AV *av)
 726 {
 727     dVAR;
 728     SV *retval;
 729     MAGIC* mg;
 730
 731     PERL_ARGS_ASSERT_AV_SHIFT;
 732     assert(SvTYPE(av) == SVt_PVAV);
 733
 734     if (SvREADONLY(av))
 735         Perl_croak_no_modify(aTHX);
 736     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
 737         retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "SHIFT", 0, 0);
 738         if (retval)
 739             retval = newSVsv(retval);
 740         return retval;
 741     }
 742     if (AvFILL(av) < 0)
 743       return &PL_sv_undef;
 744     retval = *AvARRAY(av);
 745     if (AvREAL(av))
 746         *AvARRAY(av) = &PL_sv_undef;
 747     AvARRAY(av) = AvARRAY(av) + 1;
 748     AvMAX(av)--;
 749     AvFILLp(av)--;
 750     if (SvSMAGICAL(av))
 751         mg_set(MUTABLE_SV(av));
 752     return retval;
 753 }
 754
 755 /*
 756 =for apidoc av_len
 757
 758 Returns the highest index in the array.  The number of elements in the
 759 array is C<av_len(av) + 1>.  Returns -1 if the array is empty.
 760
 761 The Perl equivalent for this is C<$#myarray>.
 762
 763 =cut
 764 */
 765
 766 I32
 767 Perl_av_len(pTHX_ AV *av)
 768 {
 769     PERL_ARGS_ASSERT_AV_LEN;
 770     assert(SvTYPE(av) == SVt_PVAV);
 771
 772     return AvFILL(av);
 773 }
 774
 775 /*
 776 =for apidoc av_fill
 777
 778 Set the highest index in the array to the given number, equivalent to
 779 Perl's C<$#array = $fill;>.
 780
 781 The number of elements in the an array will be C<fill + 1> after
 782 av_fill() returns.  If the array was previously shorter, then the
 783 additional elements appended are set to C<PL_sv_undef>.  If the array
 784 was longer, then the excess elements are freed.  C<av_fill(av, -1)> is
 785 the same as C<av_clear(av)>.
 786
 787 =cut
 788 */
 789 void
 790 Perl_av_fill(pTHX_ register AV *av, I32 fill)
 791 {
 792     dVAR;
 793     MAGIC *mg;
 794
 795     PERL_ARGS_ASSERT_AV_FILL;
 796     assert(SvTYPE(av) == SVt_PVAV);
 797
 798     if (fill < 0)
 799         fill = -1;
 800     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
 801         SV *arg1 = sv_newmortal();
 802         sv_setiv(arg1, (IV)(fill + 1));
 803         Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "STORESIZE", G_DISCARD,
 804                             1, arg1);
 805         return;
 806     }
 807     if (fill <= AvMAX(av)) {
 808         I32 key = AvFILLp(av);
 809         SV** const ary = AvARRAY(av);
 810
 811         if (AvREAL(av)) {
 812             while (key > fill) {
 813                 SvREFCNT_dec(ary[key]);
 814                 ary[key--] = &PL_sv_undef;
 815             }
 816         }
 817         else {
 818             while (key < fill)
 819                 ary[++key] = &PL_sv_undef;
 820         }
 821
 822         AvFILLp(av) = fill;
 823         if (SvSMAGICAL(av))
 824             mg_set(MUTABLE_SV(av));
 825     }
 826     else
 827         (void)av_store(av,fill,&PL_sv_undef);
 828 }
 829
 830 /*
 831 =for apidoc av_delete
 832
 833 Deletes the element indexed by C<key> from the array, makes the element mortal,
 834 and returns it.  If C<flags> equals C<G_DISCARD>, the element is freed and null
 835 is returned.  Perl equivalent: C<my $elem = delete($myarray[$idx]);> for the
 836 non-C<G_DISCARD> version and a void-context C<delete($myarray[$idx]);> for the
 837 C<G_DISCARD> version.
 838
 839 =cut
 840 */
 841 SV *
 842 Perl_av_delete(pTHX_ AV *av, I32 key, I32 flags)
 843 {
 844     dVAR;
 845     SV *sv;
 846
 847     PERL_ARGS_ASSERT_AV_DELETE;
 848     assert(SvTYPE(av) == SVt_PVAV);
 849
 850     if (SvREADONLY(av))
 851         Perl_croak_no_modify(aTHX);
 852
 853     if (SvRMAGICAL(av)) {
 854         const MAGIC * const tied_magic
 855             = mg_find((const SV *)av, PERL_MAGIC_tied);
 856         if ((tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata))) {
 857             /* Handle negative array indices 20020222 MJD */
 858             SV **svp;
 859             if (key < 0) {
 860                 unsigned adjust_index = 1;
 861                 if (tied_magic) {
 862                     SV * const * const negative_indices_glob =
 863                         hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av),
 864                                                          tied_magic))),
 865                                  NEGATIVE_INDICES_VAR, 16, 0);
 866                     if (negative_indices_glob
 867                         && SvTRUE(GvSV(*negative_indices_glob)))
 868                         adjust_index = 0;
 869                 }
 870                 if (adjust_index) {
 871                     key += AvFILL(av) + 1;
 872                     if (key < 0)
 873                         return NULL;
 874                 }
 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         if (key == AvFILLp(av)) {
 902             AvARRAY(av)[key] = &PL_sv_undef;
 903             do {
 904                 AvFILLp(av)--;
 905             } while (--key >= 0 && AvARRAY(av)[key] == &PL_sv_undef);
 906         }
 907         else
 908             AvARRAY(av)[key] = &PL_sv_undef;
 909         if (SvSMAGICAL(av))
 910             mg_set(MUTABLE_SV(av));
 911     }
 912     if (flags & G_DISCARD) {
 913         SvREFCNT_dec(sv);
 914         sv = NULL;
 915     }
 916     else if (AvREAL(av))
 917         sv = sv_2mortal(sv);
 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<&PL_sv_undef>.
 928
 929 Perl equivalent: C<exists($myarray[$key])>.
 930
 931 =cut
 932 */
 933 bool
 934 Perl_av_exists(pTHX_ AV *av, I32 key)
 935 {
 936     dVAR;
 937     PERL_ARGS_ASSERT_AV_EXISTS;
 938     assert(SvTYPE(av) == SVt_PVAV);
 939
 940     if (SvRMAGICAL(av)) {
 941         const MAGIC * const tied_magic
 942             = mg_find((const SV *)av, PERL_MAGIC_tied);
 943         const MAGIC * const regdata_magic
 944             = mg_find((const SV *)av, PERL_MAGIC_regdata);
 945         if (tied_magic || regdata_magic) {
 946             SV * const sv = sv_newmortal();
 947             MAGIC *mg;
 948             /* Handle negative array indices 20020222 MJD */
 949             if (key < 0) {
 950                 unsigned adjust_index = 1;
 951                 if (tied_magic) {
 952                     SV * const * const negative_indices_glob =
 953                         hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av),
 954                                                          tied_magic))),
 955                                  NEGATIVE_INDICES_VAR, 16, 0);
 956                     if (negative_indices_glob
 957                         && SvTRUE(GvSV(*negative_indices_glob)))
 958                         adjust_index = 0;
 959                 }
 960                 if (adjust_index) {
 961                     key += AvFILL(av) + 1;
 962                     if (key < 0)
 963                         return FALSE;
 964                     else
 965                         return TRUE;
 966                 }
 967             }
 968
 969             if(key >= 0 && regdata_magic) {
 970                 if (key <= AvFILL(av))
 971                     return TRUE;
 972                 else
 973                     return FALSE;
 974             }
 975
 976             mg_copy(MUTABLE_SV(av), sv, 0, key);
 977             mg = mg_find(sv, PERL_MAGIC_tiedelem);
 978             if (mg) {
 979                 magic_existspack(sv, mg);
 980                 return cBOOL(SvTRUE_nomg(sv));
 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  */