perl.c main()
perl.h Global declarations
perl_exp.SH Creates list of exported symbols for AIX
+ perldir.h perldir stuff
+ perlenv.h perlenv stuff
perlio.c C code for PerlIO abstraction
perlio.h Interface to PerlIO abstraction
perlio.sym Symbols for PerlIO abstraction
+ perllio.h perllio stuff
+ perlmem.h perlmem stuff
+ perlproc.h perlproc stuff
perlsdio.h Fake stdio using perlio
perlsfio.h Prototype sfio mapping for PerlIO
perlsh A poor man's perl shell
+ perlsock.h perlsock stuff
perlvars.h Global variables
perly.c A byacc'ed perly.y
perly.c.diff Fixup perly.c to allow recursion
pod/perlform.pod Format info
pod/perlfunc.pod Function info
pod/perlguts.pod Internals info
- pod/perlhist.pod The Perl history records
+ pod/perlhist.pod Perl history info
pod/perlipc.pod IPC info
pod/perllocale.pod Locale support info
pod/perllol.pod How to use lists of lists
t/lib/symbol.t See if Symbol works
t/lib/texttabs.t See if Text::Tabs works
t/lib/textwrap.t See if Text::Wrap works
-t/lib/timelocal.t See if Time::Local works
+t/lib/tie-push.t Test for Tie::Array
+t/lib/tie-stdarray.t Test for Tie::StdArray
+t/lib/tie-stdpush.t Test for Tie::StdArray
t/lib/thread.t Basic test of threading (skipped if no threads)
+ t/lib/tie-push.t See if pushing onto tied arrays works
+ t/lib/tie-stdarray.t See if tied arrays work
+ t/lib/tie-stdpush.t See if pushing onto standard tied arrays works
t/lib/trig.t See if Math::Trig works
t/op/append.t See if . works
t/op/arith.t See if arithmetic works
t/op/sysio.t See if sysread and syswrite work
t/op/taint.t See if tainting works
t/op/tie.t See if tie/untie functions work
- t/op/tiearray.t See if tied arrays work
+ t/op/tiearray.t See if tie for arrays works
t/op/time.t See if time functions work
t/op/undef.t See if undef works
t/op/universal.t See if UNIVERSAL class works
win32/TEST Win32 port
win32/autosplit.pl Win32 port
win32/bin/network.pl Win32 port
- win32/bin/perlglob.pl glob() support
+ win32/bin/perlglob.pl Win32 globbing
win32/bin/pl2bat.pl wrap perl scripts into batch files
win32/bin/runperl.pl run perl script via batch file namesake
win32/bin/search.pl Win32 port
}
croak("Can't use global %s in \"my\"",name);
}
- if (dowarn && AvFILL(comppad_name) >= 0) {
+ if (dowarn && AvFILLp(comppad_name) >= 0) {
SV **svp = AvARRAY(comppad_name);
- for (off = AvFILL(comppad_name); off > comppad_name_floor; off--) {
+ for (off = AvFILLp(comppad_name); off > comppad_name_floor; off--) {
if ((sv = svp[off])
&& sv != &sv_undef
&& SvIVX(sv) == 999999999 /* var is in open scope */
continue;
curname = (AV*)*svp;
svp = AvARRAY(curname);
- for (off = AvFILL(curname); off > 0; off--) {
+ for (off = AvFILLp(curname); off > 0; off--) {
if ((sv = svp[off]) &&
sv != &sv_undef &&
seq <= SvIVX(sv) &&
#endif /* USE_THREADS */
/* The one we're looking for is probably just before comppad_name_fill. */
- for (off = AvFILL(comppad_name); off > 0; off--) {
+ for (off = AvFILLp(comppad_name); off > 0; off--) {
if ((sv = svp[off]) &&
sv != &sv_undef &&
(!SvIVX(sv) ||
}
}
/* "Deintroduce" my variables that are leaving with this scope. */
- for (off = AvFILL(comppad_name); off > fill; off--) {
+ for (off = AvFILLp(comppad_name); off > fill; off--) {
if ((sv = svp[off]) && sv != &sv_undef && SvIVX(sv) == 999999999)
SvIVX(sv) = cop_seqmax;
}
pad_reset();
if (tmptype & SVs_PADMY) {
do {
- sv = *av_fetch(comppad, AvFILL(comppad) + 1, TRUE);
+ sv = *av_fetch(comppad, AvFILLp(comppad) + 1, TRUE);
} while (SvPADBUSY(sv)); /* need a fresh one */
- retval = AvFILL(comppad);
+ retval = AvFILLp(comppad);
}
else {
SV **names = AvARRAY(comppad_name);
- SSize_t names_fill = AvFILL(comppad_name);
+ SSize_t names_fill = AvFILLp(comppad_name);
for (;;) {
/*
* "foreach" index vars temporarily become aliases to non-"my"
if (!svp) {
SV *sv = NEWSV(0, 0);
av_store(thr->threadsv, key, sv);
+ thr->threadsvp = AvARRAY(thr->threadsv);
/*
* Some magic variables used to be automagically initialised
* in gv_fetchpv. Those which are now per-thread magicals get
int retval = savestack_ix;
SAVEI32(comppad_name_floor);
if (full) {
- if ((comppad_name_fill = AvFILL(comppad_name)) > 0)
+ if ((comppad_name_fill = AvFILLp(comppad_name)) > 0)
comppad_name_floor = comppad_name_fill;
else
comppad_name_floor = 0;
if (CvPADLIST(cv)) {
/* may be during global destruction */
if (SvREFCNT(CvPADLIST(cv))) {
- I32 i = AvFILL(CvPADLIST(cv));
+ I32 i = AvFILLp(CvPADLIST(cv));
while (i >= 0) {
SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
SV* sv = svp ? *svp : Nullsv;
pname = AvARRAY(pad_name);
ppad = AvARRAY(pad);
- for (ix = 1; ix <= AvFILL(pad_name); ix++) {
+ for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
if (SvPOK(pname[ix]))
PerlIO_printf(Perl_debug_log, "\t%4d. 0x%lx (%s\"%s\" %ld-%ld)\n",
ix, ppad[ix],
AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
SV** pname = AvARRAY(protopad_name);
SV** ppad = AvARRAY(protopad);
- I32 fname = AvFILL(protopad_name);
- I32 fpad = AvFILL(protopad);
+ I32 fname = AvFILLp(protopad_name);
+ I32 fpad = AvFILLp(protopad);
AV* comppadlist;
CV* cv;
av_store(comppadlist, 0, (SV*)comppad_name);
av_store(comppadlist, 1, (SV*)comppad);
CvPADLIST(cv) = comppadlist;
- av_fill(comppad, AvFILL(protopad));
+ av_fill(comppad, AvFILLp(protopad));
curpad = AvARRAY(comppad);
av = newAV(); /* will be @_ */
return cv;
}
- if (AvFILL(comppad_name) < AvFILL(comppad))
- av_store(comppad_name, AvFILL(comppad), Nullsv);
+ if (AvFILLp(comppad_name) < AvFILLp(comppad))
+ av_store(comppad_name, AvFILLp(comppad), Nullsv);
if (CvCLONE(cv)) {
SV **namep = AvARRAY(comppad_name);
- for (ix = AvFILL(comppad); ix > 0; ix--) {
+ for (ix = AvFILLp(comppad); ix > 0; ix--) {
SV *namesv;
if (SvIMMORTAL(curpad[ix]))
av_store(comppad, 0, (SV*)av);
AvFLAGS(av) = AVf_REIFY;
- for (ix = AvFILL(comppad); ix > 0; ix--) {
+ for (ix = AvFILLp(comppad); ix > 0; ix--) {
if (SvIMMORTAL(curpad[ix]))
continue;
if (!SvPADMY(curpad[ix]))
CvGV(cv) = (GV*)SvREFCNT_inc(gv);
CvFILEGV(cv) = curcop->cop_filegv;
- for (ix = AvFILL(comppad); ix > 0; ix--) {
+ for (ix = AvFILLp(comppad); ix > 0; ix--) {
if (!SvPADMY(curpad[ix]) && !SvIMMORTAL(curpad[ix]))
SvPADTMP_on(curpad[ix]);
}
static void
catch_sigsegv(int signo, struct sigcontext_struct sc)
{
- signal(SIGSEGV, SIG_DFL);
+ PerlProc_signal(SIGSEGV, SIG_DFL);
fprintf(stderr, "Segmentation fault dereferencing 0x%lx\n"
"return_address = 0x%lx, eip = 0x%lx\n",
sc.cr2, __builtin_return_address(0), sc.eip);
#ifdef DEBUGGING
{
char *s;
- if (s = getenv("PERL_DESTRUCT_LEVEL")) {
+ if (s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL")) {
int i = atoi(s);
if (destruct_level < i)
destruct_level = i;
croak("No -e allowed in setuid scripts");
if (!e_fp) {
e_tmpname = savepv(TMPPATH);
- (void)mktemp(e_tmpname);
+ (void)PerlLIO_mktemp(e_tmpname);
if (!*e_tmpname)
croak("Can't mktemp()");
e_fp = PerlIO_open(e_tmpname,"w");
}
switch_end:
- if (!tainting && (s = getenv("PERL5OPT"))) {
+ if (!tainting && (s = PerlEnv_getenv("PERL5OPT"))) {
while (s && *s) {
while (isSPACE(*s))
s++;
}
else if (scriptname == Nullch) {
#ifdef MSDOS
- if ( isatty(PerlIO_fileno(PerlIO_stdin())) )
+ if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
moreswitches("h");
#endif
scriptname = "-";
#endif
#if defined(DEBUGGING) && defined(USE_THREADS) && defined(__linux__)
- DEBUG_L(signal(SIGSEGV, (void(*)(int))catch_sigsegv););
+ DEBUG_L(PerlProc_signal(SIGSEGV, (void(*)(int))catch_sigsegv););
#endif
init_predump_symbols();
SvREFCNT_dec(rs);
rs = SvREFCNT_inc(nrs);
#ifdef USE_THREADS
- sv_setsv(*av_fetch(thr->threadsv, find_threadsv("/"), FALSE), rs);
+ sv_setsv(THREADSV(find_threadsv("/")), rs);
#else
sv_setsv(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), rs);
#endif /* USE_THREADS */
FREETMPS;
#ifdef MYMALLOC
- if ((s=getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
+ if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
dump_mstats("after compilation:");
#endif
if (endav)
call_list(oldscope, endav);
#ifdef MYMALLOC
- if (getenv("PERL_DEBUG_MSTATS"))
+ if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
dump_mstats("after execution: ");
#endif
JMPENV_POP;
PADOFFSET tmp = find_threadsv(name);
if (tmp != NOT_IN_PAD) {
dTHR;
- return *av_fetch(thr->threadsv, tmp, FALSE);
+ return THREADSV(tmp);
}
}
#endif /* USE_THREADS */
return s;
case 'h':
usage(origargv[0]);
- exit(0);
+ PerlProc_exit(0);
case 'i':
if (inplace)
Safefree(inplace);
printf("\n\
Perl may be copied only under the terms of either the Artistic License or the\n\
GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n");
- exit(0);
+ PerlProc_exit(0);
case 'w':
dowarn = TRUE;
s++;
if (status)
PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n",
SvPVX(prog), SvPVX(file));
- exit(status);
+ PerlProc_exit(status);
#else
# ifdef VMS
# include <lib$routines.h>
#ifdef DOSISH
&& !strchr(scriptname, '\\')
#endif
- && (s = getenv("PATH"))) {
+ && (s = PerlEnv_getenv("PATH"))) {
bool seen_dot = 0;
bufend = s + strlen(s);
croak("Can't do seteuid!\n");
}
#endif /* IAMSUID */
- rsfp = my_popen(SvPVX(cmd), "r");
+ rsfp = PerlProc_popen(SvPVX(cmd), "r");
SvREFCNT_dec(cmd);
SvREFCNT_dec(cpp);
}
if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
statbuf.st_mode & (S_ISUID|S_ISGID)) {
/* try again */
- execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
+ PerlProc_execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
croak("Can't do setuid\n");
}
#endif
dTHR;
char *s, *s2;
- if (Fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
+ if (PerlLIO_fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
croak("Can't stat script \"%s\"",origfilename);
if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
I32 len;
* But I don't think it's too important. The manual lies when
* it says access() is useful in setuid programs.
*/
- if (access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
+ if (PerlLIO_access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
croak("Permission denied");
#else
/* If we can swap euid and uid, then we can determine access rights
if (tmpstatbuf.st_dev != statbuf.st_dev ||
tmpstatbuf.st_ino != statbuf.st_ino) {
(void)PerlIO_close(rsfp);
- if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */
+ if (rsfp = PerlProc_popen("/bin/mail root","w")) { /* heh, heh */
PerlIO_printf(rsfp,
"User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
(Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
(long)statbuf.st_dev, (long)statbuf.st_ino,
SvPVX(GvSV(curcop->cop_filegv)),
(long)statbuf.st_uid, (long)statbuf.st_gid);
- (void)my_pclose(rsfp);
+ (void)PerlProc_pclose(rsfp);
}
croak("Permission denied\n");
}
(void)PerlIO_close(rsfp);
#ifndef IAMSUID
/* try again */
- execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
+ PerlProc_execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
#endif
croak("Can't do setuid\n");
}
/* exec the real perl, substituting fd script for scriptname. */
/* (We pass script name as "subdir" of fd, which perl will grok.) */
PerlIO_rewind(rsfp);
- lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
+ PerlLIO_lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
if (!origargv[which])
croak("Permission denied");
#if defined(HAS_FCNTL) && defined(F_SETFD)
fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
#endif
- execv(form("%s/perl%s", BIN_EXP, patchlevel), origargv); /* try again */
+ PerlProc_execv(form("%s/perl%s", BIN_EXP, patchlevel), origargv); /* try again */
croak("Can't do setuid\n");
#endif /* IAMSUID */
#else /* !DOSUID */
if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
#ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
dTHR;
- Fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
+ PerlLIO_fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
||
(egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
/*SUPPRESS 530*/
while (s = moreswitches(s)) ;
}
- if (cddir && chdir(cddir) < 0)
+ if (cddir && PerlDir_chdir(cddir) < 0)
croak("Can't chdir to %s",cddir);
}
}
GV *othergv;
#ifdef USE_THREADS
- sv_setpvn(*av_fetch(thr->threadsv,find_threadsv("\""),FALSE)," ", 1);
+ sv_setpvn(THREADSV(find_threadsv("\"")), " ", 1);
#else
sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
#endif /* USE_THREADS */
*s = '=';
#if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
/* Sins of the RTL. See note in my_setenv(). */
- (void)putenv(savepv(*env));
+ (void)PerlEnv_putenv(savepv(*env));
#endif
}
#endif
char *s;
if (!tainting) {
#ifndef VMS
- s = getenv("PERL5LIB");
+ s = PerlEnv_getenv("PERL5LIB");
if (s)
incpush(s, TRUE);
else
- incpush(getenv("PERLLIB"), FALSE);
+ incpush(PerlEnv_getenv("PERLLIB"), FALSE);
#else /* VMS */
/* Treat PERL5?LIB as a possible search list logical name -- the
* "natural" VMS idiom for a Unix path string. We allow each
curcop = &compiling;
thr->cvcache = newHV();
thr->threadsv = newAV();
+ /* thr->threadsvp is set when find_threadsv is called */
thr->specific = newAV();
thr->errhv = newHV();
thr->flags = THRf_R_JOINABLE;
dJMPENV;
int ret;
- while (AvFILL(list) >= 0) {
+ while (AvFILL(list) >= 0) {
CV *cv = (CV*)av_shift(list);
SAVEFREESV(cv);
#endif
#include "perlio.h"
+#include "perllio.h"
+#include "perlsock.h"
+#include "perlproc.h"
+#include "perlenv.h"
+#include "perldir.h"
#ifdef USE_NEXT_CTYPE
#ifdef USE_THREADS
# define ERRSV (thr->errsv)
# define ERRHV (thr->errhv)
- # define DEFSV *av_fetch(thr->threadsv, find_threadsv("_"), FALSE)
- # define SAVE_DEFSV save_threadsv(find_threadsv("_"))
+ # define DEFSV THREADSV(0)
+ # define SAVE_DEFSV save_threadsv(0)
#else
# define ERRSV GvSV(errgv)
# define ERRHV GvHV(errgv)
typedef I32 (*filter_t) _((int, SV *, int));
#define FILTER_READ(idx, sv, len) filter_read(idx, sv, len)
#define FILTER_DATA(idx) (AvARRAY(rsfp_filters)[idx])
-#define FILTER_ISREADER(idx) (idx >= AvFILL(rsfp_filters))
+#define FILTER_ISREADER(idx) (idx >= AvFILLp(rsfp_filters))
#ifdef DOSISH
# if defined(OS2)
if (!(what)) { \
croak("Assertion failed: file \"%s\", line %d", \
__FILE__, __LINE__); \
- exit(1); \
+ PerlProc_exit(1); \
}})
#endif
int runops_debug _((void));
#endif
+ /* _ (for $_) must be first in the following list (DEFSV requires it) */
#define THREADSV_NAMES "_123456789&`'+/.,\\\";^-%=|~:\001\005!@"
/* VMS doesn't use environ array and NeXT has problems with crt0.o globals */
magic_setsig,
0, magic_clearsig,
0};
-EXT MGVTBL vtbl_pack = {0, 0, 0, magic_wipepack,
+EXT MGVTBL vtbl_pack = {0, 0, magic_sizepack, magic_wipepack,
0};
EXT MGVTBL vtbl_packelem = {magic_getpack,
magic_setpack,
* and queried under the protection of sv_mutex
*/
#define offer_nice_chunk(chunk, chunk_size) do { \
- MUTEX_LOCK(&sv_mutex); \
+ LOCK_SV_MUTEX; \
if (!nice_chunk) { \
nice_chunk = (char*)(chunk); \
nice_chunk_size = (chunk_size); \
} \
- MUTEX_UNLOCK(&sv_mutex); \
+ UNLOCK_SV_MUTEX; \
} while (0)
*/
#ifdef CXUX_BROKEN_CONSTANT_CONVERT
static double UV_MAX_cxux = ((double)UV_MAX);
-#endif
+#endif
/*
* Types used in bitwise operations.
if (GIMME == G_ARRAY) {
I32 maxarg = AvFILL((AV*)TARG) + 1;
EXTEND(SP, maxarg);
- Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*);
+ if (SvMAGICAL(TARG)) {
+ U32 i;
+ for (i=0; i < maxarg; i++) {
+ SV **svp = av_fetch((AV*)TARG, i, FALSE);
+ SP[i+1] = (svp) ? *svp : &sv_undef;
+ }
+ }
+ else {
+ Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*);
+ }
SP += maxarg;
}
else {
PP(pp_rv2gv)
{
djSP; dTOPss;
-
+
if (SvROK(sv)) {
wasref:
sv = SvRV(sv);
PP(pp_pos)
{
djSP; dTARGET; dPOPss;
-
+
if (op->op_flags & OPf_MOD) {
if (SvTYPE(TARG) < SVt_PVLV) {
sv_upgrade(TARG, SVt_PVLV);
RETURN;
}
else {
- MAGIC* mg;
+ MAGIC* mg;
if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
mg = mg_find(sv, 'g');
djSP;
*SP = refto(*SP);
RETURN;
-}
+}
PP(pp_refgen)
{
sv = POPs;
if (sv && SvGMAGICAL(sv))
- mg_get(sv);
+ mg_get(sv);
if (!sv || !SvROK(sv))
RETPUSHNO;
{
djSP; dMARK; dTARGET;
register I32 count = 0;
-
+
while (SP > MARK)
count += do_chomp(POPs);
PUSHi(count);
PP(pp_pow)
{
- djSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
+ djSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
{
dPOPTOPnnrl;
SETn( pow( left, right) );
PP(pp_multiply)
{
- djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
+ djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
{
dPOPTOPnnrl;
SETn( left * right );
PP(pp_divide)
{
- djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
+ djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
{
dPOPPOPnnrl;
double value;
PP(pp_subtract)
{
- djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
+ djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
{
dPOPTOPnnrl_ul;
SETn( left - right );
PP(pp_left_shift)
{
- djSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
+ djSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
{
IBW shift = POPi;
if (op->op_private & HINT_INTEGER) {
PP(pp_right_shift)
{
- djSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
+ djSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
{
IBW shift = POPi;
if (op->op_private & HINT_INTEGER) {
PP(pp_lt)
{
- djSP; tryAMAGICbinSET(lt,0);
+ djSP; tryAMAGICbinSET(lt,0);
{
dPOPnv;
SETs(boolSV(TOPn < value));
PP(pp_gt)
{
- djSP; tryAMAGICbinSET(gt,0);
+ djSP; tryAMAGICbinSET(gt,0);
{
dPOPnv;
SETs(boolSV(TOPn > value));
PP(pp_le)
{
- djSP; tryAMAGICbinSET(le,0);
+ djSP; tryAMAGICbinSET(le,0);
{
dPOPnv;
SETs(boolSV(TOPn <= value));
PP(pp_ge)
{
- djSP; tryAMAGICbinSET(ge,0);
+ djSP; tryAMAGICbinSET(ge,0);
{
dPOPnv;
SETs(boolSV(TOPn >= value));
PP(pp_ne)
{
- djSP; tryAMAGICbinSET(ne,0);
+ djSP; tryAMAGICbinSET(ne,0);
{
dPOPnv;
SETs(boolSV(TOPn != value));
PP(pp_ncmp)
{
- djSP; dTARGET; tryAMAGICbin(ncmp,0);
+ djSP; dTARGET; tryAMAGICbin(ncmp,0);
{
dPOPTOPnnrl;
I32 value;
PP(pp_slt)
{
- djSP; tryAMAGICbinSET(slt,0);
+ djSP; tryAMAGICbinSET(slt,0);
{
dPOPTOPssrl;
int cmp = ((op->op_private & OPpLOCALE)
PP(pp_sgt)
{
- djSP; tryAMAGICbinSET(sgt,0);
+ djSP; tryAMAGICbinSET(sgt,0);
{
dPOPTOPssrl;
int cmp = ((op->op_private & OPpLOCALE)
PP(pp_sle)
{
- djSP; tryAMAGICbinSET(sle,0);
+ djSP; tryAMAGICbinSET(sle,0);
{
dPOPTOPssrl;
int cmp = ((op->op_private & OPpLOCALE)
PP(pp_sge)
{
- djSP; tryAMAGICbinSET(sge,0);
+ djSP; tryAMAGICbinSET(sge,0);
{
dPOPTOPssrl;
int cmp = ((op->op_private & OPpLOCALE)
PP(pp_seq)
{
- djSP; tryAMAGICbinSET(seq,0);
+ djSP; tryAMAGICbinSET(seq,0);
{
dPOPTOPssrl;
SETs(boolSV(sv_eq(left, right)));
PP(pp_sne)
{
- djSP; tryAMAGICbinSET(sne,0);
+ djSP; tryAMAGICbinSET(sne,0);
{
dPOPTOPssrl;
SETs(boolSV(!sv_eq(left, right)));
PP(pp_bit_and)
{
- djSP; dATARGET; tryAMAGICbin(band,opASSIGN);
+ djSP; dATARGET; tryAMAGICbin(band,opASSIGN);
{
dPOPTOPssrl;
if (SvNIOKp(left) || SvNIOKp(right)) {
if (op->op_private & HINT_INTEGER) {
- IBW value = SvIV(left) & SvIV(right);
+ IBW value = SvIV(left) & SvIV(right);
SETi(BWi(value));
}
else {
- UBW value = SvUV(left) & SvUV(right);
+ UBW value = SvUV(left) & SvUV(right);
SETu(BWu(value));
}
}
PP(pp_bit_xor)
{
- djSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
+ djSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
{
dPOPTOPssrl;
if (SvNIOKp(left) || SvNIOKp(right)) {
if (op->op_private & HINT_INTEGER) {
- IBW value = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
+ IBW value = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
SETi(BWi(value));
}
else {
- UBW value = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
+ UBW value = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
SETu(BWu(value));
}
}
PP(pp_bit_or)
{
- djSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
+ djSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
{
dPOPTOPssrl;
if (SvNIOKp(left) || SvNIOKp(right)) {
if (op->op_private & HINT_INTEGER) {
- IBW value = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
+ IBW value = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
SETi(BWi(value));
}
else {
- UBW value = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
+ UBW value = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
SETu(BWu(value));
}
}
PP(pp_complement)
{
- djSP; dTARGET; tryAMAGICun(compl);
+ djSP; dTARGET; tryAMAGICun(compl);
{
dTOPss;
if (SvNIOKp(sv)) {
PP(pp_i_multiply)
{
- djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
+ djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
{
dPOPTOPiirl;
SETi( left * right );
PP(pp_i_divide)
{
- djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
+ djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
{
dPOPiv;
if (value == 0)
PP(pp_i_modulo)
{
- djSP; dATARGET; tryAMAGICbin(mod,opASSIGN);
+ djSP; dATARGET; tryAMAGICbin(mod,opASSIGN);
{
dPOPTOPiirl;
if (!right)
PP(pp_i_add)
{
- djSP; dATARGET; tryAMAGICbin(add,opASSIGN);
+ djSP; dATARGET; tryAMAGICbin(add,opASSIGN);
{
dPOPTOPiirl;
SETi( left + right );
PP(pp_i_subtract)
{
- djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
+ djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
{
dPOPTOPiirl;
SETi( left - right );
PP(pp_i_lt)
{
- djSP; tryAMAGICbinSET(lt,0);
+ djSP; tryAMAGICbinSET(lt,0);
{
dPOPTOPiirl;
SETs(boolSV(left < right));
PP(pp_i_gt)
{
- djSP; tryAMAGICbinSET(gt,0);
+ djSP; tryAMAGICbinSET(gt,0);
{
dPOPTOPiirl;
SETs(boolSV(left > right));
PP(pp_i_le)
{
- djSP; tryAMAGICbinSET(le,0);
+ djSP; tryAMAGICbinSET(le,0);
{
dPOPTOPiirl;
SETs(boolSV(left <= right));
PP(pp_i_ge)
{
- djSP; tryAMAGICbinSET(ge,0);
+ djSP; tryAMAGICbinSET(ge,0);
{
dPOPTOPiirl;
SETs(boolSV(left >= right));
PP(pp_i_eq)
{
- djSP; tryAMAGICbinSET(eq,0);
+ djSP; tryAMAGICbinSET(eq,0);
{
dPOPTOPiirl;
SETs(boolSV(left == right));
PP(pp_i_ne)
{
- djSP; tryAMAGICbinSET(ne,0);
+ djSP; tryAMAGICbinSET(ne,0);
{
dPOPTOPiirl;
SETs(boolSV(left != right));
PP(pp_i_ncmp)
{
- djSP; dTARGET; tryAMAGICbin(ncmp,0);
+ djSP; dTARGET; tryAMAGICbin(ncmp,0);
{
dPOPTOPiirl;
I32 value;
PP(pp_atan2)
{
- djSP; dTARGET; tryAMAGICbin(atan2,0);
+ djSP; dTARGET; tryAMAGICbin(atan2,0);
{
dPOPTOPnnrl;
SETn(atan2(left, right));
rem -= pos;
}
if (fail < 0) {
- if (dowarn || lvalue)
+ if (dowarn || lvalue)
warn("substr outside of string");
RETPUSHUNDEF;
}
LvTYPE(TARG) = 'x';
LvTARG(TARG) = sv;
LvTARGOFF(TARG) = pos;
- LvTARGLEN(TARG) = rem;
+ LvTARGLEN(TARG) = rem;
}
}
PUSHs(TARG); /* avoid SvSETMAGIC here */
LvTYPE(TARG) = 'v';
LvTARG(TARG) = src;
- LvTARGOFF(TARG) = offset;
- LvTARGLEN(TARG) = size;
+ LvTARGOFF(TARG) = offset;
+ LvTARGLEN(TARG) = size;
}
if (len > srclen) {
if (size <= 8)
HE *entry;
I32 gimme = GIMME_V;
I32 realhv = (SvTYPE(hash) == SVt_PVHV);
-
+
PUTBACK;
/* might clobber stack_sp */
entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
I32 after;
I32 diff;
SV **tmparyval = 0;
+ MAGIC *mg;
+
+ if (SvRMAGICAL(ary) && (mg = mg_find((SV*)ary,'P'))) {
+ *MARK-- = mg->mg_obj;
+ PUSHMARK(MARK);
+ PUTBACK;
+ ENTER;
+ perl_call_method("SPLICE",GIMME_V);
+ LEAVE;
+ SPAGAIN;
+ RETURN;
+ }
SP++;
if (++MARK < SP) {
offset = i = SvIVx(*MARK);
if (offset < 0)
- offset += AvFILL(ary) + 1;
+ offset += AvFILLp(ary) + 1;
else
offset -= curcop->cop_arybase;
if (offset < 0)
offset = 0;
length = AvMAX(ary) + 1;
}
- if (offset > AvFILL(ary) + 1)
- offset = AvFILL(ary) + 1;
- after = AvFILL(ary) + 1 - (offset + length);
+ if (offset > AvFILLp(ary) + 1)
+ offset = AvFILLp(ary) + 1;
+ after = AvFILLp(ary) + 1 - (offset + length);
if (after < 0) { /* not that much array */
length += after; /* offset+length now in array */
after = 0;
SvREFCNT_dec(*dst++); /* free them now */
}
}
- AvFILL(ary) += diff;
+ AvFILLp(ary) += diff;
/* pull up or down? */
dst = src + diff; /* diff is negative */
Move(src, dst, after, SV*);
}
- dst = &AvARRAY(ary)[AvFILL(ary)+1];
+ dst = &AvARRAY(ary)[AvFILLp(ary)+1];
/* avoid later double free */
}
i = -diff;
}
SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
AvMAX(ary) += diff;
- AvFILL(ary) += diff;
+ AvFILLp(ary) += diff;
}
else {
- if (AvFILL(ary) + diff >= AvMAX(ary)) /* oh, well */
- av_extend(ary, AvFILL(ary) + diff);
- AvFILL(ary) += diff;
+ if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
+ av_extend(ary, AvFILLp(ary) + diff);
+ AvFILLp(ary) += diff;
if (after) {
- dst = AvARRAY(ary) + AvFILL(ary);
+ dst = AvARRAY(ary) + AvFILLp(ary);
src = dst - diff;
for (i = after; i; i--) {
*dst-- = *src--;
djSP; dMARK; dORIGMARK; dTARGET;
register AV *ary = (AV*)*++MARK;
register SV *sv = &sv_undef;
+ MAGIC *mg;
- for (++MARK; MARK <= SP; MARK++) {
- sv = NEWSV(51, 0);
- if (*MARK)
- sv_setsv(sv, *MARK);
- av_push(ary, sv);
+ if (SvRMAGICAL(ary) && (mg = mg_find((SV*)ary,'P'))) {
+ *MARK-- = mg->mg_obj;
+ PUSHMARK(MARK);
+ PUTBACK;
+ ENTER;
+ perl_call_method("PUSH",G_SCALAR|G_DISCARD);
+ LEAVE;
+ SPAGAIN;
+ }
+ else {
+ /* Why no pre-extend of ary here ? */
+ for (++MARK; MARK <= SP; MARK++) {
+ sv = NEWSV(51, 0);
+ if (*MARK)
+ sv_setsv(sv, *MARK);
+ av_push(ary, sv);
+ }
}
SP = ORIGMARK;
PUSHi( AvFILL(ary) + 1 );
register AV *ary = (AV*)*++MARK;
register SV *sv;
register I32 i = 0;
+ MAGIC *mg;
+
+ if (SvRMAGICAL(ary) && (mg = mg_find((SV*)ary,'P'))) {
- av_unshift(ary, SP - MARK);
- while (MARK < SP) {
- sv = NEWSV(27, 0);
- sv_setsv(sv, *++MARK);
- (void)av_store(ary, i++, sv);
- }
+ *MARK-- = mg->mg_obj;
+ PUTBACK;
+ ENTER;
+ perl_call_method("UNSHIFT",G_SCALAR|G_DISCARD);
+ LEAVE;
+ SPAGAIN;
+ }
+ else {
+ av_unshift(ary, SP - MARK);
+ while (MARK < SP) {
+ sv = NEWSV(27, 0);
+ sv_setsv(sv, *++MARK);
+ (void)av_store(ary, i++, sv);
+ }
+ }
SP = ORIGMARK;
PUSHi( AvFILL(ary) + 1 );
RETURN;
s += SIZE16;
#ifdef HAS_NTOHS
if (datumtype == 'n')
- aushort = ntohs(aushort);
+ aushort = PerlSock_ntohs(aushort);
#endif
#ifdef HAS_VTOHS
if (datumtype == 'v')
sv = NEWSV(39, 0);
#ifdef HAS_NTOHS
if (datumtype == 'n')
- aushort = ntohs(aushort);
+ aushort = PerlSock_ntohs(aushort);
#endif
#ifdef HAS_VTOHS
if (datumtype == 'v')
s += SIZE32;
#ifdef HAS_NTOHL
if (datumtype == 'N')
- aulong = ntohl(aulong);
+ aulong = PerlSock_ntohl(aulong);
#endif
#ifdef HAS_VTOHL
if (datumtype == 'V')
s += SIZE32;
#ifdef HAS_NTOHL
if (datumtype == 'N')
- aulong = ntohl(aulong);
+ aulong = PerlSock_ntohl(aulong);
#endif
#ifdef HAS_VTOHL
if (datumtype == 'V')
case 'w':
EXTEND(SP, len);
EXTEND_MORTAL(len);
- {
+ {
UV auv = 0;
U32 bytes = 0;
static int
div128(SV *pnum, bool *done)
/* must be '\0' terminated */
-
+
{
STRLEN len;
char *s = SvPV(pnum, len);
fromstr = NEXTFROM;
ashort = (I16)SvIV(fromstr);
#ifdef HAS_HTONS
- ashort = htons(ashort);
+ ashort = PerlSock_htons(ashort);
#endif
CAT16(cat, &ashort);
}
SV *norm;
STRLEN len;
bool done;
-
+
/* Copy string and check for compliance */
from = SvPV(fromstr, len);
if ((norm = is_an_int(from, len)) == NULL)
fromstr = NEXTFROM;
aulong = SvUV(fromstr);
#ifdef HAS_HTONL
- aulong = htonl(aulong);
+ aulong = PerlSock_htonl(aulong);
#endif
CAT32(cat, &aulong);
}
}
#undef NEXTFROM
+
PP(pp_split)
{
djSP; dTARG;
AV *oldstack = curstack;
I32 gimme = GIMME_V;
I32 oldsave = savestack_ix;
+ I32 make_mortal = 1;
+ MAGIC *mg = (MAGIC *) NULL;
#ifdef DEBUGGING
Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
ary = Nullav;
if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
realarray = 1;
- if (!AvREAL(ary)) {
- AvREAL_on(ary);
- for (i = AvFILL(ary); i >= 0; i--)
- AvARRAY(ary)[i] = &sv_undef; /* don't free mere refs */
- }
+ PUTBACK;
av_extend(ary,0);
av_clear(ary);
- /* temporarily switch stacks */
- SWITCHSTACK(curstack, ary);
+ SPAGAIN;
+ if (SvRMAGICAL(ary) && (mg = mg_find((SV *) ary, 'P'))) {
+ PUSHMARK(SP);
+ XPUSHs(mg->mg_obj);
+ }
+ else {
+ if (!AvREAL(ary)) {
+ AvREAL_on(ary);
+ for (i = AvFILLp(ary); i >= 0; i--)
+ AvARRAY(ary)[i] = &sv_undef; /* don't free mere refs */
+ }
+ /* temporarily switch stacks */
+ SWITCHSTACK(curstack, ary);
+ make_mortal = 0;
+ }
}
base = SP - stack_base;
orig = s;
dstr = NEWSV(30, m-s);
sv_setpvn(dstr, s, m-s);
- if (!realarray)
+ if (make_mortal)
sv_2mortal(dstr);
XPUSHs(dstr);
break;
dstr = NEWSV(30, m-s);
sv_setpvn(dstr, s, m-s);
- if (!realarray)
+ if (make_mortal)
sv_2mortal(dstr);
XPUSHs(dstr);
s = m;
}
}
- else if (rx->check_substr && !rx->nparens
+ else if (rx->check_substr && !rx->nparens
&& (rx->reganch & ROPT_CHECK_ALL)
&& !(rx->reganch & ROPT_ANCH)) {
i = SvCUR(rx->check_substr);
break;
dstr = NEWSV(30, m-s);
sv_setpvn(dstr, s, m-s);
- if (!realarray)
+ if (make_mortal)
sv_2mortal(dstr);
XPUSHs(dstr);
s = m + 1;
{
dstr = NEWSV(31, m-s);
sv_setpvn(dstr, s, m-s);
- if (!realarray)
+ if (make_mortal)
sv_2mortal(dstr);
XPUSHs(dstr);
s = m + i;
m = rx->startp[0];
dstr = NEWSV(32, m-s);
sv_setpvn(dstr, s, m-s);
- if (!realarray)
+ if (make_mortal)
sv_2mortal(dstr);
XPUSHs(dstr);
if (rx->nparens) {
}
else
dstr = NEWSV(33, 0);
- if (!realarray)
+ if (make_mortal)
sv_2mortal(dstr);
XPUSHs(dstr);
}
s = rx->endp[0];
}
}
+
LEAVE_SCOPE(oldsave);
iters = (SP - stack_base) - base;
if (iters > maxiters)
DIE("Split loop");
-
+
/* keep field after final delim? */
if (s < strend || (iters && origlimit)) {
dstr = NEWSV(34, strend-s);
sv_setpvn(dstr, s, strend-s);
- if (!realarray)
+ if (make_mortal)
sv_2mortal(dstr);
XPUSHs(dstr);
iters++;
while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
iters--, SP--;
}
+
if (realarray) {
- SWITCHSTACK(ary, oldstack);
- if (SvSMAGICAL(ary)) {
+ if (!mg) {
+ SWITCHSTACK(ary, oldstack);
+ if (SvSMAGICAL(ary)) {
+ PUTBACK;
+ mg_set((SV*)ary);
+ SPAGAIN;
+ }
+ if (gimme == G_ARRAY) {
+ EXTEND(SP, iters);
+ Copy(AvARRAY(ary), SP + 1, iters, SV*);
+ SP += iters;
+ RETURN;
+ }
+ }
+ else {
PUTBACK;
- mg_set((SV*)ary);
+ ENTER;
+ perl_call_method("PUSH",G_SCALAR|G_DISCARD);
+ LEAVE;
SPAGAIN;
- }
- if (gimme == G_ARRAY) {
- EXTEND(SP, iters);
- Copy(AvARRAY(ary), SP + 1, iters, SV*);
- SP += iters;
- RETURN;
+ if (gimme == G_ARRAY) {
+ /* EXTEND should not be needed - we just popped them */
+ EXTEND(SP, iters);
+ for (i=0; i < iters; i++) {
+ SV **svp = av_fetch(ary, i, FALSE);
+ PUSHs((svp) ? *svp : &sv_undef);
+ }
+ RETURN;
+ }
}
}
else {
{
dTHR;
MAGIC *mg = mg_find((SV*)svv, 'm');
-
+
if (!mg)
croak("panic: unlock_condpair unlocking non-mutex");
MUTEX_LOCK(MgMUTEXP(mg));
SV *retsv = sv;
#ifdef USE_THREADS
MAGIC *mg;
-
+
if (SvROK(sv))
sv = SvRV(sv);
if (op->op_private & OPpLVAL_INTRO)
PUSHs(*save_threadsv(op->op_targ));
else
- PUSHs(*av_fetch(thr->threadsv, op->op_targ, FALSE));
+ PUSHs(THREADSV(op->op_targ));
RETURN;
#else
DIE("tried to access per-thread data in non-threaded perl");
SAVETMPS;
#ifdef USE_THREADS
/* SAVE_DEFSV does *not* suffice here */
- save_sptr(av_fetch(thr->threadsv, find_threadsv("_"), FALSE));
+ save_sptr(&THREADSV(0));
#else
SAVESPTR(GvSV(defgv));
#endif /* USE_THREADS */
AvREAL_off(dbargs); /* XXX Should be REIFY */
}
- if (AvMAX(dbargs) < AvFILL(ary) + off)
- av_extend(dbargs, AvFILL(ary) + off);
- Copy(AvALLOC(ary), AvARRAY(dbargs), AvFILL(ary) + 1 + off, SV*);
- AvFILL(dbargs) = AvFILL(ary) + off;
+ if (AvMAX(dbargs) < AvFILLp(ary) + off)
+ av_extend(dbargs, AvFILLp(ary) + off);
+ Copy(AvALLOC(ary), AvARRAY(dbargs), AvFILLp(ary) + 1 + off, SV*);
+ AvFILLp(dbargs) = AvFILLp(ary) + off;
}
RETURN;
}
cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
else {
cx->blk_loop.iterary = curstack;
- AvFILL(curstack) = sp - stack_base;
+ AvFILLp(curstack) = sp - stack_base;
cx->blk_loop.iterix = MARK - stack_base;
}
if (cx->blk_sub.hasargs) { /* put @_ back onto stack */
AV* av = cx->blk_sub.argarray;
- items = AvFILL(av) + 1;
+ items = AvFILLp(av) + 1;
stack_sp++;
EXTEND(stack_sp, items); /* @_ could have been extended. */
Copy(AvARRAY(av), stack_sp, items, SV*);
else { /* save temporaries on recursion? */
if (CvDEPTH(cv) == 100 && dowarn)
sub_crush_depth(cv);
- if (CvDEPTH(cv) > AvFILL(padlist)) {
+ if (CvDEPTH(cv) > AvFILLp(padlist)) {
AV *newpad = newAV();
SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
- I32 ix = AvFILL((AV*)svp[1]);
+ I32 ix = AvFILLp((AV*)svp[1]);
svp = AvARRAY(svp[0]);
for ( ;ix > 0; ix--) {
if (svp[ix] != &sv_undef) {
AvFLAGS(av) = AVf_REIFY;
}
av_store(padlist, CvDEPTH(cv), (SV*)newpad);
- AvFILL(padlist) = CvDEPTH(cv);
+ AvFILLp(padlist) = CvDEPTH(cv);
svp = AvARRAY(padlist);
}
}
if (!cx->blk_sub.hasargs) {
AV* av = (AV*)curpad[0];
- items = AvFILL(av) + 1;
+ items = AvFILLp(av) + 1;
if (items) {
/* Mark is at the end of the stack. */
EXTEND(sp, items);
}
}
Copy(mark,AvARRAY(av),items,SV*);
- AvFILL(av) = items - 1;
+ AvFILLp(av) = items - 1;
while (items--) {
if (*mark)
HV *newstash;
CV *caller;
AV* comppadlist;
+ I32 i;
in_eval = 1;
SAVEI32(max_intro_pending);
caller = compcv;
+ for (i = cxstack_ix - 1; i >= 0; i--) {
+ PERL_CONTEXT *cx = &cxstack[i];
+ if (cx->cx_type == CXt_EVAL)
+ break;
+ else if (cx->cx_type == CXt_SUB) {
+ caller = cx->blk_sub.cv;
+ break;
+ }
+ }
+
SAVESPTR(compcv);
compcv = (CV*)NEWSV(1104,0);
sv_upgrade((SV *)compcv, SVt_PVCV);
* (Note that the fact that compcv and friends are still set here
* is, AFAIK, an accident.) --Chip
*/
- if (AvFILL(comppad_name) >= 0) {
+ if (AvFILLp(comppad_name) >= 0) {
SV **svp = AvARRAY(comppad_name);
I32 ix;
- for (ix = AvFILL(comppad_name); ix >= 0; ix--) {
+ for (ix = AvFILLp(comppad_name); ix >= 0; ix--) {
SV *sv = svp[ix];
if (sv && sv != &sv_undef && *SvPVX(sv) == '&') {
SvREFCNT_dec(sv);
stack_grow(SV **sp, SV **p, int n)
{
dTHR;
+#if defined(DEBUGGING) && !defined(USE_THREADS)
+ static int growing = 0;
+ if (growing++)
+ abort();
+#endif
stack_sp = sp;
av_extend(curstack, (p - stack_base) + (n) + 128);
+#if defined(DEBUGGING) && !defined(USE_THREADS)
+ growing--;
+#endif
return stack_sp;
}
save_ary(GV *gv)
{
dTHR;
- AV *oav, *av;
+ AV *oav = GvAVn(gv);
+ AV *av;
+ if (!AvREAL(oav) && AvREIFY(oav))
+ av_reify(oav);
SSCHECK(3);
SSPUSHPTR(gv);
- SSPUSHPTR(oav = GvAVn(gv));
+ SSPUSHPTR(oav);
SSPUSHINT(SAVEt_AV);
GvAV(gv) = Null(AV*);
{
#ifdef USE_THREADS
dTHR;
- SV **svp = av_fetch(thr->threadsv, i, FALSE);
+ SV **svp = &THREADSV(i); /* XXX Change to save by offset */
DEBUG_L(PerlIO_printf(PerlIO_stderr(), "save_threadsv %u: %p %p:%s\n",
i, svp, *svp, SvPEEK(*svp)));
save_svref(svp);
#define new_SV(p) \
do { \
- MUTEX_LOCK(&sv_mutex); \
+ LOCK_SV_MUTEX; \
(p) = (SV*)safemalloc(sizeof(SV)); \
reg_add(p); \
- MUTEX_UNLOCK(&sv_mutex); \
+ UNLOCK_SV_MUTEX; \
} while (0)
#define del_SV(p) \
do { \
- MUTEX_LOCK(&sv_mutex); \
+ LOCK_SV_MUTEX; \
reg_remove(p); \
- free((char*)(p)); \
+ Safefree((char*)(p)); \
- MUTEX_UNLOCK(&sv_mutex); \
+ UNLOCK_SV_MUTEX; \
} while (0)
static SV **registry;
U32 flags;
{
if (!(flags & SVf_FAKE))
- free(ptr);
+ Safefree(ptr);
}
#else /* ! PURIFY */
++sv_count; \
} while (0)
- #define new_SV(p) do { \
- MUTEX_LOCK(&sv_mutex); \
- if (sv_root) \
- uproot_SV(p); \
- else \
- (p) = more_sv(); \
- MUTEX_UNLOCK(&sv_mutex); \
+ #define new_SV(p) do { \
+ LOCK_SV_MUTEX; \
+ if (sv_root) \
+ uproot_SV(p); \
+ else \
+ (p) = more_sv(); \
+ UNLOCK_SV_MUTEX; \
} while (0)
#ifdef DEBUGGING
- #define del_SV(p) do { \
- MUTEX_LOCK(&sv_mutex); \
- if (debug & 32768) \
- del_sv(p); \
- else \
- plant_SV(p); \
- MUTEX_UNLOCK(&sv_mutex); \
+ #define del_SV(p) do { \
+ LOCK_SV_MUTEX; \
+ if (debug & 32768) \
+ del_sv(p); \
+ else \
+ plant_SV(p); \
+ UNLOCK_SV_MUTEX; \
} while (0)
static void
#ifdef PURIFY
#define new_XIV() (void*)safemalloc(sizeof(XPVIV))
-#define del_XIV(p) free((char*)p)
+#define del_XIV(p) Safefree((char*)p)
#else
#define new_XIV() (void*)new_xiv()
#define del_XIV(p) del_xiv((XPVIV*) p)
#ifdef PURIFY
#define new_XNV() (void*)safemalloc(sizeof(XPVNV))
-#define del_XNV(p) free((char*)p)
+#define del_XNV(p) Safefree((char*)p)
#else
#define new_XNV() (void*)new_xnv()
#define del_XNV(p) del_xnv((XPVNV*) p)
#ifdef PURIFY
#define new_XRV() (void*)safemalloc(sizeof(XRV))
-#define del_XRV(p) free((char*)p)
+#define del_XRV(p) Safefree((char*)p)
#else
#define new_XRV() (void*)new_xrv()
#define del_XRV(p) del_xrv((XRV*) p)
#ifdef PURIFY
#define new_XPV() (void*)safemalloc(sizeof(XPV))
-#define del_XPV(p) free((char*)p)
+#define del_XPV(p) Safefree((char*)p)
#else
#define new_XPV() (void*)new_xpv()
#define del_XPV(p) del_xpv((XPV *)p)
#endif
#define new_XPVIV() (void*)safemalloc(sizeof(XPVIV))
-#define del_XPVIV(p) free((char*)p)
+#define del_XPVIV(p) Safefree((char*)p)
#define new_XPVNV() (void*)safemalloc(sizeof(XPVNV))
-#define del_XPVNV(p) free((char*)p)
+#define del_XPVNV(p) Safefree((char*)p)
#define new_XPVMG() (void*)safemalloc(sizeof(XPVMG))
-#define del_XPVMG(p) free((char*)p)
+#define del_XPVMG(p) Safefree((char*)p)
#define new_XPVLV() (void*)safemalloc(sizeof(XPVLV))
-#define del_XPVLV(p) free((char*)p)
+#define del_XPVLV(p) Safefree((char*)p)
#define new_XPVAV() (void*)safemalloc(sizeof(XPVAV))
-#define del_XPVAV(p) free((char*)p)
+#define del_XPVAV(p) Safefree((char*)p)
#define new_XPVHV() (void*)safemalloc(sizeof(XPVHV))
-#define del_XPVHV(p) free((char*)p)
+#define del_XPVHV(p) Safefree((char*)p)
#define new_XPVCV() (void*)safemalloc(sizeof(XPVCV))
-#define del_XPVCV(p) free((char*)p)
+#define del_XPVCV(p) Safefree((char*)p)
#define new_XPVGV() (void*)safemalloc(sizeof(XPVGV))
-#define del_XPVGV(p) free((char*)p)
+#define del_XPVGV(p) Safefree((char*)p)
#define new_XPVBM() (void*)safemalloc(sizeof(XPVBM))
-#define del_XPVBM(p) free((char*)p)
+#define del_XPVBM(p) Safefree((char*)p)
#define new_XPVFM() (void*)safemalloc(sizeof(XPVFM))
-#define del_XPVFM(p) free((char*)p)
+#define del_XPVFM(p) Safefree((char*)p)
#define new_XPVIO() (void*)safemalloc(sizeof(XPVIO))
-#define del_XPVIO(p) free((char*)p)
+#define del_XPVIO(p) Safefree((char*)p)
bool
sv_upgrade(register SV *sv, U32 mt)
Safefree(pv);
SvPVX(sv) = 0;
AvMAX(sv) = -1;
- AvFILL(sv) = -1;
+ AvFILLp(sv) = -1;
SvIVX(sv) = 0;
SvNVX(sv) = 0.0;
SvMAGIC(sv) = magic;
#endif /* USE_LOCALE_COLLATE */
char *
-sv_gets(register SV *sv, register FILE *fp, I32 append)
+sv_gets(register SV *sv, register PerlIO *fp, I32 append)
{
dTHR;
char *rsptr;
dTHR;
if (!sv)
return 0;
- if (SvGMAGICAL(sv))
- mg_get(sv);
if (SvPOK(sv)) {
register XPV* tXpv;
if ((tXpv = (XPV*)SvANY(sv)) &&
SV*
sv_setref_pv(SV *rv, char *classname, void *pv)
{
- if (!pv)
+ if (!pv) {
sv_setsv(rv, &sv_undef);
+ SvSETMAGIC(rv);
+ }
else
sv_setiv(newSVrv(rv,classname), (IV)pv);
return rv;
case SVt_PVAV:
PerlIO_printf(Perl_debug_log, " ARRAY = 0x%lx\n", (long)AvARRAY(sv));
PerlIO_printf(Perl_debug_log, " ALLOC = 0x%lx\n", (long)AvALLOC(sv));
- PerlIO_printf(Perl_debug_log, " FILL = %ld\n", (long)AvFILL(sv));
+ PerlIO_printf(Perl_debug_log, " FILL = %ld\n", (long)AvFILLp(sv));
PerlIO_printf(Perl_debug_log, " MAX = %ld\n", (long)AvMAX(sv));
PerlIO_printf(Perl_debug_log, " ARYLEN = 0x%lx\n", (long)AvARYLEN(sv));
flags = AvFLAGS(sv);
#include "EXTERN.h"
#include "perl.h"
+#include "perlmem.h"
#if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
#include <signal.h>
static void xstat _((void));
#endif
- #ifdef USE_THREADS
- static U32 threadnum = 0;
- #endif /* USE_THREADS */
-
#ifndef MYMALLOC
/* paranoid version of malloc */
if ((long)size < 0)
croak("panic: malloc");
#endif
- ptr = malloc(size?size:1); /* malloc(0) is NASTY on our system */
+ ptr = PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */
#if !(defined(I286) || defined(atarist))
DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%x: (%05d) malloc %ld bytes\n",ptr,an++,(long)size));
#else
{
Malloc_t ptr;
#if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE)
- Malloc_t realloc();
+ Malloc_t PerlMem_realloc();
#endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */
#ifdef HAS_64K_LIMIT
if ((long)size < 0)
croak("panic: realloc");
#endif
- ptr = realloc(where,size?size:1); /* realloc(0) is NASTY on our system */
+ ptr = PerlMem_realloc(where,size?size:1); /* realloc(0) is NASTY on our system */
#if !(defined(I286) || defined(atarist))
DEBUG_m( {
#endif
if (where) {
/*SUPPRESS 701*/
- free(where);
+ PerlMem_free(where);
}
}
croak("panic: calloc");
#endif
size *= count;
- ptr = malloc(size?size:1); /* malloc(0) is NASTY on our system */
+ ptr = PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */
#if !(defined(I286) || defined(atarist))
DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%x: (%05d) calloc %ld x %ld bytes\n",ptr,an++,(long)count,(long)size));
#else
#ifdef USE_LOCALE_NUMERIC
char *curnum = NULL;
#endif /* USE_LOCALE_NUMERIC */
- char *lc_all = getenv("LC_ALL");
- char *lang = getenv("LANG");
+ char *lc_all = PerlEnv_getenv("LC_ALL");
+ char *lang = PerlEnv_getenv("LANG");
bool setlocale_failure = FALSE;
#ifdef LOCALE_ENVIRON_REQUIRED
{
#ifdef USE_LOCALE_CTYPE
if (! (curctype = setlocale(LC_CTYPE,
- (!done && (lang || getenv("LC_CTYPE")))
+ (!done && (lang || PerlEnv_getenv("LC_CTYPE")))
? "" : Nullch)))
setlocale_failure = TRUE;
#endif /* USE_LOCALE_CTYPE */
#ifdef USE_LOCALE_COLLATE
if (! (curcoll = setlocale(LC_COLLATE,
- (!done && (lang || getenv("LC_COLLATE")))
+ (!done && (lang || PerlEnv_getenv("LC_COLLATE")))
? "" : Nullch)))
setlocale_failure = TRUE;
#endif /* USE_LOCALE_COLLATE */
#ifdef USE_LOCALE_NUMERIC
if (! (curnum = setlocale(LC_NUMERIC,
- (!done && (lang || getenv("LC_NUMERIC")))
+ (!done && (lang || PerlEnv_getenv("LC_NUMERIC")))
? "" : Nullch)))
setlocale_failure = TRUE;
#endif /* USE_LOCALE_NUMERIC */
char *p;
bool locwarn = (printwarn > 1 ||
printwarn &&
- (!(p = getenv("PERL_BADLANG")) || atoi(p)));
+ (!(p = PerlEnv_getenv("PERL_BADLANG")) || atoi(p)));
if (locwarn) {
#ifdef LC_ALL
vallen = strlen(val);
New(904, envstr, namlen + vallen + 3, char);
(void)sprintf(envstr,"%s=%s",nam,val);
- (void)putenv(envstr);
+ (void)PerlEnv_putenv(envstr);
if (oldstr)
Safefree(oldstr);
#ifdef _MSC_VER
{
I32 i;
- for (i = 0; unlink(f) >= 0; i++) ;
+ for (i = 0; PerlLIO_unlink(f) >= 0; i++) ;
return i ? 0 : -1;
}
#endif
return my_syspopen(cmd,mode);
}
#endif
- if (pipe(p) < 0)
+ if (PerlProc_pipe(p) < 0)
return Nullfp;
This = (*mode == 'w');
that = !This;
}
while ((pid = (doexec?vfork():fork())) < 0) {
if (errno != EAGAIN) {
- close(p[This]);
+ PerlLIO_close(p[This]);
if (!doexec)
croak("Can't fork");
return Nullfp;
#define THIS that
#define THAT This
- close(p[THAT]);
+ PerlLIO_close(p[THAT]);
if (p[THIS] != (*mode == 'r')) {
- dup2(p[THIS], *mode == 'r');
- close(p[THIS]);
+ PerlLIO_dup2(p[THIS], *mode == 'r');
+ PerlLIO_close(p[THIS]);
}
if (doexec) {
#if !defined(HAS_FCNTL) || !defined(F_SETFD)
#define NOFILE 20
#endif
for (fd = maxsysfd + 1; fd < NOFILE; fd++)
- close(fd);
+ PerlLIO_close(fd);
#endif
do_exec(cmd); /* may or may not use the shell */
- _exit(1);
+ PerlProc__exit(1);
}
/*SUPPRESS 560*/
if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
#undef THAT
}
do_execfree(); /* free any memory malloced by child on vfork */
- close(p[that]);
+ PerlLIO_close(p[that]);
if (p[that] < p[This]) {
- dup2(p[This], p[that]);
- close(p[This]);
+ PerlLIO_dup2(p[This], p[that]);
+ PerlLIO_close(p[This]);
p[This] = p[that];
}
sv = *av_fetch(fdpid,p[This],TRUE);
PerlIO_printf(PerlIO_stderr(),"%s", s);
for (fd = 0; fd < 32; fd++) {
- if (Fstat(fd,&tmpstatbuf) >= 0)
+ if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0)
PerlIO_printf(PerlIO_stderr()," %d",fd);
}
PerlIO_printf(PerlIO_stderr(),"\n");
#if defined(HAS_FCNTL) && defined(F_DUPFD)
if (oldfd == newfd)
return oldfd;
- close(newfd);
+ PerlLIO_close(newfd);
return fcntl(oldfd, F_DUPFD, newfd);
#else
#define DUP2_MAX_FDS 256
if (oldfd == newfd)
return oldfd;
- close(newfd);
+ PerlLIO_close(newfd);
/* good enough for low fd's... */
- while ((fd = dup(oldfd)) != newfd && fd >= 0) {
+ while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
if (fdx >= DUP2_MAX_FDS) {
- close(fd);
+ PerlLIO_close(fd);
fd = -1;
break;
}
fdtmp[fdx++] = fd;
}
while (fdx > 0)
- close(fdtmp[--fdx]);
+ PerlLIO_close(fdtmp[--fdx]);
return fd;
#endif
}
Sighandler_t
rsignal(int signo, Sighandler_t handler)
{
- return signal(signo, handler);
+ return PerlProc_signal(signo, handler);
}
static int sig_trapped;
Sighandler_t oldsig;
sig_trapped = 0;
- oldsig = signal(signo, sig_trap);
- signal(signo, oldsig);
+ oldsig = PerlProc_signal(signo, sig_trap);
+ PerlProc_signal(signo, oldsig);
if (sig_trapped)
- kill(getpid(), signo);
+ PerlProc_kill(getpid(), signo);
return oldsig;
}
int
rsignal_save(int signo, Sighandler_t handler, Sigsave_t *save)
{
- *save = signal(signo, handler);
+ *save = PerlProc_signal(signo, handler);
return (*save == SIG_ERR) ? -1 : 0;
}
int
rsignal_restore(int signo, Sigsave_t *save)
{
- return (signal(signo, *save) == SIG_ERR) ? -1 : 0;
+ return (PerlProc_signal(signo, *save) == SIG_ERR) ? -1 : 0;
}
#endif /* !HAS_SIGACTION */
/* VMS' my_pclose() is in VMS.c; same with OS/2 */
#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS)
I32
-my_pclose(FILE *ptr)
+my_pclose(PerlIO *ptr)
{
Sigsave_t hstat, istat, qstat;
int status;
#endif
}
#ifdef UTS
- if(kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */
+ if(PerlProc_kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */
#endif
rsignal_save(SIGHUP, SIG_IGN, &hstat);
rsignal_save(SIGINT, SIG_IGN, &istat);
COND_INIT(&cp->owner_cond);
COND_INIT(&cp->cond);
cp->owner = 0;
- MUTEX_LOCK(&sv_mutex);
+ LOCK_SV_MUTEX;
mg = mg_find(sv, 'm');
if (mg) {
/* someone else beat us to initialising it */
- MUTEX_UNLOCK(&sv_mutex);
+ UNLOCK_SV_MUTEX;
MUTEX_DESTROY(&cp->mutex);
COND_DESTROY(&cp->owner_cond);
COND_DESTROY(&cp->cond);
mg = SvMAGIC(sv);
mg->mg_ptr = (char *)cp;
mg->mg_len = sizeof(cp);
- MUTEX_UNLOCK(&sv_mutex);
+ UNLOCK_SV_MUTEX;
DEBUG_L(WITH_THR(PerlIO_printf(PerlIO_stderr(),
"%p: condpair_magic %p\n", thr, sv));)
}
/* Initialise all per-thread SVs that the template thread used */
svp = AvARRAY(t->threadsv);
- for (i = 0; i <= AvFILL(t->threadsv); i++, svp++) {
+ for (i = 0; i <= AvFILLp(t->threadsv); i++, svp++) {
if (*svp && *svp != &sv_undef) {
SV *sv = newSVsv(*svp);
av_store(thr->threadsv, i, sv);
"new_struct_thread: copied threadsv %d %p->%p\n",i, t, thr));
}
}
+ thr->threadsvp = AvARRAY(thr->threadsv);
MUTEX_LOCK(&threads_mutex);
nthreads++;
projects / p5sagit/p5-mst-13.2.git / commitdiff