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