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