Commit | Line | Data |
---|---|---|
a0d0e21e | 1 | /* av.c |
79072805 | 2 | * |
1129b882 NC |
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 | |
79072805 LW |
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 | * | |
a0d0e21e LW |
9 | */ |
10 | ||
11 | /* | |
4ac71550 TC |
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"] | |
79072805 LW |
16 | */ |
17 | ||
18 | #include "EXTERN.h" | |
864dbfa3 | 19 | #define PERL_IN_AV_C |
79072805 LW |
20 | #include "perl.h" |
21 | ||
fb73857a | 22 | void |
864dbfa3 | 23 | Perl_av_reify(pTHX_ AV *av) |
a0d0e21e | 24 | { |
c70927a6 | 25 | SSize_t key; |
fb73857a | 26 | |
7918f24d | 27 | PERL_ARGS_ASSERT_AV_REIFY; |
2fed2a1b | 28 | assert(SvTYPE(av) == SVt_PVAV); |
ba5d1d60 | 29 | |
3c78fafa | 30 | if (AvREAL(av)) |
1604cfb0 | 31 | return; |
93965878 | 32 | #ifdef DEBUGGING |
9b387841 | 33 | if (SvTIED_mg((const SV *)av, PERL_MAGIC_tied)) |
1604cfb0 | 34 | Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "av_reify called on tied array"); |
93965878 | 35 | #endif |
a0d0e21e | 36 | key = AvMAX(av) + 1; |
93965878 | 37 | while (key > AvFILLp(av) + 1) |
1604cfb0 | 38 | AvARRAY(av)[--key] = NULL; |
a0d0e21e | 39 | while (key) { |
1604cfb0 MS |
40 | SV * const sv = AvARRAY(av)[--key]; |
41 | if (sv != &PL_sv_undef) | |
42 | SvREFCNT_inc_simple_void(sv); | |
a0d0e21e | 43 | } |
29de640a | 44 | key = AvARRAY(av) - AvALLOC(av); |
765f7ac2 DM |
45 | if (key) |
46 | Zero(AvALLOC(av), key, SV*); | |
62b1ebc2 | 47 | AvREIFY_off(av); |
a0d0e21e LW |
48 | AvREAL_on(av); |
49 | } | |
50 | ||
cb50131a CB |
51 | /* |
52 | =for apidoc av_extend | |
53 | ||
2b301921 YO |
54 | Pre-extend an array so that it is capable of storing values at indexes |
55 | C<0..key>. Thus C<av_extend(av,99)> guarantees that the array can store 100 | |
56 | elements, i.e. that C<av_store(av, 0, sv)> through C<av_store(av, 99, sv)> | |
57 | on a plain array will work without any further memory allocation. | |
58 | ||
59 | If the av argument is a tied array then will call the C<EXTEND> tied | |
60 | array method with an argument of C<(key+1)>. | |
cb50131a CB |
61 | |
62 | =cut | |
63 | */ | |
64 | ||
a0d0e21e | 65 | void |
fc16c392 | 66 | Perl_av_extend(pTHX_ AV *av, SSize_t key) |
a0d0e21e | 67 | { |
7a5b473e AL |
68 | MAGIC *mg; |
69 | ||
7918f24d | 70 | PERL_ARGS_ASSERT_AV_EXTEND; |
2fed2a1b | 71 | assert(SvTYPE(av) == SVt_PVAV); |
ba5d1d60 | 72 | |
ad64d0ec | 73 | mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied); |
823a54a3 | 74 | if (mg) { |
1604cfb0 | 75 | SV *arg1 = sv_newmortal(); |
2b301921 YO |
76 | /* NOTE: the API for av_extend() is NOT the same as the tie method EXTEND. |
77 | * | |
78 | * The C function takes an *index* (assumes 0 indexed arrays) and ensures | |
79 | * that the array is at least as large as the index provided. | |
80 | * | |
81 | * The tied array method EXTEND takes a *count* and ensures that the array | |
82 | * is at least that many elements large. Thus we have to +1 the key when | |
83 | * we call the tied method. | |
84 | */ | |
1604cfb0 MS |
85 | sv_setiv(arg1, (IV)(key + 1)); |
86 | Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(EXTEND), G_DISCARD, 1, | |
87 | arg1); | |
88 | return; | |
93965878 | 89 | } |
7261499d FC |
90 | av_extend_guts(av,key,&AvMAX(av),&AvALLOC(av),&AvARRAY(av)); |
91 | } | |
92 | ||
93 | /* The guts of av_extend. *Not* for general use! */ | |
399fef93 | 94 | /* Also called directly from pp_assign, padlist_store, padnamelist_store */ |
7261499d | 95 | void |
fc16c392 | 96 | Perl_av_extend_guts(pTHX_ AV *av, SSize_t key, SSize_t *maxp, SV ***allocp, |
440c1856 | 97 | SV ***arrayp) |
7261499d | 98 | { |
7261499d FC |
99 | PERL_ARGS_ASSERT_AV_EXTEND_GUTS; |
100 | ||
6768377c DM |
101 | if (key < -1) /* -1 is legal */ |
102 | Perl_croak(aTHX_ | |
147e3846 | 103 | "panic: av_extend_guts() negative count (%" IVdf ")", (IV)key); |
6768377c | 104 | |
7261499d | 105 | if (key > *maxp) { |
9e298ab5 RL |
106 | SSize_t ary_offset = *maxp + 1; /* Start NULL initialization |
107 | * from this element */ | |
108 | SSize_t to_null = 0; /* How many elements to Zero */ | |
399fef93 RL |
109 | SSize_t newmax = 0; |
110 | ||
111 | if (av && *allocp != *arrayp) { /* a shifted SV* array exists */ | |
9e298ab5 RL |
112 | |
113 | /* to_null will contain the number of elements currently | |
114 | * shifted and about to be unshifted. If the array has not | |
115 | * been shifted to the maximum possible extent, this will be | |
116 | * a smaller number than (*maxp - AvFILLp(av)). */ | |
399fef93 | 117 | to_null = *arrayp - *allocp; |
9e298ab5 | 118 | |
399fef93 | 119 | *maxp += to_null; |
ce9f3c9c | 120 | ary_offset = AvFILLp(av) + 1; |
440c1856 | 121 | |
440c1856 | 122 | Move(*arrayp, *allocp, AvFILLp(av)+1, SV*); |
399fef93 | 123 | |
440c1856 RL |
124 | if (key > *maxp - 10) { |
125 | newmax = key + *maxp; | |
9e298ab5 RL |
126 | |
127 | /* Zero everything above AvFILLp(av), which could be more | |
128 | * elements than have actually been shifted. If we don't | |
129 | * do this, trailing elements at the end of the resized | |
130 | * array may not be correctly initialized. */ | |
131 | to_null = *maxp - AvFILLp(av); | |
132 | ||
440c1856 RL |
133 | goto resize; |
134 | } | |
399fef93 | 135 | } else if (*allocp) { /* a full SV* array exists */ |
4633a7c4 | 136 | |
ca7c1a29 | 137 | #ifdef Perl_safesysmalloc_size |
440c1856 RL |
138 | /* Whilst it would be quite possible to move this logic around |
139 | (as I did in the SV code), so as to set AvMAX(av) early, | |
140 | based on calling Perl_safesysmalloc_size() immediately after | |
141 | allocation, I'm not convinced that it is a great idea here. | |
142 | In an array we have to loop round setting everything to | |
143 | NULL, which means writing to memory, potentially lots | |
144 | of it, whereas for the SV buffer case we don't touch the | |
145 | "bonus" memory. So there there is no cost in telling the | |
146 | world about it, whereas here we have to do work before we can | |
147 | tell the world about it, and that work involves writing to | |
148 | memory that might never be read. So, I feel, better to keep | |
149 | the current lazy system of only writing to it if our caller | |
150 | has a need for more space. NWC */ | |
151 | newmax = Perl_safesysmalloc_size((void*)*allocp) / | |
152 | sizeof(const SV *) - 1; | |
153 | ||
154 | if (key <= newmax) | |
155 | goto resized; | |
8d6dde3e | 156 | #endif |
440c1856 RL |
157 | /* overflow-safe version of newmax = key + *maxp/5 */ |
158 | newmax = *maxp / 5; | |
159 | newmax = (key > SSize_t_MAX - newmax) | |
160 | ? SSize_t_MAX : key + newmax; | |
161 | resize: | |
399fef93 RL |
162 | { |
163 | /* it should really be newmax+1 here, but if newmax | |
164 | * happens to equal SSize_t_MAX, then newmax+1 is | |
165 | * undefined. This means technically we croak one | |
166 | * index lower than we should in theory; in practice | |
167 | * its unlikely the system has SSize_t_MAX/sizeof(SV*) | |
168 | * bytes to spare! */ | |
169 | MEM_WRAP_CHECK_s(newmax, SV*, "Out of memory during array extend"); | |
170 | } | |
865e3ae0 | 171 | #ifdef STRESS_REALLOC |
440c1856 RL |
172 | { |
173 | SV ** const old_alloc = *allocp; | |
174 | Newx(*allocp, newmax+1, SV*); | |
175 | Copy(old_alloc, *allocp, *maxp + 1, SV*); | |
176 | Safefree(old_alloc); | |
177 | } | |
865e3ae0 | 178 | #else |
440c1856 | 179 | Renew(*allocp,newmax+1, SV*); |
865e3ae0 | 180 | #endif |
ca7c1a29 | 181 | #ifdef Perl_safesysmalloc_size |
440c1856 | 182 | resized: |
9c5ffd7c | 183 | #endif |
9e298ab5 RL |
184 | to_null += newmax - *maxp; /* Initialize all new elements |
185 | * (newmax - *maxp) in addition to | |
186 | * any previously specified */ | |
399fef93 RL |
187 | *maxp = newmax; |
188 | ||
189 | /* See GH#18014 for discussion of when this might be needed: */ | |
190 | if (av == PL_curstack) { /* Oops, grew stack (via av_store()?) */ | |
440c1856 RL |
191 | PL_stack_sp = *allocp + (PL_stack_sp - PL_stack_base); |
192 | PL_stack_base = *allocp; | |
193 | PL_stack_max = PL_stack_base + newmax; | |
194 | } | |
399fef93 | 195 | } else { /* there is no SV* array yet */ |
dbf3614d RL |
196 | *maxp = key < PERL_ARRAY_NEW_MIN_KEY ? |
197 | PERL_ARRAY_NEW_MIN_KEY : key; | |
440c1856 RL |
198 | { |
199 | /* see comment above about newmax+1*/ | |
399fef93 RL |
200 | MEM_WRAP_CHECK_s(*maxp, SV*, |
201 | "Out of memory during array extend"); | |
440c1856 | 202 | } |
399fef93 RL |
203 | /* Newxz isn't used below because testing showed it to be slower |
204 | * than Newx+Zero (also slower than Newx + the previous while | |
205 | * loop) for small arrays, which are very common in perl. */ | |
206 | Newx(*allocp, *maxp+1, SV*); | |
207 | /* Stacks require only the first element to be &PL_sv_undef | |
208 | * (set elsewhere). However, since non-stack AVs are likely | |
209 | * to dominate in modern production applications, stacks | |
60eec70f HS |
210 | * don't get any special treatment here. |
211 | * See https://github.com/Perl/perl5/pull/18690 for more detail */ | |
399fef93 | 212 | ary_offset = 0; |
9e298ab5 | 213 | to_null = *maxp+1; /* Initialize all new array elements */ |
399fef93 | 214 | goto zero; |
440c1856 | 215 | } |
399fef93 | 216 | |
440c1856 | 217 | if (av && AvREAL(av)) { |
399fef93 RL |
218 | zero: |
219 | Zero(*allocp + ary_offset,to_null,SV*); | |
440c1856 RL |
220 | } |
221 | ||
222 | *arrayp = *allocp; | |
a0d0e21e LW |
223 | } |
224 | } | |
225 | ||
cb50131a CB |
226 | /* |
227 | =for apidoc av_fetch | |
228 | ||
229 | Returns the SV at the specified index in the array. The C<key> is the | |
e815fc9e | 230 | index. If C<lval> is true, you are guaranteed to get a real SV back (in case |
1a328862 | 231 | it wasn't real before), which you can then modify. Check that the return |
e815fc9e | 232 | value is non-NULL before dereferencing it to a C<SV*>. |
cb50131a CB |
233 | |
234 | See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for | |
235 | more information on how to use this function on tied arrays. | |
236 | ||
17b0bd77 | 237 | The rough perl equivalent is C<$myarray[$key]>. |
3347919d | 238 | |
cb50131a CB |
239 | =cut |
240 | */ | |
241 | ||
ac9f75b5 | 242 | static bool |
c70927a6 | 243 | S_adjust_index(pTHX_ AV *av, const MAGIC *mg, SSize_t *keyp) |
ac9f75b5 FC |
244 | { |
245 | bool adjust_index = 1; | |
246 | if (mg) { | |
1604cfb0 MS |
247 | /* Handle negative array indices 20020222 MJD */ |
248 | SV * const ref = SvTIED_obj(MUTABLE_SV(av), mg); | |
249 | SvGETMAGIC(ref); | |
250 | if (SvROK(ref) && SvOBJECT(SvRV(ref))) { | |
251 | SV * const * const negative_indices_glob = | |
252 | hv_fetchs(SvSTASH(SvRV(ref)), NEGATIVE_INDICES_VAR, 0); | |
253 | ||
254 | if (negative_indices_glob && isGV(*negative_indices_glob) | |
255 | && SvTRUE(GvSV(*negative_indices_glob))) | |
256 | adjust_index = 0; | |
257 | } | |
ac9f75b5 FC |
258 | } |
259 | ||
260 | if (adjust_index) { | |
1604cfb0 MS |
261 | *keyp += AvFILL(av) + 1; |
262 | if (*keyp < 0) | |
263 | return FALSE; | |
ac9f75b5 FC |
264 | } |
265 | return TRUE; | |
266 | } | |
267 | ||
79072805 | 268 | SV** |
c70927a6 | 269 | Perl_av_fetch(pTHX_ AV *av, SSize_t key, I32 lval) |
79072805 | 270 | { |
f4d8be8b DM |
271 | SSize_t neg; |
272 | SSize_t size; | |
273 | ||
7918f24d | 274 | PERL_ARGS_ASSERT_AV_FETCH; |
2fed2a1b | 275 | assert(SvTYPE(av) == SVt_PVAV); |
a0d0e21e | 276 | |
11b62bc4 | 277 | if (UNLIKELY(SvRMAGICAL(av))) { |
ad64d0ec | 278 | const MAGIC * const tied_magic |
1604cfb0 | 279 | = mg_find((const SV *)av, PERL_MAGIC_tied); |
ad64d0ec | 280 | if (tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata)) { |
1604cfb0 MS |
281 | SV *sv; |
282 | if (key < 0) { | |
283 | if (!S_adjust_index(aTHX_ av, tied_magic, &key)) | |
284 | return NULL; | |
285 | } | |
6f12eb6d | 286 | |
7ea8b04b | 287 | sv = newSV_type_mortal(SVt_PVLV); |
1604cfb0 MS |
288 | mg_copy(MUTABLE_SV(av), sv, 0, key); |
289 | if (!tied_magic) /* for regdata, force leavesub to make copies */ | |
290 | SvTEMP_off(sv); | |
291 | LvTYPE(sv) = 't'; | |
292 | LvTARG(sv) = sv; /* fake (SV**) */ | |
293 | return &(LvTARG(sv)); | |
6f12eb6d MJD |
294 | } |
295 | } | |
296 | ||
f4d8be8b | 297 | neg = (key < 0); |
25cf9644 | 298 | size = AvFILLp(av) + 1; |
f4d8be8b DM |
299 | key += neg * size; /* handle negative index without using branch */ |
300 | ||
301 | /* the cast from SSize_t to Size_t allows both (key < 0) and (key >= size) | |
302 | * to be tested as a single condition */ | |
303 | if ((Size_t)key >= (Size_t)size) { | |
1604cfb0 MS |
304 | if (UNLIKELY(neg)) |
305 | return NULL; | |
0c6362ad | 306 | goto emptiness; |
93965878 | 307 | } |
f4d8be8b DM |
308 | |
309 | if (!AvARRAY(av)[key]) { | |
0c6362ad | 310 | emptiness: |
8fcb2425 | 311 | return lval ? av_store(av,key,newSV_type(SVt_NULL)) : NULL; |
79072805 | 312 | } |
55d3f3e5 | 313 | |
463ee0b2 | 314 | return &AvARRAY(av)[key]; |
79072805 LW |
315 | } |
316 | ||
cb50131a CB |
317 | /* |
318 | =for apidoc av_store | |
319 | ||
320 | Stores an SV in an array. The array index is specified as C<key>. The | |
796b6530 | 321 | return value will be C<NULL> if the operation failed or if the value did not |
cb50131a | 322 | need to be actually stored within the array (as in the case of tied |
72d33970 | 323 | arrays). Otherwise, it can be dereferenced |
4f540dd3 | 324 | to get the C<SV*> that was stored |
f0b90de1 SF |
325 | there (= C<val>)). |
326 | ||
327 | Note that the caller is responsible for suitably incrementing the reference | |
cb50131a | 328 | count of C<val> before the call, and decrementing it if the function |
796b6530 | 329 | returned C<NULL>. |
cb50131a | 330 | |
17b0bd77 | 331 | Approximate Perl equivalent: C<splice(@myarray, $key, 1, $val)>. |
f0b90de1 | 332 | |
cb50131a CB |
333 | See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for |
334 | more information on how to use this function on tied arrays. | |
335 | ||
336 | =cut | |
337 | */ | |
338 | ||
79072805 | 339 | SV** |
c70927a6 | 340 | Perl_av_store(pTHX_ AV *av, SSize_t key, SV *val) |
79072805 | 341 | { |
79072805 LW |
342 | SV** ary; |
343 | ||
7918f24d | 344 | PERL_ARGS_ASSERT_AV_STORE; |
2fed2a1b | 345 | assert(SvTYPE(av) == SVt_PVAV); |
ba5d1d60 | 346 | |
725ac12f NC |
347 | /* S_regclass relies on being able to pass in a NULL sv |
348 | (unicode_alternate may be NULL). | |
349 | */ | |
350 | ||
6f12eb6d | 351 | if (SvRMAGICAL(av)) { |
ad64d0ec | 352 | const MAGIC * const tied_magic = mg_find((const SV *)av, PERL_MAGIC_tied); |
6f12eb6d | 353 | if (tied_magic) { |
6f12eb6d | 354 | if (key < 0) { |
1604cfb0 | 355 | if (!S_adjust_index(aTHX_ av, tied_magic, &key)) |
6f12eb6d | 356 | return 0; |
6f12eb6d | 357 | } |
1604cfb0 MS |
358 | if (val) { |
359 | mg_copy(MUTABLE_SV(av), val, 0, key); | |
360 | } | |
361 | return NULL; | |
6f12eb6d MJD |
362 | } |
363 | } | |
364 | ||
365 | ||
a0d0e21e | 366 | if (key < 0) { |
1604cfb0 MS |
367 | key += AvFILL(av) + 1; |
368 | if (key < 0) | |
369 | return NULL; | |
79072805 | 370 | } |
93965878 | 371 | |
43fcc5d2 | 372 | if (SvREADONLY(av) && key >= AvFILL(av)) |
1604cfb0 | 373 | Perl_croak_no_modify(); |
93965878 | 374 | |
49beac48 | 375 | if (!AvREAL(av) && AvREIFY(av)) |
1604cfb0 | 376 | av_reify(av); |
a0d0e21e | 377 | if (key > AvMAX(av)) |
1604cfb0 | 378 | av_extend(av,key); |
463ee0b2 | 379 | ary = AvARRAY(av); |
93965878 | 380 | if (AvFILLp(av) < key) { |
1604cfb0 MS |
381 | if (!AvREAL(av)) { |
382 | if (av == PL_curstack && key > PL_stack_sp - PL_stack_base) | |
383 | PL_stack_sp = PL_stack_base + key; /* XPUSH in disguise */ | |
384 | do { | |
385 | ary[++AvFILLp(av)] = NULL; | |
386 | } while (AvFILLp(av) < key); | |
387 | } | |
388 | AvFILLp(av) = key; | |
79072805 | 389 | } |
811f8a24 | 390 | else if (AvREAL(av)) |
1604cfb0 | 391 | SvREFCNT_dec(ary[key]); |
829184bb YO |
392 | |
393 | /* store the val into the AV before we call magic so that the magic can | |
394 | * "see" the new value. Especially set magic on the AV itself. */ | |
79072805 | 395 | ary[key] = val; |
829184bb | 396 | |
8990e307 | 397 | if (SvSMAGICAL(av)) { |
1604cfb0 MS |
398 | const MAGIC *mg = SvMAGIC(av); |
399 | bool set = TRUE; | |
829184bb YO |
400 | /* We have to increment the refcount on val before we call any magic, |
401 | * as it is now stored in the AV (just before this block), we will | |
402 | * then call the magic handlers which might die/Perl_croak, and | |
403 | * longjmp up the stack to the most recent exception trap. Which means | |
404 | * the caller code that would be expected to handle the refcount | |
405 | * increment likely would never be executed, leading to a double free. | |
406 | * This can happen in a case like | |
407 | * | |
408 | * @ary = (1); | |
409 | * | |
410 | * or this: | |
411 | * | |
412 | * if (av_store(av,n,sv)) SvREFCNT_inc(sv); | |
413 | * | |
414 | * where @ary/av has set magic applied to it which can die. In the | |
415 | * first case the sv representing 1 would be mortalized, so when the | |
416 | * set magic threw an exception it would be freed as part of the | |
417 | * normal stack unwind. However this leaves the av structure still | |
418 | * holding a valid visible pointer to the now freed value. In practice | |
419 | * the next SV created will reuse the same reference, but without the | |
420 | * refcount to account for the previous ownership and we end up with | |
421 | * warnings about a totally different variable being double freed in | |
422 | * the form of "attempt to free unreferenced variable" | |
423 | * warnings/errors. | |
424 | * | |
425 | * https://github.com/Perl/perl5/issues/20675 | |
426 | * | |
427 | * Arguably the API for av_store is broken in the face of magic. Instead | |
428 | * av_store should be responsible for the refcount increment, and only | |
429 | * not do it when specifically told to do so (eg, when storing an | |
430 | * otherwise unreferenced scalar into an AV). | |
431 | */ | |
432 | SvREFCNT_inc(val); /* see comment above */ | |
1604cfb0 MS |
433 | for (; mg; mg = mg->mg_moremagic) { |
434 | if (!isUPPER(mg->mg_type)) continue; | |
435 | if (val) { | |
436 | sv_magic(val, MUTABLE_SV(av), toLOWER(mg->mg_type), 0, key); | |
437 | } | |
438 | if (PL_delaymagic && mg->mg_type == PERL_MAGIC_isa) { | |
439 | PL_delaymagic |= DM_ARRAY_ISA; | |
440 | set = FALSE; | |
441 | } | |
442 | } | |
443 | if (set) | |
444 | mg_set(MUTABLE_SV(av)); | |
829184bb YO |
445 | /* And now we are done the magic, we have to decrement it back as the av_store() api |
446 | * says the caller is responsible for the refcount increment, assuming | |
447 | * av_store returns true. */ | |
448 | SvREFCNT_dec(val); | |
463ee0b2 | 449 | } |
79072805 LW |
450 | return &ary[key]; |
451 | } | |
452 | ||
cb50131a | 453 | /* |
cb50131a CB |
454 | =for apidoc av_make |
455 | ||
e815fc9e KW |
456 | Creates a new AV and populates it with a list (C<**strp>, length C<size>) of |
457 | SVs. A copy is made of each SV, so their refcounts are not changed. The new | |
458 | AV will have a reference count of 1. | |
cb50131a | 459 | |
775f1d61 SF |
460 | Perl equivalent: C<my @new_array = ($scalar1, $scalar2, $scalar3...);> |
461 | ||
cb50131a CB |
462 | =cut |
463 | */ | |
464 | ||
79072805 | 465 | AV * |
c70927a6 | 466 | Perl_av_make(pTHX_ SSize_t size, SV **strp) |
79072805 | 467 | { |
f73391e4 | 468 | AV * const av = newAV(); |
a7f5e44d | 469 | /* sv_upgrade does AvREAL_only() */ |
7918f24d | 470 | PERL_ARGS_ASSERT_AV_MAKE; |
2fed2a1b NC |
471 | assert(SvTYPE(av) == SVt_PVAV); |
472 | ||
a0288114 | 473 | if (size) { /* "defined" was returning undef for size==0 anyway. */ |
eb578fdb | 474 | SV** ary; |
c70927a6 | 475 | SSize_t i; |
be988557 DM |
476 | SSize_t orig_ix; |
477 | ||
1604cfb0 MS |
478 | Newx(ary,size,SV*); |
479 | AvALLOC(av) = ary; | |
480 | AvARRAY(av) = ary; | |
481 | AvMAX(av) = size - 1; | |
be988557 DM |
482 | /* avoid av being leaked if croak when calling magic below */ |
483 | EXTEND_MORTAL(1); | |
484 | PL_tmps_stack[++PL_tmps_ix] = (SV*)av; | |
485 | orig_ix = PL_tmps_ix; | |
486 | ||
1604cfb0 MS |
487 | for (i = 0; i < size; i++) { |
488 | assert (*strp); | |
2b676593 | 489 | |
1604cfb0 MS |
490 | /* Don't let sv_setsv swipe, since our source array might |
491 | have multiple references to the same temp scalar (e.g. | |
492 | from a list slice) */ | |
2b676593 | 493 | |
1604cfb0 MS |
494 | SvGETMAGIC(*strp); /* before newSV, in case it dies */ |
495 | AvFILLp(av)++; | |
8fcb2425 | 496 | ary[i] = newSV_type(SVt_NULL); |
1604cfb0 MS |
497 | sv_setsv_flags(ary[i], *strp, |
498 | SV_DO_COW_SVSETSV|SV_NOSTEAL); | |
499 | strp++; | |
500 | } | |
be988557 DM |
501 | /* disarm av's leak guard */ |
502 | if (LIKELY(PL_tmps_ix == orig_ix)) | |
503 | PL_tmps_ix--; | |
504 | else | |
505 | PL_tmps_stack[orig_ix] = &PL_sv_undef; | |
79072805 | 506 | } |
463ee0b2 | 507 | return av; |
79072805 LW |
508 | } |
509 | ||
cb50131a | 510 | /* |
5f6512c9 PE |
511 | =for apidoc newAVav |
512 | ||
513 | Creates a new AV and populates it with values copied from an existing AV. The | |
514 | new AV will have a reference count of 1, and will contain newly created SVs | |
515 | copied from the original SV. The original source will remain unchanged. | |
516 | ||
517 | Perl equivalent: C<my @new_array = @existing_array;> | |
518 | ||
519 | =cut | |
520 | */ | |
521 | ||
522 | AV * | |
523 | Perl_newAVav(pTHX_ AV *oav) | |
524 | { | |
525 | PERL_ARGS_ASSERT_NEWAVAV; | |
526 | ||
80c024ac | 527 | Size_t count = av_count(oav); |
3b6b0454 RL |
528 | |
529 | if(UNLIKELY(!oav) || count == 0) | |
5f6512c9 PE |
530 | return newAV(); |
531 | ||
3b6b0454 | 532 | AV *ret = newAV_alloc_x(count); |
5f6512c9 PE |
533 | |
534 | /* avoid ret being leaked if croak when calling magic below */ | |
535 | EXTEND_MORTAL(1); | |
536 | PL_tmps_stack[++PL_tmps_ix] = (SV *)ret; | |
537 | SSize_t ret_at_tmps_ix = PL_tmps_ix; | |
538 | ||
80c024ac RL |
539 | Size_t i; |
540 | if(LIKELY(!SvRMAGICAL(oav) && AvREAL(oav) && (SvTYPE(oav) == SVt_PVAV))) { | |
541 | for(i = 0; i < count; i++) { | |
542 | SV **svp = av_fetch_simple(oav, i, 0); | |
543 | av_push_simple(ret, svp ? newSVsv(*svp) : &PL_sv_undef); | |
544 | } | |
545 | } else { | |
546 | for(i = 0; i < count; i++) { | |
547 | SV **svp = av_fetch(oav, i, 0); | |
548 | av_push_simple(ret, svp ? newSVsv(*svp) : &PL_sv_undef); | |
549 | } | |
5f6512c9 PE |
550 | } |
551 | ||
552 | /* disarm leak guard */ | |
553 | if(LIKELY(PL_tmps_ix == ret_at_tmps_ix)) | |
554 | PL_tmps_ix--; | |
555 | else | |
556 | PL_tmps_stack[ret_at_tmps_ix] = &PL_sv_undef; | |
557 | ||
558 | return ret; | |
559 | } | |
560 | ||
561 | /* | |
562 | =for apidoc newAVhv | |
563 | ||
564 | Creates a new AV and populates it with keys and values copied from an existing | |
565 | HV. The new AV will have a reference count of 1, and will contain newly | |
566 | created SVs copied from the original HV. The original source will remain | |
567 | unchanged. | |
568 | ||
569 | Perl equivalent: C<my @new_array = %existing_hash;> | |
570 | ||
571 | =cut | |
572 | */ | |
573 | ||
574 | AV * | |
575 | Perl_newAVhv(pTHX_ HV *ohv) | |
576 | { | |
577 | PERL_ARGS_ASSERT_NEWAVHV; | |
578 | ||
579 | if(UNLIKELY(!ohv)) | |
580 | return newAV(); | |
581 | ||
582 | bool tied = SvRMAGICAL(ohv) && mg_find(MUTABLE_SV(ohv), PERL_MAGIC_tied); | |
583 | ||
f98a2322 | 584 | Size_t nkeys = hv_iterinit(ohv); |
3b6b0454 RL |
585 | /* This number isn't perfect but it doesn't matter; it only has to be |
586 | * close to make the initial allocation about the right size | |
587 | */ | |
1805204a | 588 | AV *ret = newAV_alloc_xz(nkeys ? nkeys * 2 : 2); |
5f6512c9 PE |
589 | |
590 | /* avoid ret being leaked if croak when calling magic below */ | |
591 | EXTEND_MORTAL(1); | |
592 | PL_tmps_stack[++PL_tmps_ix] = (SV *)ret; | |
593 | SSize_t ret_at_tmps_ix = PL_tmps_ix; | |
594 | ||
5f6512c9 PE |
595 | |
596 | HE *he; | |
597 | while((he = hv_iternext(ohv))) { | |
598 | if(tied) { | |
f98a2322 RL |
599 | av_push_simple(ret, newSVsv(hv_iterkeysv(he))); |
600 | av_push_simple(ret, newSVsv(hv_iterval(ohv, he))); | |
5f6512c9 PE |
601 | } |
602 | else { | |
f98a2322 RL |
603 | av_push_simple(ret, newSVhek(HeKEY_hek(he))); |
604 | av_push_simple(ret, HeVAL(he) ? newSVsv(HeVAL(he)) : &PL_sv_undef); | |
5f6512c9 PE |
605 | } |
606 | } | |
607 | ||
608 | /* disarm leak guard */ | |
609 | if(LIKELY(PL_tmps_ix == ret_at_tmps_ix)) | |
610 | PL_tmps_ix--; | |
611 | else | |
612 | PL_tmps_stack[ret_at_tmps_ix] = &PL_sv_undef; | |
613 | ||
614 | return ret; | |
615 | } | |
616 | ||
617 | /* | |
cb50131a CB |
618 | =for apidoc av_clear |
619 | ||
bb8005f7 | 620 | Frees all the elements of an array, leaving it empty. |
a4395eba | 621 | The XS equivalent of C<@array = ()>. See also L</av_undef>. |
8b9a1153 | 622 | |
a4395eba DM |
623 | Note that it is possible that the actions of a destructor called directly |
624 | or indirectly by freeing an element of the array could cause the reference | |
625 | count of the array itself to be reduced (e.g. by deleting an entry in the | |
626 | symbol table). So it is a possibility that the AV could have been freed | |
627 | (or even reallocated) on return from the call unless you hold a reference | |
628 | to it. | |
cb50131a CB |
629 | |
630 | =cut | |
631 | */ | |
632 | ||
79072805 | 633 | void |
5aaab254 | 634 | Perl_av_clear(pTHX_ AV *av) |
79072805 | 635 | { |
60edcf09 | 636 | bool real; |
be988557 | 637 | SSize_t orig_ix = 0; |
79072805 | 638 | |
7918f24d | 639 | PERL_ARGS_ASSERT_AV_CLEAR; |
2fed2a1b NC |
640 | assert(SvTYPE(av) == SVt_PVAV); |
641 | ||
7d55f622 | 642 | #ifdef DEBUGGING |
9b387841 | 643 | if (SvREFCNT(av) == 0) { |
1604cfb0 | 644 | Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "Attempt to clear deleted array"); |
7d55f622 | 645 | } |
646 | #endif | |
a0d0e21e | 647 | |
39caa665 | 648 | if (SvREADONLY(av)) |
1604cfb0 | 649 | Perl_croak_no_modify(); |
39caa665 | 650 | |
93965878 | 651 | /* Give any tie a chance to cleanup first */ |
89c14e2e | 652 | if (SvRMAGICAL(av)) { |
1604cfb0 MS |
653 | const MAGIC* const mg = SvMAGIC(av); |
654 | if (PL_delaymagic && mg && mg->mg_type == PERL_MAGIC_isa) | |
655 | PL_delaymagic |= DM_ARRAY_ISA; | |
89c14e2e | 656 | else |
1604cfb0 | 657 | mg_clear(MUTABLE_SV(av)); |
89c14e2e | 658 | } |
93965878 | 659 | |
a60c0954 | 660 | if (AvMAX(av) < 0) |
1604cfb0 | 661 | return; |
a60c0954 | 662 | |
be988557 | 663 | if ((real = cBOOL(AvREAL(av)))) { |
1604cfb0 MS |
664 | SV** const ary = AvARRAY(av); |
665 | SSize_t index = AvFILLp(av) + 1; | |
be988557 DM |
666 | |
667 | /* avoid av being freed when calling destructors below */ | |
668 | EXTEND_MORTAL(1); | |
669 | PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(av); | |
670 | orig_ix = PL_tmps_ix; | |
671 | ||
1604cfb0 MS |
672 | while (index) { |
673 | SV * const sv = ary[--index]; | |
674 | /* undef the slot before freeing the value, because a | |
675 | * destructor might try to modify this array */ | |
676 | ary[index] = NULL; | |
677 | SvREFCNT_dec(sv); | |
678 | } | |
a0d0e21e | 679 | } |
93965878 | 680 | AvFILLp(av) = -1; |
765f7ac2 DM |
681 | av_remove_offset(av); |
682 | ||
be988557 DM |
683 | if (real) { |
684 | /* disarm av's premature free guard */ | |
685 | if (LIKELY(PL_tmps_ix == orig_ix)) | |
686 | PL_tmps_ix--; | |
687 | else | |
688 | PL_tmps_stack[orig_ix] = &PL_sv_undef; | |
689 | SvREFCNT_dec_NN(av); | |
690 | } | |
79072805 LW |
691 | } |
692 | ||
cb50131a CB |
693 | /* |
694 | =for apidoc av_undef | |
695 | ||
a4395eba DM |
696 | Undefines the array. The XS equivalent of C<undef(@array)>. |
697 | ||
698 | As well as freeing all the elements of the array (like C<av_clear()>), this | |
699 | also frees the memory used by the av to store its list of scalars. | |
700 | ||
701 | See L</av_clear> for a note about the array possibly being invalid on | |
702 | return. | |
cb50131a CB |
703 | |
704 | =cut | |
705 | */ | |
706 | ||
79072805 | 707 | void |
5aaab254 | 708 | Perl_av_undef(pTHX_ AV *av) |
79072805 | 709 | { |
60edcf09 | 710 | bool real; |
0c6362ad | 711 | SSize_t orig_ix = PL_tmps_ix; /* silence bogus warning about possible uninitialized use */ |
60edcf09 | 712 | |
7918f24d | 713 | PERL_ARGS_ASSERT_AV_UNDEF; |
2fed2a1b | 714 | assert(SvTYPE(av) == SVt_PVAV); |
93965878 NIS |
715 | |
716 | /* Give any tie a chance to cleanup first */ | |
ad64d0ec | 717 | if (SvTIED_mg((const SV *)av, PERL_MAGIC_tied)) |
1604cfb0 | 718 | av_fill(av, -1); |
93965878 | 719 | |
84610c52 YO |
720 | real = cBOOL(AvREAL(av)); |
721 | if (real) { | |
1604cfb0 | 722 | SSize_t key = AvFILLp(av) + 1; |
be988557 DM |
723 | |
724 | /* avoid av being freed when calling destructors below */ | |
725 | EXTEND_MORTAL(1); | |
726 | PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(av); | |
727 | orig_ix = PL_tmps_ix; | |
728 | ||
1604cfb0 MS |
729 | while (key) |
730 | SvREFCNT_dec(AvARRAY(av)[--key]); | |
a0d0e21e | 731 | } |
22717f83 | 732 | |
463ee0b2 | 733 | Safefree(AvALLOC(av)); |
35da51f7 | 734 | AvALLOC(av) = NULL; |
9c6bc640 | 735 | AvARRAY(av) = NULL; |
93965878 | 736 | AvMAX(av) = AvFILLp(av) = -1; |
22717f83 | 737 | |
ad64d0ec | 738 | if(SvRMAGICAL(av)) mg_clear(MUTABLE_SV(av)); |
be988557 DM |
739 | if (real) { |
740 | /* disarm av's premature free guard */ | |
741 | if (LIKELY(PL_tmps_ix == orig_ix)) | |
742 | PL_tmps_ix--; | |
743 | else | |
744 | PL_tmps_stack[orig_ix] = &PL_sv_undef; | |
745 | SvREFCNT_dec_NN(av); | |
746 | } | |
79072805 LW |
747 | } |
748 | ||
cb50131a | 749 | /* |
29a861e7 NC |
750 | |
751 | =for apidoc av_create_and_push | |
752 | ||
753 | Push an SV onto the end of the array, creating the array if necessary. | |
754 | A small internal helper function to remove a commonly duplicated idiom. | |
755 | ||
756 | =cut | |
757 | */ | |
758 | ||
759 | void | |
760 | Perl_av_create_and_push(pTHX_ AV **const avp, SV *const val) | |
761 | { | |
7918f24d | 762 | PERL_ARGS_ASSERT_AV_CREATE_AND_PUSH; |
2fed2a1b | 763 | |
832a378e KW |
764 | if (!*avp) |
765 | *avp = newAV(); | |
766 | av_push(*avp, val); | |
29a861e7 NC |
767 | } |
768 | ||
769 | /* | |
cb50131a CB |
770 | =for apidoc av_push |
771 | ||
b895c103 KW |
772 | Pushes an SV (transferring control of one reference count) onto the end of the |
773 | array. The array will grow automatically to accommodate the addition. | |
cb50131a | 774 | |
17b0bd77 | 775 | Perl equivalent: C<push @myarray, $val;>. |
f0b90de1 | 776 | |
cb50131a CB |
777 | =cut |
778 | */ | |
779 | ||
a0d0e21e | 780 | void |
5aaab254 | 781 | Perl_av_push(pTHX_ AV *av, SV *val) |
93965878 NIS |
782 | { |
783 | MAGIC *mg; | |
7918f24d NC |
784 | |
785 | PERL_ARGS_ASSERT_AV_PUSH; | |
2fed2a1b | 786 | assert(SvTYPE(av) == SVt_PVAV); |
ba5d1d60 | 787 | |
93965878 | 788 | if (SvREADONLY(av)) |
1604cfb0 | 789 | Perl_croak_no_modify(); |
93965878 | 790 | |
ad64d0ec | 791 | if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) { |
1604cfb0 MS |
792 | Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(PUSH), G_DISCARD, 1, |
793 | val); | |
794 | return; | |
93965878 NIS |
795 | } |
796 | av_store(av,AvFILLp(av)+1,val); | |
79072805 LW |
797 | } |
798 | ||
cb50131a CB |
799 | /* |
800 | =for apidoc av_pop | |
801 | ||
f5d13a25 KW |
802 | Removes one SV from the end of the array, reducing its size by one and |
803 | returning the SV (transferring control of one reference count) to the | |
804 | caller. Returns C<&PL_sv_undef> if the array is empty. | |
cb50131a | 805 | |
f0b90de1 SF |
806 | Perl equivalent: C<pop(@myarray);> |
807 | ||
cb50131a CB |
808 | =cut |
809 | */ | |
810 | ||
79072805 | 811 | SV * |
5aaab254 | 812 | Perl_av_pop(pTHX_ AV *av) |
79072805 LW |
813 | { |
814 | SV *retval; | |
93965878 | 815 | MAGIC* mg; |
79072805 | 816 | |
7918f24d | 817 | PERL_ARGS_ASSERT_AV_POP; |
2fed2a1b | 818 | assert(SvTYPE(av) == SVt_PVAV); |
ba5d1d60 | 819 | |
43fcc5d2 | 820 | if (SvREADONLY(av)) |
1604cfb0 | 821 | Perl_croak_no_modify(); |
ad64d0ec | 822 | if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) { |
1604cfb0 MS |
823 | retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(POP), 0, 0); |
824 | if (retval) | |
825 | retval = newSVsv(retval); | |
826 | return retval; | |
93965878 | 827 | } |
d19c0e07 | 828 | if (AvFILL(av) < 0) |
1604cfb0 | 829 | return &PL_sv_undef; |
93965878 | 830 | retval = AvARRAY(av)[AvFILLp(av)]; |
ce0d59fd | 831 | AvARRAY(av)[AvFILLp(av)--] = NULL; |
8990e307 | 832 | if (SvSMAGICAL(av)) |
1604cfb0 | 833 | mg_set(MUTABLE_SV(av)); |
ce0d59fd | 834 | return retval ? retval : &PL_sv_undef; |
79072805 LW |
835 | } |
836 | ||
cb50131a | 837 | /* |
29a861e7 NC |
838 | |
839 | =for apidoc av_create_and_unshift_one | |
840 | ||
841 | Unshifts an SV onto the beginning of the array, creating the array if | |
842 | necessary. | |
843 | A small internal helper function to remove a commonly duplicated idiom. | |
844 | ||
845 | =cut | |
846 | */ | |
847 | ||
848 | SV ** | |
849 | Perl_av_create_and_unshift_one(pTHX_ AV **const avp, SV *const val) | |
850 | { | |
7918f24d | 851 | PERL_ARGS_ASSERT_AV_CREATE_AND_UNSHIFT_ONE; |
2fed2a1b | 852 | |
832a378e KW |
853 | if (!*avp) |
854 | *avp = newAV(); | |
855 | av_unshift(*avp, 1); | |
856 | return av_store(*avp, 0, val); | |
29a861e7 NC |
857 | } |
858 | ||
859 | /* | |
cb50131a CB |
860 | =for apidoc av_unshift |
861 | ||
862 | Unshift the given number of C<undef> values onto the beginning of the | |
17b0bd77 | 863 | array. The array will grow automatically to accommodate the addition. |
cb50131a | 864 | |
17b0bd77 | 865 | Perl equivalent: S<C<unshift @myarray, ((undef) x $num);>> |
f703fc96 | 866 | |
cb50131a CB |
867 | =cut |
868 | */ | |
869 | ||
79072805 | 870 | void |
c70927a6 | 871 | Perl_av_unshift(pTHX_ AV *av, SSize_t num) |
79072805 | 872 | { |
c70927a6 | 873 | SSize_t i; |
93965878 | 874 | MAGIC* mg; |
79072805 | 875 | |
7918f24d | 876 | PERL_ARGS_ASSERT_AV_UNSHIFT; |
2fed2a1b | 877 | assert(SvTYPE(av) == SVt_PVAV); |
ba5d1d60 | 878 | |
43fcc5d2 | 879 | if (SvREADONLY(av)) |
1604cfb0 | 880 | Perl_croak_no_modify(); |
93965878 | 881 | |
ad64d0ec | 882 | if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) { |
1604cfb0 MS |
883 | Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(UNSHIFT), |
884 | G_DISCARD | G_UNDEF_FILL, num); | |
885 | return; | |
93965878 NIS |
886 | } |
887 | ||
d19c0e07 MJD |
888 | if (num <= 0) |
889 | return; | |
49beac48 | 890 | if (!AvREAL(av) && AvREIFY(av)) |
1604cfb0 | 891 | av_reify(av); |
a0d0e21e LW |
892 | i = AvARRAY(av) - AvALLOC(av); |
893 | if (i) { | |
1604cfb0 MS |
894 | if (i > num) |
895 | i = num; | |
896 | num -= i; | |
a0d0e21e | 897 | |
1604cfb0 MS |
898 | AvMAX(av) += i; |
899 | AvFILLp(av) += i; | |
900 | AvARRAY(av) = AvARRAY(av) - i; | |
4f91780c DM |
901 | #ifdef PERL_RC_STACK |
902 | Zero(AvARRAY(av), i, SV*); | |
903 | #endif | |
a0d0e21e | 904 | } |
d2719217 | 905 | if (num) { |
1604cfb0 MS |
906 | SV **ary; |
907 | const SSize_t i = AvFILLp(av); | |
908 | /* Create extra elements */ | |
909 | const SSize_t slide = i > 0 ? i : 0; | |
910 | num += slide; | |
911 | av_extend(av, i + num); | |
912 | AvFILLp(av) += num; | |
913 | ary = AvARRAY(av); | |
914 | Move(ary, ary + num, i + 1, SV*); | |
915 | do { | |
916 | ary[--num] = NULL; | |
917 | } while (num); | |
918 | /* Make extra elements into a buffer */ | |
919 | AvMAX(av) -= slide; | |
920 | AvFILLp(av) -= slide; | |
921 | AvARRAY(av) = AvARRAY(av) + slide; | |
79072805 LW |
922 | } |
923 | } | |
924 | ||
cb50131a CB |
925 | /* |
926 | =for apidoc av_shift | |
927 | ||
dbc2ea0c S |
928 | Removes one SV from the start of the array, reducing its size by one and |
929 | returning the SV (transferring control of one reference count) to the | |
930 | caller. Returns C<&PL_sv_undef> if the array is empty. | |
cb50131a | 931 | |
f0b90de1 SF |
932 | Perl equivalent: C<shift(@myarray);> |
933 | ||
cb50131a CB |
934 | =cut |
935 | */ | |
936 | ||
79072805 | 937 | SV * |
5aaab254 | 938 | Perl_av_shift(pTHX_ AV *av) |
79072805 LW |
939 | { |
940 | SV *retval; | |
93965878 | 941 | MAGIC* mg; |
79072805 | 942 | |
7918f24d | 943 | PERL_ARGS_ASSERT_AV_SHIFT; |
2fed2a1b | 944 | assert(SvTYPE(av) == SVt_PVAV); |
ba5d1d60 | 945 | |
43fcc5d2 | 946 | if (SvREADONLY(av)) |
1604cfb0 | 947 | Perl_croak_no_modify(); |
ad64d0ec | 948 | if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) { |
1604cfb0 MS |
949 | retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(SHIFT), 0, 0); |
950 | if (retval) | |
951 | retval = newSVsv(retval); | |
952 | return retval; | |
93965878 | 953 | } |
d19c0e07 MJD |
954 | if (AvFILL(av) < 0) |
955 | return &PL_sv_undef; | |
463ee0b2 | 956 | retval = *AvARRAY(av); |
4f91780c | 957 | #ifndef PERL_RC_STACK |
a0d0e21e | 958 | if (AvREAL(av)) |
1604cfb0 | 959 | *AvARRAY(av) = NULL; |
4f91780c | 960 | #endif |
9c6bc640 | 961 | AvARRAY(av) = AvARRAY(av) + 1; |
463ee0b2 | 962 | AvMAX(av)--; |
93965878 | 963 | AvFILLp(av)--; |
8990e307 | 964 | if (SvSMAGICAL(av)) |
1604cfb0 | 965 | mg_set(MUTABLE_SV(av)); |
ce0d59fd | 966 | return retval ? retval : &PL_sv_undef; |
79072805 LW |
967 | } |
968 | ||
cb50131a | 969 | /* |
a56541eb KW |
970 | =for apidoc av_tindex |
971 | =for apidoc_item av_top_index | |
cb50131a | 972 | |
a56541eb KW |
973 | These behave identically. |
974 | If the array C<av> is empty, these return -1; otherwise they return the maximum | |
975 | value of the indices of all the array elements which are currently defined in | |
976 | C<av>. | |
cb50131a | 977 | |
a56541eb | 978 | They process 'get' magic. |
a8676f70 | 979 | |
a56541eb KW |
980 | The Perl equivalent for these is C<$#av>. |
981 | ||
982 | Use C<L</av_count>> to get the number of elements in an array. | |
12719193 | 983 | |
36baafc9 KW |
984 | =for apidoc av_len |
985 | ||
b985ae61 | 986 | Same as L</av_top_index>. Note that, unlike what the name implies, it returns |
a56541eb | 987 | the maximum index in the array. This is unlike L</sv_len>, which returns what |
87306e06 KW |
988 | you would expect. |
989 | ||
990 | B<To get the true number of elements in the array, instead use C<L</av_count>>>. | |
36baafc9 | 991 | |
cb50131a CB |
992 | =cut |
993 | */ | |
994 | ||
c70927a6 | 995 | SSize_t |
bb5dd93d | 996 | Perl_av_len(pTHX_ AV *av) |
79072805 | 997 | { |
7918f24d | 998 | PERL_ARGS_ASSERT_AV_LEN; |
36baafc9 | 999 | |
be3a7a5d | 1000 | return av_top_index(av); |
36baafc9 KW |
1001 | } |
1002 | ||
f3b76584 SC |
1003 | /* |
1004 | =for apidoc av_fill | |
1005 | ||
977a499b | 1006 | Set the highest index in the array to the given number, equivalent to |
61b16eb9 | 1007 | Perl's S<C<$#array = $fill;>>. |
f3b76584 | 1008 | |
61b16eb9 | 1009 | The number of elements in the array will be S<C<fill + 1>> after |
796b6530 | 1010 | C<av_fill()> returns. If the array was previously shorter, then the |
ce0d59fd | 1011 | additional elements appended are set to NULL. If the array |
61b16eb9 | 1012 | was longer, then the excess elements are freed. S<C<av_fill(av, -1)>> is |
977a499b GA |
1013 | the same as C<av_clear(av)>. |
1014 | ||
f3b76584 SC |
1015 | =cut |
1016 | */ | |
79072805 | 1017 | void |
c70927a6 | 1018 | Perl_av_fill(pTHX_ AV *av, SSize_t fill) |
79072805 | 1019 | { |
93965878 | 1020 | MAGIC *mg; |
ba5d1d60 | 1021 | |
7918f24d | 1022 | PERL_ARGS_ASSERT_AV_FILL; |
2fed2a1b | 1023 | assert(SvTYPE(av) == SVt_PVAV); |
ba5d1d60 | 1024 | |
79072805 | 1025 | if (fill < 0) |
1604cfb0 | 1026 | fill = -1; |
ad64d0ec | 1027 | if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) { |
1604cfb0 MS |
1028 | SV *arg1 = sv_newmortal(); |
1029 | sv_setiv(arg1, (IV)(fill + 1)); | |
1030 | Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(STORESIZE), G_DISCARD, | |
1031 | 1, arg1); | |
1032 | return; | |
93965878 | 1033 | } |
463ee0b2 | 1034 | if (fill <= AvMAX(av)) { |
1604cfb0 MS |
1035 | SSize_t key = AvFILLp(av); |
1036 | SV** const ary = AvARRAY(av); | |
1037 | ||
1038 | if (AvREAL(av)) { | |
1039 | while (key > fill) { | |
1040 | SvREFCNT_dec(ary[key]); | |
1041 | ary[key--] = NULL; | |
1042 | } | |
1043 | } | |
1044 | else { | |
1045 | while (key < fill) | |
1046 | ary[++key] = NULL; | |
1047 | } | |
1048 | ||
1049 | AvFILLp(av) = fill; | |
1050 | if (SvSMAGICAL(av)) | |
1051 | mg_set(MUTABLE_SV(av)); | |
463ee0b2 | 1052 | } |
a0d0e21e | 1053 | else |
1604cfb0 | 1054 | (void)av_store(av,fill,NULL); |
79072805 | 1055 | } |
c750a3ec | 1056 | |
f3b76584 SC |
1057 | /* |
1058 | =for apidoc av_delete | |
1059 | ||
17b0bd77 DM |
1060 | Deletes the element indexed by C<key> from the array, makes the element |
1061 | mortal, and returns it. If C<flags> equals C<G_DISCARD>, the element is | |
1062 | freed and NULL is returned. NULL is also returned if C<key> is out of | |
1063 | range. | |
1064 | ||
1065 | Perl equivalent: S<C<splice(@myarray, $key, 1, undef)>> (with the | |
1066 | C<splice> in void context if C<G_DISCARD> is present). | |
f3b76584 SC |
1067 | |
1068 | =cut | |
1069 | */ | |
146174a9 | 1070 | SV * |
c70927a6 | 1071 | Perl_av_delete(pTHX_ AV *av, SSize_t key, I32 flags) |
146174a9 CB |
1072 | { |
1073 | SV *sv; | |
1074 | ||
7918f24d | 1075 | PERL_ARGS_ASSERT_AV_DELETE; |
2fed2a1b | 1076 | assert(SvTYPE(av) == SVt_PVAV); |
ba5d1d60 | 1077 | |
146174a9 | 1078 | if (SvREADONLY(av)) |
1604cfb0 | 1079 | Perl_croak_no_modify(); |
6f12eb6d MJD |
1080 | |
1081 | if (SvRMAGICAL(av)) { | |
ad64d0ec | 1082 | const MAGIC * const tied_magic |
1604cfb0 | 1083 | = mg_find((const SV *)av, PERL_MAGIC_tied); |
ad64d0ec | 1084 | if ((tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata))) { |
35a4481c | 1085 | SV **svp; |
6f12eb6d | 1086 | if (key < 0) { |
1604cfb0 MS |
1087 | if (!S_adjust_index(aTHX_ av, tied_magic, &key)) |
1088 | return NULL; | |
6f12eb6d MJD |
1089 | } |
1090 | svp = av_fetch(av, key, TRUE); | |
1091 | if (svp) { | |
1092 | sv = *svp; | |
1093 | mg_clear(sv); | |
1094 | if (mg_find(sv, PERL_MAGIC_tiedelem)) { | |
1095 | sv_unmagic(sv, PERL_MAGIC_tiedelem); /* No longer an element */ | |
1096 | return sv; | |
1097 | } | |
1604cfb0 | 1098 | return NULL; |
6f12eb6d MJD |
1099 | } |
1100 | } | |
1101 | } | |
1102 | ||
146174a9 | 1103 | if (key < 0) { |
1604cfb0 MS |
1104 | key += AvFILL(av) + 1; |
1105 | if (key < 0) | |
1106 | return NULL; | |
146174a9 | 1107 | } |
6f12eb6d | 1108 | |
146174a9 | 1109 | if (key > AvFILLp(av)) |
1604cfb0 | 1110 | return NULL; |
146174a9 | 1111 | else { |
1604cfb0 MS |
1112 | if (!AvREAL(av) && AvREIFY(av)) |
1113 | av_reify(av); | |
1114 | sv = AvARRAY(av)[key]; | |
1115 | AvARRAY(av)[key] = NULL; | |
1116 | if (key == AvFILLp(av)) { | |
1117 | do { | |
1118 | AvFILLp(av)--; | |
1119 | } while (--key >= 0 && !AvARRAY(av)[key]); | |
1120 | } | |
1121 | if (SvSMAGICAL(av)) | |
1122 | mg_set(MUTABLE_SV(av)); | |
146174a9 | 1123 | } |
725995b4 | 1124 | if(sv != NULL) { |
1604cfb0 MS |
1125 | if (flags & G_DISCARD) { |
1126 | SvREFCNT_dec_NN(sv); | |
1127 | return NULL; | |
1128 | } | |
1129 | else if (AvREAL(av)) | |
1130 | sv_2mortal(sv); | |
146174a9 CB |
1131 | } |
1132 | return sv; | |
1133 | } | |
1134 | ||
1135 | /* | |
f3b76584 SC |
1136 | =for apidoc av_exists |
1137 | ||
1138 | Returns true if the element indexed by C<key> has been initialized. | |
146174a9 | 1139 | |
f3b76584 | 1140 | This relies on the fact that uninitialized array elements are set to |
796b6530 | 1141 | C<NULL>. |
f3b76584 | 1142 | |
b7ff7ff2 SF |
1143 | Perl equivalent: C<exists($myarray[$key])>. |
1144 | ||
f3b76584 SC |
1145 | =cut |
1146 | */ | |
146174a9 | 1147 | bool |
c70927a6 | 1148 | Perl_av_exists(pTHX_ AV *av, SSize_t key) |
146174a9 | 1149 | { |
7918f24d | 1150 | PERL_ARGS_ASSERT_AV_EXISTS; |
2fed2a1b | 1151 | assert(SvTYPE(av) == SVt_PVAV); |
6f12eb6d MJD |
1152 | |
1153 | if (SvRMAGICAL(av)) { | |
ad64d0ec | 1154 | const MAGIC * const tied_magic |
1604cfb0 | 1155 | = mg_find((const SV *)av, PERL_MAGIC_tied); |
54a4274e PM |
1156 | const MAGIC * const regdata_magic |
1157 | = mg_find((const SV *)av, PERL_MAGIC_regdata); | |
1158 | if (tied_magic || regdata_magic) { | |
6f12eb6d MJD |
1159 | MAGIC *mg; |
1160 | /* Handle negative array indices 20020222 MJD */ | |
1161 | if (key < 0) { | |
1604cfb0 | 1162 | if (!S_adjust_index(aTHX_ av, tied_magic, &key)) |
6f12eb6d | 1163 | return FALSE; |
6f12eb6d MJD |
1164 | } |
1165 | ||
54a4274e PM |
1166 | if(key >= 0 && regdata_magic) { |
1167 | if (key <= AvFILL(av)) | |
1168 | return TRUE; | |
1169 | else | |
1170 | return FALSE; | |
1171 | } | |
1604cfb0 MS |
1172 | { |
1173 | SV * const sv = sv_newmortal(); | |
1174 | mg_copy(MUTABLE_SV(av), sv, 0, key); | |
1175 | mg = mg_find(sv, PERL_MAGIC_tiedelem); | |
1176 | if (mg) { | |
1177 | magic_existspack(sv, mg); | |
1178 | { | |
1179 | I32 retbool = SvTRUE_nomg_NN(sv); | |
1180 | return cBOOL(retbool); | |
1181 | } | |
1182 | } | |
1183 | } | |
6f12eb6d MJD |
1184 | } |
1185 | } | |
1186 | ||
146174a9 | 1187 | if (key < 0) { |
1604cfb0 MS |
1188 | key += AvFILL(av) + 1; |
1189 | if (key < 0) | |
1190 | return FALSE; | |
146174a9 | 1191 | } |
6f12eb6d | 1192 | |
ce0d59fd | 1193 | if (key <= AvFILLp(av) && AvARRAY(av)[key]) |
146174a9 | 1194 | { |
1604cfb0 MS |
1195 | if (SvSMAGICAL(AvARRAY(av)[key]) |
1196 | && mg_find(AvARRAY(av)[key], PERL_MAGIC_nonelem)) | |
1197 | return FALSE; | |
1198 | return TRUE; | |
146174a9 CB |
1199 | } |
1200 | else | |
1604cfb0 | 1201 | return FALSE; |
146174a9 | 1202 | } |
66610fdd | 1203 | |
c33269f7 | 1204 | static MAGIC * |
878d132a | 1205 | S_get_aux_mg(pTHX_ AV *av) { |
ba5d1d60 GA |
1206 | MAGIC *mg; |
1207 | ||
7918f24d | 1208 | PERL_ARGS_ASSERT_GET_AUX_MG; |
2fed2a1b | 1209 | assert(SvTYPE(av) == SVt_PVAV); |
ba5d1d60 | 1210 | |
ad64d0ec | 1211 | mg = mg_find((const SV *)av, PERL_MAGIC_arylen_p); |
a3874608 NC |
1212 | |
1213 | if (!mg) { | |
1604cfb0 MS |
1214 | mg = sv_magicext(MUTABLE_SV(av), 0, PERL_MAGIC_arylen_p, |
1215 | &PL_vtbl_arylen_p, 0, 0); | |
1216 | assert(mg); | |
1217 | /* sv_magicext won't set this for us because we pass in a NULL obj */ | |
1218 | mg->mg_flags |= MGf_REFCOUNTED; | |
a3874608 | 1219 | } |
878d132a NC |
1220 | return mg; |
1221 | } | |
1222 | ||
1223 | SV ** | |
1224 | Perl_av_arylen_p(pTHX_ AV *av) { | |
1225 | MAGIC *const mg = get_aux_mg(av); | |
7918f24d NC |
1226 | |
1227 | PERL_ARGS_ASSERT_AV_ARYLEN_P; | |
2fed2a1b | 1228 | assert(SvTYPE(av) == SVt_PVAV); |
7918f24d | 1229 | |
a3874608 NC |
1230 | return &(mg->mg_obj); |
1231 | } | |
1232 | ||
453d94a9 | 1233 | IV * |
878d132a NC |
1234 | Perl_av_iter_p(pTHX_ AV *av) { |
1235 | MAGIC *const mg = get_aux_mg(av); | |
7918f24d NC |
1236 | |
1237 | PERL_ARGS_ASSERT_AV_ITER_P; | |
2fed2a1b | 1238 | assert(SvTYPE(av) == SVt_PVAV); |
7918f24d | 1239 | |
4803e7f7 | 1240 | if (sizeof(IV) == sizeof(SSize_t)) { |
1604cfb0 | 1241 | return (IV *)&(mg->mg_len); |
4803e7f7 | 1242 | } else { |
1604cfb0 MS |
1243 | if (!mg->mg_ptr) { |
1244 | IV *temp; | |
1245 | mg->mg_len = IVSIZE; | |
1246 | Newxz(temp, 1, IV); | |
1247 | mg->mg_ptr = (char *) temp; | |
1248 | } | |
1249 | return (IV *)mg->mg_ptr; | |
453d94a9 | 1250 | } |
878d132a NC |
1251 | } |
1252 | ||
1f1dcfb5 FC |
1253 | SV * |
1254 | Perl_av_nonelem(pTHX_ AV *av, SSize_t ix) { | |
8fcb2425 | 1255 | SV * const sv = newSV_type(SVt_NULL); |
1f1dcfb5 FC |
1256 | PERL_ARGS_ASSERT_AV_NONELEM; |
1257 | if (!av_store(av,ix,sv)) | |
1604cfb0 | 1258 | return sv_2mortal(sv); /* has tie magic */ |
1f1dcfb5 FC |
1259 | sv_magic(sv, NULL, PERL_MAGIC_nonelem, NULL, 0); |
1260 | return sv; | |
1261 | } | |
1262 | ||
66610fdd | 1263 | /* |
14d04a33 | 1264 | * ex: set ts=8 sts=4 sw=4 et: |
37442d52 | 1265 | */ |