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