1N/A/* av.c
1N/A *
1N/A * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
1N/A * 2000, 2001, 2002, 2003, by Larry Wall and others
1N/A *
1N/A * You may distribute under the terms of either the GNU General Public
1N/A * License or the Artistic License, as specified in the README file.
1N/A *
1N/A */
1N/A
1N/A/*
1N/A * "...for the Entwives desired order, and plenty, and peace (by which they
1N/A * meant that things should remain where they had set them)." --Treebeard
1N/A */
1N/A
1N/A/*
1N/A=head1 Array Manipulation Functions
1N/A*/
1N/A
1N/A#include "EXTERN.h"
1N/A#define PERL_IN_AV_C
1N/A#include "perl.h"
1N/A
1N/Avoid
1N/APerl_av_reify(pTHX_ AV *av)
1N/A{
1N/A I32 key;
1N/A SV* sv;
1N/A
1N/A if (AvREAL(av))
1N/A return;
1N/A#ifdef DEBUGGING
1N/A if (SvTIED_mg((SV*)av, PERL_MAGIC_tied) && ckWARN_d(WARN_DEBUGGING))
1N/A Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "av_reify called on tied array");
1N/A#endif
1N/A key = AvMAX(av) + 1;
1N/A while (key > AvFILLp(av) + 1)
1N/A AvARRAY(av)[--key] = &PL_sv_undef;
1N/A while (key) {
1N/A sv = AvARRAY(av)[--key];
1N/A assert(sv);
1N/A if (sv != &PL_sv_undef)
1N/A (void)SvREFCNT_inc(sv);
1N/A }
1N/A key = AvARRAY(av) - AvALLOC(av);
1N/A while (key)
1N/A AvALLOC(av)[--key] = &PL_sv_undef;
1N/A AvREIFY_off(av);
1N/A AvREAL_on(av);
1N/A}
1N/A
1N/A/*
1N/A=for apidoc av_extend
1N/A
1N/APre-extend an array. The C<key> is the index to which the array should be
1N/Aextended.
1N/A
1N/A=cut
1N/A*/
1N/A
1N/Avoid
1N/APerl_av_extend(pTHX_ AV *av, I32 key)
1N/A{
1N/A MAGIC *mg;
1N/A if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
1N/A dSP;
1N/A ENTER;
1N/A SAVETMPS;
1N/A PUSHSTACKi(PERLSI_MAGIC);
1N/A PUSHMARK(SP);
1N/A EXTEND(SP,2);
1N/A PUSHs(SvTIED_obj((SV*)av, mg));
1N/A PUSHs(sv_2mortal(newSViv(key+1)));
1N/A PUTBACK;
1N/A call_method("EXTEND", G_SCALAR|G_DISCARD);
1N/A POPSTACK;
1N/A FREETMPS;
1N/A LEAVE;
1N/A return;
1N/A }
1N/A if (key > AvMAX(av)) {
1N/A SV** ary;
1N/A I32 tmp;
1N/A I32 newmax;
1N/A
1N/A if (AvALLOC(av) != AvARRAY(av)) {
1N/A ary = AvALLOC(av) + AvFILLp(av) + 1;
1N/A tmp = AvARRAY(av) - AvALLOC(av);
1N/A Move(AvARRAY(av), AvALLOC(av), AvFILLp(av)+1, SV*);
1N/A AvMAX(av) += tmp;
1N/A SvPVX(av) = (char*)AvALLOC(av);
1N/A if (AvREAL(av)) {
1N/A while (tmp)
1N/A ary[--tmp] = &PL_sv_undef;
1N/A }
1N/A
1N/A if (key > AvMAX(av) - 10) {
1N/A newmax = key + AvMAX(av);
1N/A goto resize;
1N/A }
1N/A }
1N/A else {
1N/A if (AvALLOC(av)) {
1N/A#if !defined(STRANGE_MALLOC) && !defined(MYMALLOC)
1N/A MEM_SIZE bytes;
1N/A IV itmp;
1N/A#endif
1N/A
1N/A#ifdef MYMALLOC
1N/A newmax = malloced_size((void*)AvALLOC(av))/sizeof(SV*) - 1;
1N/A
1N/A if (key <= newmax)
1N/A goto resized;
1N/A#endif
1N/A newmax = key + AvMAX(av) / 5;
1N/A resize:
1N/A MEM_WRAP_CHECK_1(newmax+1, SV*, "panic: array extend");
1N/A#if defined(STRANGE_MALLOC) || defined(MYMALLOC)
1N/A Renew(AvALLOC(av),newmax+1, SV*);
1N/A#else
1N/A bytes = (newmax + 1) * sizeof(SV*);
1N/A#define MALLOC_OVERHEAD 16
1N/A itmp = MALLOC_OVERHEAD;
1N/A while ((MEM_SIZE)(itmp - MALLOC_OVERHEAD) < bytes)
1N/A itmp += itmp;
1N/A itmp -= MALLOC_OVERHEAD;
1N/A itmp /= sizeof(SV*);
1N/A assert(itmp > newmax);
1N/A newmax = itmp - 1;
1N/A assert(newmax >= AvMAX(av));
1N/A New(2,ary, newmax+1, SV*);
1N/A Copy(AvALLOC(av), ary, AvMAX(av)+1, SV*);
1N/A if (AvMAX(av) > 64)
1N/A offer_nice_chunk(AvALLOC(av), (AvMAX(av)+1) * sizeof(SV*));
1N/A else
1N/A Safefree(AvALLOC(av));
1N/A AvALLOC(av) = ary;
1N/A#endif
1N/A#ifdef MYMALLOC
1N/A resized:
1N/A#endif
1N/A ary = AvALLOC(av) + AvMAX(av) + 1;
1N/A tmp = newmax - AvMAX(av);
1N/A if (av == PL_curstack) { /* Oops, grew stack (via av_store()?) */
1N/A PL_stack_sp = AvALLOC(av) + (PL_stack_sp - PL_stack_base);
1N/A PL_stack_base = AvALLOC(av);
1N/A PL_stack_max = PL_stack_base + newmax;
1N/A }
1N/A }
1N/A else {
1N/A newmax = key < 3 ? 3 : key;
1N/A MEM_WRAP_CHECK_1(newmax+1, SV*, "panic: array extend");
1N/A New(2,AvALLOC(av), newmax+1, SV*);
1N/A ary = AvALLOC(av) + 1;
1N/A tmp = newmax;
1N/A AvALLOC(av)[0] = &PL_sv_undef; /* For the stacks */
1N/A }
1N/A if (AvREAL(av)) {
1N/A while (tmp)
1N/A ary[--tmp] = &PL_sv_undef;
1N/A }
1N/A
1N/A SvPVX(av) = (char*)AvALLOC(av);
1N/A AvMAX(av) = newmax;
1N/A }
1N/A }
1N/A}
1N/A
1N/A/*
1N/A=for apidoc av_fetch
1N/A
1N/AReturns the SV at the specified index in the array. The C<key> is the
1N/Aindex. If C<lval> is set then the fetch will be part of a store. Check
1N/Athat the return value is non-null before dereferencing it to a C<SV*>.
1N/A
1N/ASee L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
1N/Amore information on how to use this function on tied arrays.
1N/A
1N/A=cut
1N/A*/
1N/A
1N/ASV**
1N/APerl_av_fetch(pTHX_ register AV *av, I32 key, I32 lval)
1N/A{
1N/A SV *sv;
1N/A
1N/A if (!av)
1N/A return 0;
1N/A
1N/A if (SvRMAGICAL(av)) {
1N/A MAGIC *tied_magic = mg_find((SV*)av, PERL_MAGIC_tied);
1N/A if (tied_magic || mg_find((SV*)av, PERL_MAGIC_regdata)) {
1N/A U32 adjust_index = 1;
1N/A
1N/A if (tied_magic && key < 0) {
1N/A /* Handle negative array indices 20020222 MJD */
1N/A SV **negative_indices_glob =
1N/A hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *)av,
1N/A tied_magic))),
1N/A NEGATIVE_INDICES_VAR, 16, 0);
1N/A
1N/A if (negative_indices_glob
1N/A && SvTRUE(GvSV(*negative_indices_glob)))
1N/A adjust_index = 0;
1N/A }
1N/A
1N/A if (key < 0 && adjust_index) {
1N/A key += AvFILL(av) + 1;
1N/A if (key < 0)
1N/A return 0;
1N/A }
1N/A
1N/A sv = sv_newmortal();
1N/A sv_upgrade(sv, SVt_PVLV);
1N/A mg_copy((SV*)av, sv, 0, key);
1N/A LvTYPE(sv) = 't';
1N/A LvTARG(sv) = sv; /* fake (SV**) */
1N/A return &(LvTARG(sv));
1N/A }
1N/A }
1N/A
1N/A if (key < 0) {
1N/A key += AvFILL(av) + 1;
1N/A if (key < 0)
1N/A return 0;
1N/A }
1N/A
1N/A if (key > AvFILLp(av)) {
1N/A if (!lval)
1N/A return 0;
1N/A sv = NEWSV(5,0);
1N/A return av_store(av,key,sv);
1N/A }
1N/A if (AvARRAY(av)[key] == &PL_sv_undef) {
1N/A emptyness:
1N/A if (lval) {
1N/A sv = NEWSV(6,0);
1N/A return av_store(av,key,sv);
1N/A }
1N/A return 0;
1N/A }
1N/A else if (AvREIFY(av)
1N/A && (!AvARRAY(av)[key] /* eg. @_ could have freed elts */
1N/A || SvTYPE(AvARRAY(av)[key]) == SVTYPEMASK)) {
1N/A AvARRAY(av)[key] = &PL_sv_undef; /* 1/2 reify */
1N/A goto emptyness;
1N/A }
1N/A return &AvARRAY(av)[key];
1N/A}
1N/A
1N/A/*
1N/A=for apidoc av_store
1N/A
1N/AStores an SV in an array. The array index is specified as C<key>. The
1N/Areturn value will be NULL if the operation failed or if the value did not
1N/Aneed to be actually stored within the array (as in the case of tied
1N/Aarrays). Otherwise it can be dereferenced to get the original C<SV*>. Note
1N/Athat the caller is responsible for suitably incrementing the reference
1N/Acount of C<val> before the call, and decrementing it if the function
1N/Areturned NULL.
1N/A
1N/ASee L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
1N/Amore information on how to use this function on tied arrays.
1N/A
1N/A=cut
1N/A*/
1N/A
1N/ASV**
1N/APerl_av_store(pTHX_ register AV *av, I32 key, SV *val)
1N/A{
1N/A SV** ary;
1N/A
1N/A if (!av)
1N/A return 0;
1N/A if (!val)
1N/A val = &PL_sv_undef;
1N/A
1N/A if (SvRMAGICAL(av)) {
1N/A MAGIC *tied_magic = mg_find((SV*)av, PERL_MAGIC_tied);
1N/A if (tied_magic) {
1N/A /* Handle negative array indices 20020222 MJD */
1N/A if (key < 0) {
1N/A unsigned adjust_index = 1;
1N/A SV **negative_indices_glob =
1N/A hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *)av,
1N/A tied_magic))),
1N/A NEGATIVE_INDICES_VAR, 16, 0);
1N/A if (negative_indices_glob
1N/A && SvTRUE(GvSV(*negative_indices_glob)))
1N/A adjust_index = 0;
1N/A if (adjust_index) {
1N/A key += AvFILL(av) + 1;
1N/A if (key < 0)
1N/A return 0;
1N/A }
1N/A }
1N/A if (val != &PL_sv_undef) {
1N/A mg_copy((SV*)av, val, 0, key);
1N/A }
1N/A return 0;
1N/A }
1N/A }
1N/A
1N/A
1N/A if (key < 0) {
1N/A key += AvFILL(av) + 1;
1N/A if (key < 0)
1N/A return 0;
1N/A }
1N/A
1N/A if (SvREADONLY(av) && key >= AvFILL(av))
1N/A Perl_croak(aTHX_ PL_no_modify);
1N/A
1N/A if (!AvREAL(av) && AvREIFY(av))
1N/A av_reify(av);
1N/A if (key > AvMAX(av))
1N/A av_extend(av,key);
1N/A ary = AvARRAY(av);
1N/A if (AvFILLp(av) < key) {
1N/A if (!AvREAL(av)) {
1N/A if (av == PL_curstack && key > PL_stack_sp - PL_stack_base)
1N/A PL_stack_sp = PL_stack_base + key; /* XPUSH in disguise */
1N/A do
1N/A ary[++AvFILLp(av)] = &PL_sv_undef;
1N/A while (AvFILLp(av) < key);
1N/A }
1N/A AvFILLp(av) = key;
1N/A }
1N/A else if (AvREAL(av))
1N/A SvREFCNT_dec(ary[key]);
1N/A ary[key] = val;
1N/A if (SvSMAGICAL(av)) {
1N/A if (val != &PL_sv_undef) {
1N/A MAGIC* mg = SvMAGIC(av);
1N/A sv_magic(val, (SV*)av, toLOWER(mg->mg_type), 0, key);
1N/A }
1N/A mg_set((SV*)av);
1N/A }
1N/A return &ary[key];
1N/A}
1N/A
1N/A/*
1N/A=for apidoc newAV
1N/A
1N/ACreates a new AV. The reference count is set to 1.
1N/A
1N/A=cut
1N/A*/
1N/A
1N/AAV *
1N/APerl_newAV(pTHX)
1N/A{
1N/A register AV *av;
1N/A
1N/A av = (AV*)NEWSV(3,0);
1N/A sv_upgrade((SV *)av, SVt_PVAV);
1N/A AvREAL_on(av);
1N/A AvALLOC(av) = 0;
1N/A SvPVX(av) = 0;
1N/A AvMAX(av) = AvFILLp(av) = -1;
1N/A return av;
1N/A}
1N/A
1N/A/*
1N/A=for apidoc av_make
1N/A
1N/ACreates a new AV and populates it with a list of SVs. The SVs are copied
1N/Ainto the array, so they may be freed after the call to av_make. The new AV
1N/Awill have a reference count of 1.
1N/A
1N/A=cut
1N/A*/
1N/A
1N/AAV *
1N/APerl_av_make(pTHX_ register I32 size, register SV **strp)
1N/A{
1N/A register AV *av;
1N/A register I32 i;
1N/A register SV** ary;
1N/A
1N/A av = (AV*)NEWSV(8,0);
1N/A sv_upgrade((SV *) av,SVt_PVAV);
1N/A AvFLAGS(av) = AVf_REAL;
1N/A if (size) { /* `defined' was returning undef for size==0 anyway. */
1N/A New(4,ary,size,SV*);
1N/A AvALLOC(av) = ary;
1N/A SvPVX(av) = (char*)ary;
1N/A AvFILLp(av) = size - 1;
1N/A AvMAX(av) = size - 1;
1N/A for (i = 0; i < size; i++) {
1N/A assert (*strp);
1N/A ary[i] = NEWSV(7,0);
1N/A sv_setsv(ary[i], *strp);
1N/A strp++;
1N/A }
1N/A }
1N/A return av;
1N/A}
1N/A
1N/AAV *
1N/APerl_av_fake(pTHX_ register I32 size, register SV **strp)
1N/A{
1N/A register AV *av;
1N/A register SV** ary;
1N/A
1N/A av = (AV*)NEWSV(9,0);
1N/A sv_upgrade((SV *)av, SVt_PVAV);
1N/A New(4,ary,size+1,SV*);
1N/A AvALLOC(av) = ary;
1N/A Copy(strp,ary,size,SV*);
1N/A AvFLAGS(av) = AVf_REIFY;
1N/A SvPVX(av) = (char*)ary;
1N/A AvFILLp(av) = size - 1;
1N/A AvMAX(av) = size - 1;
1N/A while (size--) {
1N/A assert (*strp);
1N/A SvTEMP_off(*strp);
1N/A strp++;
1N/A }
1N/A return av;
1N/A}
1N/A
1N/A/*
1N/A=for apidoc av_clear
1N/A
1N/AClears an array, making it empty. Does not free the memory used by the
1N/Aarray itself.
1N/A
1N/A=cut
1N/A*/
1N/A
1N/Avoid
1N/APerl_av_clear(pTHX_ register AV *av)
1N/A{
1N/A register I32 key;
1N/A SV** ary;
1N/A
1N/A#ifdef DEBUGGING
1N/A if (SvREFCNT(av) == 0 && ckWARN_d(WARN_DEBUGGING)) {
1N/A Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "Attempt to clear deleted array");
1N/A }
1N/A#endif
1N/A if (!av)
1N/A return;
1N/A /*SUPPRESS 560*/
1N/A
1N/A if (SvREADONLY(av))
1N/A Perl_croak(aTHX_ PL_no_modify);
1N/A
1N/A /* Give any tie a chance to cleanup first */
1N/A if (SvRMAGICAL(av))
1N/A mg_clear((SV*)av);
1N/A
1N/A if (AvMAX(av) < 0)
1N/A return;
1N/A
1N/A if (AvREAL(av)) {
1N/A ary = AvARRAY(av);
1N/A key = AvFILLp(av) + 1;
1N/A while (key) {
1N/A SV * sv = ary[--key];
1N/A /* undef the slot before freeing the value, because a
1N/A * destructor might try to modify this arrray */
1N/A ary[key] = &PL_sv_undef;
1N/A SvREFCNT_dec(sv);
1N/A }
1N/A }
1N/A if ((key = AvARRAY(av) - AvALLOC(av))) {
1N/A AvMAX(av) += key;
1N/A SvPVX(av) = (char*)AvALLOC(av);
1N/A }
1N/A AvFILLp(av) = -1;
1N/A
1N/A}
1N/A
1N/A/*
1N/A=for apidoc av_undef
1N/A
1N/AUndefines the array. Frees the memory used by the array itself.
1N/A
1N/A=cut
1N/A*/
1N/A
1N/Avoid
1N/APerl_av_undef(pTHX_ register AV *av)
1N/A{
1N/A register I32 key;
1N/A
1N/A if (!av)
1N/A return;
1N/A /*SUPPRESS 560*/
1N/A
1N/A /* Give any tie a chance to cleanup first */
1N/A if (SvTIED_mg((SV*)av, PERL_MAGIC_tied))
1N/A av_fill(av, -1); /* mg_clear() ? */
1N/A
1N/A if (AvREAL(av)) {
1N/A key = AvFILLp(av) + 1;
1N/A while (key)
1N/A SvREFCNT_dec(AvARRAY(av)[--key]);
1N/A }
1N/A Safefree(AvALLOC(av));
1N/A AvALLOC(av) = 0;
1N/A SvPVX(av) = 0;
1N/A AvMAX(av) = AvFILLp(av) = -1;
1N/A if (AvARYLEN(av)) {
1N/A SvREFCNT_dec(AvARYLEN(av));
1N/A AvARYLEN(av) = 0;
1N/A }
1N/A}
1N/A
1N/A/*
1N/A=for apidoc av_push
1N/A
1N/APushes an SV onto the end of the array. The array will grow automatically
1N/Ato accommodate the addition.
1N/A
1N/A=cut
1N/A*/
1N/A
1N/Avoid
1N/APerl_av_push(pTHX_ register AV *av, SV *val)
1N/A{
1N/A MAGIC *mg;
1N/A if (!av)
1N/A return;
1N/A if (SvREADONLY(av))
1N/A Perl_croak(aTHX_ PL_no_modify);
1N/A
1N/A if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
1N/A dSP;
1N/A PUSHSTACKi(PERLSI_MAGIC);
1N/A PUSHMARK(SP);
1N/A EXTEND(SP,2);
1N/A PUSHs(SvTIED_obj((SV*)av, mg));
1N/A PUSHs(val);
1N/A PUTBACK;
1N/A ENTER;
1N/A call_method("PUSH", G_SCALAR|G_DISCARD);
1N/A LEAVE;
1N/A POPSTACK;
1N/A return;
1N/A }
1N/A av_store(av,AvFILLp(av)+1,val);
1N/A}
1N/A
1N/A/*
1N/A=for apidoc av_pop
1N/A
1N/APops an SV off the end of the array. Returns C<&PL_sv_undef> if the array
1N/Ais empty.
1N/A
1N/A=cut
1N/A*/
1N/A
1N/ASV *
1N/APerl_av_pop(pTHX_ register AV *av)
1N/A{
1N/A SV *retval;
1N/A MAGIC* mg;
1N/A
1N/A if (!av)
1N/A return &PL_sv_undef;
1N/A if (SvREADONLY(av))
1N/A Perl_croak(aTHX_ PL_no_modify);
1N/A if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
1N/A dSP;
1N/A PUSHSTACKi(PERLSI_MAGIC);
1N/A PUSHMARK(SP);
1N/A XPUSHs(SvTIED_obj((SV*)av, mg));
1N/A PUTBACK;
1N/A ENTER;
1N/A if (call_method("POP", G_SCALAR)) {
1N/A retval = newSVsv(*PL_stack_sp--);
1N/A } else {
1N/A retval = &PL_sv_undef;
1N/A }
1N/A LEAVE;
1N/A POPSTACK;
1N/A return retval;
1N/A }
1N/A if (AvFILL(av) < 0)
1N/A return &PL_sv_undef;
1N/A retval = AvARRAY(av)[AvFILLp(av)];
1N/A AvARRAY(av)[AvFILLp(av)--] = &PL_sv_undef;
1N/A if (SvSMAGICAL(av))
1N/A mg_set((SV*)av);
1N/A return retval;
1N/A}
1N/A
1N/A/*
1N/A=for apidoc av_unshift
1N/A
1N/AUnshift the given number of C<undef> values onto the beginning of the
1N/Aarray. The array will grow automatically to accommodate the addition. You
1N/Amust then use C<av_store> to assign values to these new elements.
1N/A
1N/A=cut
1N/A*/
1N/A
1N/Avoid
1N/APerl_av_unshift(pTHX_ register AV *av, register I32 num)
1N/A{
1N/A register I32 i;
1N/A register SV **ary;
1N/A MAGIC* mg;
1N/A I32 slide;
1N/A
1N/A if (!av)
1N/A return;
1N/A if (SvREADONLY(av))
1N/A Perl_croak(aTHX_ PL_no_modify);
1N/A
1N/A if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
1N/A dSP;
1N/A PUSHSTACKi(PERLSI_MAGIC);
1N/A PUSHMARK(SP);
1N/A EXTEND(SP,1+num);
1N/A PUSHs(SvTIED_obj((SV*)av, mg));
1N/A while (num-- > 0) {
1N/A PUSHs(&PL_sv_undef);
1N/A }
1N/A PUTBACK;
1N/A ENTER;
1N/A call_method("UNSHIFT", G_SCALAR|G_DISCARD);
1N/A LEAVE;
1N/A POPSTACK;
1N/A return;
1N/A }
1N/A
1N/A if (num <= 0)
1N/A return;
1N/A if (!AvREAL(av) && AvREIFY(av))
1N/A av_reify(av);
1N/A i = AvARRAY(av) - AvALLOC(av);
1N/A if (i) {
1N/A if (i > num)
1N/A i = num;
1N/A num -= i;
1N/A
1N/A AvMAX(av) += i;
1N/A AvFILLp(av) += i;
1N/A SvPVX(av) = (char*)(AvARRAY(av) - i);
1N/A }
1N/A if (num) {
1N/A i = AvFILLp(av);
1N/A /* Create extra elements */
1N/A slide = i > 0 ? i : 0;
1N/A num += slide;
1N/A av_extend(av, i + num);
1N/A AvFILLp(av) += num;
1N/A ary = AvARRAY(av);
1N/A Move(ary, ary + num, i + 1, SV*);
1N/A do {
1N/A ary[--num] = &PL_sv_undef;
1N/A } while (num);
1N/A /* Make extra elements into a buffer */
1N/A AvMAX(av) -= slide;
1N/A AvFILLp(av) -= slide;
1N/A SvPVX(av) = (char*)(AvARRAY(av) + slide);
1N/A }
1N/A}
1N/A
1N/A/*
1N/A=for apidoc av_shift
1N/A
1N/AShifts an SV off the beginning of the array.
1N/A
1N/A=cut
1N/A*/
1N/A
1N/ASV *
1N/APerl_av_shift(pTHX_ register AV *av)
1N/A{
1N/A SV *retval;
1N/A MAGIC* mg;
1N/A
1N/A if (!av)
1N/A return &PL_sv_undef;
1N/A if (SvREADONLY(av))
1N/A Perl_croak(aTHX_ PL_no_modify);
1N/A if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
1N/A dSP;
1N/A PUSHSTACKi(PERLSI_MAGIC);
1N/A PUSHMARK(SP);
1N/A XPUSHs(SvTIED_obj((SV*)av, mg));
1N/A PUTBACK;
1N/A ENTER;
1N/A if (call_method("SHIFT", G_SCALAR)) {
1N/A retval = newSVsv(*PL_stack_sp--);
1N/A } else {
1N/A retval = &PL_sv_undef;
1N/A }
1N/A LEAVE;
1N/A POPSTACK;
1N/A return retval;
1N/A }
1N/A if (AvFILL(av) < 0)
1N/A return &PL_sv_undef;
1N/A retval = *AvARRAY(av);
1N/A if (AvREAL(av))
1N/A *AvARRAY(av) = &PL_sv_undef;
1N/A SvPVX(av) = (char*)(AvARRAY(av) + 1);
1N/A AvMAX(av)--;
1N/A AvFILLp(av)--;
1N/A if (SvSMAGICAL(av))
1N/A mg_set((SV*)av);
1N/A return retval;
1N/A}
1N/A
1N/A/*
1N/A=for apidoc av_len
1N/A
1N/AReturns the highest index in the array. Returns -1 if the array is
1N/Aempty.
1N/A
1N/A=cut
1N/A*/
1N/A
1N/AI32
1N/APerl_av_len(pTHX_ register AV *av)
1N/A{
1N/A return AvFILL(av);
1N/A}
1N/A
1N/A/*
1N/A=for apidoc av_fill
1N/A
1N/AEnsure than an array has a given number of elements, equivalent to
1N/APerl's C<$#array = $fill;>.
1N/A
1N/A=cut
1N/A*/
1N/Avoid
1N/APerl_av_fill(pTHX_ register AV *av, I32 fill)
1N/A{
1N/A MAGIC *mg;
1N/A if (!av)
1N/A Perl_croak(aTHX_ "panic: null array");
1N/A if (fill < 0)
1N/A fill = -1;
1N/A if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
1N/A dSP;
1N/A ENTER;
1N/A SAVETMPS;
1N/A PUSHSTACKi(PERLSI_MAGIC);
1N/A PUSHMARK(SP);
1N/A EXTEND(SP,2);
1N/A PUSHs(SvTIED_obj((SV*)av, mg));
1N/A PUSHs(sv_2mortal(newSViv(fill+1)));
1N/A PUTBACK;
1N/A call_method("STORESIZE", G_SCALAR|G_DISCARD);
1N/A POPSTACK;
1N/A FREETMPS;
1N/A LEAVE;
1N/A return;
1N/A }
1N/A if (fill <= AvMAX(av)) {
1N/A I32 key = AvFILLp(av);
1N/A SV** ary = AvARRAY(av);
1N/A
1N/A if (AvREAL(av)) {
1N/A while (key > fill) {
1N/A SvREFCNT_dec(ary[key]);
1N/A ary[key--] = &PL_sv_undef;
1N/A }
1N/A }
1N/A else {
1N/A while (key < fill)
1N/A ary[++key] = &PL_sv_undef;
1N/A }
1N/A
1N/A AvFILLp(av) = fill;
1N/A if (SvSMAGICAL(av))
1N/A mg_set((SV*)av);
1N/A }
1N/A else
1N/A (void)av_store(av,fill,&PL_sv_undef);
1N/A}
1N/A
1N/A/*
1N/A=for apidoc av_delete
1N/A
1N/ADeletes the element indexed by C<key> from the array. Returns the
1N/Adeleted element. If C<flags> equals C<G_DISCARD>, the element is freed
1N/Aand null is returned.
1N/A
1N/A=cut
1N/A*/
1N/ASV *
1N/APerl_av_delete(pTHX_ AV *av, I32 key, I32 flags)
1N/A{
1N/A SV *sv;
1N/A
1N/A if (!av)
1N/A return Nullsv;
1N/A if (SvREADONLY(av))
1N/A Perl_croak(aTHX_ PL_no_modify);
1N/A
1N/A if (SvRMAGICAL(av)) {
1N/A MAGIC *tied_magic = mg_find((SV*)av, PERL_MAGIC_tied);
1N/A SV **svp;
1N/A if ((tied_magic || mg_find((SV*)av, PERL_MAGIC_regdata))) {
1N/A /* Handle negative array indices 20020222 MJD */
1N/A if (key < 0) {
1N/A unsigned adjust_index = 1;
1N/A if (tied_magic) {
1N/A SV **negative_indices_glob =
1N/A hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *)av,
1N/A tied_magic))),
1N/A NEGATIVE_INDICES_VAR, 16, 0);
1N/A if (negative_indices_glob
1N/A && SvTRUE(GvSV(*negative_indices_glob)))
1N/A adjust_index = 0;
1N/A }
1N/A if (adjust_index) {
1N/A key += AvFILL(av) + 1;
1N/A if (key < 0)
1N/A return Nullsv;
1N/A }
1N/A }
1N/A svp = av_fetch(av, key, TRUE);
1N/A if (svp) {
1N/A sv = *svp;
1N/A mg_clear(sv);
1N/A if (mg_find(sv, PERL_MAGIC_tiedelem)) {
1N/A sv_unmagic(sv, PERL_MAGIC_tiedelem); /* No longer an element */
1N/A return sv;
1N/A }
1N/A return Nullsv;
1N/A }
1N/A }
1N/A }
1N/A
1N/A if (key < 0) {
1N/A key += AvFILL(av) + 1;
1N/A if (key < 0)
1N/A return Nullsv;
1N/A }
1N/A
1N/A if (key > AvFILLp(av))
1N/A return Nullsv;
1N/A else {
1N/A if (!AvREAL(av) && AvREIFY(av))
1N/A av_reify(av);
1N/A sv = AvARRAY(av)[key];
1N/A if (key == AvFILLp(av)) {
1N/A AvARRAY(av)[key] = &PL_sv_undef;
1N/A do {
1N/A AvFILLp(av)--;
1N/A } while (--key >= 0 && AvARRAY(av)[key] == &PL_sv_undef);
1N/A }
1N/A else
1N/A AvARRAY(av)[key] = &PL_sv_undef;
1N/A if (SvSMAGICAL(av))
1N/A mg_set((SV*)av);
1N/A }
1N/A if (flags & G_DISCARD) {
1N/A SvREFCNT_dec(sv);
1N/A sv = Nullsv;
1N/A }
1N/A return sv;
1N/A}
1N/A
1N/A/*
1N/A=for apidoc av_exists
1N/A
1N/AReturns true if the element indexed by C<key> has been initialized.
1N/A
1N/AThis relies on the fact that uninitialized array elements are set to
1N/AC<&PL_sv_undef>.
1N/A
1N/A=cut
1N/A*/
1N/Abool
1N/APerl_av_exists(pTHX_ AV *av, I32 key)
1N/A{
1N/A if (!av)
1N/A return FALSE;
1N/A
1N/A
1N/A if (SvRMAGICAL(av)) {
1N/A MAGIC *tied_magic = mg_find((SV*)av, PERL_MAGIC_tied);
1N/A if (tied_magic || mg_find((SV*)av, PERL_MAGIC_regdata)) {
1N/A SV *sv = sv_newmortal();
1N/A MAGIC *mg;
1N/A /* Handle negative array indices 20020222 MJD */
1N/A if (key < 0) {
1N/A unsigned adjust_index = 1;
1N/A if (tied_magic) {
1N/A SV **negative_indices_glob =
1N/A hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *)av,
1N/A tied_magic))),
1N/A NEGATIVE_INDICES_VAR, 16, 0);
1N/A if (negative_indices_glob
1N/A && SvTRUE(GvSV(*negative_indices_glob)))
1N/A adjust_index = 0;
1N/A }
1N/A if (adjust_index) {
1N/A key += AvFILL(av) + 1;
1N/A if (key < 0)
1N/A return FALSE;
1N/A }
1N/A }
1N/A
1N/A mg_copy((SV*)av, sv, 0, key);
1N/A mg = mg_find(sv, PERL_MAGIC_tiedelem);
1N/A if (mg) {
1N/A magic_existspack(sv, mg);
1N/A return (bool)SvTRUE(sv);
1N/A }
1N/A
1N/A }
1N/A }
1N/A
1N/A if (key < 0) {
1N/A key += AvFILL(av) + 1;
1N/A if (key < 0)
1N/A return FALSE;
1N/A }
1N/A
1N/A if (key <= AvFILLp(av) && AvARRAY(av)[key] != &PL_sv_undef
1N/A && AvARRAY(av)[key])
1N/A {
1N/A return TRUE;
1N/A }
1N/A else
1N/A return FALSE;
1N/A}
1N/A
1N/A/* AVHV: Support for treating arrays as if they were hashes. The
1N/A * first element of the array should be a hash reference that maps
1N/A * hash keys to array indices.
1N/A */
1N/A
1N/ASTATIC I32
1N/AS_avhv_index_sv(pTHX_ SV* sv)
1N/A{
1N/A I32 index = SvIV(sv);
1N/A if (index < 1)
1N/A Perl_croak(aTHX_ "Bad index while coercing array into hash");
1N/A return index;
1N/A}
1N/A
1N/ASTATIC I32
1N/AS_avhv_index(pTHX_ AV *av, SV *keysv, U32 hash)
1N/A{
1N/A HV *keys;
1N/A HE *he;
1N/A STRLEN n_a;
1N/A
1N/A keys = avhv_keys(av);
1N/A he = hv_fetch_ent(keys, keysv, FALSE, hash);
1N/A if (!he)
1N/A Perl_croak(aTHX_ "No such pseudo-hash field \"%s\"", SvPV(keysv,n_a));
1N/A return avhv_index_sv(HeVAL(he));
1N/A}
1N/A
1N/AHV*
1N/APerl_avhv_keys(pTHX_ AV *av)
1N/A{
1N/A SV **keysp = av_fetch(av, 0, FALSE);
1N/A if (keysp) {
1N/A SV *sv = *keysp;
1N/A if (SvGMAGICAL(sv))
1N/A mg_get(sv);
1N/A if (SvROK(sv)) {
1N/A if (ckWARN(WARN_DEPRECATED) && !sv_isa(sv, "pseudohash"))
1N/A Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
1N/A "Pseudo-hashes are deprecated");
1N/A sv = SvRV(sv);
1N/A if (SvTYPE(sv) == SVt_PVHV)
1N/A return (HV*)sv;
1N/A }
1N/A }
1N/A Perl_croak(aTHX_ "Can't coerce array into hash");
1N/A return Nullhv;
1N/A}
1N/A
1N/ASV**
1N/APerl_avhv_store_ent(pTHX_ AV *av, SV *keysv, SV *val, U32 hash)
1N/A{
1N/A return av_store(av, avhv_index(av, keysv, hash), val);
1N/A}
1N/A
1N/ASV**
1N/APerl_avhv_fetch_ent(pTHX_ AV *av, SV *keysv, I32 lval, U32 hash)
1N/A{
1N/A return av_fetch(av, avhv_index(av, keysv, hash), lval);
1N/A}
1N/A
1N/ASV *
1N/APerl_avhv_delete_ent(pTHX_ AV *av, SV *keysv, I32 flags, U32 hash)
1N/A{
1N/A HV *keys = avhv_keys(av);
1N/A HE *he;
1N/A
1N/A he = hv_fetch_ent(keys, keysv, FALSE, hash);
1N/A if (!he || !SvOK(HeVAL(he)))
1N/A return Nullsv;
1N/A
1N/A return av_delete(av, avhv_index_sv(HeVAL(he)), flags);
1N/A}
1N/A
1N/A/* Check for the existence of an element named by a given key.
1N/A *
1N/A */
1N/Abool
1N/APerl_avhv_exists_ent(pTHX_ AV *av, SV *keysv, U32 hash)
1N/A{
1N/A HV *keys = avhv_keys(av);
1N/A HE *he;
1N/A
1N/A he = hv_fetch_ent(keys, keysv, FALSE, hash);
1N/A if (!he || !SvOK(HeVAL(he)))
1N/A return FALSE;
1N/A
1N/A return av_exists(av, avhv_index_sv(HeVAL(he)));
1N/A}
1N/A
1N/AHE *
1N/APerl_avhv_iternext(pTHX_ AV *av)
1N/A{
1N/A HV *keys = avhv_keys(av);
1N/A return hv_iternext(keys);
1N/A}
1N/A
1N/ASV *
1N/APerl_avhv_iterval(pTHX_ AV *av, register HE *entry)
1N/A{
1N/A SV *sv = hv_iterval(avhv_keys(av), entry);
1N/A return *av_fetch(av, avhv_index_sv(sv), TRUE);
1N/A}