perl
view release on metacpan or search on metacpan
/* else a value has been assigned manually, so do nothing */
}
break;
case '<':
sv_setuid(sv, PerlProc_getuid());
break;
case '>':
sv_setuid(sv, PerlProc_geteuid());
break;
case '(':
sv_setgid(sv, PerlProc_getgid());
goto add_groups;
case ')':
sv_setgid(sv, PerlProc_getegid());
add_groups:
#ifdef HAS_GETGROUPS
{
Groups_t *gary = NULL;
I32 num_groups = getgroups(0, gary);
if (num_groups > 0) {
I32 i;
Newx(gary, num_groups, Groups_t);
num_groups = getgroups(num_groups, gary);
for (i = 0; i < num_groups; i++)
sv_catpvf(sv, " %" IVdf, (IV)gary[i]);
Safefree(gary);
}
}
/*
Set this to avoid warnings when the SV is used as a number.
Avoid setting the public IOK flag so that serializers will
use the PV.
*/
(void)SvIOKp_on(sv); /* what a wonderful hack! */
#endif
break;
case '0':
break;
}
return 0;
set_undef:
sv_set_undef(sv);
return 0;
}
int
Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
{
struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
PERL_ARGS_ASSERT_MAGIC_GETUVAR;
if (uf && uf->uf_val)
(*uf->uf_val)(aTHX_ uf->uf_index, sv);
return 0;
}
int
Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
{
STRLEN len = 0, klen;
const char *key;
const char *s = "";
SV *keysv = MgSV(mg);
if (keysv == NULL) {
key = mg->mg_ptr;
klen = mg->mg_len;
}
else {
if (!sv_utf8_downgrade(keysv, /* fail_ok */ TRUE)) {
ck_warner_d(packWARN(WARN_UTF8), "Wide character in %s", "setenv key (encoding to utf8)");
}
key = SvPV_const(keysv,klen);
}
PERL_ARGS_ASSERT_MAGIC_SETENV;
SvGETMAGIC(sv);
if (SvOK(sv)) {
/* defined environment variables are byte strings; unfortunately
there is no SvPVbyte_force_nomg(), so we must do this piecewise */
(void)SvPV_force_nomg_nolen(sv);
(void)sv_utf8_downgrade(sv, /* fail_ok */ TRUE);
if (SvUTF8(sv)) {
ck_warner_d(packWARN(WARN_UTF8), "Wide character in %s", "setenv");
SvUTF8_off(sv);
}
s = SvPVX(sv);
len = SvCUR(sv);
}
my_setenv(key, s); /* does the deed */
#ifdef DYNAMIC_ENV_FETCH
/* We just undefd an environment var. Is a replacement */
/* waiting in the wings? */
if (!len) {
SV ** const valp = hv_fetch(GvHVn(PL_envgv), key, klen, FALSE);
if (valp)
s = SvOK(*valp) ? SvPV_const(*valp, len) : "";
}
#endif
#if !defined(OS2) && !defined(WIN32)
/* And you'll never guess what the dog had */
/* in its mouth... */
if (TAINTING_get) {
MgTAINTEDDIR_off(mg);
#ifdef VMS
if (s && memEQs(key, klen, "DCL$PATH")) {
char pathbuf[256], eltbuf[256], *cp, *elt;
int i = 0, j = 0;
my_strlcpy(eltbuf, s, sizeof(eltbuf));
elt = eltbuf;
do { /* DCL$PATH may be a search list */
while (1) { /* as may dev portion of any element */
if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
if ( *(cp+1) == '.' || *(cp+1) == '-' ||
cando_by_name(S_IWUSR,0,elt) ) {
MgTAINTEDDIR_on(mg);
return 0;
}
}
if ((cp = strchr(elt, ':')) != NULL)
*cp = '\0';
if (my_trnlnm(elt, eltbuf, j++))
elt = eltbuf;
else
break;
}
j = 0;
} while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
}
#endif /* VMS */
if (s && memEQs(key, klen, "PATH")) {
const char * const strend = s + len;
#ifdef __VMS /* Hmm. How do we get $Config{path_sep} from C? */
const char path_sep = PL_perllib_sep;
#else
const char path_sep = ':';
#endif
#ifndef __VMS
/* Does this apply for VMS?
* Empty PATH on linux is treated same as ".", which is forbidden
* under taint. So check if the PATH variable is empty. */
if (!len) {
MgTAINTEDDIR_on(mg);
return 0;
}
#endif
/* set MGf_TAINTEDDIR if any component of the new path is
* relative or world-writeable */
while (s < strend) {
char tmpbuf[256];
Stat_t st;
I32 i;
s = delimcpy_no_escape(tmpbuf, tmpbuf + sizeof tmpbuf,
s, strend, path_sep, &i);
s++;
if (i >= (I32)sizeof tmpbuf /* too long -- assume the worst */
#ifdef __VMS
/* no colon thus no device name -- assume relative path */
|| (PL_perllib_sep != ':' && !strchr(tmpbuf, ':'))
/* Using Unix separator, e.g. under bash, so act line Unix */
|| (PL_perllib_sep == ':' && *tmpbuf != '/')
#else
|| *tmpbuf != '/' /* no starting slash -- assume relative path */
|| s == strend /* trailing empty component -- same as "." */
#endif
|| (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
MgTAINTEDDIR_on(mg);
return 0;
}
}
}
}
#endif /* neither OS2 nor WIN32 */
return 0;
}
int
Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
{
PERL_ARGS_ASSERT_MAGIC_CLEARENV;
PERL_UNUSED_ARG(sv);
my_setenv(MgPV_nolen_const(mg),NULL);
return 0;
}
int
Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
{
PERL_ARGS_ASSERT_MAGIC_SET_ALL_ENV;
PERL_UNUSED_ARG(mg);
#if defined(VMS)
die("Can't make list assignment to %%ENV on this system");
#else
if (PL_localizing) {
HE* entry;
my_clearenv();
hv_iterinit(MUTABLE_HV(sv));
while ((entry = hv_iternext(MUTABLE_HV(sv)))) {
I32 keylen;
my_setenv(hv_iterkey(entry, &keylen),
SvPV_nolen_const(hv_iterval(MUTABLE_HV(sv), entry)));
}
}
#endif
return 0;
}
int
Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
{
PERL_ARGS_ASSERT_MAGIC_CLEAR_ALL_ENV;
PERL_UNUSED_ARG(sv);
PERL_UNUSED_ARG(mg);
#if defined(VMS)
die("Can't make list assignment to %%ENV on this system");
#else
my_clearenv();
#endif
return 0;
}
#ifdef HAS_SIGPROCMASK
static void
restore_sigmask(pTHX_ SV *save_sv)
{
const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
(void)sigprocmask(SIG_SETMASK, ossetp, NULL);
}
#endif
int
Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
{
/* Are we fetching a signal entry? */
int i = (I16)mg->mg_private;
PERL_ARGS_ASSERT_MAGIC_GETSIG;
if (!i) {
STRLEN siglen;
const char * sig = MgPV_const(mg, siglen);
mg->mg_private = i = whichsig_pvn(sig, siglen);
}
if (i > 0) {
if(PL_psig_ptr[i])
sv_setsv(sv,PL_psig_ptr[i]);
else {
Sighandler_t sigstate = rsignal_state(i);
#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
if (PL_sig_handlers_initted && PL_sig_ignoring[i])
sigstate = SIG_IGN;
#endif
#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
if (PL_sig_handlers_initted && PL_sig_defaulting[i])
sigstate = SIG_DFL;
#endif
/* cache state so we don't fetch it again */
if(sigstate == (Sighandler_t) SIG_IGN)
sv_setpvs(sv,"IGNORE");
else
( run in 0.907 second using v1.01-cache-2.11-cpan-39bf76dae61 )