while (key) {
sv = AvARRAY(av)[--key];
assert(sv);
- if (sv != &PL_sv_undef) {
- dTHR;
+ if (sv != &PL_sv_undef)
(void)SvREFCNT_inc(sv);
- }
}
key = AvARRAY(av) - AvALLOC(av);
while (key)
void
Perl_av_extend(pTHX_ AV *av, I32 key)
{
- dTHR; /* only necessary if we have to extend stack */
MAGIC *mg;
if ((mg = SvTIED_mg((SV*)av, 'P'))) {
dSP;
if (SvRMAGICAL(av)) {
if (mg_find((SV*)av,'P') || mg_find((SV*)av,'D')) {
- dTHR;
sv = sv_newmortal();
mg_copy((SV*)av, sv, 0, key);
PL_av_fetch_sv = sv;
ary = AvARRAY(av);
if (AvFILLp(av) < key) {
if (!AvREAL(av)) {
- dTHR;
if (av == PL_curstack && key > PL_stack_sp - PL_stack_base)
PL_stack_sp = PL_stack_base + key; /* XPUSH in disguise */
do
childpid = spawnvp(_P_NOWAIT,path,argv);
if (childpid < 0) {
status = -1;
- if(ckWARN(WARN_EXEC)) {
- dTHR;
+ if(ckWARN(WARN_EXEC))
Perl_warner(aTHX_ WARN_EXEC,"Can't spawn \"%s\": %s",
path,Strerror (errno));
- }
} else {
do {
result = wait4pid(childpid, &status, 0);
Perl_vdeb(pTHX_ const char *pat, va_list *args)
{
#ifdef DEBUGGING
- dTHR;
char* file = CopFILE(PL_curcop);
#ifdef USE_THREADS
Perl_debstackptrs(pTHX)
{
#ifdef DEBUGGING
- dTHR;
PerlIO_printf(Perl_debug_log,
"%8"UVxf" %8"UVxf" %8"IVdf" %8"IVdf" %8"IVdf"\n",
PTR2UV(PL_curstack), PTR2UV(PL_stack_base),
Perl_debstack(pTHX)
{
#ifdef DEBUGGING
- dTHR;
I32 top = PL_stack_sp - PL_stack_base;
register I32 i = top - 30;
I32 *markscan = PL_markstack + PL_curstackinfo->si_markoff;
int
do_aspawn (pTHX_ SV *really,SV **mark,SV **sp)
{
- dTHR;
int rc;
char **a,*tmps,**argv;
STRLEN n_a;
len = tend-type;
}
if (*name == '\0') { /* command is missing 19990114 */
- dTHR;
if (ckWARN(WARN_PIPE))
Perl_warner(aTHX_ WARN_PIPE, "Missing command in piped open");
errno = EPIPE;
TAINT_ENV();
TAINT_PROPER("piped open");
if (!num_svs && name[len-1] == '|') {
- dTHR;
name[--len] = '\0' ;
if (ckWARN(WARN_PIPE))
Perl_warner(aTHX_ WARN_PIPE, "Can't open bidirectional pipe");
len = tend-type;
}
if (*name == '\0') { /* command is missing 19990114 */
- dTHR;
if (ckWARN(WARN_PIPE))
Perl_warner(aTHX_ WARN_PIPE, "Missing command in piped open");
errno = EPIPE;
}
}
if (!fp) {
- dTHR;
if (ckWARN(WARN_NEWLINE) && IoTYPE(io) == IoTYPE_RDONLY && strchr(name, '\n'))
Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "open");
goto say_false;
}
if (IoTYPE(io) && IoTYPE(io) != IoTYPE_PIPE && IoTYPE(io) != IoTYPE_STD) {
- dTHR;
if (PerlLIO_fstat(PerlIO_fileno(fp),&PL_statbuf) < 0) {
(void)PerlIO_close(fp);
goto say_false;
IoFLAGS(io) &= ~IOf_NOLINE;
if (writing) {
- dTHR;
if (IoTYPE(io) == IoTYPE_SOCKET
|| (IoTYPE(io) == IoTYPE_WRONLY && S_ISCHR(PL_statbuf.st_mode)) )
{
}
PL_filemode = 0;
while (av_len(GvAV(gv)) >= 0) {
- dTHR;
STRLEN oldlen;
sv = av_shift(GvAV(gv));
SAVEFREESV(sv);
return IoIFP(GvIOp(gv));
}
else {
- dTHR;
if (ckWARN_d(WARN_INPLACE)) {
int eno = errno;
if (PerlLIO_stat(PL_oldname, &PL_statbuf) >= 0
io = GvIO(gv);
if (!io) { /* never opened */
if (not_implicit) {
- dTHR;
if (ckWARN(WARN_UNOPENED)) /* no check for closed here */
report_evil_fh(gv, io, PL_op->op_type);
SETERRNO(EBADF,SS$_IVCHAN);
bool
Perl_do_eof(pTHX_ GV *gv)
{
- dTHR;
register IO *io;
int ch;
#endif
return PerlIO_tell(fp);
}
- {
- dTHR;
- if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
- report_evil_fh(gv, io, PL_op->op_type);
- }
+ if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
+ report_evil_fh(gv, io, PL_op->op_type);
SETERRNO(EBADF,RMS$_IFI);
return (Off_t)-1;
}
#endif
return PerlIO_seek(fp, pos, whence) >= 0;
}
- {
- dTHR;
- if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
- report_evil_fh(gv, io, PL_op->op_type);
- }
+ if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
+ report_evil_fh(gv, io, PL_op->op_type);
SETERRNO(EBADF,RMS$_IFI);
return FALSE;
}
if (gv && (io = GvIO(gv)) && (fp = IoIFP(io)))
return PerlLIO_lseek(PerlIO_fileno(fp), pos, whence);
- {
- dTHR;
- if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
- report_evil_fh(gv, io, PL_op->op_type);
- }
+ if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
+ report_evil_fh(gv, io, PL_op->op_type);
SETERRNO(EBADF,RMS$_IFI);
return (Off_t)-1;
}
}
switch (SvTYPE(sv)) {
case SVt_NULL:
- {
- dTHR;
- if (ckWARN(WARN_UNINITIALIZED))
- report_uninit();
- }
+ if (ckWARN(WARN_UNINITIALIZED))
+ report_uninit();
return TRUE;
case SVt_IV:
if (SvIOK(sv)) {
STRLEN n_a;
if (sp > mark) {
- dTHR;
New(401,PL_Argv, sp - mark + 1, char*);
a = PL_Argv;
while (++mark <= sp) {
goto doshell;
}
{
- dTHR;
int e = errno;
if (ckWARN(WARN_EXEC))
I32
Perl_apply(pTHX_ I32 type, register SV **mark, register SV **sp)
{
- dTHR;
register I32 val;
register I32 val2;
register I32 tot = 0;
I32
Perl_do_ipcget(pTHX_ I32 optype, SV **mark, SV **sp)
{
- dTHR;
key_t key;
I32 n, flags;
I32
Perl_do_ipcctl(pTHX_ I32 optype, SV **mark, SV **sp)
{
- dTHR;
SV *astr;
char *a;
I32 id, n, cmd, infosize, getinfo;
Perl_do_msgsnd(pTHX_ SV **mark, SV **sp)
{
#ifdef HAS_MSG
- dTHR;
SV *mstr;
char *mbuf;
I32 id, msize, flags;
Perl_do_msgrcv(pTHX_ SV **mark, SV **sp)
{
#ifdef HAS_MSG
- dTHR;
SV *mstr;
char *mbuf;
long mtype;
Perl_do_semop(pTHX_ SV **mark, SV **sp)
{
#ifdef HAS_SEM
- dTHR;
SV *opstr;
char *opbuf;
I32 id;
Perl_do_shmio(pTHX_ I32 optype, SV **mark, SV **sp)
{
#ifdef HAS_SHM
- dTHR;
SV *mstr;
char *mbuf, *shm;
I32 id, mpos, msize;
STATIC I32
S_do_trans_simple(pTHX_ SV *sv)
{
- dTHR;
U8 *s;
U8 *d;
U8 *send;
STATIC I32
S_do_trans_count(pTHX_ SV *sv)/* SPC - OK */
{
- dTHR;
U8 *s;
U8 *send;
I32 matches = 0;
STATIC I32
S_do_trans_complex(pTHX_ SV *sv)/* SPC - NOT OK */
{
- dTHR;
U8 *s;
U8 *send;
U8 *d;
STATIC I32
S_do_trans_simple_utf8(pTHX_ SV *sv)/* SPC - OK */
{
- dTHR;
U8 *s;
U8 *send;
U8 *d;
STATIC I32
S_do_trans_count_utf8(pTHX_ SV *sv)/* SPC - OK */
{
- dTHR;
U8 *s;
U8 *send;
I32 matches = 0;
STATIC I32
S_do_trans_complex_utf8(pTHX_ SV *sv) /* SPC - NOT OK */
{
- dTHR;
U8 *s;
U8 *send;
U8 *d;
I32
Perl_do_trans(pTHX_ SV *sv)
{
- dTHR;
STRLEN len;
I32 hasutf = (PL_op->op_private &
(OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF));
}
#ifdef UV_IS_QUAD
else if (size == 64) {
- dTHR;
if (ckWARN(WARN_PORTABLE))
Perl_warner(aTHX_ WARN_PORTABLE,
"Bit vector size > 32 non-portable");
s[offset + 3];
#ifdef UV_IS_QUAD
else if (size == 64) {
- dTHR;
if (ckWARN(WARN_PORTABLE))
Perl_warner(aTHX_ WARN_PORTABLE,
"Bit vector size > 32 non-portable");
}
#ifdef UV_IS_QUAD
else if (size == 64) {
- dTHR;
if (ckWARN(WARN_PORTABLE))
Perl_warner(aTHX_ WARN_PORTABLE,
"Bit vector size > 32 non-portable");
{
STRLEN len;
char *s;
- dTHR;
if (SvTYPE(sv) == SVt_PVAV) {
register I32 i;
I32
Perl_do_chomp(pTHX_ register SV *sv)
{
- dTHR;
register I32 count;
STRLEN len;
char *s;
void
Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right)
{
- dTHR; /* just for taint */
#ifdef LIBERAL
register long *dl;
register long *ll;
void
Perl_dump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
{
- dTHR;
PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
PerlIO_vprintf(file, pat, *args);
}
void
Perl_dump_all(pTHX)
{
- dTHR;
PerlIO_setlinebuf(Perl_debug_log);
if (PL_main_root)
op_dump(PL_main_root);
void
Perl_dump_packsubs(pTHX_ HV *stash)
{
- dTHR;
I32 i;
HE *entry;
void
Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, OP *o)
{
- dTHR;
Perl_dump_indent(aTHX_ level, file, "{\n");
level++;
if (o->op_seq)
void
Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
{
- dTHR;
SV *d;
char *s;
U32 flags;
int
do_spawn (pTHX_ SV *really,SV **mark,SV **sp)
{
- dTHR;
int rc;
char **a,*cmd,**ptr, *cmdline, **argv, *p2;
STRLEN n_a;
static I32
byteloader_filter(pTHXo_ int idx, SV *buf_sv, int maxlen)
{
- dTHR;
OP *saveroot = PL_main_root;
OP *savestart = PL_main_start;
struct byteloader_state bstate;
void
byterun(pTHXo_ register struct byteloader_state *bstate)
{
- dTHR;
register int insn;
U32 ix;
SV *specialsv_list[6];
#include "perl.h"
#include "XSUB.h"
-/* For older Perls */
-#ifndef dTHR
-# define dTHR int dummy_thr
-#endif /* dTHR */
-
/*#define DBG_SUB 1 */
/*#define DBG_TIMER 1 */
static void
test_time(pTHX_ clock_t *r, clock_t *u, clock_t *s)
{
- dTHR;
CV *cv = perl_get_cv("Devel::DProf::NONESUCH_noxs", FALSE);
int i, j, k = 0;
HV *oldstash = PL_curstash;
DEBUG_S(PerlIO_printf(Perl_debug_log, "new thread %p waiting to start\n",
thr));
- /* Don't call *anything* requiring dTHR until after PERL_SET_THX() */
/*
* Wait until our creator releases us. If we didn't do this, then
* it would be potentially possible for out thread to carry on and
*/
PERL_SET_THX(thr);
- /* Only now can we use SvPEEK (which calls sv_newmortal which does dTHR) */
DEBUG_S(PerlIO_printf(Perl_debug_log, "new thread %p starting at %s\n",
thr, SvPEEK(TOPs)));
static void
deinstall(pTHX)
{
- dTHR;
PL_regexecp = Perl_regexec_flags;
PL_regcompp = Perl_pregcomp;
PL_regint_start = Perl_re_intuit_start;
static void
install(pTHX)
{
- dTHR;
PL_colorset = 0; /* Allow reinspection of ENV. */
PL_regexecp = &my_regexec;
PL_regcompp = &my_regcomp;
GV *
Perl_gv_fetchfile(pTHX_ const char *name)
{
- dTHR;
char smallbuf[256];
char *tmpbuf;
STRLEN tmplen;
void
Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi)
{
- dTHR;
register GP *gp;
bool doproto = SvTYPE(gv) > SVt_NULL;
char *proto = (doproto && SvPOK(gv)) ? SvPVX(gv) : NULL;
basestash = gv_stashpvn(packname, packlen, TRUE);
gvp = (GV**)hv_fetch(basestash, "ISA", 3, FALSE);
if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) {
- dTHR; /* just for SvREFCNT_dec */
gvp = (GV**)hv_fetch(stash, "ISA", 3, TRUE);
if (!gvp || !(gv = *gvp))
Perl_croak(aTHX_ "Cannot create %s::ISA", HvNAME(stash));
SV* sv = *svp++;
HV* basestash = gv_stashsv(sv, FALSE);
if (!basestash) {
- dTHR; /* just for ckWARN */
if (ckWARN(WARN_MISC))
Perl_warner(aTHX_ WARN_MISC, "Can't locate package %s for @%s::ISA",
SvPVX(sv), HvNAME(stash));
GV *
Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
{
- dTHR;
register const char *nend;
const char *nsplit = 0;
GV* gv;
GV*
Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
{
- dTHR;
static char autoload[] = "AUTOLOAD";
static STRLEN autolen = 8;
GV* gv;
GV *
Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type)
{
- dTHR;
register const char *name = nambeg;
register GV *gv = 0;
GV**gvp;
IO *
Perl_newIO(pTHX)
{
- dTHR;
IO *io;
GV *iogv;
void
Perl_gv_check(pTHX_ HV *stash)
{
- dTHR;
register HE *entry;
register I32 i;
register GV *gv;
void
Perl_gp_free(pTHX_ GV *gv)
{
- dTHR;
GP* gp;
if (!gv || !(gp = GvGP(gv)))
bool
Perl_Gv_AMupdate(pTHX_ HV *stash)
{
- dTHR;
GV* gv;
CV* cv;
MAGIC* mg=mg_find((SV*)stash,'c');
SV*
Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
{
- dTHR;
MAGIC *mg;
CV *cv;
CV **cvp=NULL, **ocvp=NULL;
if (SvRMAGICAL(hv)) {
if (mg_find((SV*)hv,'P')) {
- dTHR;
sv = sv_newmortal();
mg_copy((SV*)hv, sv, key, klen);
PL_hv_fetch_sv = sv;
if (SvRMAGICAL(hv)) {
if (mg_find((SV*)hv,'P')) {
- dTHR;
sv = sv_newmortal();
keysv = sv_2mortal(newSVsv(keysv));
mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY);
xhv = (XPVHV*)SvANY(hv);
if (SvMAGICAL(hv)) {
- dTHR;
bool needs_copy;
bool needs_store;
hv_magic_check (hv, &needs_copy, &needs_store);
if (SvRMAGICAL(hv)) {
if (mg_find((SV*)hv,'P')) {
- dTHR;
sv = sv_newmortal();
mg_copy((SV*)hv, sv, key, klen);
magic_existspack(sv, mg_find(sv, 'p'));
if (SvRMAGICAL(hv)) {
if (mg_find((SV*)hv,'P')) {
- dTHR; /* just for SvTRUE */
sv = sv_newmortal();
keysv = sv_2mortal(newSVsv(keysv));
mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY);
}
UNLOCK_STRTAB_MUTEX;
- {
- dTHR;
- if (!found && ckWARN_d(WARN_INTERNAL))
- Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free non-existent shared string '%s'",str);
- }
+ if (!found && ckWARN_d(WARN_INTERNAL))
+ Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free non-existent shared string '%s'",str);
}
/* get a (constant) string ptr from the global string table
STATIC void
S_save_magic(pTHX_ I32 mgs_ix, SV *sv)
{
- dTHR;
MGS* mgs;
assert(SvMAGICAL(sv));
int
Perl_mg_get(pTHX_ SV *sv)
{
- dTHR;
I32 mgs_ix;
MAGIC* mg;
MAGIC** mgp;
int
Perl_mg_set(pTHX_ SV *sv)
{
- dTHR;
I32 mgs_ix;
MAGIC* mg;
MAGIC* nextmg;
U32
Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
{
- dTHR;
register REGEXP *rx;
if (PL_curpm && (rx = PL_curpm->op_pmregexp)) {
int
Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
{
- dTHR;
register I32 paren;
register I32 s;
register I32 i;
int
Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
{
- dTHR;
Perl_croak(aTHX_ PL_no_modify);
/* NOT REACHED */
return 0;
U32
Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
{
- dTHR;
register I32 paren;
register I32 i;
register REGEXP *rx;
int
Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
{
- dTHR;
register I32 paren;
register char *s;
register I32 i;
break;
case '\023': /* ^S */
{
- dTHR;
if (PL_lex_state != LEX_NOTPARSING)
(void)SvOK_off(sv);
else if (PL_in_eval)
#if defined(VMS)
Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
#else
- dTHR;
if (PL_localizing) {
HE* entry;
STRLEN n_a;
int
Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
{
- dTHR;
register char *s;
I32 i;
SV** svp;
int
Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
{
- dTHR;
OP *o;
I32 i;
GV* gv;
int
Perl_magic_getarylen(pTHX_ SV *sv, MAGIC *mg)
{
- dTHR;
sv_setiv(sv, AvFILL((AV*)mg->mg_obj) + PL_curcop->cop_arybase);
return 0;
}
int
Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
{
- dTHR;
av_fill((AV*)mg->mg_obj, SvIV(sv) - PL_curcop->cop_arybase);
return 0;
}
if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
mg = mg_find(lsv, 'g');
if (mg && mg->mg_len >= 0) {
- dTHR;
I32 i = mg->mg_len;
if (DO_UTF8(lsv))
sv_pos_b2u(lsv, &i);
SSize_t pos;
STRLEN len;
STRLEN ulen = 0;
- dTHR;
mg = 0;
int
Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
{
- dTHR;
TAINT_IF((mg->mg_len & 1) ||
((mg->mg_len & 2) && mg->mg_obj == sv)); /* kludge */
return 0;
int
Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
{
- dTHR;
if (PL_localizing) {
if (PL_localizing == 1)
mg->mg_len <<= 1;
targ = AvARRAY(av)[LvTARGOFF(sv)];
}
if (targ && targ != &PL_sv_undef) {
- dTHR; /* just for SvREFCNT_dec */
/* somebody else defined it for us */
SvREFCNT_dec(LvTARG(sv));
LvTARG(sv) = SvREFCNT_inc(targ);
void
Perl_vivify_defelem(pTHX_ SV *sv)
{
- dTHR; /* just for SvREFCNT_inc and SvREFCNT_dec*/
MAGIC *mg;
SV *value = Nullsv;
int
Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
{
- dTHR;
register char *s;
I32 i;
STRLEN len;
int
Perl_magic_mutexfree(pTHX_ SV *sv, MAGIC *mg)
{
- dTHR;
DEBUG_S(PerlIO_printf(Perl_debug_log,
"0x%"UVxf": magic_mutexfree 0x%"UVxf"\n",
PTR2UV(thr), PTR2UV(sv));)
static void
restore_magic(pTHXo_ void *p)
{
- dTHR;
MGS* mgs = SSPTR(PTR2IV(p), MGS*);
SV* sv = mgs->mgs_sv;
static void
unwind_handler_stack(pTHXo_ void *p)
{
- dTHR;
U32 flags = *(U32*)p;
if (flags & 1)
PADOFFSET
Perl_pad_allocmy(pTHX_ char *name)
{
- dTHR;
PADOFFSET off;
SV *sv;
S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv,
I32 cx_ix, I32 saweval, U32 flags)
{
- dTHR;
CV *cv;
I32 off;
SV *sv;
PADOFFSET
Perl_pad_findmy(pTHX_ char *name)
{
- dTHR;
I32 off;
I32 pendoff = 0;
SV *sv;
void
Perl_pad_leavemy(pTHX_ I32 fill)
{
- dTHR;
I32 off;
SV **svp = AvARRAY(PL_comppad_name);
SV *sv;
PADOFFSET
Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
{
- dTHR;
SV *sv;
I32 retval;
SV *
Perl_pad_sv(pTHX_ PADOFFSET po)
{
- dTHR;
#ifdef USE_THREADS
DEBUG_X(PerlIO_printf(Perl_debug_log,
"0x%"UVxf" Pad 0x%"UVxf" sv %"IVdf"\n",
void
Perl_pad_free(pTHX_ PADOFFSET po)
{
- dTHR;
if (!PL_curpad)
return;
if (AvARRAY(PL_comppad) != PL_curpad)
void
Perl_pad_swipe(pTHX_ PADOFFSET po)
{
- dTHR;
if (AvARRAY(PL_comppad) != PL_curpad)
Perl_croak(aTHX_ "panic: pad_swipe curpad");
if (!po)
Perl_pad_reset(pTHX)
{
#ifdef USE_BROKEN_PAD_RESET
- dTHR;
register I32 po;
if (AvARRAY(PL_comppad) != PL_curpad)
PADOFFSET
Perl_find_threadsv(pTHX_ const char *name)
{
- dTHR;
char *p;
PADOFFSET key;
SV **svp;
S_scalarboolean(pTHX_ OP *o)
{
if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
- dTHR;
if (ckWARN(WARN_SYNTAX)) {
line_t oldline = CopLINE(PL_curcop);
|| (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
|| o->op_targ == OP_SETSTATE
|| o->op_targ == OP_DBSTATE)))
- {
- dTHR;
PL_curcop = (COP*)o; /* for warning below */
- }
/* assumes no premature commitment */
want = o->op_flags & OPf_WANT;
if (cSVOPo->op_private & OPpCONST_STRICT)
no_bareword_allowed(o);
else {
- dTHR;
if (ckWARN(WARN_VOID)) {
useless = "a constant";
if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
}
break;
}
- if (useless) {
- dTHR;
- if (ckWARN(WARN_VOID))
- Perl_warner(aTHX_ WARN_VOID, "Useless use of %s in void context", useless);
- }
+ if (useless && ckWARN(WARN_VOID))
+ Perl_warner(aTHX_ WARN_VOID, "Useless use of %s in void context", useless);
return o;
}
o->op_type == OP_LEAVE ||
o->op_type == OP_LEAVETRY)
{
- dTHR;
for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
if (kid->op_sibling) {
scalarvoid(kid);
OP *
Perl_mod(pTHX_ OP *o, I32 type)
{
- dTHR;
OP *kid;
STRLEN n_a;
OP *
Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
{
- dTHR;
OP *o;
if (ckWARN(WARN_MISC) &&
int
Perl_block_start(pTHX_ int full)
{
- dTHR;
int retval = PL_savestack_ix;
SAVEI32(PL_comppad_name_floor);
OP*
Perl_block_end(pTHX_ I32 floor, OP *seq)
{
- dTHR;
int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
OP* retval = scalarseq(seq);
LEAVE_SCOPE(floor);
void
Perl_newPROG(pTHX_ OP *o)
{
- dTHR;
if (PL_in_eval) {
if (PL_eval_root)
return;
if (o->op_flags & OPf_PARENS)
list(o);
else {
- dTHR;
if (ckWARN(WARN_PARENTHESIS) && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',') {
char *s;
for (s = PL_bufptr; *s && (isALNUM(*s) || (*s & 0x80) || strchr("@$%, ",*s)); s++) ;
OP *
Perl_fold_constants(pTHX_ register OP *o)
{
- dTHR;
register OP *curop;
I32 type = o->op_type;
SV *sv;
OP *
Perl_gen_constant_list(pTHX_ register OP *o)
{
- dTHR;
register OP *curop;
I32 oldtmps_floor = PL_tmps_floor;
OP *
Perl_newPMOP(pTHX_ I32 type, I32 flags)
{
- dTHR;
PMOP *pmop;
NewOp(1101, pmop, 1, PMOP);
OP *
Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
{
- dTHR;
PMOP *pm;
LOGOP *rcop;
I32 repl_has_vars = 0;
OP *
Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
{
- dTHR;
#ifdef USE_ITHREADS
GvIN_PAD_on(gv);
return newPADOP(type, flags, SvREFCNT_inc(gv));
void
Perl_package(pTHX_ OP *o)
{
- dTHR;
SV *sv;
save_hptr(&PL_curstash);
}
if (list_assignment(left)) {
- dTHR;
OP *curop;
PL_modcount = 0;
OP *
Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
{
- dTHR;
U32 seq = intro_my();
register COP *cop;
STATIC OP *
S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
{
- dTHR;
LOGOP *logop;
OP *o;
OP *first = *firstp;
OP *
Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
{
- dTHR;
LOGOP *logop;
OP *start;
OP *o;
OP *
Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
{
- dTHR;
LOGOP *range;
OP *flip;
OP *flop;
OP *
Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
{
- dTHR;
OP* listop;
OP* o;
int once = block && block->op_flags & OPf_SPECIAL &&
OP *
Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
{
- dTHR;
OP *redo;
OP *next = 0;
OP *listop;
OP*
Perl_newLOOPEX(pTHX_ I32 type, OP *label)
{
- dTHR;
OP *o;
STRLEN n_a;
void
Perl_cv_undef(pTHX_ CV *cv)
{
- dTHR;
#ifdef USE_THREADS
if (CvMUTEXP(cv)) {
MUTEX_DESTROY(CvMUTEXP(cv));
STATIC CV *
S_cv_clone2(pTHX_ CV *proto, CV *outside)
{
- dTHR;
AV* av;
I32 ix;
AV* protopadlist = CvPADLIST(proto);
void
Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
{
- dTHR;
-
if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
SV* msg = sv_newmortal();
SV* name = Nullsv;
CV *
Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
{
- dTHR;
STRLEN n_a;
char *name;
char *aname;
CV *
Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
{
- dTHR;
CV* cv;
ENTER;
CV *
Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
{
- dTHR;
GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
register CV *cv;
void
Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
{
- dTHR;
register CV *cv;
char *name;
GV *gv;
OP *
Perl_oopsHV(pTHX_ OP *o)
{
- dTHR;
-
switch (o->op_type) {
case OP_PADSV:
case OP_PADAV:
OP *
Perl_ck_rvconst(pTHX_ register OP *o)
{
- dTHR;
SVOP *kid = (SVOP*)cUNOPo->op_first;
o->op_private |= (PL_hints & HINT_STRICT_REFS);
OP *
Perl_ck_ftst(pTHX_ OP *o)
{
- dTHR;
I32 type = o->op_type;
if (o->op_flags & OPf_REF) {
OP *
Perl_ck_fun(pTHX_ OP *o)
{
- dTHR;
register OP *kid;
OP **tokid;
OP *sibl;
OP *
Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
{
- dTHR;
if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
switch (cUNOPo->op_first->op_type) {
case OP_RV2AV:
STATIC void
S_simplify_sort(pTHX_ OP *o)
{
- dTHR;
register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
OP *k;
int reversed;
OP *
Perl_ck_subr(pTHX_ OP *o)
{
- dTHR;
OP *prev = ((cUNOPo->op_first->op_sibling)
? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
OP *o2 = prev->op_sibling;
void
Perl_peep(pTHX_ register OP *o)
{
- dTHR;
register OP* oldop = 0;
STRLEN n_a;
OP *last_composite = Nullop;
static SV*
exec_in_REXX(pTHX_ char *cmd, char * handlerName, RexxFunctionHandler *handler)
{
- dTHR;
HMODULE hRexx, hRexxAPI;
BYTE buf[200];
LONG APIENTRY (*pRexxStart) (LONG, PRXSTRING, PSZ, PRXSTRING,
static int
result(pTHX_ int flag, int pid)
{
- dTHR;
int r, status;
Signal_t (*ihand)(); /* place to save signal during system() */
Signal_t (*qhand)(); /* place to save signal during system() */
int
do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag)
{
- dTHR;
int trueflag = flag;
int rc, pass = 1;
char *tmps;
int
do_spawn3(pTHX_ char *cmd, int execf, int flag)
{
- dTHR;
register char **a;
register char *s;
char flags[10];
int
os2_do_aspawn(pTHX_ SV *really, register SV **mark, register SV **sp)
{
- dTHR;
register char **a;
int rc;
int flag = P_WAIT, flag_set = 0;
int
os2_do_spawn(pTHX_ char *cmd)
{
- dTHR;
return do_spawn3(aTHX_ cmd, EXECF_SPAWN, 0);
}
int
do_spawn_nowait(pTHX_ char *cmd)
{
- dTHR;
return do_spawn3(aTHX_ cmd, EXECF_SPAWN_NOWAIT,0);
}
bool
Perl_do_exec(pTHX_ char *cmd)
{
- dTHR;
do_spawn3(aTHX_ cmd, EXECF_EXEC, 0);
return FALSE;
}
bool
os2exec(pTHX_ char *cmd)
{
- dTHR;
return do_spawn3(aTHX_ cmd, EXECF_TRUEEXEC, 0);
}
char *
os2_execname(pTHX)
{
- dTHR;
char buf[300], *p;
if (_execname(buf, sizeof buf) != 0)
Perl_croak_nocontext("panic: COND_DESTROY, rc=%i", rc); \
} STMT_END
/*#define THR ((struct thread *) TlsGetValue(PL_thr_key))
-#define dTHR struct thread *thr = THR
*/
#ifdef USE_SLOW_THREAD_SPECIFIC
void
perl_destruct(pTHXx)
{
- dTHR;
int destruct_level; /* 0=none, 1=full, 2=full with checks */
I32 last_sv_count;
HV *hv;
int
perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
{
- dTHR;
I32 oldscope;
int ret;
dJMPENV;
STATIC void *
S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
{
- dTHR;
int argc = PL_origargc;
char **argv = PL_origargv;
char *scriptname = NULL;
int
perl_run(pTHXx)
{
- dTHR;
I32 oldscope;
int ret = 0;
dJMPENV;
STATIC void *
S_run_body(pTHX_ I32 oldscope)
{
- dTHR;
-
DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
PL_sawampersand ? "Enabling" : "Omitting"));
#ifdef USE_THREADS
if (name[1] == '\0' && !isALPHA(name[0])) {
PADOFFSET tmp = find_threadsv(name);
- if (tmp != NOT_IN_PAD) {
- dTHR;
+ if (tmp != NOT_IN_PAD)
return THREADSV(tmp);
- }
}
#endif /* USE_THREADS */
gv = gv_fetchpv(name, create, SVt_PV);
STATIC void
S_call_body(pTHX_ OP *myop, int is_eval)
{
- dTHR;
-
if (PL_op == myop) {
if (is_eval)
PL_op = Perl_pp_entereval(aTHX); /* this doesn't do a POPMARK */
switch (*s) {
case '0':
{
- dTHR;
numlen = 0; /* disallow underscores */
rschar = (U32)scan_oct(s, 4, &numlen);
SvREFCNT_dec(PL_nrs);
}
PL_debug |= 0x80000000;
#else
- dTHR;
if (ckWARN_d(WARN_DEBUGGING))
Perl_warner(aTHX_ WARN_DEBUGGING,
"Recompile perl with -DDEBUGGING to use -D switch\n");
s += numlen;
}
else {
- dTHR;
if (RsPARA(PL_nrs)) {
PL_ors = "\n\n";
PL_orslen = 2;
STATIC void
S_init_main_stash(pTHX)
{
- dTHR;
GV *gv;
/* Note that strtab is a rather special HV. Assumptions are made
STATIC void
S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
{
- dTHR;
-
*fdscript = -1;
if (PL_e_script) {
*/
#ifdef DOSUID
- dTHR;
char *s, *s2;
if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
#else /* !DOSUID */
if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
#ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
- dTHR;
PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
||
void
Perl_init_debugger(pTHX)
{
- dTHR;
HV *ostash = PL_curstash;
PL_curstash = PL_debstash;
STATIC void
S_nuke_stacks(pTHX)
{
- dTHR;
while (PL_curstackinfo->si_next)
PL_curstackinfo = PL_curstackinfo->si_next;
while (PL_curstackinfo) {
STATIC void
S_init_predump_symbols(pTHX)
{
- dTHR;
GV *tmpgv;
IO *io;
STATIC void
S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
{
- dTHR;
char *s;
SV *sv;
GV* tmpgv;
PERL_SET_THX(thr);
/*
- * These must come after the SET_THR because sv_setpvn does
- * SvTAINT and the taint fields require dTHR.
+ * These must come after the thread self setting
+ * because sv_setpvn does SvTAINT and the taint
+ * fields thread selfness being set.
*/
PL_toptarget = NEWSV(0,0);
sv_upgrade(PL_toptarget, SVt_PVFM);
void
Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
{
- dTHR;
SV *atsv;
line_t oldline = CopLINE(PL_curcop);
CV *cv;
void
Perl_my_exit(pTHX_ U32 status)
{
- dTHR;
-
DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
thr, (unsigned long) status));
switch (status) {
STATIC void
S_my_exit_jump(pTHX)
{
- dTHR;
register PERL_CONTEXT *cx;
I32 gimme;
SV **newsp;
struct perl_thread;
# define pTHX register struct perl_thread *thr
# define aTHX thr
-# define dTHR dNOOP
+# define dTHR dNOOP /* only backward compatibility */
# define dTHXa(a) pTHX = (struct perl_thread*)a
# else
# ifndef MULTIPLICITY
#endif
#define WITH_THX(s) STMT_START { dTHX; s; } STMT_END
-#define WITH_THR(s) STMT_START { dTHR; s; } STMT_END
+#define WITH_THR(s) WITH_THX(s)
/*
* SOFT_CAST can be used for args to prototyped functions to retain some
#undef Perl_hv_delete
SV*
-Perl_hv_delete(pTHXo_ HV* tb, const char* key, U32 klen, I32 flags)
+Perl_hv_delete(pTHXo_ HV* tb, const char* key, I32 klen, I32 flags)
{
return ((CPerlObj*)pPerl)->Perl_hv_delete(tb, key, klen, flags);
}
#undef Perl_hv_exists
bool
-Perl_hv_exists(pTHXo_ HV* tb, const char* key, U32 klen)
+Perl_hv_exists(pTHXo_ HV* tb, const char* key, I32 klen)
{
return ((CPerlObj*)pPerl)->Perl_hv_exists(tb, key, klen);
}
#undef Perl_hv_fetch
SV**
-Perl_hv_fetch(pTHXo_ HV* tb, const char* key, U32 klen, I32 lval)
+Perl_hv_fetch(pTHXo_ HV* tb, const char* key, I32 klen, I32 lval)
{
return ((CPerlObj*)pPerl)->Perl_hv_fetch(tb, key, klen, lval);
}
#undef Perl_hv_store
SV**
-Perl_hv_store(pTHXo_ HV* tb, const char* key, U32 klen, SV* val, U32 hash)
+Perl_hv_store(pTHXo_ HV* tb, const char* key, I32 klen, SV* val, U32 hash)
{
return ((CPerlObj*)pPerl)->Perl_hv_store(tb, key, klen, val, hash);
}
}
#undef Perl_utf8_distance
-I32
+IV
Perl_utf8_distance(pTHXo_ U8 *a, U8 *b)
{
return ((CPerlObj*)pPerl)->Perl_utf8_distance(a, b);
#define SEED_C3 269
#define SEED_C5 26107
- dTHR;
#ifndef PERL_NO_DEV_RANDOM
int fd;
#endif
void
Perl_unlock_condpair(pTHX_ void *svv)
{
- dTHR;
MAGIC *mg = mg_find((SV*)svv, 'm');
if (!mg)
#define POPMARK (*PL_markstack_ptr--)
#define djSP register SV **sp = PL_stack_sp
-#define dSP dTHR; djSP
+#define dSP djSP
#define dMARK register SV **mark = PL_stack_base + POPMARK
#define dORIGMARK I32 origmark = mark - PL_stack_base
#define SETORIGMARK origmark = mark - PL_stack_base
STATIC I32
S_dopoptolabel(pTHX_ char *label)
{
- dTHR;
register I32 i;
register PERL_CONTEXT *cx;
I32
Perl_block_gimme(pTHX)
{
- dTHR;
I32 cxix;
cxix = dopoptosub(cxstack_ix);
STATIC I32
S_dopoptosub(pTHX_ I32 startingblock)
{
- dTHR;
return dopoptosub_at(cxstack, startingblock);
}
STATIC I32
S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
{
- dTHR;
I32 i;
register PERL_CONTEXT *cx;
for (i = startingblock; i >= 0; i--) {
STATIC I32
S_dopoptoeval(pTHX_ I32 startingblock)
{
- dTHR;
I32 i;
register PERL_CONTEXT *cx;
for (i = startingblock; i >= 0; i--) {
STATIC I32
S_dopoptoloop(pTHX_ I32 startingblock)
{
- dTHR;
I32 i;
register PERL_CONTEXT *cx;
for (i = startingblock; i >= 0; i--) {
void
Perl_dounwind(pTHX_ I32 cxix)
{
- dTHR;
register PERL_CONTEXT *cx;
I32 optype;
STATIC void
S_free_closures(pTHX)
{
- dTHR;
SV **svp = AvARRAY(PL_comppad_name);
I32 ix;
for (ix = AvFILLp(PL_comppad_name); ix >= 0; ix--) {
#ifdef USE_THREADS
if (PL_op->op_flags & OPf_SPECIAL) {
- dTHR;
svp = &THREADSV(PL_op->op_targ); /* per-thread variable */
SAVEGENERICSV(*svp);
*svp = NEWSV(0,0);
}
*ops = 0;
if (o->op_flags & OPf_KIDS) {
- dTHR;
/* First try all the kids at this level, since that's likeliest. */
for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
STATIC OP *
S_docatch(pTHX_ OP *o)
{
- dTHR;
int ret;
OP *oldop = PL_op;
volatile PERL_SI *cursi = PL_curstackinfo;
static I32
sortcv(pTHXo_ SV *a, SV *b)
{
- dTHR;
I32 oldsaveix = PL_savestack_ix;
I32 oldscopeix = PL_scopestack_ix;
I32 result;
static I32
sortcv_stacked(pTHXo_ SV *a, SV *b)
{
- dTHR;
I32 oldsaveix = PL_savestack_ix;
I32 oldscopeix = PL_scopestack_ix;
I32 result;
RETURN;
}
if (!(io = GvIO(gv))) {
- dTHR;
if ((GvEGV(gv)) && (mg = SvTIED_mg((SV*)GvEGV(gv),'q')))
goto had_magic;
if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
STATIC CV *
S_get_db_sub(pTHX_ SV **svp, CV *cv)
{
- dTHR;
SV *dbsv = GvSV(PL_DBsub);
if (!PERLDB_SUB_NN) {
unset_cvowner(pTHXo_ void *cvarg)
{
register CV* cv = (CV *) cvarg;
-#ifdef DEBUGGING
- dTHR;
-#endif /* DEBUGGING */
DEBUG_S((PerlIO_printf(Perl_debug_log, "%p unsetting CvOWNER of %p:%s\n",
thr, cv, SvPEEK((SV*)cv))));
void
Perl_setdefout(pTHX_ GV *gv)
{
- dTHR;
if (gv)
(void)SvREFCNT_inc(gv);
if (PL_defoutgv)
STATIC OP *
S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
{
- dTHR;
register PERL_CONTEXT *cx;
I32 gimme = GIMME_V;
AV* padlist = CvPADLIST(cv);
sv = NEWSV(0,0);
if (!(io = GvIO(gv))) {
- dTHR;
if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
report_evil_fh(gv, io, PL_op->op_type);
SETERRNO(EBADF,RMS$_IFI);
? PerlLIO_fstat(PerlIO_fileno(IoIFP(GvIOn(gv))), &PL_statcache) : -1);
}
if (PL_laststatval < 0) {
- dTHR;
if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
report_evil_fh(gv, GvIO(gv), PL_op->op_type);
max = 0;
len = 512;
}
else {
- dTHR;
if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
gv = cGVOP_gv;
report_evil_fh(gv, GvIO(gv), PL_op->op_type);
STATIC void
S_scan_commit(pTHX_ RExC_state_t *pRExC_state, scan_data_t *data)
{
- dTHR;
STRLEN l = CHR_SVLEN(data->last_found);
STRLEN old_l = CHR_SVLEN(*data->longest);
/* deltap: Write maxlen-minlen here. */
/* last: Stop before this one. */
{
- dTHR;
I32 min = 0, pars = 0, code;
regnode *scan = *scanp, *next;
I32 delta = 0;
STATIC I32
S_add_data(pTHX_ RExC_state_t *pRExC_state, I32 n, char *s)
{
- dTHR;
if (RExC_rx->data) {
Renewc(RExC_rx->data,
sizeof(*RExC_rx->data) + sizeof(void*) * (RExC_rx->data->count + n - 1),
void
Perl_reginitcolors(pTHX)
{
- dTHR;
int i = 0;
char *s = PerlEnv_getenv("PERL_RE_COLORS");
regexp *
Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm)
{
- dTHR;
register regexp *r;
regnode *scan;
regnode *first;
S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp)
/* paren: Parenthesized? 0=top, 1=(, inside: changed to letter. */
{
- dTHR;
register regnode *ret; /* Will be the head of the group. */
register regnode *br;
register regnode *lastbr;
/* FALL THROUGH */
case '{':
{
- dTHR;
I32 count = 1, n = 0;
char c;
char *s = RExC_parse;
STATIC regnode *
S_regbranch(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, I32 first)
{
- dTHR;
register regnode *ret;
register regnode *chain = NULL;
register regnode *latest;
STATIC regnode *
S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp)
{
- dTHR;
register regnode *ret;
register char op;
register char *next;
STATIC regnode *
S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp)
{
- dTHR;
register regnode *ret = 0;
I32 flags;
STATIC I32
S_regpposixcc(pTHX_ RExC_state_t *pRExC_state, I32 value)
{
- dTHR;
char *posixcc = 0;
I32 namedclass = OOB_NAMEDCLASS;
STATIC regnode *
S_regclass(pTHX_ RExC_state_t *pRExC_state)
{
- dTHR;
register U32 value;
register I32 lastvalue = OOB_CHAR8;
register I32 range = 0;
STATIC regnode *
S_regclassutf8(pTHX_ RExC_state_t *pRExC_state)
{
- dTHR;
register char *e;
register U32 value;
register U32 lastvalue = OOB_UTF8;
STATIC char*
S_nextchar(pTHX_ RExC_state_t *pRExC_state)
{
- dTHR;
char* retval = RExC_parse++;
for (;;) {
STATIC regnode * /* Location. */
S_reg_node(pTHX_ RExC_state_t *pRExC_state, U8 op)
{
- dTHR;
register regnode *ret;
register regnode *ptr;
STATIC regnode * /* Location. */
S_reganode(pTHX_ RExC_state_t *pRExC_state, U8 op, U32 arg)
{
- dTHR;
register regnode *ret;
register regnode *ptr;
STATIC void
S_reguni(pTHX_ RExC_state_t *pRExC_state, UV uv, char* s, STRLEN* lenp)
{
- dTHR;
*lenp = SIZE_ONLY ? UNISKIP(uv) : (uv_to_utf8((U8*)s, uv) - (U8*)s);
}
STATIC void
S_reginsert(pTHX_ RExC_state_t *pRExC_state, U8 op, regnode *opnd)
{
- dTHR;
register regnode *src;
register regnode *dst;
register regnode *place;
STATIC void
S_regtail(pTHX_ RExC_state_t *pRExC_state, regnode *p, regnode *val)
{
- dTHR;
register regnode *scan;
register regnode *temp;
STATIC void
S_regoptail(pTHX_ RExC_state_t *pRExC_state, regnode *p, regnode *val)
{
- dTHR;
/* "Operandless" and "op != BRANCH" are synonymous in practice. */
if (p == NULL || SIZE_ONLY)
return;
Perl_regdump(pTHX_ regexp *r)
{
#ifdef DEBUGGING
- dTHR;
SV *sv = sv_newmortal();
(void)dumpuntil(r->program, r->program + 1, NULL, sv, 0);
Perl_regprop(pTHX_ SV *sv, regnode *o)
{
#ifdef DEBUGGING
- dTHR;
register int k;
sv_setpvn(sv, "", 0);
void
Perl_pregfree(pTHX_ struct regexp *r)
{
- dTHR;
DEBUG_r(if (!PL_colorset) reginitcolors());
if (!r || (--r->refcnt > 0))
regnode *
Perl_regnext(pTHX_ register regnode *p)
{
- dTHR;
register I32 offset;
if (p == &PL_regdummy)
void
Perl_save_re_context(pTHX)
{
- dTHR;
-
#if 0
SAVEPPTR(RExC_precomp); /* uncompiled string. */
SAVEI32(RExC_npar); /* () count. */
STATIC CHECKPOINT
S_regcppush(pTHX_ I32 parenfloor)
{
- dTHR;
int retval = PL_savestack_ix;
int i = (PL_regsize - parenfloor) * 4;
int p;
STATIC char *
S_regcppop(pTHX)
{
- dTHR;
I32 i = SSPOPINT;
U32 paren = 0;
char *input;
STATIC char *
S_regcp_set_to(pTHX_ I32 ss)
{
- dTHR;
I32 tmp = PL_savestack_ix;
PL_savestack_ix = ss;
STATIC void
S_cache_re(pTHX_ regexp *prog)
{
- dTHR;
PL_regprecomp = prog->precomp; /* Needed for FAIL. */
#ifdef DEBUGGING
PL_regprogram = prog->program;
/* data: May be used for some additional optimizations. */
/* nosave: For optimizations. */
{
- dTHR;
register char *s;
register regnode *c;
register char *startpos = stringarg;
STATIC I32 /* 0 failure, 1 success */
S_regtry(pTHX_ regexp *prog, char *startpos)
{
- dTHR;
register I32 i;
register I32 *sp;
register I32 *ep;
STATIC I32 /* 0 failure, 1 success */
S_regmatch(pTHX_ regnode *prog)
{
- dTHR;
register regnode *scan; /* Current node. */
regnode *next; /* Next node. */
regnode *inner; /* Next node in internal branch. */
STATIC I32
S_regrepeat(pTHX_ regnode *p, I32 max)
{
- dTHR;
register char *scan;
register I32 c;
register char *loceol = PL_regeol;
STATIC I32
S_regrepeat_hard(pTHX_ regnode *p, I32 max, I32 *lp)
{
- dTHR;
register char *scan;
register char *start;
register char *loceol = PL_regeol;
STATIC bool
S_reginclass(pTHX_ register regnode *p, register I32 c)
{
- dTHR;
char flags = ANYOF_FLAGS(p);
bool match = FALSE;
STATIC bool
S_reginclassutf8(pTHX_ regnode *f, U8 *p)
{
- dTHR;
char flags = ARG1(f);
bool match = FALSE;
#ifdef DEBUGGING
STATIC U8 *
S_reghop(pTHX_ U8 *s, I32 off)
{
- dTHR;
if (off >= 0) {
while (off-- && s < (U8*)PL_regeol)
s += UTF8SKIP(s);
STATIC U8 *
S_reghopmaybe(pTHX_ U8* s, I32 off)
{
- dTHR;
if (off >= 0) {
while (off-- && s < (U8*)PL_regeol)
s += UTF8SKIP(s);
static void
restore_pos(pTHXo_ void *arg)
{
- dTHR;
if (PL_reg_eval_set) {
if (PL_reg_oldsaved) {
PL_reg_re->subbeg = PL_reg_oldsaved;
int
Perl_runops_standard(pTHX)
{
- dTHR;
-
while ((PL_op = CALL_FPTR(PL_op->op_ppaddr)(aTHX))) {
PERL_ASYNC_CHECK();
}
Perl_runops_debug(pTHX)
{
#ifdef DEBUGGING
- dTHR;
if (!PL_op) {
if (ckWARN_d(WARN_DEBUGGING))
Perl_warner(aTHX_ WARN_DEBUGGING, "NULL OP IN RUN");
Perl_watch(pTHX_ char **addr)
{
#ifdef DEBUGGING
- dTHR;
PL_watchaddr = addr;
PL_watchok = *addr;
PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
Perl_vdefault_protect(pTHX_ volatile JMPENV *pcur_env, int *excpt,
protect_body_t body, va_list *args)
{
- dTHR;
int ex;
void *ret;
SV**
Perl_stack_grow(pTHX_ SV **sp, SV **p, int n)
{
- dTHR;
#if defined(DEBUGGING) && !defined(USE_THREADS)
static int growing = 0;
if (growing++)
I32
Perl_cxinc(pTHX)
{
- dTHR;
cxstack_max = GROW(cxstack_max);
Renew(cxstack, cxstack_max + 1, PERL_CONTEXT); /* XXX should fix CXINC macro */
return cxstack_ix + 1;
void
Perl_push_return(pTHX_ OP *retop)
{
- dTHR;
if (PL_retstack_ix == PL_retstack_max) {
PL_retstack_max = GROW(PL_retstack_max);
Renew(PL_retstack, PL_retstack_max, OP*);
OP *
Perl_pop_return(pTHX)
{
- dTHR;
if (PL_retstack_ix > 0)
return PL_retstack[--PL_retstack_ix];
else
void
Perl_push_scope(pTHX)
{
- dTHR;
if (PL_scopestack_ix == PL_scopestack_max) {
PL_scopestack_max = GROW(PL_scopestack_max);
Renew(PL_scopestack, PL_scopestack_max, I32);
void
Perl_pop_scope(pTHX)
{
- dTHR;
I32 oldsave = PL_scopestack[--PL_scopestack_ix];
LEAVE_SCOPE(oldsave);
}
void
Perl_markstack_grow(pTHX)
{
- dTHR;
I32 oldmax = PL_markstack_max - PL_markstack;
I32 newmax = GROW(oldmax);
void
Perl_savestack_grow(pTHX)
{
- dTHR;
PL_savestack_max = GROW(PL_savestack_max) + 4;
Renew(PL_savestack, PL_savestack_max, ANY);
}
void
Perl_tmps_grow(pTHX_ I32 n)
{
- dTHR;
#ifndef STRESS_REALLOC
if (n < 128)
n = (PL_tmps_max < 512) ? 128 : 512;
void
Perl_free_tmps(pTHX)
{
- dTHR;
/* XXX should tmps_floor live in cxstack? */
I32 myfloor = PL_tmps_floor;
while (PL_tmps_ix > myfloor) { /* clean up after last statement */
STATIC SV *
S_save_scalar_at(pTHX_ SV **sptr)
{
- dTHR;
register SV *sv;
SV *osv = *sptr;
SV *
Perl_save_scalar(pTHX_ GV *gv)
{
- dTHR;
SV **sptr = &GvSV(gv);
SSCHECK(3);
SSPUSHPTR(SvREFCNT_inc(gv));
SV*
Perl_save_svref(pTHX_ SV **sptr)
{
- dTHR;
SSCHECK(3);
SSPUSHPTR(sptr);
SSPUSHPTR(SvREFCNT_inc(*sptr));
void
Perl_save_generic_svref(pTHX_ SV **sptr)
{
- dTHR;
SSCHECK(3);
SSPUSHPTR(sptr);
SSPUSHPTR(SvREFCNT_inc(*sptr));
void
Perl_save_generic_pvref(pTHX_ char **str)
{
- dTHR;
SSCHECK(3);
SSPUSHPTR(str);
SSPUSHPTR(*str);
void
Perl_save_gp(pTHX_ GV *gv, I32 empty)
{
- dTHR;
SSCHECK(6);
SSPUSHIV((IV)SvLEN(gv));
SvLEN(gv) = 0; /* forget that anything was allocated here */
AV *
Perl_save_ary(pTHX_ GV *gv)
{
- dTHR;
AV *oav = GvAVn(gv);
AV *av;
HV *
Perl_save_hash(pTHX_ GV *gv)
{
- dTHR;
HV *ohv, *hv;
SSCHECK(3);
void
Perl_save_item(pTHX_ register SV *item)
{
- dTHR;
register SV *sv = NEWSV(0,0);
sv_setsv(sv,item);
void
Perl_save_int(pTHX_ int *intp)
{
- dTHR;
SSCHECK(3);
SSPUSHINT(*intp);
SSPUSHPTR(intp);
void
Perl_save_long(pTHX_ long int *longp)
{
- dTHR;
SSCHECK(3);
SSPUSHLONG(*longp);
SSPUSHPTR(longp);
void
Perl_save_I32(pTHX_ I32 *intp)
{
- dTHR;
SSCHECK(3);
SSPUSHINT(*intp);
SSPUSHPTR(intp);
void
Perl_save_I16(pTHX_ I16 *intp)
{
- dTHR;
SSCHECK(3);
SSPUSHINT(*intp);
SSPUSHPTR(intp);
void
Perl_save_I8(pTHX_ I8 *bytep)
{
- dTHR;
SSCHECK(3);
SSPUSHINT(*bytep);
SSPUSHPTR(bytep);
void
Perl_save_iv(pTHX_ IV *ivp)
{
- dTHR;
SSCHECK(3);
SSPUSHIV(*ivp);
SSPUSHPTR(ivp);
void
Perl_save_pptr(pTHX_ char **pptr)
{
- dTHR;
SSCHECK(3);
SSPUSHPTR(*pptr);
SSPUSHPTR(pptr);
void
Perl_save_vptr(pTHX_ void *ptr)
{
- dTHR;
SSCHECK(3);
SSPUSHPTR(*(char**)ptr);
SSPUSHPTR(ptr);
void
Perl_save_sptr(pTHX_ SV **sptr)
{
- dTHR;
SSCHECK(3);
SSPUSHPTR(*sptr);
SSPUSHPTR(sptr);
void
Perl_save_padsv(pTHX_ PADOFFSET off)
{
- dTHR;
SSCHECK(4);
SSPUSHPTR(PL_curpad[off]);
SSPUSHPTR(PL_curpad);
Perl_save_threadsv(pTHX_ PADOFFSET i)
{
#ifdef USE_THREADS
- dTHR;
SV **svp = &THREADSV(i); /* XXX Change to save by offset */
DEBUG_S(PerlIO_printf(Perl_debug_log, "save_threadsv %"UVuf": %p %p:%s\n",
(UV)i, svp, *svp, SvPEEK(*svp)));
void
Perl_save_nogv(pTHX_ GV *gv)
{
- dTHR;
SSCHECK(2);
SSPUSHPTR(gv);
SSPUSHINT(SAVEt_NSTAB);
void
Perl_save_hptr(pTHX_ HV **hptr)
{
- dTHR;
SSCHECK(3);
SSPUSHPTR(*hptr);
SSPUSHPTR(hptr);
void
Perl_save_aptr(pTHX_ AV **aptr)
{
- dTHR;
SSCHECK(3);
SSPUSHPTR(*aptr);
SSPUSHPTR(aptr);
void
Perl_save_freesv(pTHX_ SV *sv)
{
- dTHR;
SSCHECK(2);
SSPUSHPTR(sv);
SSPUSHINT(SAVEt_FREESV);
void
Perl_save_freeop(pTHX_ OP *o)
{
- dTHR;
SSCHECK(2);
SSPUSHPTR(o);
SSPUSHINT(SAVEt_FREEOP);
void
Perl_save_freepv(pTHX_ char *pv)
{
- dTHR;
SSCHECK(2);
SSPUSHPTR(pv);
SSPUSHINT(SAVEt_FREEPV);
void
Perl_save_clearsv(pTHX_ SV **svp)
{
- dTHR;
SSCHECK(2);
SSPUSHLONG((long)(svp-PL_curpad));
SSPUSHINT(SAVEt_CLEARSV);
void
Perl_save_delete(pTHX_ HV *hv, char *key, I32 klen)
{
- dTHR;
SSCHECK(4);
SSPUSHINT(klen);
SSPUSHPTR(key);
void
Perl_save_list(pTHX_ register SV **sarg, I32 maxsarg)
{
- dTHR;
register SV *sv;
register I32 i;
void
Perl_save_destructor(pTHX_ DESTRUCTORFUNC_NOCONTEXT_t f, void* p)
{
- dTHR;
SSCHECK(3);
SSPUSHDPTR(f);
SSPUSHPTR(p);
void
Perl_save_destructor_x(pTHX_ DESTRUCTORFUNC_t f, void* p)
{
- dTHR;
SSCHECK(3);
SSPUSHDXPTR(f);
SSPUSHPTR(p);
void
Perl_save_aelem(pTHX_ AV *av, I32 idx, SV **sptr)
{
- dTHR;
SSCHECK(4);
SSPUSHPTR(SvREFCNT_inc(av));
SSPUSHINT(idx);
void
Perl_save_helem(pTHX_ HV *hv, SV *key, SV **sptr)
{
- dTHR;
SSCHECK(4);
SSPUSHPTR(SvREFCNT_inc(hv));
SSPUSHPTR(SvREFCNT_inc(key));
void
Perl_save_op(pTHX)
{
- dTHR;
SSCHECK(2);
SSPUSHPTR(PL_op);
SSPUSHINT(SAVEt_OP);
I32
Perl_save_alloc(pTHX_ I32 size, I32 pad)
{
- dTHR;
register I32 start = pad + ((char*)&PL_savestack[PL_savestack_ix]
- (char*)PL_savestack);
register I32 elems = 1 + ((size + pad - 1) / sizeof(*PL_savestack));
void
Perl_leave_scope(pTHX_ I32 base)
{
- dTHR;
register SV *sv;
register SV *value;
register GV *gv;
Perl_cx_dump(pTHX_ PERL_CONTEXT *cx)
{
#ifdef DEBUGGING
- dTHR;
PerlIO_printf(Perl_debug_log, "CX %ld = %s\n", (long)(cx - cxstack), PL_block_type[CxTYPE(cx)]);
if (CxTYPE(cx) != CXt_SUBST) {
PerlIO_printf(Perl_debug_log, "BLK_OLDSP = %ld\n", (long)cx->blk_oldsp);
case SVt_PVCV:
case SVt_PVFM:
case SVt_PVIO:
- {
- dTHR;
- Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
- PL_op_desc[PL_op->op_type]);
- }
+ Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
+ PL_op_desc[PL_op->op_type]);
}
(void)SvIOK_only(sv); /* validate number */
SvIVX(sv) = i;
case SVt_PVCV:
case SVt_PVFM:
case SVt_PVIO:
- {
- dTHR;
- Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
- PL_op_name[PL_op->op_type]);
- }
+ Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
+ PL_op_name[PL_op->op_type]);
}
SvNVX(sv) = num;
(void)SvNOK_only(sv); /* validate number */
STATIC void
S_not_a_number(pTHX_ SV *sv)
{
- dTHR;
char tmpbuf[64];
char *d = tmpbuf;
char *s;
return asIV(sv);
if (!SvROK(sv)) {
if (!(SvFLAGS(sv) & SVs_PADTMP)) {
- dTHR;
if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
report_uninit();
}
sv_force_normal(sv);
}
if (SvREADONLY(sv) && !SvOK(sv)) {
- dTHR;
if (ckWARN(WARN_UNINITIALIZED))
report_uninit();
return 0;
}
}
else {
- dTHR;
if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
report_uninit();
if (SvTYPE(sv) < SVt_IV)
return asUV(sv);
if (!SvROK(sv)) {
if (!(SvFLAGS(sv) & SVs_PADTMP)) {
- dTHR;
if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
report_uninit();
}
return PTR2UV(SvRV(sv));
}
if (SvREADONLY(sv) && !SvOK(sv)) {
- dTHR;
if (ckWARN(WARN_UNINITIALIZED))
report_uninit();
return 0;
#endif
}
else { /* Not a number. Cache 0. */
- dTHR;
-
if (SvTYPE(sv) < SVt_PVIV)
sv_upgrade(sv, SVt_PVIV);
(void)SvIOK_on(sv);
}
else {
if (!(SvFLAGS(sv) & SVs_PADTMP)) {
- dTHR;
if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
report_uninit();
}
if (SvNOKp(sv))
return SvNVX(sv);
if (SvPOKp(sv) && SvLEN(sv)) {
- dTHR;
if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
not_a_number(sv);
return Atof(SvPVX(sv));
}
if (!SvROK(sv)) {
if (!(SvFLAGS(sv) & SVs_PADTMP)) {
- dTHR;
if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
report_uninit();
}
return PTR2NV(SvRV(sv));
}
if (SvREADONLY(sv) && !SvOK(sv)) {
- dTHR;
if (ckWARN(WARN_UNINITIALIZED))
report_uninit();
return 0.0;
SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv);
}
else if (SvPOKp(sv) && SvLEN(sv)) {
- dTHR;
if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
not_a_number(sv);
SvNVX(sv) = Atof(SvPVX(sv));
}
else {
- dTHR;
if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
report_uninit();
if (SvTYPE(sv) < SVt_NV)
if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
return Atol(SvPVX(sv));
if (!numtype) {
- dTHR;
if (ckWARN(WARN_NUMERIC))
not_a_number(sv);
}
return Strtoul(SvPVX(sv), Null(char**), 10);
#endif
if (!numtype) {
- dTHR;
if (ckWARN(WARN_NUMERIC))
not_a_number(sv);
}
}
if (!SvROK(sv)) {
if (!(SvFLAGS(sv) & SVs_PADTMP)) {
- dTHR;
if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
report_uninit();
}
== (SVs_OBJECT|SVs_RMG))
&& strEQ(s=HvNAME(SvSTASH(sv)), "Regexp")
&& (mg = mg_find(sv, 'r'))) {
- dTHR;
regexp *re = (regexp *)mg->mg_obj;
if (!mg->mg_ptr) {
return s;
}
if (SvREADONLY(sv) && !SvOK(sv)) {
- dTHR;
if (ckWARN(WARN_UNINITIALIZED))
report_uninit();
*lp = 0;
SvPOK_on(sv);
}
else {
- dTHR;
if (ckWARN(WARN_UNINITIALIZED)
&& !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
- {
report_uninit();
- }
*lp = 0;
if (SvTYPE(sv) < SVt_PV)
/* Typically the caller expects that sv_any is not NULL now. */
if (!SvOK(sv))
return 0;
if (SvROK(sv)) {
- dTHR;
SV* tmpsv;
if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
(SvRV(tmpsv) != SvRV(sv)))
void
Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
{
- dTHR;
register U32 sflags;
register int dtype;
register int stype;
Perl_sv_force_normal(pTHX_ register SV *sv)
{
if (SvREADONLY(sv)) {
- dTHR;
if (SvFAKE(sv)) {
char *pvx = SvPVX(sv);
STRLEN len = SvCUR(sv);
MAGIC* mg;
if (SvREADONLY(sv)) {
- dTHR;
if (PL_curcop != &PL_compiling && !strchr("gBf", how))
Perl_croak(aTHX_ PL_no_modify);
}
if (!obj || obj == sv || how == '#' || how == 'r')
mg->mg_obj = obj;
else {
- dTHR;
mg->mg_obj = SvREFCNT_inc(obj);
mg->mg_flags |= MGf_REFCOUNTED;
}
if (!SvROK(sv))
Perl_croak(aTHX_ "Can't weaken a nonreference");
else if (SvWEAKREF(sv)) {
- dTHR;
if (ckWARN(WARN_MISC))
Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
return sv;
void
Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
{
- dTHR;
U32 refcnt = SvREFCNT(sv);
SV_CHECK_THINKFIRST(sv);
if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
assert(SvREFCNT(sv) == 0);
if (SvOBJECT(sv)) {
- dTHR;
if (PL_defstash) { /* Still have a symbol table? */
djSP;
GV* destructor;
void
Perl_sv_free(pTHX_ SV *sv)
{
- dTHR;
int refcount_is_zero;
if (!sv)
++len;
}
if (s != send) {
- dTHR;
if (ckWARN_d(WARN_UTF8))
Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character");
--len;
char *
Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
{
- dTHR;
char *rsptr;
STRLEN rslen;
register STDCHAR rslast;
mg_get(sv);
if (SvTHINKFIRST(sv)) {
if (SvREADONLY(sv)) {
- dTHR;
if (PL_curcop != &PL_compiling)
Perl_croak(aTHX_ PL_no_modify);
}
mg_get(sv);
if (SvTHINKFIRST(sv)) {
if (SvREADONLY(sv)) {
- dTHR;
if (PL_curcop != &PL_compiling)
Perl_croak(aTHX_ PL_no_modify);
}
SV *
Perl_sv_mortalcopy(pTHX_ SV *oldstr)
{
- dTHR;
register SV *sv;
new_SV(sv);
SV *
Perl_sv_newmortal(pTHX)
{
- dTHR;
register SV *sv;
new_SV(sv);
SV *
Perl_sv_2mortal(pTHX_ register SV *sv)
{
- dTHR;
if (!sv)
return sv;
if (SvREADONLY(sv) && SvIMMORTAL(sv))
SV *
Perl_newRV_noinc(pTHX_ SV *tmpRef)
{
- dTHR;
register SV *sv;
new_SV(sv);
SV *
Perl_newSVsv(pTHX_ register SV *old)
{
- dTHR;
register SV *sv;
if (!old)
if (SvGMAGICAL(sv))
mg_get(sv);
if (SvROK(sv)) {
- dTHR;
SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
tryAMAGICunDEREF(to_cv);
I32
Perl_sv_true(pTHX_ register SV *sv)
{
- dTHR;
if (!sv)
return 0;
if (SvPOK(sv)) {
}
else {
if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
- dTHR;
Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
PL_op_name[PL_op->op_type]);
}
SV*
Perl_newSVrv(pTHX_ SV *rv, const char *classname)
{
- dTHR;
SV *sv;
new_SV(sv);
SV*
Perl_sv_bless(pTHX_ SV *sv, HV *stash)
{
- dTHR;
SV *tmpRef;
if (!SvROK(sv))
Perl_croak(aTHX_ "Can't bless non-reference value");
void
Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
{
- dTHR;
char *p;
char *q;
char *patend;
void
Perl_taint_proper(pTHX_ const char *f, const char *s)
{
- dTHR; /* just for taint */
char *ug;
#ifdef HAS_SETEUID
if (!svp || *svp == &PL_sv_undef)
break;
if (SvTAINTED(*svp)) {
- dTHR;
TAINT;
taint_proper("Insecure %s%s", "$ENV{DCL$PATH}");
}
if ((mg = mg_find(*svp, 'e')) && MgTAINTEDDIR(mg)) {
- dTHR;
TAINT;
taint_proper("Insecure directory in %s%s", "$ENV{DCL$PATH}");
}
svp = hv_fetch(GvHVn(PL_envgv),"PATH",4,FALSE);
if (svp && *svp) {
if (SvTAINTED(*svp)) {
- dTHR;
TAINT;
taint_proper("Insecure %s%s", "$ENV{PATH}");
}
if ((mg = mg_find(*svp, 'e')) && MgTAINTEDDIR(mg)) {
- dTHR;
TAINT;
taint_proper("Insecure directory in %s%s", "$ENV{PATH}");
}
/* tainted $TERM is okay if it contains no metachars */
svp = hv_fetch(GvHVn(PL_envgv),"TERM",4,FALSE);
if (svp && *svp && SvTAINTED(*svp)) {
- dTHR; /* just for taint */
STRLEN n_a;
bool was_tainted = PL_tainted;
char *t = SvPV(*svp, n_a);
for (e = misc_env; *e; e++) {
svp = hv_fetch(GvHVn(PL_envgv), *e, strlen(*e), FALSE);
if (svp && *svp != &PL_sv_undef && SvTAINTED(*svp)) {
- dTHR; /* just for taint */
TAINT;
taint_proper("Insecure $ENV{%s}%s", *e);
}
void
Perl_deprecate(pTHX_ char *s)
{
- dTHR;
if (ckWARN(WARN_DEPRECATED))
Perl_warner(aTHX_ WARN_DEPRECATED, "Use of %s is deprecated", s);
}
void
Perl_lex_start(pTHX_ SV *line)
{
- dTHR;
char *s;
STRLEN len;
STATIC void
S_incline(pTHX_ char *s)
{
- dTHR;
char *t;
char *n;
char *e;
STATIC char *
S_skipspace(pTHX_ register char *s)
{
- dTHR;
if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
while (s < PL_bufend && SPACE_OR_TAB(*s))
s++;
{
char *s;
char *t;
- dTHR;
if (PL_oldoldbufptr != PL_last_uni)
return;
STATIC I32
S_lop(pTHX_ I32 f, int x, char *s)
{
- dTHR;
yylval.ival = f;
CLINE;
PL_expect = x;
PL_nextval[PL_nexttoke].opval = o;
force_next(WORD);
if (kind) {
- dTHR; /* just for in_eval */
o->op_private = OPpCONST_ENTERED;
/* XXX see note in pp_entereval() for why we forgo typo
warnings if the symbol must be introduced in an eval.
STATIC I32
S_sublex_push(pTHX)
{
- dTHR;
ENTER;
PL_lex_state = PL_sublex_info.super_state;
if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
{
- dTHR; /* only for ckWARN */
if (ckWARN(WARN_SYNTAX))
Perl_warner(aTHX_ WARN_SYNTAX, "\\%c better written as $%c", *s, *s);
*--s = '$';
/* FALL THROUGH */
default:
{
- dTHR;
if (ckWARN(WARN_MISC) && isALNUM(*s))
Perl_warner(aTHX_ WARN_MISC,
"Unrecognized escape \\%c passed through",
int
Perl_yylex_r(pTHX_ YYSTYPE *lvalp, int *lcharp)
{
- dTHR;
int r;
yylval_pointer[yyactlevel] = lvalp;
Perl_yylex(pTHX)
#endif
{
- dTHR;
register char *s;
register char *d;
register I32 tmp;
char *w;
if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
- dTHR; /* only for ckWARN */
if (ckWARN(WARN_SYNTAX)) {
int level = 1;
for (w = s+2; *w && level; w++) {
*d = '\0';
while (s < send && SPACE_OR_TAB(*s)) s++;
if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
- dTHR; /* only for ckWARN */
if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
const char *brack = *s == '[' ? "[...]" : "{...}";
Perl_warner(aTHX_ WARN_AMBIGUOUS,
if (funny == '#')
funny = '@';
if (PL_lex_state == LEX_NORMAL) {
- dTHR; /* only for ckWARN */
if (ckWARN(WARN_AMBIGUOUS) &&
(keyword(dest, d - dest) || get_cv(dest, FALSE)))
{
STATIC char *
S_scan_heredoc(pTHX_ register char *s)
{
- dTHR;
SV *herewas;
I32 op_type = OP_SCALAR;
I32 len;
STATIC char *
S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
{
- dTHR;
SV *sv; /* scalar value: string */
char *tmps; /* temp string, used for delimiter matching */
register char *s = start; /* current position in the buffer */
we in octal/hex/binary?" indicator to disallow hex characters
when in octal mode.
*/
- dTHR;
NV n = 0.0;
UV u = 0;
I32 shift;
if ((x >> shift) != u
&& !(PL_hints & HINT_NEW_BINARY)) {
- dTHR;
overflowed = TRUE;
n = (NV) u;
if (ckWARN_d(WARN_OVERFLOW))
out:
sv = NEWSV(92,0);
if (overflowed) {
- dTHR;
if (ckWARN(WARN_PORTABLE) && n > 4294967295.0)
Perl_warner(aTHX_ WARN_PORTABLE,
"%s number > %s non-portable",
}
else {
#if UVSIZE > 4
- dTHR;
if (ckWARN(WARN_PORTABLE) && u > 0xffffffff)
Perl_warner(aTHX_ WARN_PORTABLE,
"%s number > %s non-portable",
if -w is on
*/
if (*s == '_') {
- dTHR; /* only for ckWARN */
if (ckWARN(WARN_SYNTAX) && lastub && s - lastub != 3)
Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
lastub = ++s;
/* final misplaced underbar check */
if (lastub && s - lastub != 3) {
- dTHR;
if (ckWARN(WARN_SYNTAX))
Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
}
STATIC char *
S_scan_formline(pTHX_ register char *s)
{
- dTHR;
register char *eol;
register char *t;
SV *stuff = newSVpvn("",0);
I32
Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
{
- dTHR;
I32 oldsavestack_ix = PL_savestack_ix;
CV* outsidecv = PL_compcv;
AV* comppadlist;
int
Perl_yywarn(pTHX_ char *s)
{
- dTHR;
PL_in_eval |= EVAL_WARNONLY;
yyerror(s);
PL_in_eval &= ~EVAL_WARNONLY;
int
Perl_yyerror(pTHX_ char *s)
{
- dTHR;
char *where = NULL;
char *context = NULL;
int contlen = -1;
SV* sv = *svp++;
HV* basestash = gv_stashsv(sv, FALSE);
if (!basestash) {
- dTHR;
if (ckWARN(WARN_MISC))
Perl_warner(aTHX_ WARN_SYNTAX,
"Can't locate package %s for @%s::ISA",
UV
Perl_utf8_to_uv(pTHX_ U8* s, STRLEN curlen, STRLEN* retlen, U32 flags)
{
- dTHR;
UV uv = *s, ouv;
STRLEN len = 1;
#ifdef EBCDIC
U8*
Perl_bytes_to_utf8(pTHX_ U8* s, STRLEN *len)
{
- dTHR;
U8 *send;
U8 *d;
U8 *dst;
continue;
}
if (uv >= 0xd800 && uv < 0xdbff) { /* surrogates */
- dTHR;
UV low = *p++;
if (low < 0xdc00 || low >= 0xdfff)
Perl_croak(aTHX_ "Malformed UTF-16 surrogate");
char *
Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last)
{
- dTHR;
register unsigned char *s, *x;
register unsigned char *big;
register I32 pos;
STATIC SV *
S_mess_alloc(pTHX)
{
- dTHR;
SV *sv;
XPVMG *any;
sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
- dTHR;
if (CopLINE(PL_curcop))
Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf,
CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
OP *
Perl_vdie(pTHX_ const char* pat, va_list *args)
{
- dTHR;
char *message;
int was_in_eval = PL_in_eval;
HV *stash;
void
Perl_vcroak(pTHX_ const char* pat, va_list *args)
{
- dTHR;
char *message;
HV *stash;
GV *gv;
if (PL_warnhook) {
/* sv_2cv might call Perl_warn() */
- dTHR;
SV *oldwarnhook = PL_warnhook;
ENTER;
SAVESPTR(PL_warnhook);
void
Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args)
{
- dTHR;
char *message;
HV *stash;
GV *gv;
else {
if (PL_warnhook) {
/* sv_2cv might call Perl_warn() */
- dTHR;
SV *oldwarnhook = PL_warnhook;
ENTER;
SAVESPTR(PL_warnhook);
continue;
}
else {
- dTHR;
if (ckWARN(WARN_DIGIT))
Perl_warner(aTHX_ WARN_DIGIT,
"Illegal binary digit '%c' ignored", *s);
register UV xuv = ruv << 1;
if ((xuv >> 1) != ruv) {
- dTHR;
overflowed = TRUE;
rnv = (NV) ruv;
if (ckWARN_d(WARN_OVERFLOW))
|| (!overflowed && ruv > 0xffffffff )
#endif
) {
- dTHR;
if (ckWARN(WARN_PORTABLE))
Perl_warner(aTHX_ WARN_PORTABLE,
"Binary number > 0b11111111111111111111111111111111 non-portable");
* as soon as non-octal characters are seen, complain only iff
* someone seems to want to use the digits eight and nine). */
if (*s == '8' || *s == '9') {
- dTHR;
if (ckWARN(WARN_DIGIT))
Perl_warner(aTHX_ WARN_DIGIT,
"Illegal octal digit '%c' ignored", *s);
register UV xuv = ruv << 3;
if ((xuv >> 3) != ruv) {
- dTHR;
overflowed = TRUE;
rnv = (NV) ruv;
if (ckWARN_d(WARN_OVERFLOW))
|| (!overflowed && ruv > 0xffffffff )
#endif
) {
- dTHR;
if (ckWARN(WARN_PORTABLE))
Perl_warner(aTHX_ WARN_PORTABLE,
"Octal number > 037777777777 non-portable");
++s;
}
else {
- dTHR;
if (ckWARN(WARN_DIGIT))
Perl_warner(aTHX_ WARN_DIGIT,
"Illegal hexadecimal digit '%c' ignored", *s);
register UV xuv = ruv << 4;
if ((xuv >> 4) != ruv) {
- dTHR;
overflowed = TRUE;
rnv = (NV) ruv;
if (ckWARN_d(WARN_OVERFLOW))
|| (!overflowed && ruv > 0xffffffff )
#endif
) {
- dTHR;
if (ckWARN(WARN_PORTABLE))
Perl_warner(aTHX_ WARN_PORTABLE,
"Hexadecimal number > 0xffffffff non-portable");
char*
Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 flags)
{
- dTHR;
char *xfound = Nullch;
char *xfailed = Nullch;
char tmpbuf[MAXPATHLEN];
status = FAIL;
if (sp > mark)
{
- dTHR;
New(401,PL_Argv, sp - mark + 1, char*);
a = PL_Argv;
while (++mark <= sp)
(const char **) environ);
if (pid < 0)
{
- dTHR;
status = FAIL;
if (ckWARN(WARN_EXEC))
warner(WARN_EXEC,"Can't exec \"%s\": %s",
HV *stash;
IO *io;
- dTHR;
/* Find stash for VMS::Stdio. We don't do this once at boot
* to allow for possibility of threaded Perl with per-thread
* symbol tables. This code (through io = ...) is really
}
else {
if (status < 0) {
- dTHR;
if (ckWARN(WARN_EXEC))
Perl_warner(aTHX_ WARN_EXEC, "Can't spawn \"%s\": %s", argv[0], strerror(errno));
status = 255 * 256;
}
else {
if (status < 0) {
- dTHR;
if (ckWARN(WARN_EXEC))
Perl_warner(aTHX_ WARN_EXEC, "Can't %s \"%s\": %s",
(exectype == EXECF_EXEC ? "exec" : "spawn"),
{
dTHXo;
#ifdef HAVE_DES_FCRYPT
- dTHR;
return des_fcrypt(txt, salt, w32_crypt_buffer);
#else
Perl_croak(aTHX_ "The crypt() function is unimplemented due to excessive paranoia.");
https://perl5.git.perl.org / perl5.git / commitdiff