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