This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix -Wwrite-string warnings in cygwin.c
[perl5.git] / cygwin / cygwin.c
CommitLineData
5db16f6a
FE
1/*
2 * Cygwin extras
3 */
4
5#include "EXTERN.h"
6#include "perl.h"
7#undef USE_DYNAMIC_LOADING
8#include "XSUB.h"
9
6b49d266 10#include <unistd.h>
b4bcd662 11#include <process.h>
49fd6edc 12#include <sys/cygwin.h>
a25ce5f3 13#include <mntent.h>
6d7e4387 14#include <alloca.h>
9fb265f7 15#include <dlfcn.h>
5db16f6a 16
b4bcd662
GS
17/*
18 * pp_system() implemented via spawn()
19 * - more efficient and useful when embedding Perl in non-Cygwin apps
20 * - code mostly borrowed from djgpp.c
21 */
22static int
23do_spawnvp (const char *path, const char * const *argv)
24{
acfe0abc 25 dTHX;
b4bcd662
GS
26 Sigsave_t ihand,qhand;
27 int childpid, result, status;
28
ec1aec95
YST
29 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &ihand);
30 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
b4bcd662
GS
31 childpid = spawnvp(_P_NOWAIT,path,argv);
32 if (childpid < 0) {
33 status = -1;
411caa50 34 if(ckWARN(WARN_EXEC))
f98bc0c6 35 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn \"%s\": %s",
b4bcd662 36 path,Strerror (errno));
b4bcd662
GS
37 } else {
38 do {
39 result = wait4pid(childpid, &status, 0);
40 } while (result == -1 && errno == EINTR);
41 if(result < 0)
42 status = -1;
43 }
44 (void)rsignal_restore(SIGINT, &ihand);
45 (void)rsignal_restore(SIGQUIT, &qhand);
46 return status;
47}
48
49int
50do_aspawn (SV *really, void **mark, void **sp)
51{
acfe0abc 52 dTHX;
b4bcd662 53 int rc;
a4ec4e68
JHR
54 char const **a;
55 char *tmps,**argv;
56 STRLEN n_a;
b4bcd662
GS
57
58 if (sp<=mark)
59 return -1;
a4ec4e68
JHR
60 argv=(char**) alloca ((sp-mark+3)*sizeof (char*));
61 a=(char const **)argv;
b4bcd662
GS
62
63 while (++mark <= sp)
64 if (*mark)
667e2948 65 *a++ = SvPVx((SV *)*mark, n_a);
b4bcd662
GS
66 else
67 *a++ = "";
dfe169ee 68 *a = (char*)NULL;
b4bcd662
GS
69
70 if (argv[0][0] != '/' && argv[0][0] != '\\'
71 && !(argv[0][0] && argv[0][1] == ':'
72 && (argv[0][2] == '/' || argv[0][2] != '\\'))
73 ) /* will swawnvp use PATH? */
74 TAINT_ENV(); /* testing IFS here is overkill, probably */
75
76 if (really && *(tmps = SvPV(really, n_a)))
77 rc=do_spawnvp (tmps,(const char * const *)argv);
78 else
79 rc=do_spawnvp (argv[0],(const char *const *)argv);
80
81 return rc;
82}
83
84int
85do_spawn (char *cmd)
86{
acfe0abc 87 dTHX;
3f5211dd 88 char const **a;
a4ec4e68
JHR
89 char *s;
90 char const *metachars = "$&*(){}[]'\";\\?>|<~`\n";
b4bcd662
GS
91 const char *command[4];
92
93 while (*cmd && isSPACE(*cmd))
94 cmd++;
95
96 if (strnEQ (cmd,"/bin/sh",7) && isSPACE (cmd[7]))
97 cmd+=5;
98
99 /* save an extra exec if possible */
100 /* see if there are shell metacharacters in it */
101 if (strstr (cmd,"..."))
102 goto doshell;
103 if (*cmd=='.' && isSPACE (cmd[1]))
104 goto doshell;
105 if (strnEQ (cmd,"exec",4) && isSPACE (cmd[4]))
106 goto doshell;
107 for (s=cmd; *s && isALPHA (*s); s++) ; /* catch VAR=val gizmo */
108 if (*s=='=')
109 goto doshell;
110
111 for (s=cmd; *s; s++)
112 if (strchr (metachars,*s))
113 {
114 if (*s=='\n' && s[1]=='\0')
115 {
116 *s='\0';
117 break;
118 }
119 doshell:
120 command[0] = "sh";
121 command[1] = "-c";
122 command[2] = cmd;
123 command[3] = NULL;
124
125 return do_spawnvp("sh",command);
126 }
127
3f5211dd 128 Newx (PL_Argv,(s-cmd)/2+2,const char*);
b4bcd662
GS
129 PL_Cmd=savepvn (cmd,s-cmd);
130 a=PL_Argv;
131 for (s=PL_Cmd; *s;) {
132 while (*s && isSPACE (*s)) s++;
133 if (*s)
134 *(a++)=s;
135 while (*s && !isSPACE (*s)) s++;
136 if (*s)
137 *s++='\0';
138 }
dfe169ee 139 *a = (char*)NULL;
b4bcd662
GS
140 if (!PL_Argv[0])
141 return -1;
142
143 return do_spawnvp(PL_Argv[0],(const char * const *)PL_Argv);
144}
5db16f6a
FE
145
146/* see also Cwd.pm */
5db16f6a
FE
147XS(Cygwin_cwd)
148{
149 dXSARGS;
150 char *cwd;
151
482150a7
JH
152 /* See http://rt.perl.org/rt3/Ticket/Display.html?id=38628
153 There is Cwd->cwd() usage in the wild, and previous versions didn't die.
154 */
155 if(items > 1)
5db16f6a 156 Perl_croak(aTHX_ "Usage: Cwd::cwd()");
47dafe4d 157 if((cwd = getcwd(NULL, -1))) {
5db16f6a 158 ST(0) = sv_2mortal(newSVpv(cwd, 0));
a236cecb 159 free(cwd);
6be3b590
JH
160#ifndef INCOMPLETE_TAINTS
161 SvTAINTED_on(ST(0));
162#endif
5db16f6a
FE
163 XSRETURN(1);
164 }
165 XSRETURN_UNDEF;
166}
167
49fd6edc
YST
168XS(XS_Cygwin_pid_to_winpid)
169{
170 dXSARGS;
d2dc0126
YST
171 dXSTARG;
172 pid_t pid, RETVAL;
173
49fd6edc
YST
174 if (items != 1)
175 Perl_croak(aTHX_ "Usage: Cygwin::pid_to_winpid(pid)");
d2dc0126
YST
176
177 pid = (pid_t)SvIV(ST(0));
178
49fd6edc
YST
179 if ((RETVAL = cygwin_internal(CW_CYGWIN_PID_TO_WINPID, pid)) > 0) {
180 XSprePUSH; PUSHi((IV)RETVAL);
181 XSRETURN(1);
182 }
183 XSRETURN_UNDEF;
184}
185
49fd6edc
YST
186XS(XS_Cygwin_winpid_to_pid)
187{
188 dXSARGS;
d2dc0126
YST
189 dXSTARG;
190 pid_t pid, RETVAL;
191
49fd6edc
YST
192 if (items != 1)
193 Perl_croak(aTHX_ "Usage: Cygwin::winpid_to_pid(pid)");
d2dc0126
YST
194
195 pid = (pid_t)SvIV(ST(0));
196
49fd6edc
YST
197 if ((RETVAL = cygwin32_winpid_to_pid(pid)) > 0) {
198 XSprePUSH; PUSHi((IV)RETVAL);
199 XSRETURN(1);
200 }
201 XSRETURN_UNDEF;
202}
203
15414d2b
RU
204XS(XS_Cygwin_win_to_posix_path)
205{
206 dXSARGS;
207 int absolute_flag = 0;
208 STRLEN len;
209 int err;
210 char *pathname, *buf;
211
212 if (items < 1 || items > 2)
213 Perl_croak(aTHX_ "Usage: Cygwin::win_to_posix_path(pathname, [absolute])");
214
215 pathname = SvPV(ST(0), len);
216 if (items == 2)
217 absolute_flag = SvTRUE(ST(1));
218
219 if (!len)
220 Perl_croak(aTHX_ "can't convert empty path");
221 buf = (char *) safemalloc (len + 260 + 1001);
222
223 if (absolute_flag)
224 err = cygwin_conv_to_full_posix_path(pathname, buf);
225 else
226 err = cygwin_conv_to_posix_path(pathname, buf);
227 if (!err) {
228 ST(0) = sv_2mortal(newSVpv(buf, 0));
229 safefree(buf);
230 XSRETURN(1);
231 } else {
232 safefree(buf);
233 XSRETURN_UNDEF;
234 }
235}
236
237XS(XS_Cygwin_posix_to_win_path)
238{
239 dXSARGS;
240 int absolute_flag = 0;
241 STRLEN len;
242 int err;
243 char *pathname, *buf;
244
245 if (items < 1 || items > 2)
246 Perl_croak(aTHX_ "Usage: Cygwin::posix_to_win_path(pathname, [absolute])");
247
248 pathname = SvPV(ST(0), len);
249 if (items == 2)
250 absolute_flag = SvTRUE(ST(1));
251
252 if (!len)
253 Perl_croak(aTHX_ "can't convert empty path");
254 buf = (char *) safemalloc(len + 260 + 1001);
255
256 if (absolute_flag)
257 err = cygwin_conv_to_full_win32_path(pathname, buf);
258 else
259 err = cygwin_conv_to_win32_path(pathname, buf);
260 if (!err) {
261 ST(0) = sv_2mortal(newSVpv(buf, 0));
262 safefree(buf);
263 XSRETURN(1);
264 } else {
265 safefree(buf);
266 XSRETURN_UNDEF;
267 }
268}
269
a25ce5f3
RU
270XS(XS_Cygwin_mount_table)
271{
272 dXSARGS;
273 struct mntent *mnt;
274
275 if (items != 0)
276 Perl_croak(aTHX_ "Usage: Cygwin::mount_table");
277 /* => array of [mnt_dir mnt_fsname mnt_type mnt_opts] */
278
279 setmntent (0, 0);
280 while ((mnt = getmntent (0))) {
281 AV* av = newAV();
282 av_push(av, newSVpvn(mnt->mnt_dir, strlen(mnt->mnt_dir)));
283 av_push(av, newSVpvn(mnt->mnt_fsname, strlen(mnt->mnt_fsname)));
284 av_push(av, newSVpvn(mnt->mnt_type, strlen(mnt->mnt_type)));
285 av_push(av, newSVpvn(mnt->mnt_opts, strlen(mnt->mnt_opts)));
286 XPUSHs(sv_2mortal(newRV_noinc((SV*)av)));
287 }
288 endmntent (0);
289 PUTBACK;
290}
291
292XS(XS_Cygwin_mount_flags)
293{
294 dXSARGS;
295 char *pathname;
296 char flags[260];
297
298 if (items != 1)
74dc058d 299 Perl_croak(aTHX_ "Usage: Cygwin::mount_flags(mnt_dir|'/cygwin')");
a25ce5f3
RU
300
301 pathname = SvPV_nolen(ST(0));
74dc058d
JH
302
303 /* TODO: Check for cygdrive registry setting,
304 * and then use CW_GET_CYGDRIVE_INFO
a25ce5f3
RU
305 */
306 if (!strcmp(pathname, "/cygdrive")) {
307 char user[260];
308 char system[260];
309 char user_flags[260];
310 char system_flags[260];
74dc058d 311
a25ce5f3
RU
312 cygwin_internal (CW_GET_CYGDRIVE_INFO, user, system, user_flags,
313 system_flags);
74dc058d
JH
314
315 if (strlen(user) > 0) {
316 sprintf(flags, "%s,cygdrive,%s", user_flags, user);
317 } else {
318 sprintf(flags, "%s,cygdrive,%s", system_flags, system);
319 }
320
a25ce5f3
RU
321 ST(0) = sv_2mortal(newSVpv(flags, 0));
322 XSRETURN(1);
74dc058d 323
a25ce5f3
RU
324 } else {
325 struct mntent *mnt;
326 setmntent (0, 0);
327 while ((mnt = getmntent (0))) {
328 if (!strcmp(pathname, mnt->mnt_dir)) {
329 strcpy(flags, mnt->mnt_type);
330 if (strlen(mnt->mnt_opts) > 0) {
331 strcat(flags, ",");
332 strcat(flags, mnt->mnt_opts);
333 }
334 break;
335 }
336 }
337 endmntent (0);
338 ST(0) = sv_2mortal(newSVpv(flags, 0));
339 XSRETURN(1);
340 }
341}
342
15414d2b
RU
343XS(XS_Cygwin_is_binmount)
344{
345 dXSARGS;
346 char *pathname;
347
348 if (items != 1)
349 Perl_croak(aTHX_ "Usage: Cygwin::is_binmount(pathname)");
350
351 pathname = SvPV_nolen(ST(0));
352
353 ST(0) = boolSV(cygwin_internal(CW_GET_BINMODE, pathname));
354 XSRETURN(1);
355}
356
5db16f6a
FE
357void
358init_os_extras(void)
359{
5db16f6a 360 dTHX;
a4ec4e68 361 char const *file = __FILE__;
9fb265f7 362 void *handle;
5db16f6a
FE
363
364 newXS("Cwd::cwd", Cygwin_cwd, file);
15414d2b
RU
365 newXSproto("Cygwin::winpid_to_pid", XS_Cygwin_winpid_to_pid, file, "$");
366 newXSproto("Cygwin::pid_to_winpid", XS_Cygwin_pid_to_winpid, file, "$");
367 newXSproto("Cygwin::win_to_posix_path", XS_Cygwin_win_to_posix_path, file, "$;$");
368 newXSproto("Cygwin::posix_to_win_path", XS_Cygwin_posix_to_win_path, file, "$;$");
a25ce5f3
RU
369 newXSproto("Cygwin::mount_table", XS_Cygwin_mount_table, file, "");
370 newXSproto("Cygwin::mount_flags", XS_Cygwin_mount_flags, file, "$");
15414d2b 371 newXSproto("Cygwin::is_binmount", XS_Cygwin_is_binmount, file, "$");
78ff2d7b 372
9fb265f7
JD
373 /* Initialize Win32CORE if it has been statically linked. */
374 handle = dlopen(NULL, RTLD_LAZY);
375 if (handle) {
376 void (*pfn_init)(pTHX);
377 pfn_init = (void (*)(pTHX))dlsym(handle, "init_Win32CORE");
378 if (pfn_init)
379 pfn_init(aTHX);
380 dlclose(handle);
78ff2d7b 381 }
5db16f6a 382}