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