1 | /* av.c |
---|
2 | * |
---|
3 | * Copyright (c) 1991-2001, Larry Wall |
---|
4 | * |
---|
5 | * You may distribute under the terms of either the GNU General Public |
---|
6 | * License or the Artistic License, as specified in the README file. |
---|
7 | * |
---|
8 | */ |
---|
9 | |
---|
10 | /* |
---|
11 | * "...for the Entwives desired order, and plenty, and peace (by which they |
---|
12 | * meant that things should remain where they had set them)." --Treebeard |
---|
13 | */ |
---|
14 | |
---|
15 | #include "EXTERN.h" |
---|
16 | #define PERL_IN_AV_C |
---|
17 | #include "perl.h" |
---|
18 | |
---|
19 | void |
---|
20 | Perl_av_reify(pTHX_ AV *av) |
---|
21 | { |
---|
22 | I32 key; |
---|
23 | SV* sv; |
---|
24 | |
---|
25 | if (AvREAL(av)) |
---|
26 | return; |
---|
27 | #ifdef DEBUGGING |
---|
28 | if (SvTIED_mg((SV*)av, 'P') && ckWARN_d(WARN_DEBUGGING)) |
---|
29 | Perl_warner(aTHX_ WARN_DEBUGGING, "av_reify called on tied array"); |
---|
30 | #endif |
---|
31 | key = AvMAX(av) + 1; |
---|
32 | while (key > AvFILLp(av) + 1) |
---|
33 | AvARRAY(av)[--key] = &PL_sv_undef; |
---|
34 | while (key) { |
---|
35 | sv = AvARRAY(av)[--key]; |
---|
36 | assert(sv); |
---|
37 | if (sv != &PL_sv_undef) |
---|
38 | (void)SvREFCNT_inc(sv); |
---|
39 | } |
---|
40 | key = AvARRAY(av) - AvALLOC(av); |
---|
41 | while (key) |
---|
42 | AvALLOC(av)[--key] = &PL_sv_undef; |
---|
43 | AvREIFY_off(av); |
---|
44 | AvREAL_on(av); |
---|
45 | } |
---|
46 | |
---|
47 | /* |
---|
48 | =for apidoc av_extend |
---|
49 | |
---|
50 | Pre-extend an array. The C<key> is the index to which the array should be |
---|
51 | extended. |
---|
52 | |
---|
53 | =cut |
---|
54 | */ |
---|
55 | |
---|
56 | void |
---|
57 | Perl_av_extend(pTHX_ AV *av, I32 key) |
---|
58 | { |
---|
59 | MAGIC *mg; |
---|
60 | if ((mg = SvTIED_mg((SV*)av, 'P'))) { |
---|
61 | dSP; |
---|
62 | ENTER; |
---|
63 | SAVETMPS; |
---|
64 | PUSHSTACKi(PERLSI_MAGIC); |
---|
65 | PUSHMARK(SP); |
---|
66 | EXTEND(SP,2); |
---|
67 | PUSHs(SvTIED_obj((SV*)av, mg)); |
---|
68 | PUSHs(sv_2mortal(newSViv(key+1))); |
---|
69 | PUTBACK; |
---|
70 | call_method("EXTEND", G_SCALAR|G_DISCARD); |
---|
71 | POPSTACK; |
---|
72 | FREETMPS; |
---|
73 | LEAVE; |
---|
74 | return; |
---|
75 | } |
---|
76 | if (key > AvMAX(av)) { |
---|
77 | SV** ary; |
---|
78 | I32 tmp; |
---|
79 | I32 newmax; |
---|
80 | |
---|
81 | if (AvALLOC(av) != AvARRAY(av)) { |
---|
82 | ary = AvALLOC(av) + AvFILLp(av) + 1; |
---|
83 | tmp = AvARRAY(av) - AvALLOC(av); |
---|
84 | Move(AvARRAY(av), AvALLOC(av), AvFILLp(av)+1, SV*); |
---|
85 | AvMAX(av) += tmp; |
---|
86 | SvPVX(av) = (char*)AvALLOC(av); |
---|
87 | if (AvREAL(av)) { |
---|
88 | while (tmp) |
---|
89 | ary[--tmp] = &PL_sv_undef; |
---|
90 | } |
---|
91 | |
---|
92 | if (key > AvMAX(av) - 10) { |
---|
93 | newmax = key + AvMAX(av); |
---|
94 | goto resize; |
---|
95 | } |
---|
96 | } |
---|
97 | else { |
---|
98 | if (AvALLOC(av)) { |
---|
99 | #ifndef STRANGE_MALLOC |
---|
100 | MEM_SIZE bytes; |
---|
101 | IV itmp; |
---|
102 | #endif |
---|
103 | |
---|
104 | #if defined(MYMALLOC) && !defined(LEAKTEST) |
---|
105 | newmax = malloced_size((void*)AvALLOC(av))/sizeof(SV*) - 1; |
---|
106 | |
---|
107 | if (key <= newmax) |
---|
108 | goto resized; |
---|
109 | #endif |
---|
110 | newmax = key + AvMAX(av) / 5; |
---|
111 | resize: |
---|
112 | #if defined(STRANGE_MALLOC) || defined(MYMALLOC) |
---|
113 | Renew(AvALLOC(av),newmax+1, SV*); |
---|
114 | #else |
---|
115 | bytes = (newmax + 1) * sizeof(SV*); |
---|
116 | #define MALLOC_OVERHEAD 16 |
---|
117 | itmp = MALLOC_OVERHEAD; |
---|
118 | while (itmp - MALLOC_OVERHEAD < bytes) |
---|
119 | itmp += itmp; |
---|
120 | itmp -= MALLOC_OVERHEAD; |
---|
121 | itmp /= sizeof(SV*); |
---|
122 | assert(itmp > newmax); |
---|
123 | newmax = itmp - 1; |
---|
124 | assert(newmax >= AvMAX(av)); |
---|
125 | New(2,ary, newmax+1, SV*); |
---|
126 | Copy(AvALLOC(av), ary, AvMAX(av)+1, SV*); |
---|
127 | if (AvMAX(av) > 64) |
---|
128 | offer_nice_chunk(AvALLOC(av), (AvMAX(av)+1) * sizeof(SV*)); |
---|
129 | else |
---|
130 | Safefree(AvALLOC(av)); |
---|
131 | AvALLOC(av) = ary; |
---|
132 | #endif |
---|
133 | resized: |
---|
134 | ary = AvALLOC(av) + AvMAX(av) + 1; |
---|
135 | tmp = newmax - AvMAX(av); |
---|
136 | if (av == PL_curstack) { /* Oops, grew stack (via av_store()?) */ |
---|
137 | PL_stack_sp = AvALLOC(av) + (PL_stack_sp - PL_stack_base); |
---|
138 | PL_stack_base = AvALLOC(av); |
---|
139 | PL_stack_max = PL_stack_base + newmax; |
---|
140 | } |
---|
141 | } |
---|
142 | else { |
---|
143 | newmax = key < 3 ? 3 : key; |
---|
144 | New(2,AvALLOC(av), newmax+1, SV*); |
---|
145 | ary = AvALLOC(av) + 1; |
---|
146 | tmp = newmax; |
---|
147 | AvALLOC(av)[0] = &PL_sv_undef; /* For the stacks */ |
---|
148 | } |
---|
149 | if (AvREAL(av)) { |
---|
150 | while (tmp) |
---|
151 | ary[--tmp] = &PL_sv_undef; |
---|
152 | } |
---|
153 | |
---|
154 | SvPVX(av) = (char*)AvALLOC(av); |
---|
155 | AvMAX(av) = newmax; |
---|
156 | } |
---|
157 | } |
---|
158 | } |
---|
159 | |
---|
160 | /* |
---|
161 | =for apidoc av_fetch |
---|
162 | |
---|
163 | Returns the SV at the specified index in the array. The C<key> is the |
---|
164 | index. If C<lval> is set then the fetch will be part of a store. Check |
---|
165 | that the return value is non-null before dereferencing it to a C<SV*>. |
---|
166 | |
---|
167 | See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for |
---|
168 | more information on how to use this function on tied arrays. |
---|
169 | |
---|
170 | =cut |
---|
171 | */ |
---|
172 | |
---|
173 | SV** |
---|
174 | Perl_av_fetch(pTHX_ register AV *av, I32 key, I32 lval) |
---|
175 | { |
---|
176 | SV *sv; |
---|
177 | |
---|
178 | if (!av) |
---|
179 | return 0; |
---|
180 | |
---|
181 | if (key < 0) { |
---|
182 | key += AvFILL(av) + 1; |
---|
183 | if (key < 0) |
---|
184 | return 0; |
---|
185 | } |
---|
186 | |
---|
187 | if (SvRMAGICAL(av)) { |
---|
188 | if (mg_find((SV*)av,'P') || mg_find((SV*)av,'D')) { |
---|
189 | sv = sv_newmortal(); |
---|
190 | mg_copy((SV*)av, sv, 0, key); |
---|
191 | PL_av_fetch_sv = sv; |
---|
192 | return &PL_av_fetch_sv; |
---|
193 | } |
---|
194 | } |
---|
195 | |
---|
196 | if (key > AvFILLp(av)) { |
---|
197 | if (!lval) |
---|
198 | return 0; |
---|
199 | sv = NEWSV(5,0); |
---|
200 | return av_store(av,key,sv); |
---|
201 | } |
---|
202 | if (AvARRAY(av)[key] == &PL_sv_undef) { |
---|
203 | emptyness: |
---|
204 | if (lval) { |
---|
205 | sv = NEWSV(6,0); |
---|
206 | return av_store(av,key,sv); |
---|
207 | } |
---|
208 | return 0; |
---|
209 | } |
---|
210 | else if (AvREIFY(av) |
---|
211 | && (!AvARRAY(av)[key] /* eg. @_ could have freed elts */ |
---|
212 | || SvTYPE(AvARRAY(av)[key]) == SVTYPEMASK)) { |
---|
213 | AvARRAY(av)[key] = &PL_sv_undef; /* 1/2 reify */ |
---|
214 | goto emptyness; |
---|
215 | } |
---|
216 | return &AvARRAY(av)[key]; |
---|
217 | } |
---|
218 | |
---|
219 | /* |
---|
220 | =for apidoc av_store |
---|
221 | |
---|
222 | Stores an SV in an array. The array index is specified as C<key>. The |
---|
223 | return value will be NULL if the operation failed or if the value did not |
---|
224 | need to be actually stored within the array (as in the case of tied |
---|
225 | arrays). Otherwise it can be dereferenced to get the original C<SV*>. Note |
---|
226 | that the caller is responsible for suitably incrementing the reference |
---|
227 | count of C<val> before the call, and decrementing it if the function |
---|
228 | returned NULL. |
---|
229 | |
---|
230 | See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for |
---|
231 | more information on how to use this function on tied arrays. |
---|
232 | |
---|
233 | =cut |
---|
234 | */ |
---|
235 | |
---|
236 | SV** |
---|
237 | Perl_av_store(pTHX_ register AV *av, I32 key, SV *val) |
---|
238 | { |
---|
239 | SV** ary; |
---|
240 | |
---|
241 | if (!av) |
---|
242 | return 0; |
---|
243 | if (!val) |
---|
244 | val = &PL_sv_undef; |
---|
245 | |
---|
246 | if (key < 0) { |
---|
247 | key += AvFILL(av) + 1; |
---|
248 | if (key < 0) |
---|
249 | return 0; |
---|
250 | } |
---|
251 | |
---|
252 | if (SvREADONLY(av) && key >= AvFILL(av)) |
---|
253 | Perl_croak(aTHX_ PL_no_modify); |
---|
254 | |
---|
255 | if (SvRMAGICAL(av)) { |
---|
256 | if (mg_find((SV*)av,'P')) { |
---|
257 | if (val != &PL_sv_undef) { |
---|
258 | mg_copy((SV*)av, val, 0, key); |
---|
259 | } |
---|
260 | return 0; |
---|
261 | } |
---|
262 | } |
---|
263 | |
---|
264 | if (!AvREAL(av) && AvREIFY(av)) |
---|
265 | av_reify(av); |
---|
266 | if (key > AvMAX(av)) |
---|
267 | av_extend(av,key); |
---|
268 | ary = AvARRAY(av); |
---|
269 | if (AvFILLp(av) < key) { |
---|
270 | if (!AvREAL(av)) { |
---|
271 | if (av == PL_curstack && key > PL_stack_sp - PL_stack_base) |
---|
272 | PL_stack_sp = PL_stack_base + key; /* XPUSH in disguise */ |
---|
273 | do |
---|
274 | ary[++AvFILLp(av)] = &PL_sv_undef; |
---|
275 | while (AvFILLp(av) < key); |
---|
276 | } |
---|
277 | AvFILLp(av) = key; |
---|
278 | } |
---|
279 | else if (AvREAL(av)) |
---|
280 | SvREFCNT_dec(ary[key]); |
---|
281 | ary[key] = val; |
---|
282 | if (SvSMAGICAL(av)) { |
---|
283 | if (val != &PL_sv_undef) { |
---|
284 | MAGIC* mg = SvMAGIC(av); |
---|
285 | sv_magic(val, (SV*)av, toLOWER(mg->mg_type), 0, key); |
---|
286 | } |
---|
287 | mg_set((SV*)av); |
---|
288 | } |
---|
289 | return &ary[key]; |
---|
290 | } |
---|
291 | |
---|
292 | /* |
---|
293 | =for apidoc newAV |
---|
294 | |
---|
295 | Creates a new AV. The reference count is set to 1. |
---|
296 | |
---|
297 | =cut |
---|
298 | */ |
---|
299 | |
---|
300 | AV * |
---|
301 | Perl_newAV(pTHX) |
---|
302 | { |
---|
303 | register AV *av; |
---|
304 | |
---|
305 | av = (AV*)NEWSV(3,0); |
---|
306 | sv_upgrade((SV *)av, SVt_PVAV); |
---|
307 | AvREAL_on(av); |
---|
308 | AvALLOC(av) = 0; |
---|
309 | SvPVX(av) = 0; |
---|
310 | AvMAX(av) = AvFILLp(av) = -1; |
---|
311 | return av; |
---|
312 | } |
---|
313 | |
---|
314 | /* |
---|
315 | =for apidoc av_make |
---|
316 | |
---|
317 | Creates a new AV and populates it with a list of SVs. The SVs are copied |
---|
318 | into the array, so they may be freed after the call to av_make. The new AV |
---|
319 | will have a reference count of 1. |
---|
320 | |
---|
321 | =cut |
---|
322 | */ |
---|
323 | |
---|
324 | AV * |
---|
325 | Perl_av_make(pTHX_ register I32 size, register SV **strp) |
---|
326 | { |
---|
327 | register AV *av; |
---|
328 | register I32 i; |
---|
329 | register SV** ary; |
---|
330 | |
---|
331 | av = (AV*)NEWSV(8,0); |
---|
332 | sv_upgrade((SV *) av,SVt_PVAV); |
---|
333 | AvFLAGS(av) = AVf_REAL; |
---|
334 | if (size) { /* `defined' was returning undef for size==0 anyway. */ |
---|
335 | New(4,ary,size,SV*); |
---|
336 | AvALLOC(av) = ary; |
---|
337 | SvPVX(av) = (char*)ary; |
---|
338 | AvFILLp(av) = size - 1; |
---|
339 | AvMAX(av) = size - 1; |
---|
340 | for (i = 0; i < size; i++) { |
---|
341 | assert (*strp); |
---|
342 | ary[i] = NEWSV(7,0); |
---|
343 | sv_setsv(ary[i], *strp); |
---|
344 | strp++; |
---|
345 | } |
---|
346 | } |
---|
347 | return av; |
---|
348 | } |
---|
349 | |
---|
350 | AV * |
---|
351 | Perl_av_fake(pTHX_ register I32 size, register SV **strp) |
---|
352 | { |
---|
353 | register AV *av; |
---|
354 | register SV** ary; |
---|
355 | |
---|
356 | av = (AV*)NEWSV(9,0); |
---|
357 | sv_upgrade((SV *)av, SVt_PVAV); |
---|
358 | New(4,ary,size+1,SV*); |
---|
359 | AvALLOC(av) = ary; |
---|
360 | Copy(strp,ary,size,SV*); |
---|
361 | AvFLAGS(av) = AVf_REIFY; |
---|
362 | SvPVX(av) = (char*)ary; |
---|
363 | AvFILLp(av) = size - 1; |
---|
364 | AvMAX(av) = size - 1; |
---|
365 | while (size--) { |
---|
366 | assert (*strp); |
---|
367 | SvTEMP_off(*strp); |
---|
368 | strp++; |
---|
369 | } |
---|
370 | return av; |
---|
371 | } |
---|
372 | |
---|
373 | /* |
---|
374 | =for apidoc av_clear |
---|
375 | |
---|
376 | Clears an array, making it empty. Does not free the memory used by the |
---|
377 | array itself. |
---|
378 | |
---|
379 | =cut |
---|
380 | */ |
---|
381 | |
---|
382 | void |
---|
383 | Perl_av_clear(pTHX_ register AV *av) |
---|
384 | { |
---|
385 | register I32 key; |
---|
386 | SV** ary; |
---|
387 | |
---|
388 | #ifdef DEBUGGING |
---|
389 | if (SvREFCNT(av) == 0 && ckWARN_d(WARN_DEBUGGING)) { |
---|
390 | Perl_warner(aTHX_ WARN_DEBUGGING, "Attempt to clear deleted array"); |
---|
391 | } |
---|
392 | #endif |
---|
393 | if (!av) |
---|
394 | return; |
---|
395 | /*SUPPRESS 560*/ |
---|
396 | |
---|
397 | if (SvREADONLY(av)) |
---|
398 | Perl_croak(aTHX_ PL_no_modify); |
---|
399 | |
---|
400 | /* Give any tie a chance to cleanup first */ |
---|
401 | if (SvRMAGICAL(av)) |
---|
402 | mg_clear((SV*)av); |
---|
403 | |
---|
404 | if (AvMAX(av) < 0) |
---|
405 | return; |
---|
406 | |
---|
407 | if (AvREAL(av)) { |
---|
408 | ary = AvARRAY(av); |
---|
409 | key = AvFILLp(av) + 1; |
---|
410 | while (key) { |
---|
411 | SvREFCNT_dec(ary[--key]); |
---|
412 | ary[key] = &PL_sv_undef; |
---|
413 | } |
---|
414 | } |
---|
415 | if ((key = AvARRAY(av) - AvALLOC(av))) { |
---|
416 | AvMAX(av) += key; |
---|
417 | SvPVX(av) = (char*)AvALLOC(av); |
---|
418 | } |
---|
419 | AvFILLp(av) = -1; |
---|
420 | |
---|
421 | } |
---|
422 | |
---|
423 | /* |
---|
424 | =for apidoc av_undef |
---|
425 | |
---|
426 | Undefines the array. Frees the memory used by the array itself. |
---|
427 | |
---|
428 | =cut |
---|
429 | */ |
---|
430 | |
---|
431 | void |
---|
432 | Perl_av_undef(pTHX_ register AV *av) |
---|
433 | { |
---|
434 | register I32 key; |
---|
435 | |
---|
436 | if (!av) |
---|
437 | return; |
---|
438 | /*SUPPRESS 560*/ |
---|
439 | |
---|
440 | /* Give any tie a chance to cleanup first */ |
---|
441 | if (SvTIED_mg((SV*)av, 'P')) |
---|
442 | av_fill(av, -1); /* mg_clear() ? */ |
---|
443 | |
---|
444 | if (AvREAL(av)) { |
---|
445 | key = AvFILLp(av) + 1; |
---|
446 | while (key) |
---|
447 | SvREFCNT_dec(AvARRAY(av)[--key]); |
---|
448 | } |
---|
449 | Safefree(AvALLOC(av)); |
---|
450 | AvALLOC(av) = 0; |
---|
451 | SvPVX(av) = 0; |
---|
452 | AvMAX(av) = AvFILLp(av) = -1; |
---|
453 | if (AvARYLEN(av)) { |
---|
454 | SvREFCNT_dec(AvARYLEN(av)); |
---|
455 | AvARYLEN(av) = 0; |
---|
456 | } |
---|
457 | } |
---|
458 | |
---|
459 | /* |
---|
460 | =for apidoc av_push |
---|
461 | |
---|
462 | Pushes an SV onto the end of the array. The array will grow automatically |
---|
463 | to accommodate the addition. |
---|
464 | |
---|
465 | =cut |
---|
466 | */ |
---|
467 | |
---|
468 | void |
---|
469 | Perl_av_push(pTHX_ register AV *av, SV *val) |
---|
470 | { |
---|
471 | MAGIC *mg; |
---|
472 | if (!av) |
---|
473 | return; |
---|
474 | if (SvREADONLY(av)) |
---|
475 | Perl_croak(aTHX_ PL_no_modify); |
---|
476 | |
---|
477 | if ((mg = SvTIED_mg((SV*)av, 'P'))) { |
---|
478 | dSP; |
---|
479 | PUSHSTACKi(PERLSI_MAGIC); |
---|
480 | PUSHMARK(SP); |
---|
481 | EXTEND(SP,2); |
---|
482 | PUSHs(SvTIED_obj((SV*)av, mg)); |
---|
483 | PUSHs(val); |
---|
484 | PUTBACK; |
---|
485 | ENTER; |
---|
486 | call_method("PUSH", G_SCALAR|G_DISCARD); |
---|
487 | LEAVE; |
---|
488 | POPSTACK; |
---|
489 | return; |
---|
490 | } |
---|
491 | av_store(av,AvFILLp(av)+1,val); |
---|
492 | } |
---|
493 | |
---|
494 | /* |
---|
495 | =for apidoc av_pop |
---|
496 | |
---|
497 | Pops an SV off the end of the array. Returns C<&PL_sv_undef> if the array |
---|
498 | is empty. |
---|
499 | |
---|
500 | =cut |
---|
501 | */ |
---|
502 | |
---|
503 | SV * |
---|
504 | Perl_av_pop(pTHX_ register AV *av) |
---|
505 | { |
---|
506 | SV *retval; |
---|
507 | MAGIC* mg; |
---|
508 | |
---|
509 | if (!av || AvFILL(av) < 0) |
---|
510 | return &PL_sv_undef; |
---|
511 | if (SvREADONLY(av)) |
---|
512 | Perl_croak(aTHX_ PL_no_modify); |
---|
513 | if ((mg = SvTIED_mg((SV*)av, 'P'))) { |
---|
514 | dSP; |
---|
515 | PUSHSTACKi(PERLSI_MAGIC); |
---|
516 | PUSHMARK(SP); |
---|
517 | XPUSHs(SvTIED_obj((SV*)av, mg)); |
---|
518 | PUTBACK; |
---|
519 | ENTER; |
---|
520 | if (call_method("POP", G_SCALAR)) { |
---|
521 | retval = newSVsv(*PL_stack_sp--); |
---|
522 | } else { |
---|
523 | retval = &PL_sv_undef; |
---|
524 | } |
---|
525 | LEAVE; |
---|
526 | POPSTACK; |
---|
527 | return retval; |
---|
528 | } |
---|
529 | retval = AvARRAY(av)[AvFILLp(av)]; |
---|
530 | AvARRAY(av)[AvFILLp(av)--] = &PL_sv_undef; |
---|
531 | if (SvSMAGICAL(av)) |
---|
532 | mg_set((SV*)av); |
---|
533 | return retval; |
---|
534 | } |
---|
535 | |
---|
536 | /* |
---|
537 | =for apidoc av_unshift |
---|
538 | |
---|
539 | Unshift the given number of C<undef> values onto the beginning of the |
---|
540 | array. The array will grow automatically to accommodate the addition. You |
---|
541 | must then use C<av_store> to assign values to these new elements. |
---|
542 | |
---|
543 | =cut |
---|
544 | */ |
---|
545 | |
---|
546 | void |
---|
547 | Perl_av_unshift(pTHX_ register AV *av, register I32 num) |
---|
548 | { |
---|
549 | register I32 i; |
---|
550 | register SV **ary; |
---|
551 | MAGIC* mg; |
---|
552 | I32 slide; |
---|
553 | |
---|
554 | if (!av || num <= 0) |
---|
555 | return; |
---|
556 | if (SvREADONLY(av)) |
---|
557 | Perl_croak(aTHX_ PL_no_modify); |
---|
558 | |
---|
559 | if ((mg = SvTIED_mg((SV*)av, 'P'))) { |
---|
560 | dSP; |
---|
561 | PUSHSTACKi(PERLSI_MAGIC); |
---|
562 | PUSHMARK(SP); |
---|
563 | EXTEND(SP,1+num); |
---|
564 | PUSHs(SvTIED_obj((SV*)av, mg)); |
---|
565 | while (num-- > 0) { |
---|
566 | PUSHs(&PL_sv_undef); |
---|
567 | } |
---|
568 | PUTBACK; |
---|
569 | ENTER; |
---|
570 | call_method("UNSHIFT", G_SCALAR|G_DISCARD); |
---|
571 | LEAVE; |
---|
572 | POPSTACK; |
---|
573 | return; |
---|
574 | } |
---|
575 | |
---|
576 | if (!AvREAL(av) && AvREIFY(av)) |
---|
577 | av_reify(av); |
---|
578 | i = AvARRAY(av) - AvALLOC(av); |
---|
579 | if (i) { |
---|
580 | if (i > num) |
---|
581 | i = num; |
---|
582 | num -= i; |
---|
583 | |
---|
584 | AvMAX(av) += i; |
---|
585 | AvFILLp(av) += i; |
---|
586 | SvPVX(av) = (char*)(AvARRAY(av) - i); |
---|
587 | } |
---|
588 | if (num) { |
---|
589 | i = AvFILLp(av); |
---|
590 | /* Create extra elements */ |
---|
591 | slide = i > 0 ? i : 0; |
---|
592 | num += slide; |
---|
593 | av_extend(av, i + num); |
---|
594 | AvFILLp(av) += num; |
---|
595 | ary = AvARRAY(av); |
---|
596 | Move(ary, ary + num, i + 1, SV*); |
---|
597 | do { |
---|
598 | ary[--num] = &PL_sv_undef; |
---|
599 | } while (num); |
---|
600 | /* Make extra elements into a buffer */ |
---|
601 | AvMAX(av) -= slide; |
---|
602 | AvFILLp(av) -= slide; |
---|
603 | SvPVX(av) = (char*)(AvARRAY(av) + slide); |
---|
604 | } |
---|
605 | } |
---|
606 | |
---|
607 | /* |
---|
608 | =for apidoc av_shift |
---|
609 | |
---|
610 | Shifts an SV off the beginning of the array. |
---|
611 | |
---|
612 | =cut |
---|
613 | */ |
---|
614 | |
---|
615 | SV * |
---|
616 | Perl_av_shift(pTHX_ register AV *av) |
---|
617 | { |
---|
618 | SV *retval; |
---|
619 | MAGIC* mg; |
---|
620 | |
---|
621 | if (!av || AvFILL(av) < 0) |
---|
622 | return &PL_sv_undef; |
---|
623 | if (SvREADONLY(av)) |
---|
624 | Perl_croak(aTHX_ PL_no_modify); |
---|
625 | if ((mg = SvTIED_mg((SV*)av, 'P'))) { |
---|
626 | dSP; |
---|
627 | PUSHSTACKi(PERLSI_MAGIC); |
---|
628 | PUSHMARK(SP); |
---|
629 | XPUSHs(SvTIED_obj((SV*)av, mg)); |
---|
630 | PUTBACK; |
---|
631 | ENTER; |
---|
632 | if (call_method("SHIFT", G_SCALAR)) { |
---|
633 | retval = newSVsv(*PL_stack_sp--); |
---|
634 | } else { |
---|
635 | retval = &PL_sv_undef; |
---|
636 | } |
---|
637 | LEAVE; |
---|
638 | POPSTACK; |
---|
639 | return retval; |
---|
640 | } |
---|
641 | retval = *AvARRAY(av); |
---|
642 | if (AvREAL(av)) |
---|
643 | *AvARRAY(av) = &PL_sv_undef; |
---|
644 | SvPVX(av) = (char*)(AvARRAY(av) + 1); |
---|
645 | AvMAX(av)--; |
---|
646 | AvFILLp(av)--; |
---|
647 | if (SvSMAGICAL(av)) |
---|
648 | mg_set((SV*)av); |
---|
649 | return retval; |
---|
650 | } |
---|
651 | |
---|
652 | /* |
---|
653 | =for apidoc av_len |
---|
654 | |
---|
655 | Returns the highest index in the array. Returns -1 if the array is |
---|
656 | empty. |
---|
657 | |
---|
658 | =cut |
---|
659 | */ |
---|
660 | |
---|
661 | I32 |
---|
662 | Perl_av_len(pTHX_ register AV *av) |
---|
663 | { |
---|
664 | return AvFILL(av); |
---|
665 | } |
---|
666 | |
---|
667 | /* |
---|
668 | =for apidoc av_fill |
---|
669 | |
---|
670 | Ensure than an array has a given number of elements, equivalent to |
---|
671 | Perl's C<$#array = $fill;>. |
---|
672 | |
---|
673 | =cut |
---|
674 | */ |
---|
675 | void |
---|
676 | Perl_av_fill(pTHX_ register AV *av, I32 fill) |
---|
677 | { |
---|
678 | MAGIC *mg; |
---|
679 | if (!av) |
---|
680 | Perl_croak(aTHX_ "panic: null array"); |
---|
681 | if (fill < 0) |
---|
682 | fill = -1; |
---|
683 | if ((mg = SvTIED_mg((SV*)av, 'P'))) { |
---|
684 | dSP; |
---|
685 | ENTER; |
---|
686 | SAVETMPS; |
---|
687 | PUSHSTACKi(PERLSI_MAGIC); |
---|
688 | PUSHMARK(SP); |
---|
689 | EXTEND(SP,2); |
---|
690 | PUSHs(SvTIED_obj((SV*)av, mg)); |
---|
691 | PUSHs(sv_2mortal(newSViv(fill+1))); |
---|
692 | PUTBACK; |
---|
693 | call_method("STORESIZE", G_SCALAR|G_DISCARD); |
---|
694 | POPSTACK; |
---|
695 | FREETMPS; |
---|
696 | LEAVE; |
---|
697 | return; |
---|
698 | } |
---|
699 | if (fill <= AvMAX(av)) { |
---|
700 | I32 key = AvFILLp(av); |
---|
701 | SV** ary = AvARRAY(av); |
---|
702 | |
---|
703 | if (AvREAL(av)) { |
---|
704 | while (key > fill) { |
---|
705 | SvREFCNT_dec(ary[key]); |
---|
706 | ary[key--] = &PL_sv_undef; |
---|
707 | } |
---|
708 | } |
---|
709 | else { |
---|
710 | while (key < fill) |
---|
711 | ary[++key] = &PL_sv_undef; |
---|
712 | } |
---|
713 | |
---|
714 | AvFILLp(av) = fill; |
---|
715 | if (SvSMAGICAL(av)) |
---|
716 | mg_set((SV*)av); |
---|
717 | } |
---|
718 | else |
---|
719 | (void)av_store(av,fill,&PL_sv_undef); |
---|
720 | } |
---|
721 | |
---|
722 | /* |
---|
723 | =for apidoc av_delete |
---|
724 | |
---|
725 | Deletes the element indexed by C<key> from the array. Returns the |
---|
726 | deleted element. C<flags> is currently ignored. |
---|
727 | |
---|
728 | =cut |
---|
729 | */ |
---|
730 | SV * |
---|
731 | Perl_av_delete(pTHX_ AV *av, I32 key, I32 flags) |
---|
732 | { |
---|
733 | SV *sv; |
---|
734 | |
---|
735 | if (!av) |
---|
736 | return Nullsv; |
---|
737 | if (SvREADONLY(av)) |
---|
738 | Perl_croak(aTHX_ PL_no_modify); |
---|
739 | if (key < 0) { |
---|
740 | key += AvFILL(av) + 1; |
---|
741 | if (key < 0) |
---|
742 | return Nullsv; |
---|
743 | } |
---|
744 | if (SvRMAGICAL(av)) { |
---|
745 | SV **svp; |
---|
746 | if ((mg_find((SV*)av,'P') || mg_find((SV*)av,'D')) |
---|
747 | && (svp = av_fetch(av, key, TRUE))) |
---|
748 | { |
---|
749 | sv = *svp; |
---|
750 | mg_clear(sv); |
---|
751 | if (mg_find(sv, 'p')) { |
---|
752 | sv_unmagic(sv, 'p'); /* No longer an element */ |
---|
753 | return sv; |
---|
754 | } |
---|
755 | return Nullsv; /* element cannot be deleted */ |
---|
756 | } |
---|
757 | } |
---|
758 | if (key > AvFILLp(av)) |
---|
759 | return Nullsv; |
---|
760 | else { |
---|
761 | sv = AvARRAY(av)[key]; |
---|
762 | if (key == AvFILLp(av)) { |
---|
763 | do { |
---|
764 | AvFILLp(av)--; |
---|
765 | } while (--key >= 0 && AvARRAY(av)[key] == &PL_sv_undef); |
---|
766 | } |
---|
767 | else |
---|
768 | AvARRAY(av)[key] = &PL_sv_undef; |
---|
769 | if (SvSMAGICAL(av)) |
---|
770 | mg_set((SV*)av); |
---|
771 | } |
---|
772 | if (flags & G_DISCARD) { |
---|
773 | SvREFCNT_dec(sv); |
---|
774 | sv = Nullsv; |
---|
775 | } |
---|
776 | return sv; |
---|
777 | } |
---|
778 | |
---|
779 | /* |
---|
780 | =for apidoc av_exists |
---|
781 | |
---|
782 | Returns true if the element indexed by C<key> has been initialized. |
---|
783 | |
---|
784 | This relies on the fact that uninitialized array elements are set to |
---|
785 | C<&PL_sv_undef>. |
---|
786 | |
---|
787 | =cut |
---|
788 | */ |
---|
789 | bool |
---|
790 | Perl_av_exists(pTHX_ AV *av, I32 key) |
---|
791 | { |
---|
792 | if (!av) |
---|
793 | return FALSE; |
---|
794 | if (key < 0) { |
---|
795 | key += AvFILL(av) + 1; |
---|
796 | if (key < 0) |
---|
797 | return FALSE; |
---|
798 | } |
---|
799 | if (SvRMAGICAL(av)) { |
---|
800 | if (mg_find((SV*)av,'P') || mg_find((SV*)av,'D')) { |
---|
801 | SV *sv = sv_newmortal(); |
---|
802 | MAGIC *mg; |
---|
803 | |
---|
804 | mg_copy((SV*)av, sv, 0, key); |
---|
805 | mg = mg_find(sv, 'p'); |
---|
806 | if (mg) { |
---|
807 | magic_existspack(sv, mg); |
---|
808 | return SvTRUE(sv); |
---|
809 | } |
---|
810 | } |
---|
811 | } |
---|
812 | if (key <= AvFILLp(av) && AvARRAY(av)[key] != &PL_sv_undef |
---|
813 | && AvARRAY(av)[key]) |
---|
814 | { |
---|
815 | return TRUE; |
---|
816 | } |
---|
817 | else |
---|
818 | return FALSE; |
---|
819 | } |
---|
820 | |
---|
821 | /* AVHV: Support for treating arrays as if they were hashes. The |
---|
822 | * first element of the array should be a hash reference that maps |
---|
823 | * hash keys to array indices. |
---|
824 | */ |
---|
825 | |
---|
826 | STATIC I32 |
---|
827 | S_avhv_index_sv(pTHX_ SV* sv) |
---|
828 | { |
---|
829 | I32 index = SvIV(sv); |
---|
830 | if (index < 1) |
---|
831 | Perl_croak(aTHX_ "Bad index while coercing array into hash"); |
---|
832 | return index; |
---|
833 | } |
---|
834 | |
---|
835 | STATIC I32 |
---|
836 | S_avhv_index(pTHX_ AV *av, SV *keysv, U32 hash) |
---|
837 | { |
---|
838 | HV *keys; |
---|
839 | HE *he; |
---|
840 | STRLEN n_a; |
---|
841 | |
---|
842 | keys = avhv_keys(av); |
---|
843 | he = hv_fetch_ent(keys, keysv, FALSE, hash); |
---|
844 | if (!he) |
---|
845 | Perl_croak(aTHX_ "No such pseudo-hash field \"%s\"", SvPV(keysv,n_a)); |
---|
846 | return avhv_index_sv(HeVAL(he)); |
---|
847 | } |
---|
848 | |
---|
849 | HV* |
---|
850 | Perl_avhv_keys(pTHX_ AV *av) |
---|
851 | { |
---|
852 | SV **keysp = av_fetch(av, 0, FALSE); |
---|
853 | if (keysp) { |
---|
854 | SV *sv = *keysp; |
---|
855 | if (SvGMAGICAL(sv)) |
---|
856 | mg_get(sv); |
---|
857 | if (SvROK(sv)) { |
---|
858 | sv = SvRV(sv); |
---|
859 | if (SvTYPE(sv) == SVt_PVHV) |
---|
860 | return (HV*)sv; |
---|
861 | } |
---|
862 | } |
---|
863 | Perl_croak(aTHX_ "Can't coerce array into hash"); |
---|
864 | return Nullhv; |
---|
865 | } |
---|
866 | |
---|
867 | SV** |
---|
868 | Perl_avhv_store_ent(pTHX_ AV *av, SV *keysv, SV *val, U32 hash) |
---|
869 | { |
---|
870 | return av_store(av, avhv_index(av, keysv, hash), val); |
---|
871 | } |
---|
872 | |
---|
873 | SV** |
---|
874 | Perl_avhv_fetch_ent(pTHX_ AV *av, SV *keysv, I32 lval, U32 hash) |
---|
875 | { |
---|
876 | return av_fetch(av, avhv_index(av, keysv, hash), lval); |
---|
877 | } |
---|
878 | |
---|
879 | SV * |
---|
880 | Perl_avhv_delete_ent(pTHX_ AV *av, SV *keysv, I32 flags, U32 hash) |
---|
881 | { |
---|
882 | HV *keys = avhv_keys(av); |
---|
883 | HE *he; |
---|
884 | |
---|
885 | he = hv_fetch_ent(keys, keysv, FALSE, hash); |
---|
886 | if (!he || !SvOK(HeVAL(he))) |
---|
887 | return Nullsv; |
---|
888 | |
---|
889 | return av_delete(av, avhv_index_sv(HeVAL(he)), flags); |
---|
890 | } |
---|
891 | |
---|
892 | /* Check for the existence of an element named by a given key. |
---|
893 | * |
---|
894 | */ |
---|
895 | bool |
---|
896 | Perl_avhv_exists_ent(pTHX_ AV *av, SV *keysv, U32 hash) |
---|
897 | { |
---|
898 | HV *keys = avhv_keys(av); |
---|
899 | HE *he; |
---|
900 | |
---|
901 | he = hv_fetch_ent(keys, keysv, FALSE, hash); |
---|
902 | if (!he || !SvOK(HeVAL(he))) |
---|
903 | return FALSE; |
---|
904 | |
---|
905 | return av_exists(av, avhv_index_sv(HeVAL(he))); |
---|
906 | } |
---|
907 | |
---|
908 | HE * |
---|
909 | Perl_avhv_iternext(pTHX_ AV *av) |
---|
910 | { |
---|
911 | HV *keys = avhv_keys(av); |
---|
912 | return hv_iternext(keys); |
---|
913 | } |
---|
914 | |
---|
915 | SV * |
---|
916 | Perl_avhv_iterval(pTHX_ AV *av, register HE *entry) |
---|
917 | { |
---|
918 | SV *sv = hv_iterval(avhv_keys(av), entry); |
---|
919 | return *av_fetch(av, avhv_index_sv(sv), TRUE); |
---|
920 | } |
---|