add ~~x and x~~ overloads, deprecating ~~ overloads
[perl.git] / taint.c
1 /*    taint.c
2  *
3  *    Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,
4  *    2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
5  *
6  *    You may distribute under the terms of either the GNU General Public
7  *    License or the Artistic License, as specified in the README file.
8  *
9  */
10
11 /*
12  * '...we will have peace, when you and all your works have perished--and
13  *  the works of your dark master to whom you would deliver us.  You are a
14  *  liar, Saruman, and a corrupter of men's hearts.'       --Théoden
15  *
16  *     [p.580 of _The Lord of the Rings_, III/x: "The Voice of Saruman"]
17  */
18
19 /* This file contains a few functions for handling data tainting in Perl
20  */
21
22 #include "EXTERN.h"
23 #define PERL_IN_TAINT_C
24 #include "perl.h"
25
26 void
27 Perl_taint_proper(pTHX_ const char *f, const char *const s)
28 {
29 #if defined(HAS_SETEUID) && defined(DEBUGGING)
30     PERL_ARGS_ASSERT_TAINT_PROPER;
31
32     {
33         const Uid_t  uid = PerlProc_getuid();
34         const Uid_t euid = PerlProc_geteuid();
35
36 #if Uid_t_sign == 1 /* uid_t is unsigned. */
37         DEBUG_u(PerlIO_printf(Perl_debug_log,
38                               "%s %d %"UVuf" %"UVuf"\n",
39                               s, TAINT_get, (UV)uid, (UV)euid));
40 #else /* uid_t is signed (Uid_t_sign == -1), or don't know. */
41         DEBUG_u(PerlIO_printf(Perl_debug_log,
42                               "%s %d %"IVdf" %"IVdf"\n",
43                               s, TAINT_get, (IV)uid, (IV)euid));
44 #endif
45     }
46 #endif
47
48     if (TAINT_get) {
49         const char *ug;
50
51         if (!f)
52             f = PL_no_security;
53         if (PerlProc_getuid() != PerlProc_geteuid())
54             ug = " while running setuid";
55         else if (PerlProc_getgid() != PerlProc_getegid())
56             ug = " while running setgid";
57         else if (TAINT_WARN_get)
58             ug = " while running with -t switch";
59         else
60             ug = " while running with -T switch";
61
62         /* XXX because taint_proper adds extra format args, we can't
63          * get the caller to check properly; o we just silence the warning
64          * and hope the callers aren't naughty */
65         GCC_DIAG_IGNORE(-Wformat-nonliteral);
66         if (PL_unsafe || TAINT_WARN_get) {
67             Perl_ck_warner_d(aTHX_ packWARN(WARN_TAINT), f, s, ug);
68         }
69         else {
70             Perl_croak(aTHX_ f, s, ug);
71         }
72         GCC_DIAG_RESTORE;
73
74     }
75 }
76
77 void
78 Perl_taint_env(pTHX)
79 {
80     SV** svp;
81     MAGIC* mg;
82     const char* const *e;
83     static const char* const misc_env[] = {
84         "IFS",          /* most shells' inter-field separators */
85         "CDPATH",       /* ksh dain bramage #1 */
86         "ENV",          /* ksh dain bramage #2 */
87         "BASH_ENV",     /* bash dain bramage -- I guess it's contagious */
88 #ifdef WIN32
89         "PERL5SHELL",   /* used for system() on Windows */
90 #endif
91         NULL
92     };
93
94     /* Don't bother if there's no *ENV glob */
95     if (!PL_envgv)
96         return;
97     /* If there's no %ENV hash or if it's not magical, croak, because
98      * it probably doesn't reflect the actual environment */
99     if (!GvHV(PL_envgv) || !(SvRMAGICAL(GvHV(PL_envgv))
100             && mg_find((const SV *)GvHV(PL_envgv), PERL_MAGIC_env))) {
101         const bool was_tainted = TAINT_get;
102         const char * const name = GvENAME(PL_envgv);
103         TAINT;
104         if (strEQ(name,"ENV"))
105             /* hash alias */
106             taint_proper("%%ENV is aliased to %s%s", "another variable");
107         else
108             /* glob alias: report it in the error message */
109             taint_proper("%%ENV is aliased to %%%s%s", name);
110         /* this statement is reached under -t or -U */
111         TAINT_set(was_tainted);
112 #ifdef NO_TAINT_SUPPORT
113         PERL_UNUSED_VAR(was_tainted);
114 #endif
115     }
116
117 #ifdef VMS
118     {
119     int i = 0;
120     char name[10 + TYPE_DIGITS(int)] = "DCL$PATH";
121     STRLEN len = 8; /* strlen(name)  */
122
123     while (1) {
124         if (i)
125             len = my_sprintf(name,"DCL$PATH;%d", i);
126         svp = hv_fetch(GvHVn(PL_envgv), name, len, FALSE);
127         if (!svp || *svp == &PL_sv_undef)
128             break;
129         if (SvTAINTED(*svp)) {
130             TAINT;
131             taint_proper("Insecure %s%s", "$ENV{DCL$PATH}");
132         }
133         if ((mg = mg_find(*svp, PERL_MAGIC_envelem)) && MgTAINTEDDIR(mg)) {
134             TAINT;
135             taint_proper("Insecure directory in %s%s", "$ENV{DCL$PATH}");
136         }
137         i++;
138     }
139   }
140 #endif /* VMS */
141
142     svp = hv_fetchs(GvHVn(PL_envgv),"PATH",FALSE);
143     if (svp && *svp) {
144         if (SvTAINTED(*svp)) {
145             TAINT;
146             taint_proper("Insecure %s%s", "$ENV{PATH}");
147         }
148         if ((mg = mg_find(*svp, PERL_MAGIC_envelem)) && MgTAINTEDDIR(mg)) {
149             TAINT;
150             taint_proper("Insecure directory in %s%s", "$ENV{PATH}");
151         }
152     }
153
154 #ifndef VMS
155     /* tainted $TERM is okay if it contains no metachars */
156     svp = hv_fetchs(GvHVn(PL_envgv),"TERM",FALSE);
157     if (svp && *svp && SvTAINTED(*svp)) {
158         STRLEN len;
159         const bool was_tainted = TAINT_get;
160         const char *t = SvPV_const(*svp, len);
161         const char * const e = t + len;
162
163         TAINT_set(was_tainted);
164 #ifdef NO_TAINT_SUPPORT
165         PERL_UNUSED_VAR(was_tainted);
166 #endif
167         if (t < e && isWORDCHAR(*t))
168             t++;
169         while (t < e && (isWORDCHAR(*t) || strchr("-_.+", *t)))
170             t++;
171         if (t < e) {
172             TAINT;
173             taint_proper("Insecure $ENV{%s}%s", "TERM");
174         }
175     }
176 #endif /* !VMS */
177
178     for (e = misc_env; *e; e++) {
179         SV * const * const svp = hv_fetch(GvHVn(PL_envgv), *e, strlen(*e), FALSE);
180         if (svp && *svp != &PL_sv_undef && SvTAINTED(*svp)) {
181             TAINT;
182             taint_proper("Insecure $ENV{%s}%s", *e);
183         }
184     }
185 }
186
187 /*
188  * ex: set ts=8 sts=4 sw=4 et:
189  */