1N/A * Copyright 2009 Sun Microsystems, Inc. All rights reserved. 1N/A * Use is subject to license terms. 1N/A * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 1N/A * 2000, 2001, 2002, 2003, 2004, by Larry Wall and others 1N/A * You may distribute under the terms of either the GNU General Public 1N/A * License or the Artistic License, as specified in the README file. 1N/A * "Sam sat on the ground and put his head in his hands. 'I wish I had never 1N/A * come here, and I don't want to see no more magic,' he said, and fell silent." 1N/A=head1 Magical Functions 1N/A/* if you only have signal() and it resets on each signal, FAKE_PERSISTENT_SIGNAL_HANDLERS fixes */ 1N/A/* if we're doing kill() with sys$sigprc on VMS, FAKE_DEFAULT_SIGNAL_HANDLERS */ 1N/A/* Missing protos on LynxOS */ 1N/A * Use the "DESTRUCTOR" scope cleanup to reinstate magic. 1N/A/* MGS is typedef'ed to struct magic_state in perl.h */ 1N/A=for apidoc mg_magical 1N/ATurns on the magical status of an SV. See C<sv_magic>. 1N/ADo magic after a value is retrieved from the SV. See C<sv_magic>. 1N/A /* We must call svt_get(sv, mg) for each valid entry in the linked 1N/A list of magic. svt_get() may delete the current entry, add new 1N/A magic to the head of the list, or upgrade the SV. AMS 20010810 */ 1N/A /* guard against sv having been freed */ 1N/A /* guard against magic having been deleted - eg FETCH calling 1N/A /* Don't restore the flags for this entry if it was deleted. */ 1N/A /* Have we finished with the new entries we saw? Start again 1N/A where we left off (unless there are more new entries). */ 1N/A /* Were any new entries added? */ 1N/ADo magic after a value is assigned to the SV. See C<sv_magic>. 1N/A=for apidoc mg_length 1N/AReport on the SV's length. See C<sv_magic>. 1N/A /* omit MGf_GSKIP -- not changed here */ 1N/A /* omit MGf_GSKIP -- not changed here */ 1N/AClear something magical that the SV represents. See C<sv_magic>. 1N/A /* omit GSKIP -- never set here */ 1N/AFinds the magic pointer for type matching the SV. See C<sv_magic>. 1N/ACopies the magic from one SV to another. See C<sv_magic>. 1N/AFree any magic storage used by the SV. See C<sv_magic>. 1N/A case '1':
case '2':
case '3':
case '4':
1N/A case '5':
case '6':
case '7':
case '8':
case '9':
case '&':
1N/A case '\016':
/* ^N */ 1N/A case '\001':
/* ^A */ 1N/A case '\003':
/* ^C */ 1N/A case '\004':
/* ^D */ 1N/A case '\005':
/* ^E */ 1N/A if (
tmp)
/* 2nd call to _syserrno() makes it 0 */ 1N/A case '\006':
/* ^F */ 1N/A case '\010':
/* ^H */ 1N/A case '\011':
/* ^I */ /* NOT \t in EBCDIC */ 1N/A case '\017':
/* ^O & ^OPEN */ 1N/A case '\020':
/* ^P */ 1N/A case '\023':
/* ^S */ 1N/A case '\024':
/* ^T */ 1N/A case '\025':
/* $^UNICODE */ 1N/A case '\027':
/* ^W & $^WARNING_BITS */ 1N/A case '1':
case '2':
case '3':
case '4':
1N/A case '5':
case '6':
case '7':
case '8':
case '9':
case '&':
1N/A * Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj)); 1N/A * XXX Does the new way break anything? 1N/A case '\016':
/* ^N */ 1N/A#
endif /* USE_5005THREADS */ 1N/A /* We just undefd an environment var. Is a replacement */ 1N/A /* waiting in the wings? */ 1N/A /* And you'll never guess what the dog had */ 1N/A /* in its mouth... */ 1N/A do {
/* DCL$PATH may be a search list */ 1N/A while (
1) {
/* as may dev portion of any element */ 1N/A if ( *(
cp+
1) ==
'.' || *(
cp+
1) ==
'-' ||
1N/A if (i >=
sizeof tmpbuf /* too long -- assume the worst */ 1N/A#
endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */ 1N/A /* only the parent thread can clobber the process environment */ 1N/A#
endif /* PERL_USE_SAFE_PUTENV */ 1N/A#
endif /* USE_ENVIRON_ARRAY */ 1N/A#
endif /* PERL_IMPLICIT_SYS || WIN32 */ 1N/A#
endif /* VMS || EPOC */ 1N/A#
endif /* !PERL_MICRO */ 1N/A /* Are we fetching a signal entry? */ 1N/A /* cache state so we don't fetch it again */ 1N/A /* XXX Some of this code was copied from Perl_magic_setsig. A little 1N/A * refactoring might be in order. 1N/A /* Are we clearing a signal entry? */ 1N/A /* Avoid having the signal arrive at a bad time, if possible. */ 1N/A /* Set a flag to say this signal is pending */ 1N/A /* And one to say _a_ signal is pending */ 1N/A /* Call the perl level handler now-- 1N/A * with risk we may be in malloc() etc. */ 1N/A /* Need to be careful with SvREFCNT_dec(), because that can have side 1N/A * effects (due to closures). We must make sure that the new disposition 1N/A * is in place before it is called. 1N/A /* Avoid having the signal arrive at a bad time, if possible. */ 1N/A * We should warn if HINT_STRICT_REFS, but without 1N/A * access to a known hint bit in a known OP, we can't 1N/A * tell whether HINT_STRICT_REFS is in force or not. 1N/A#
endif /* !PERL_MICRO */ 1N/A /* HV_badAMAGIC_on(Sv_STASH(sv)); */ 1N/A /* we are in an iteration so the hash cannot be empty */ 1N/A /* no xhv_eiter so now use FIRSTKEY */ 1N/A /* there is a SCALAR method that we can call */ 1N/A /* set or clear breakpoint in the relevant control op */ 1N/A if (*s ==
'*' && s[
1])
1N/A /* somebody else defined it for us */ 1N/A /* XXX Should we check that it hasn't changed? */ 1N/A * RenE<eacute> Descartes said "I think not." 1N/A * and vanished with a faint plop. 1N/A#
endif /* USE_LOCALE_COLLATE */ 1N/A/* Just clear the UTF-8 cache data. */ 1N/A case '\001':
/* ^A */ 1N/A case '\003':
/* ^C */ 1N/A case '\004':
/* ^D */ 1N/A case '\005':
/* ^E */ 1N/A /* will anyone ever use this? */ 1N/A case '\006':
/* ^F */ 1N/A case '\010':
/* ^H */ 1N/A case '\011':
/* ^I */ /* NOT \t in EBCDIC */ 1N/A case '\017':
/* ^O */ 1N/A case '\020':
/* ^P */ 1N/A case '\024':
/* ^T */ 1N/A case '\027':
/* ^W & $^WARNING_BITS */ 1N/A break;
/* don't do magic till later */ 1N/A /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */ 1N/A break;
/* don't do magic till later */ 1N/A break;
/* don't do magic till later */ 1N/A#
else /* HAS_SETGROUPS */ 1N/A#
endif /* HAS_SETGROUPS */ 1N/A break;
/* don't do magic till later */ 1N/A /* The BSDs don't show the argv[] in ps(1) output, they 1N/A * show a string from the process struct and provide 1N/A * the setproctitle() routine to manipulate that. */ 1N/A /* The leading "-" removes the "perl: " prefix, 1N/A * but not the "(perl) suffix from the ps(1) 1N/A * output, because that's what ps(1) shows if the 1N/A * argv[] is modified. */ 1N/A#
else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */ 1N/A /* This doesn't really work if you assume that 1N/A * $0 = 'foobar'; will wipe out 'perl' from the $0 1N/A * because in ps(1) output the result will be like 1N/A * sprintf("perl: %s (perl)", s) 1N/A * I guess this is a security feature: 1N/A * one (a user process) cannot get rid of the original name. 1N/A /* PL_origalen is set in perl_parse(). */ 1N/A /* Longer than original, will be truncated. */ 1N/A /* Shorter than original, will be padded. */ 1N/A /* Is the space counterintuitive? Yes. 1N/A * (You were expecting \0?) 1N/A * Does it work? Seems to. (In Linux 2.4.20 at least.) 1N/A#
endif /* USE_5005THREADS */ 1N/A#
endif /* USE_5005THREADS */ 1N/A /* Max number of items pushed there is 3*n or 4. We cannot fix 1N/A infinity, so we fix 4 (in fact 5): */ 1N/A /* sv_2cv is too complicated, try a simpler variant first: */ 1N/A /* Handler "died", for example to get out of a restart-able read(). 1N/A * Before we re-do that on its behalf re-enable the signal which was 1N/A * blocked by the system when we entered. 1N/A /* Not clear if this will work */ 1N/A#
endif /* !PERL_MICRO */ 1N/A /* If we're still on top of the stack, pop us off. (That condition 1N/A * will be satisfied if restore_magic was called explicitly, but *not* 1N/A * if it's being called via leave_scope.) 1N/A * The reason for doing this is that otherwise, things like sv_2cv() 1N/A * may leave alloc gunk on the savestack, and some code 1N/A * (e.g. sighandler) doesn't expect that... 1N/A /* cxstack_ix-- Not needed, die already unwound it. */