This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Remove use of dVAR in core
[perl5.git] / cygwin / cygwin.c
1 /*
2  * Cygwin extras
3  */
4
5 #define PERLIO_NOT_STDIO 0
6 #include "EXTERN.h"
7 #include "perl.h"
8 #undef USE_DYNAMIC_LOADING
9 #include "XSUB.h"
10
11 #include <unistd.h>
12 #include <process.h>
13 #include <sys/cygwin.h>
14 #include <cygwin/version.h>
15 #include <mntent.h>
16 #include <alloca.h>
17 #include <dlfcn.h>
18 #if (CYGWIN_VERSION_API_MINOR >= 181)
19 #include <wchar.h>
20 #endif
21
22 /*
23  * pp_system() implemented via spawn()
24  * - more efficient and useful when embedding Perl in non-Cygwin apps
25  * - code mostly borrowed from djgpp.c
26  */
27 static int
28 do_spawnvp (const char *path, const char * const *argv)
29 {
30     dTHX;
31     Sigsave_t ihand,qhand;
32     int childpid, result, status;
33
34     rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &ihand);
35     rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
36     childpid = spawnvp(_P_NOWAIT,path,argv);
37     if (childpid < 0) {
38         status = -1;
39         if(ckWARN(WARN_EXEC))
40             Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn \"%s\": %s",
41                     path,Strerror (errno));
42     } else {
43         do {
44             result = wait4pid(childpid, &status, 0);
45         } while (result == -1 && errno == EINTR);
46         if(result < 0)
47             status = -1;
48     }
49     (void)rsignal_restore(SIGINT, &ihand);
50     (void)rsignal_restore(SIGQUIT, &qhand);
51     return status;
52 }
53
54 int
55 do_aspawn (SV *really, void **mark, void **sp)
56 {
57     dTHX;
58     int  rc;
59     char const **a;
60     char *tmps,**argv;
61     STRLEN n_a;
62
63     if (sp<=mark)
64         return -1;
65     argv=(char**) alloca ((sp-mark+3)*sizeof (char*));
66     a=(char const **)argv;
67
68     while (++mark <= sp)
69         if (*mark)
70             *a++ = SvPVx((SV *)*mark, n_a);
71         else
72             *a++ = "";
73     *a = (char*)NULL;
74
75     if (argv[0][0] != '/' && argv[0][0] != '\\'
76         && !(argv[0][0] && argv[0][1] == ':'
77         && (argv[0][2] == '/' || argv[0][2] != '\\'))
78      ) /* will swawnvp use PATH? */
79          TAINT_ENV();   /* testing IFS here is overkill, probably */
80
81     if (really && *(tmps = SvPV(really, n_a)))
82         rc=do_spawnvp (tmps,(const char * const *)argv);
83     else
84         rc=do_spawnvp (argv[0],(const char *const *)argv);
85
86     return rc;
87 }
88
89 int
90 do_spawn (char *cmd)
91 {
92     dTHX;
93     char const **argv, **a;
94     char *s;
95     char const *metachars = "$&*(){}[]'\";\\?>|<~`\n";
96     const char *command[4];
97     int result;
98
99     ENTER;
100     while (*cmd && isSPACE(*cmd))
101         cmd++;
102
103     if (strBEGINs (cmd,"/bin/sh") && isSPACE (cmd[7]))
104         cmd+=5;
105
106     /* save an extra exec if possible */
107     /* see if there are shell metacharacters in it */
108     if (strstr (cmd,"..."))
109         goto doshell;
110     if (*cmd=='.' && isSPACE (cmd[1]))
111         goto doshell;
112     if (strBEGINs (cmd,"exec") && isSPACE (cmd[4]))
113         goto doshell;
114     for (s=cmd; *s && isALPHA (*s); s++) ;      /* catch VAR=val gizmo */
115     if (*s=='=')
116         goto doshell;
117
118     for (s=cmd; *s; s++)
119         if (strchr (metachars,*s))
120         {
121             if (*s=='\n' && s[1]=='\0')
122             {
123                 *s='\0';
124                 break;
125             }
126         doshell:
127             command[0] = "sh";
128             command[1] = "-c";
129             command[2] = cmd;
130             command[3] = NULL;
131
132             result = do_spawnvp("sh",command);
133             goto leave;
134         }
135
136     Newx (argv, (s-cmd)/2+2, const char*);
137     SAVEFREEPV(argv);
138     cmd=savepvn (cmd,s-cmd);
139     SAVEFREEPV(cmd);
140     a=argv;
141     for (s=cmd; *s;) {
142         while (*s && isSPACE (*s)) s++;
143         if (*s)
144             *(a++)=s;
145         while (*s && !isSPACE (*s)) s++;
146         if (*s)
147             *s++='\0';
148     }
149     *a = (char*)NULL;
150     if (!argv[0])
151         result = -1;
152     else
153         result = do_spawnvp(argv[0],(const char * const *)argv);
154 leave:
155     LEAVE;
156     return result;
157 }
158
159 #if (CYGWIN_VERSION_API_MINOR >= 181)
160 char*
161 wide_to_utf8(const wchar_t *wbuf)
162 {
163     char *buf;
164     int wlen = 0;
165     char *oldlocale;
166
167     /* Here and elsewhere in this file, we have a critical section to prevent
168      * another thread from changing the locale out from under us.  XXX But why
169      * not just use uvchr_to_utf8? */
170     LOCALE_LOCK;
171
172     oldlocale = setlocale(LC_CTYPE, NULL);
173     setlocale(LC_CTYPE, "utf-8");
174
175     /* uvchr_to_utf8(buf, chr) or Encoding::_bytes_to_utf8(sv, "UCS-2BE"); */
176     wlen = wcsrtombs(NULL, (const wchar_t **)&wbuf, wlen, NULL);
177     buf = (char *) safemalloc(wlen+1);
178     wcsrtombs(buf, (const wchar_t **)&wbuf, wlen, NULL);
179
180     if (oldlocale) setlocale(LC_CTYPE, oldlocale);
181     else setlocale(LC_CTYPE, "C");
182
183     LOCALE_UNLOCK;
184
185     return buf;
186 }
187
188 wchar_t*
189 utf8_to_wide(const char *buf)
190 {
191     wchar_t *wbuf;
192     mbstate_t mbs;
193     char *oldlocale;
194     int wlen = sizeof(wchar_t)*strlen(buf);
195
196     LOCALE_LOCK;
197
198     oldlocale = setlocale(LC_CTYPE, NULL);
199
200     setlocale(LC_CTYPE, "utf-8");
201     wbuf = (wchar_t *) safemalloc(wlen);
202     /* utf8_to_uvchr_buf(pathname, pathname + wlen, wpath) or Encoding::_utf8_to_bytes(sv, "UCS-2BE"); */
203     wlen = mbsrtowcs(wbuf, (const char**)&buf, wlen, &mbs);
204
205     if (oldlocale) setlocale(LC_CTYPE, oldlocale);
206     else setlocale(LC_CTYPE, "C");
207
208     LOCALE_UNLOCK;
209
210     return wbuf;
211 }
212 #endif /* cygwin 1.7 */
213
214 /* see also Cwd.pm */
215 XS(Cygwin_cwd)
216 {
217     dXSARGS;
218     char *cwd;
219
220     /* See https://github.com/Perl/perl5/issues/8345
221        There is Cwd->cwd() usage in the wild, and previous versions didn't die.
222      */
223     if(items > 1)
224         Perl_croak(aTHX_ "Usage: Cwd::cwd()");
225     if((cwd = getcwd(NULL, -1))) {
226         ST(0) = sv_2mortal(newSVpv(cwd, 0));
227         free(cwd);
228         SvTAINTED_on(ST(0));
229         XSRETURN(1);
230     }
231     XSRETURN_UNDEF;
232 }
233
234 XS(XS_Cygwin_pid_to_winpid)
235 {
236     dXSARGS;
237     dXSTARG;
238     pid_t pid, RETVAL;
239
240     if (items != 1)
241         Perl_croak(aTHX_ "Usage: Cygwin::pid_to_winpid(pid)");
242
243     pid = (pid_t)SvIV(ST(0));
244
245     if ((RETVAL = cygwin_internal(CW_CYGWIN_PID_TO_WINPID, pid)) > 0) {
246         XSprePUSH; PUSHi((IV)RETVAL);
247         XSRETURN(1);
248     }
249     XSRETURN_UNDEF;
250 }
251
252 XS(XS_Cygwin_winpid_to_pid)
253 {
254     dXSARGS;
255     dXSTARG;
256     pid_t pid, RETVAL;
257
258     if (items != 1)
259         Perl_croak(aTHX_ "Usage: Cygwin::winpid_to_pid(pid)");
260
261     pid = (pid_t)SvIV(ST(0));
262
263 #if (CYGWIN_VERSION_API_MINOR >= 181)
264     RETVAL = cygwin_winpid_to_pid(pid);
265 #else
266     RETVAL = cygwin32_winpid_to_pid(pid);
267 #endif
268     if (RETVAL > 0) {
269         XSprePUSH; PUSHi((IV)RETVAL);
270         XSRETURN(1);
271     }
272     XSRETURN_UNDEF;
273 }
274
275 XS(XS_Cygwin_win_to_posix_path)
276
277 {
278     dXSARGS;
279     int absolute_flag = 0;
280     STRLEN len;
281     int err = 0;
282     char *src_path;
283     char *posix_path;
284     int isutf8 = 0;
285
286     if (items < 1 || items > 2)
287         Perl_croak(aTHX_ "Usage: Cygwin::win_to_posix_path(pathname, [absolute])");
288
289     src_path = SvPV(ST(0), len);
290     if (items == 2)
291         absolute_flag = SvTRUE(ST(1));
292
293     if (!len)
294         Perl_croak(aTHX_ "can't convert empty path");
295     isutf8 = SvUTF8(ST(0));
296
297 #if (CYGWIN_VERSION_API_MINOR >= 181)
298     /* Check utf8 flag and use wide api then.
299        Size calculation: On overflow let cygwin_conv_path calculate the final size.
300      */
301     if (isutf8) {
302         int what = absolute_flag ? CCP_WIN_W_TO_POSIX : CCP_WIN_W_TO_POSIX | CCP_RELATIVE;
303         STRLEN wlen = sizeof(wchar_t)*(len + 260 + 1001);
304         wchar_t *wpath = (wchar_t *) safemalloc(sizeof(wchar_t)*len);
305         wchar_t *wbuf = (wchar_t *) safemalloc(wlen);
306         if (!IN_BYTES) {
307             mbstate_t mbs;
308             char *oldlocale;
309
310             LOCALE_LOCK;
311
312             oldlocale = setlocale(LC_CTYPE, NULL);
313             setlocale(LC_CTYPE, "utf-8");
314             /* utf8_to_uvchr_buf(src_path, src_path + wlen, wpath) or Encoding::_utf8_to_bytes(sv, "UCS-2BE"); */
315             wlen = mbsrtowcs(wpath, (const char**)&src_path, wlen, &mbs);
316             if (wlen > 0)
317                 err = cygwin_conv_path(what, wpath, wbuf, wlen);
318             if (oldlocale) setlocale(LC_CTYPE, oldlocale);
319             else setlocale(LC_CTYPE, "C");
320
321             LOCALE_UNLOCK;
322         } else { /* use bytes; assume already ucs-2 encoded bytestream */
323             err = cygwin_conv_path(what, src_path, wbuf, wlen);
324         }
325         if (err == ENOSPC) { /* our space assumption was wrong, not enough space */
326             int newlen = cygwin_conv_path(what, wpath, wbuf, 0);
327             wbuf = (wchar_t *) realloc(&wbuf, newlen);
328             err = cygwin_conv_path(what, wpath, wbuf, newlen);
329             wlen = newlen;
330         }
331         /* utf16_to_utf8(*p, *d, bytlen, *newlen) */
332         posix_path = (char *) safemalloc(wlen*3);
333         Perl_utf16_to_utf8(aTHX_ (U8*)&wpath, (U8*)posix_path, wlen*2, &len);
334         /*
335         wlen = wcsrtombs(NULL, (const wchar_t **)&wbuf, wlen, NULL);
336         posix_path = (char *) safemalloc(wlen+1);
337         wcsrtombs(posix_path, (const wchar_t **)&wbuf, wlen, NULL);
338         */
339     } else {
340         int what = absolute_flag ? CCP_WIN_A_TO_POSIX : CCP_WIN_A_TO_POSIX | CCP_RELATIVE;
341         posix_path = (char *) safemalloc (len + 260 + 1001);
342         err = cygwin_conv_path(what, src_path, posix_path, len + 260 + 1001);
343         if (err == ENOSPC) { /* our space assumption was wrong, not enough space */
344             int newlen = cygwin_conv_path(what, src_path, posix_path, 0);
345             posix_path = (char *) realloc(&posix_path, newlen);
346             err = cygwin_conv_path(what, src_path, posix_path, newlen);
347         }
348     }
349 #else
350     posix_path = (char *) safemalloc (len + 260 + 1001);
351     if (absolute_flag)
352         err = cygwin_conv_to_full_posix_path(src_path, posix_path);
353     else
354         err = cygwin_conv_to_posix_path(src_path, posix_path);
355 #endif
356     if (!err) {
357         EXTEND(SP, 1);
358         ST(0) = sv_2mortal(newSVpv(posix_path, 0));
359         if (isutf8) { /* src was utf-8, so result should also */
360             /* TODO: convert ANSI (local windows encoding) to utf-8 on cygwin-1.5 */
361             SvUTF8_on(ST(0));
362         }
363         safefree(posix_path);
364         XSRETURN(1);
365     } else {
366         safefree(posix_path);
367         XSRETURN_UNDEF;
368     }
369 }
370
371 XS(XS_Cygwin_posix_to_win_path)
372 {
373     dXSARGS;
374     int absolute_flag = 0;
375     STRLEN len;
376     int err = 0;
377     char *src_path, *win_path;
378     int isutf8 = 0;
379
380     if (items < 1 || items > 2)
381         Perl_croak(aTHX_ "Usage: Cygwin::posix_to_win_path(pathname, [absolute])");
382
383     src_path = SvPVx(ST(0), len);
384     if (items == 2)
385         absolute_flag = SvTRUE(ST(1));
386
387     if (!len)
388         Perl_croak(aTHX_ "can't convert empty path");
389     isutf8 = SvUTF8(ST(0));
390 #if (CYGWIN_VERSION_API_MINOR >= 181)
391     /* Check utf8 flag and use wide api then.
392        Size calculation: On overflow let cygwin_conv_path calculate the final size.
393      */
394     if (isutf8) {
395         int what = absolute_flag ? CCP_POSIX_TO_WIN_W : CCP_POSIX_TO_WIN_W | CCP_RELATIVE;
396         int wlen = sizeof(wchar_t)*(len + 260 + 1001);
397         wchar_t *wpath = (wchar_t *) safemalloc(sizeof(wchar_t)*len);
398         wchar_t *wbuf = (wchar_t *) safemalloc(wlen);
399         char *oldlocale;
400
401         LOCALE_LOCK;
402
403         oldlocale = setlocale(LC_CTYPE, NULL);
404         setlocale(LC_CTYPE, "utf-8");
405         if (!IN_BYTES) {
406             mbstate_t mbs;
407             /* utf8_to_uvchr_buf(src_path, src_path + wlen, wpath) or Encoding::_utf8_to_bytes(sv, "UCS-2BE"); */
408             wlen = mbsrtowcs(wpath, (const char**)&src_path, wlen, &mbs);
409             if (wlen > 0)
410                 err = cygwin_conv_path(what, wpath, wbuf, wlen);
411         } else { /* use bytes; assume already ucs-2 encoded bytestream */
412             err = cygwin_conv_path(what, src_path, wbuf, wlen);
413         }
414         if (err == ENOSPC) { /* our space assumption was wrong, not enough space */
415             int newlen = cygwin_conv_path(what, wpath, wbuf, 0);
416             wbuf = (wchar_t *) realloc(&wbuf, newlen);
417             err = cygwin_conv_path(what, wpath, wbuf, newlen);
418             wlen = newlen;
419         }
420         /* also see utf8.c: Perl_utf16_to_utf8() or Encoding::_bytes_to_utf8(sv, "UCS-2BE"); */
421         wlen = wcsrtombs(NULL, (const wchar_t **)&wbuf, wlen, NULL);
422         win_path = (char *) safemalloc(wlen+1);
423         wcsrtombs(win_path, (const wchar_t **)&wbuf, wlen, NULL);
424         if (oldlocale) setlocale(LC_CTYPE, oldlocale);
425         else setlocale(LC_CTYPE, "C");
426
427         LOCALE_UNLOCK;
428     } else {
429         int what = absolute_flag ? CCP_POSIX_TO_WIN_A : CCP_POSIX_TO_WIN_A | CCP_RELATIVE;
430         win_path = (char *) safemalloc(len + 260 + 1001);
431         err = cygwin_conv_path(what, src_path, win_path, len + 260 + 1001);
432         if (err == ENOSPC) { /* our space assumption was wrong, not enough space */
433             int newlen = cygwin_conv_path(what, src_path, win_path, 0);
434             win_path = (char *) realloc(&win_path, newlen);
435             err = cygwin_conv_path(what, src_path, win_path, newlen);
436         }
437     }
438 #else
439     if (isutf8)
440         Perl_warn(aTHX_ "can't convert utf8 path");
441     win_path = (char *) safemalloc(len + 260 + 1001);
442     if (absolute_flag)
443         err = cygwin_conv_to_full_win32_path(src_path, win_path);
444     else
445         err = cygwin_conv_to_win32_path(src_path, win_path);
446 #endif
447     if (!err) {
448         EXTEND(SP, 1);
449         ST(0) = sv_2mortal(newSVpv(win_path, 0));
450         if (isutf8) {
451             SvUTF8_on(ST(0));
452         }
453         safefree(win_path);
454         XSRETURN(1);
455     } else {
456         safefree(win_path);
457         XSRETURN_UNDEF;
458     }
459 }
460
461 XS(XS_Cygwin_mount_table)
462 {
463     dXSARGS;
464     struct mntent *mnt;
465
466     if (items != 0)
467         Perl_croak(aTHX_ "Usage: Cygwin::mount_table");
468     /* => array of [mnt_dir mnt_fsname mnt_type mnt_opts] */
469
470     setmntent (0, 0);
471     while ((mnt = getmntent (0))) {
472         AV* av = newAV();
473         av_push(av, newSVpvn(mnt->mnt_dir, strlen(mnt->mnt_dir)));
474         av_push(av, newSVpvn(mnt->mnt_fsname, strlen(mnt->mnt_fsname)));
475         av_push(av, newSVpvn(mnt->mnt_type, strlen(mnt->mnt_type)));
476         av_push(av, newSVpvn(mnt->mnt_opts, strlen(mnt->mnt_opts)));
477         XPUSHs(sv_2mortal(newRV_noinc((SV*)av)));
478     }
479     endmntent (0);
480     PUTBACK;
481 }
482
483 XS(XS_Cygwin_mount_flags)
484 {
485     dXSARGS;
486     char *pathname;
487     char flags[PATH_MAX];
488     flags[0] = '\0';
489
490     if (items != 1)
491         Perl_croak(aTHX_ "Usage: Cygwin::mount_flags( mnt_dir | '/cygdrive' )");
492
493     pathname = SvPV_nolen(ST(0));
494
495     if (strEQ(pathname, "/cygdrive")) {
496         char user[PATH_MAX];
497         char system[PATH_MAX];
498         char user_flags[PATH_MAX];
499         char system_flags[PATH_MAX];
500
501         cygwin_internal (CW_GET_CYGDRIVE_INFO, user, system,
502                          user_flags, system_flags);
503
504         if (strlen(user) > 0) {
505             sprintf(flags, "%s,cygdrive,%s", user_flags, user);
506         } else {
507             sprintf(flags, "%s,cygdrive,%s", system_flags, system);
508         }
509
510         ST(0) = sv_2mortal(newSVpv(flags, 0));
511         XSRETURN(1);
512
513     } else {
514         struct mntent *mnt;
515         int found = 0;
516         setmntent (0, 0);
517         while ((mnt = getmntent (0))) {
518             if (strEQ(pathname, mnt->mnt_dir)) {
519                 strcpy(flags, mnt->mnt_type);
520                 if (strlen(mnt->mnt_opts) > 0) {
521                     strcat(flags, ",");
522                     strcat(flags, mnt->mnt_opts);
523                 }
524                 found++;
525                 break;
526             }
527         }
528         endmntent (0);
529
530         /* Check if arg is the current volume moint point if not default,
531          * and then use CW_GET_CYGDRIVE_INFO also.
532          */
533         if (!found) {
534             char user[PATH_MAX];
535             char system[PATH_MAX];
536             char user_flags[PATH_MAX];
537             char system_flags[PATH_MAX];
538
539             cygwin_internal (CW_GET_CYGDRIVE_INFO, user, system,
540                              user_flags, system_flags);
541
542             if (strlen(user) > 0) {
543                 if (strNE(user,pathname)) {
544                     sprintf(flags, "%s,cygdrive,%s", user_flags, user);
545                     found++;
546                 }
547             } else {
548                 if (strNE(user,pathname)) {
549                     sprintf(flags, "%s,cygdrive,%s", system_flags, system);
550                     found++;
551                 }
552             }
553         }
554         if (found) {
555             ST(0) = sv_2mortal(newSVpv(flags, 0));
556             XSRETURN(1);
557         } else {
558             XSRETURN_UNDEF;
559         }
560     }
561 }
562
563 XS(XS_Cygwin_is_binmount)
564 {
565     dXSARGS;
566     char *pathname;
567
568     if (items != 1)
569         Perl_croak(aTHX_ "Usage: Cygwin::is_binmount(pathname)");
570
571     pathname = SvPV_nolen(ST(0));
572
573     ST(0) = boolSV(cygwin_internal(CW_GET_BINMODE, pathname));
574     XSRETURN(1);
575 }
576
577 XS(XS_Cygwin_sync_winenv){ cygwin_internal(CW_SYNC_WINENV); }
578
579 void
580 init_os_extras(void)
581 {
582     dTHX;
583     char const *file = __FILE__;
584     void *handle;
585
586     newXS("Cwd::cwd", Cygwin_cwd, file);
587     newXSproto("Cygwin::winpid_to_pid", XS_Cygwin_winpid_to_pid, file, "$");
588     newXSproto("Cygwin::pid_to_winpid", XS_Cygwin_pid_to_winpid, file, "$");
589     newXSproto("Cygwin::win_to_posix_path", XS_Cygwin_win_to_posix_path, file, "$;$");
590     newXSproto("Cygwin::posix_to_win_path", XS_Cygwin_posix_to_win_path, file, "$;$");
591     newXSproto("Cygwin::mount_table", XS_Cygwin_mount_table, file, "");
592     newXSproto("Cygwin::mount_flags", XS_Cygwin_mount_flags, file, "$");
593     newXSproto("Cygwin::is_binmount", XS_Cygwin_is_binmount, file, "$");
594     newXS("Cygwin::sync_winenv", XS_Cygwin_sync_winenv, file);
595
596     /* Initialize Win32CORE if it has been statically linked. */
597     handle = dlopen(NULL, RTLD_LAZY);
598     if (handle) {
599         void (*pfn_init)(pTHX);
600         pfn_init = (void (*)(pTHX))dlsym(handle, "init_Win32CORE");
601         if (pfn_init)
602             pfn_init(aTHX);
603         dlclose(handle);
604     }
605 }