mg.c revision 7c478bd95313f5f23a4c958a745db2134aa03244
/* mg.c
*
* Copyright (c) 1991-2001, Larry Wall
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
*
*/
/*
* "Sam sat on the ground and put his head in his hands. 'I wish I had never
* come here, and I don't want to see no more magic,' he said, and fell silent."
*/
#include "EXTERN.h"
#define PERL_IN_MG_C
#include "perl.h"
#if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS)
# ifndef NGROUPS
# define NGROUPS 32
# endif
#endif
static void restore_magic(pTHXo_ void *p);
static void unwind_handler_stack(pTHXo_ void *p);
/*
* Use the "DESTRUCTOR" scope cleanup to reinstate magic.
*/
struct magic_state {
};
/* MGS is typedef'ed to struct magic_state in perl.h */
STATIC void
{
}
/*
=for apidoc mg_magical
Turns on the magical status of an SV. See C<sv_magic>.
=cut
*/
void
{
if (vtbl) {
}
}
}
/*
=for apidoc mg_get
Do magic after a value is retrieved from the SV. See C<sv_magic>.
=cut
*/
int
{
int mgp_valid = 0;
/* Ignore this magic if it's been deleted */
}
/* Advance to next magic (complicated by possible deletion) */
mgp_valid = 1;
}
else
}
return 0;
}
/*
=for apidoc mg_set
Do magic after a value is assigned to the SV. See C<sv_magic>.
=cut
*/
int
{
}
}
return 0;
}
/*
=for apidoc mg_length
Report on the SV's length. See C<sv_magic>.
=cut
*/
{
char *junk;
/* omit MGf_GSKIP -- not changed here */
return len;
}
}
return len;
}
{
/* omit MGf_GSKIP -- not changed here */
return len;
}
}
case SVt_PVAV:
return len;
case SVt_PVHV:
/* FIXME */
default:
break;
}
return 0;
}
/*
=for apidoc mg_clear
Clear something magical that the SV represents. See C<sv_magic>.
=cut
*/
int
{
/* omit GSKIP -- never set here */
}
return 0;
}
/*
=for apidoc mg_find
Finds the magic pointer for type matching the SV. See C<sv_magic>.
=cut
*/
{
return mg;
}
return 0;
}
/*
=for apidoc mg_copy
Copies the magic from one SV to another. See C<sv_magic>.
=cut
*/
int
{
int count = 0;
count++;
}
}
return count;
}
/*
=for apidoc mg_free
Free any magic storage used by the SV. See C<sv_magic>.
=cut
*/
int
{
}
return 0;
}
#include <signal.h>
#endif
{
else /* @- */
}
return (U32)-1;
}
int
{
register I32 s;
register I32 i;
I32 t;
if (paren < 0)
return 0;
{
i = t;
else /* @- */
i = s;
}
}
return 0;
}
int
{
/* NOT REACHED */
return 0;
}
{
register I32 i;
case '1': case '2': case '3': case '4':
case '5': case '6': case '7': case '8': case '9': case '&':
{
i = 0;
while (s < send) {
s += UTF8SKIP(s);
i++;
}
}
if (i >= 0)
return i;
}
}
return 0;
case '+':
if (paren)
goto getparen;
}
return 0;
case '`':
if (i > 0) {
s1 = 0;
t1 = i;
goto getlen;
}
}
}
return 0;
case '\'':
if (i > 0) {
goto getlen;
}
}
}
return 0;
case ',':
case '\\':
}
}
return 0;
}
int
{
register char *s;
register I32 i;
case '\001': /* ^A */
break;
case '\003': /* ^C */
break;
case '\004': /* ^D */
#endif
break;
case '\005': /* ^E */
#ifdef MACOS_TRADITIONAL
{
char msg[256];
}
#else
#ifdef VMS
{
# include <descrip.h>
# include <starlet.h>
char msg[255];
else
}
#else
#ifdef OS2
} else {
if (errno != errno_isOS2) {
if (tmp) /* 2nd call to _syserrno() makes it 0 */
}
}
#else
#ifdef WIN32
{
if (dwErr)
{
}
else
}
#else
#endif
#endif
#endif
#endif
break;
case '\006': /* ^F */
break;
case '\010': /* ^H */
break;
case '\011': /* ^I */ /* NOT \t in EBCDIC */
if (PL_inplace)
else
break;
case '\017': /* ^O */
break;
case '\020': /* ^P */
break;
case '\023': /* ^S */
{
if (PL_lex_state != LEX_NOTPARSING)
else if (PL_in_eval)
}
break;
case '\024': /* ^T */
#ifdef BIG_TIME
#else
#endif
break;
case '\027': /* ^W & $^WARNING_BITS & ^WIDE_SYSTEM_CALLS */
{
}
}
else {
}
SvPOK_only(sv);
}
break;
case '1': case '2': case '3': case '4':
case '5': case '6': case '7': case '8': case '9': case '&':
/*
* Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj));
* XXX Does the new way break anything?
*/
{
break;
if (i >= 0) {
bool was_tainted;
if (PL_tainting) {
PL_tainted = FALSE;
}
else
SvUTF8_off(sv);
if (PL_tainting)
break;
}
}
}
break;
case '+':
if (paren)
goto getparen;
}
break;
case '`':
goto getrx;
}
}
break;
case '\'':
goto getrx;
}
}
break;
case '.':
#ifndef lint
if (GvIO(PL_last_in_gv)) {
}
#endif
break;
case '?':
{
#ifdef COMPLEX_STATUS
#endif
}
break;
case '^':
if (s)
else {
}
break;
case '~':
if (!s)
s = GvENAME(PL_defoutgv);
break;
#ifndef lint
case '=':
break;
case '-':
break;
case '%':
break;
#endif
case ':':
break;
case '/':
break;
case '[':
break;
case '|':
break;
case ',':
break;
case '\\':
break;
case '#':
break;
case '!':
#ifdef VMS
#else
{
#ifdef OS2
else
#endif
}
#endif
break;
case '<':
break;
case '>':
break;
case '(':
#ifdef HAS_GETGROUPS
#endif
goto add_groups;
case ')':
#ifdef HAS_GETGROUPS
#endif
#ifdef HAS_GETGROUPS
{
while (--i >= 0)
}
#endif
break;
case '*':
break;
#ifndef MACOS_TRADITIONAL
case '0':
break;
#endif
#ifdef USE_THREADS
case '@':
break;
#endif /* USE_THREADS */
}
return 0;
}
int
{
return 0;
}
int
{
register char *s;
char *ptr;
I32 i;
#ifdef DYNAMIC_ENV_FETCH
/* We just undefd an environment var. Is a replacement */
/* waiting in the wings? */
if (!len) {
}
#endif
/* And you'll never guess what the dog had */
/* in its mouth... */
if (PL_tainting) {
#ifdef VMS
int i = 0, j = 0;
do { /* DCL$PATH may be a search list */
while (1) { /* as may dev portion of any element */
return 0;
}
}
*cp = '\0';
else
break;
}
j = 0;
}
#endif /* VMS */
while (s < strend) {
char tmpbuf[256];
s, strend, ':', &i);
s++;
if (i >= sizeof tmpbuf /* too long -- assume the worst */
|| *tmpbuf != '/'
return 0;
}
}
}
}
#endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
return 0;
}
int
{
return 0;
}
int
{
#if defined(VMS)
#else
if (PL_localizing) {
}
}
#endif
return 0;
}
int
{
#else
# ifdef PERL_IMPLICIT_SYS
# else
# ifdef WIN32
char *envv = GetEnvironmentStrings();
while (*cur) {
*end = '\0';
*end = '=';
}
}
# else
#if !defined(MACOS_TRADITIONAL)
# ifndef PERL_USE_SAFE_PUTENV
I32 i;
if (environ == PL_origenviron)
environ = (char**)safesysmalloc(sizeof(char*));
else
for (i = 0; environ[i]; i++)
safesysfree(environ[i]);
# endif /* PERL_USE_SAFE_PUTENV */
#endif /* !defined(MACOS_TRADITIONAL) */
# endif /* WIN32 */
# endif /* PERL_IMPLICIT_SYS */
#endif /* VMS */
return 0;
}
int
{
I32 i;
/* Are we fetching a signal entry? */
if (i) {
if(PL_psig_ptr[i])
else {
/* cache state so we don't fetch it again */
else
SvTEMP_off(sv);
}
}
return 0;
}
int
{
I32 i;
/* Are we clearing a signal entry? */
if (i) {
if(PL_psig_ptr[i]) {
SvREFCNT_dec(PL_psig_ptr[i]);
PL_psig_ptr[i]=0;
}
if(PL_psig_name[i]) {
SvREFCNT_dec(PL_psig_name[i]);
PL_psig_name[i]=0;
}
}
return 0;
}
int
{
register char *s;
I32 i;
if (*s == '_') {
if (strEQ(s,"__DIE__"))
svp = &PL_diehook;
else if (strEQ(s,"__WARN__"))
svp = &PL_warnhook;
else
i = 0;
if (*svp) {
SvREFCNT_dec(*svp);
*svp = 0;
}
}
else {
i = whichsig(s); /* ...no, a brick */
if (!i) {
if (ckWARN(WARN_SIGNAL))
return 0;
}
SvREFCNT_dec(PL_psig_name[i]);
SvREFCNT_dec(PL_psig_ptr[i]);
}
if (i)
(void)rsignal(i, PL_sighandlerp);
else
return 0;
}
if (strEQ(s,"IGNORE")) {
if (i)
else
*svp = 0;
}
else if (strEQ(s,"DEFAULT") || !*s) {
if (i)
else
*svp = 0;
}
else {
/*
* We should warn if HINT_STRICT_REFS, but without
* access to a known hint bit in a known OP, we can't
* tell whether HINT_STRICT_REFS is in force or not.
*/
if (i)
(void)rsignal(i, PL_sighandlerp);
else
}
return 0;
}
int
{
return 0;
}
int
{
/* HV_badAMAGIC_on(Sv_STASH(sv)); */
return 0;
}
int
{
I32 i = 0;
if (hv) {
(void) hv_iterinit(hv);
else {
/*SUPPRESS 560*/
i++;
}
}
}
return 0;
}
int
{
}
return 0;
}
STATIC int
{
dSP;
if (n > 1) {
}
}
}
if (n > 2) {
}
}
STATIC int
{
dSP;
}
return 0;
}
int
{
return 0;
}
int
{
dSP;
return 0;
}
int
{
}
{
dSP;
sv = *PL_stack_sp--;
}
return retval;
}
int
{
dSP;
return 0;
}
int
{
dSP;
return 0;
}
int
{
}
int
{
OP *o;
I32 i;
o->op_private = i;
return 0;
}
int
{
return 0;
}
int
{
return 0;
}
int
{
sv_pos_b2u(lsv, &i);
return 0;
}
}
return 0;
}
int
{
mg = 0;
if (!mg) {
return 0;
}
return 0;
}
if (ulen)
}
if (pos < 0) {
if (pos < 0)
pos = 0;
}
if (ulen) {
sv_pos_u2b(lsv, &p, 0);
pos = p;
}
return 0;
}
int
{
SvFAKE_off(sv);
}
else
return 0;
}
int
{
register char *s;
return 0;
if (*s == '*' && s[1])
s++;
return 0;
return 0;
}
int
{
return 0;
}
int
{
}
}
else
return 0;
}
int
{
return 0;
}
int
{
if (PL_localizing) {
if (PL_localizing == 1)
else
}
else if (PL_tainted)
else
return 0;
}
int
{
if (!lsv) {
return 0;
}
return 0;
}
int
{
return 0;
}
int
{
if (he)
}
else {
if (svp)
}
}
else {
}
/* somebody else defined it for us */
}
}
else
return 0;
}
int
{
}
return 0;
}
void
{
return;
if (he)
}
else {
if (svp)
}
}
else {
else {
}
}
(void)SvREFCNT_inc(value);
}
int
{
while (i >= 0) {
/* XXX Should we check that it hasn't changed? */
SvWEAKREF_off(svp[i]);
svp[i] = &PL_sv_undef;
}
i--;
}
return 0;
}
int
{
return 0;
}
int
{
return 0;
}
int
{
return 0;
}
int
{
return 0;
}
int
{
return 0;
}
#ifdef USE_LOCALE_COLLATE
int
{
/*
* RenE<eacute> Descartes said "I think not."
* and vanished with a faint plop.
*/
}
return 0;
}
#endif /* USE_LOCALE_COLLATE */
int
{
register char *s;
I32 i;
case '\001': /* ^A */
break;
case '\003': /* ^C */
break;
case '\004': /* ^D */
break;
case '\005': /* ^E */
#ifdef MACOS_TRADITIONAL
#else
# ifdef VMS
# else
# ifdef WIN32
# else
# ifndef OS2
/* will anyone ever use this? */
# endif
# endif
# endif
#endif
break;
case '\006': /* ^F */
break;
case '\010': /* ^H */
break;
case '\011': /* ^I */ /* NOT \t in EBCDIC */
if (PL_inplace)
else
PL_inplace = Nullch;
break;
case '\017': /* ^O */
if (PL_osname)
else
break;
case '\020': /* ^P */
if (PL_perldb && !PL_DBsingle)
break;
case '\024': /* ^T */
#ifdef BIG_TIME
#else
#endif
break;
case '\027': /* ^W & $^WARNING_BITS & ^WIDE_SYSTEM_CALLS */
if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
| (i ? G_WARN_ON : G_WARN_OFF) ;
}
}
if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
break;
}
{
int accumulate = 0 ;
int any_fatals = 0 ;
for (i = 0 ; i < len ; ++i) {
accumulate |= ptr[i] ;
}
if (!accumulate)
PL_dowarn |= G_WARN_ONCE ;
}
else {
else
PL_dowarn |= G_WARN_ONCE ;
}
}
}
}
break;
case '.':
if (PL_localizing) {
if (PL_localizing == 1)
}
break;
case '^':
break;
case '~':
break;
case '=':
break;
case '-':
break;
case '%':
break;
case '|':
{
if(!io)
break;
else {
if (ofp)
(void)PerlIO_flush(ofp);
}
}
}
break;
case '*':
PL_multiline = (i != 0);
break;
case '/':
break;
case '\\':
if (PL_ors)
}
else {
PL_orslen = 0;
}
break;
case ',':
if (PL_ofs)
break;
case '#':
if (PL_ofmt)
break;
case '[':
break;
case '?':
#ifdef COMPLEX_STATUS
if (PL_localizing == 2) {
}
else
#endif
#ifdef VMSISH_STATUS
if (VMSISH_STATUS)
else
#endif
break;
case '!':
break;
case '<':
if (PL_delaymagic) {
PL_delaymagic |= DM_RUID;
break; /* don't do magic till later */
}
#ifdef HAS_SETRUID
#else
#ifdef HAS_SETREUID
#else
#ifdef HAS_SETRESUID
#else
(void)PerlProc_setuid(PL_uid);
else {
PL_uid = PerlProc_getuid();
}
#endif
#endif
#endif
PL_uid = PerlProc_getuid();
break;
case '>':
if (PL_delaymagic) {
PL_delaymagic |= DM_EUID;
break; /* don't do magic till later */
}
#ifdef HAS_SETEUID
#else
#ifdef HAS_SETREUID
#else
#ifdef HAS_SETRESUID
#else
else {
PL_euid = PerlProc_geteuid();
}
#endif
#endif
#endif
PL_euid = PerlProc_geteuid();
break;
case '(':
if (PL_delaymagic) {
PL_delaymagic |= DM_RGID;
break; /* don't do magic till later */
}
#ifdef HAS_SETRGID
#else
#ifdef HAS_SETREGID
#else
#ifdef HAS_SETRESGID
#else
(void)PerlProc_setgid(PL_gid);
else {
PL_gid = PerlProc_getgid();
}
#endif
#endif
#endif
PL_gid = PerlProc_getgid();
break;
case ')':
#ifdef HAS_SETGROUPS
{
while (isSPACE(*p))
++p;
for (i = 0; i < NGROUPS; ++i) {
while (*p && !isSPACE(*p))
++p;
while (isSPACE(*p))
++p;
if (!*p)
break;
}
if (i)
}
#else /* HAS_SETGROUPS */
#endif /* HAS_SETGROUPS */
if (PL_delaymagic) {
PL_delaymagic |= DM_EGID;
break; /* don't do magic till later */
}
#ifdef HAS_SETEGID
#else
#ifdef HAS_SETREGID
#else
#ifdef HAS_SETRESGID
#else
(void)PerlProc_setgid(PL_egid);
else {
PL_egid = PerlProc_getegid();
}
#endif
#endif
#endif
PL_egid = PerlProc_getegid();
break;
case ':':
break;
#ifndef MACOS_TRADITIONAL
case '0':
#ifdef HAS_SETPROCTITLE
/* The BSDs don't show the argv[] in ps(1) output, they
* show a string from the process struct and provide
* the setproctitle() routine to manipulate that. */
{
# if __FreeBSD_version >= 410001
/* The leading "-" removes the "perl: " prefix,
* but not the "(perl) suffix from the ps(1)
* output, because that's what ps(1) shows if the
* argv[] is modified. */
# else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
/* This doesn't really work if you assume that
* $0 = 'foobar'; will wipe out 'perl' from the $0
* because in ps(1) output the result will be like
* sprintf("perl: %s (perl)", s)
* I guess this is a security feature:
* one (a user process) cannot get rid of the original name.
* --jhi */
setproctitle("%s", s);
# endif
}
#endif
if (!PL_origalen) {
s = PL_origargv[0];
s += strlen(s);
/* See if all the arguments are contiguous in memory */
for (i = 1; i < PL_origargc; i++) {
if (PL_origargv[i] == s + 1
#ifdef OS2
|| PL_origargv[i] == s + 2
#endif
)
{
++s;
s += strlen(s); /* this one is ok too */
}
else
break;
}
/* can grab env area too? */
#ifdef OS2
#endif
)) {
/* force copy of environment */
for (i = 0; PL_origenviron[i]; i++)
if (PL_origenviron[i] == s + 1) {
++s;
s += strlen(s);
}
else
break;
}
PL_origalen = s - PL_origargv[0];
}
i = len;
if (i >= PL_origalen) {
i = PL_origalen;
/* don't allow system to limit $0 seen by script */
/* SvCUR_set(sv, i); *SvEND(sv) = '\0'; */
Copy(s, PL_origargv[0], i, char);
s = PL_origargv[0]+i;
*s = '\0';
}
else {
Copy(s, PL_origargv[0], i, char);
s = PL_origargv[0]+i;
*s++ = '\0';
while (++i < PL_origalen)
*s++ = ' ';
s = PL_origargv[0]+i;
for (i = 1; i < PL_origargc; i++)
PL_origargv[i] = Nullch;
}
break;
#endif
#ifdef USE_THREADS
case '@':
break;
#endif /* USE_THREADS */
}
return 0;
}
#ifdef USE_THREADS
int
{
return 0;
}
#endif /* USE_THREADS */
{
register char **sigv;
#ifdef SIGCLD
return SIGCLD;
#endif
#ifdef SIGCHLD
return SIGCHLD;
#endif
return 0;
}
Perl_sighandler(int sig)
{
#if defined(WIN32) && defined(PERL_IMPLICIT_CONTEXT)
#else
dTHX;
#endif
dSP;
#if defined(WIN32) && defined(PERL_IMPLICIT_CONTEXT)
#endif
flags |= 1;
flags |= 4;
flags |= 8;
flags |= 16;
if (!PL_psig_ptr[sig])
PL_sig_name[sig]);
/* Max number of items pushed there is 3*n or 4. We cannot fix
infinity, so we fix 4 (in fact 5): */
if (flags & 1) {
}
if (flags & 4)
PL_markstack_ptr++; /* Protect mark. */
if (flags & 8) {
}
if (flags & 16)
PL_scopestack_ix += 1;
/* sv_2cv is too complicated, try a simpler variant first: */
if (ckWARN(WARN_SIGNAL))
: "__ANON__")));
goto cleanup;
}
if(PL_psig_name[sig]) {
flags |= 64;
} else {
sv = sv_newmortal();
}
if (flags & 1)
if (flags & 4)
if (flags & 8)
if (flags & 16)
PL_scopestack_ix -= 1;
if (flags & 64)
return;
}
#ifdef PERL_OBJECT
#include "XSUB.h"
#endif
static void
restore_magic(pTHXo_ void *p)
{
if (!sv)
return;
{
else
mg_magical(sv);
if (SvGMAGICAL(sv))
}
/* If we're still on top of the stack, pop us off. (That condition
* will be satisfied if restore_magic was called explicitly, but *not*
* if it's being called via leave_scope.)
* The reason for doing this is that otherwise, things like sv_2cv()
* may leave alloc gunk on the savestack, and some code
* (e.g. sighandler) doesn't expect that...
*/
{
PL_savestack_ix -= 2;
}
}
static void
unwind_handler_stack(pTHXo_ void *p)
{
if (flags & 1)
/* cxstack_ix-- Not needed, die already unwound it. */
if (flags & 64)
}