File Coverage

av.c
Criterion Covered Total %
statement 338 366 92.3
branch 289 412 70.1
condition n/a
subroutine n/a
total 627 778 80.6


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