perl5.git.perl.org Git - perl5.git/blob

1 /* taint.c

2 *

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 */

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 */

19 /* This file contains a few functions for handling data tainting in Perl

20 */

22 #include "EXTERN.h"

23 #define PERL_IN_TAINT_C

24 #include "perl.h"

26 /*

27 =for apidoc taint_proper

29 Implements the L</TAINT_PROPER> macro, which you should generally use instead.

31 =cut

32 */

34 void

35 Perl_taint_proper(pTHX_ const char *f, const char *const s)

36 {

37 /* Don't use directly; instead use TAINT_PROPER

38 *

39 * Output a tainting violation, croaking unless we're just to warn.

40 * '_proper' is just to throw you off the scent */

42 #if defined(HAS_SETEUID) && defined(DEBUGGING)

43 PERL_ARGS_ASSERT_TAINT_PROPER;

45 {

46 const Uid_t uid = PerlProc_getuid();

47 const Uid_t euid = PerlProc_geteuid();

49 #if Uid_t_sign == 1 /* uid_t is unsigned. */

50 DEBUG_u(PerlIO_printf(Perl_debug_log,

51 "%s %d %" UVuf " %" UVuf "\n",

52 s, TAINT_get, (UV)uid, (UV)euid));

53 #else /* uid_t is signed (Uid_t_sign == -1), or don't know. */

54 DEBUG_u(PerlIO_printf(Perl_debug_log,

55 "%s %d %" IVdf " %" IVdf "\n",

56 s, TAINT_get, (IV)uid, (IV)euid));

57 #endif

58 }

59 #endif

61 if (TAINT_get) {

62 const char *ug;

64 if (!f)

65 f = PL_no_security;

66 if (PerlProc_getuid() != PerlProc_geteuid())

67 ug = " while running setuid";

68 else if (PerlProc_getgid() != PerlProc_getegid())

69 ug = " while running setgid";

70 else if (TAINT_WARN_get)

71 ug = " while running with -t switch";

72 else

73 ug = " while running with -T switch";

75 /* XXX because taint_proper adds extra format args, we can't

76 * get the caller to check properly; so we just silence the warning

77 * and hope the callers aren't naughty */

78 GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral);

79 if (PL_unsafe || TAINT_WARN_get) {

80 Perl_ck_warner_d(aTHX_ packWARN(WARN_TAINT), f, s, ug);

81 }

82 else {

83 Perl_croak(aTHX_ f, s, ug);

84 }

85 GCC_DIAG_RESTORE_STMT;

87 }

88 }

90 /*

91 =for apidoc taint_env

93 Implements the L</TAINT_ENV> macro, which you should generally use instead.

95 =cut

96 */

97 void

98 Perl_taint_env(pTHX)

99 {

100 /* Don't use directly; instead use TAINT_ENV */

101

102 SV** svp;

103 const char* const *e;

104 static const char* const misc_env[] = {

105 "IFS", /* most shells' inter-field separators */

106 "CDPATH", /* ksh dain bramage #1 */

107 "ENV", /* ksh dain bramage #2 */

108 "BASH_ENV", /* bash dain bramage -- I guess it's contagious */

109 #ifdef WIN32

110 "PERL5SHELL", /* used for system() on Windows */

111 #endif

112 NULL

113 };

114

115 /* Don't bother if there's no *ENV glob */

116 if (!PL_envgv)

117 return;

118 /* If there's no %ENV hash or if it's not magical, croak, because

119 * it probably doesn't reflect the actual environment */

120 if (!GvHV(PL_envgv) || !(SvRMAGICAL(GvHV(PL_envgv))

121 && mg_find((const SV *)GvHV(PL_envgv), PERL_MAGIC_env))) {

122 const bool was_tainted = TAINT_get;

123 const char * const name = GvENAME(PL_envgv);

124 TAINT;

125 if (strEQ(name,"ENV"))

126 /* hash alias */

127 taint_proper("%%ENV is aliased to %s%s", "another variable");

128 else

129 /* glob alias: report it in the error message */

130 taint_proper("%%ENV is aliased to %%%s%s", name);

131 /* this statement is reached under -t or -U */

132 TAINT_set(was_tainted);

133 #ifdef NO_TAINT_SUPPORT

134 PERL_UNUSED_VAR(was_tainted);

135 #endif

136 }

137

138 #ifdef VMS

139 {

140 int i = 0;

141 char name[10 + TYPE_DIGITS(int)] = "DCL$PATH";

142 STRLEN len = 8; /* strlen(name) */

143

144 while (1) {

145 MAGIC* mg;

146 if (i)

147 len = my_snprintf(name, sizeof name, "DCL$PATH;%d", i);

148 svp = hv_fetch(GvHVn(PL_envgv), name, len, FALSE);

149 if (!svp || *svp == &PL_sv_undef)

150 break;

151 if (SvTAINTED(*svp)) {

152 TAINT;

153 taint_proper("Insecure %s%s", "$ENV{DCL$PATH}");

154 }

155 if ((mg = mg_find(*svp, PERL_MAGIC_envelem)) && MgTAINTEDDIR(mg)) {

156 TAINT;

157 taint_proper("Insecure directory in %s%s", "$ENV{DCL$PATH}");

158 }

159 i++;

160 }

161 }

162 #endif /* VMS */

163

164 svp = hv_fetchs(GvHVn(PL_envgv),"PATH",FALSE);

165 if (svp && *svp) {

166 MAGIC* mg;

167 if (SvTAINTED(*svp)) {

168 TAINT;

169 taint_proper("Insecure %s%s", "$ENV{PATH}");

170 }

171 if ((mg = mg_find(*svp, PERL_MAGIC_envelem)) && MgTAINTEDDIR(mg)) {

172 TAINT;

173 taint_proper("Insecure directory in %s%s", "$ENV{PATH}");

174 }

175 }

176

177 #ifndef VMS

178 /* tainted $TERM is okay if it contains no metachars */

179 svp = hv_fetchs(GvHVn(PL_envgv),"TERM",FALSE);

180 if (svp && *svp && SvTAINTED(*svp)) {

181 STRLEN len;

182 const bool was_tainted = TAINT_get;

183 const char *t = SvPV_const(*svp, len);

184 const char * const e = t + len;

185

186 TAINT_set(was_tainted);

187 #ifdef NO_TAINT_SUPPORT

188 PERL_UNUSED_VAR(was_tainted);

189 #endif

190 if (t < e && isWORDCHAR(*t))

191 t++;

192 while (t < e && (isWORDCHAR(*t) || memCHRs("-_.+", *t)))

193 t++;

194 if (t < e) {

195 TAINT;

196 taint_proper("Insecure $ENV{%s}%s", "TERM");

197 }

198 }

199 #endif /* !VMS */

200

201 for (e = misc_env; *e; e++) {

202 SV * const * const svp = hv_fetch(GvHVn(PL_envgv), *e, strlen(*e), FALSE);

203 if (svp && *svp != &PL_sv_undef && SvTAINTED(*svp)) {

204 TAINT;

205 taint_proper("Insecure $ENV{%s}%s", *e);

206 }

207 }

208 }

209

210 /*

211 * ex: set ts=8 sts=4 sw=4 et:

212 */