Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

win32.c@ 3951

Visit:

Last change on this file since 3951 was 3181, checked in by bird, 19 years ago
perl 5.8.8
File size: 122.3 KB

Line
1	/* WIN32.C
2	*
3	* (c) 1995 Microsoft Corporation. All rights reserved.
4	* Developed by hip communications inc., http://info.hip.com/info/
5	* Portions (c) 1993 Intergraph Corporation. All rights reserved.
6	*
7	* You may distribute under the terms of either the GNU General Public
8	* License or the Artistic License, as specified in the README file.
9	*/
10	#define PERLIO_NOT_STDIO 0
11	#define WIN32_LEAN_AND_MEAN
12	#define WIN32IO_IS_STDIO
13	#include <tchar.h>
14	#ifdef __GNUC__
15	#define Win32_Winsock
16	#endif
17	#include <windows.h>
18	/* GCC-2.95.2/Mingw32-1.1 forgot the WINAPI on CommandLineToArgvW() */
19	#if defined(__MINGW32__) && (__MINGW32_MAJOR_VERSION==1)
20	# include <shellapi.h>
21	#else
22	LPWSTR* WINAPI CommandLineToArgvW(LPCWSTR lpCommandLine, int * pNumArgs);
23	#endif
24	#include <winnt.h>
25	#include <io.h>
26	#include <signal.h>
27
28	/* #include "config.h" */
29
30	#if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
31	#define PerlIO FILE
32	#endif
33
34	#include <sys/stat.h>
35	#include "EXTERN.h"
36	#include "perl.h"
37
38	#define NO_XSLOCKS
39	#define PERL_NO_GET_CONTEXT
40	#include "XSUB.h"
41
42	#include "Win32iop.h"
43	#include <fcntl.h>
44	#ifndef __GNUC__
45	/* assert.h conflicts with #define of assert in perl.h */
46	#include <assert.h>
47	#endif
48	#include <string.h>
49	#include <stdarg.h>
50	#include <float.h>
51	#include <time.h>
52	#if defined(_MSC_VER) \|\| defined(__MINGW32__)
53	#include <sys/utime.h>
54	#else
55	#include <utime.h>
56	#endif
57	#ifdef __GNUC__
58	/* Mingw32 defaults to globing command line
59	* So we turn it off like this:
60	*/
61	int _CRT_glob = 0;
62	#endif
63
64	#if defined(__MINGW32__) && (__MINGW32_MAJOR_VERSION==1)
65	/* Mingw32-1.1 is missing some prototypes */
66	FILE * _wfopen(LPCWSTR wszFileName, LPCWSTR wszMode);
67	FILE * _wfdopen(int nFd, LPCWSTR wszMode);
68	FILE * _freopen(LPCWSTR wszFileName, LPCWSTR wszMode, FILE * pOldStream);
69	int _flushall();
70	int _fcloseall();
71	#endif
72
73	#if defined(__BORLANDC__)
74	# define _stat stat
75	# define _utimbuf utimbuf
76	#endif
77
78	#define EXECF_EXEC 1
79	#define EXECF_SPAWN 2
80	#define EXECF_SPAWN_NOWAIT 3
81
82	#if defined(PERL_IMPLICIT_SYS)
83	# undef win32_get_privlib
84	# define win32_get_privlib g_win32_get_privlib
85	# undef win32_get_sitelib
86	# define win32_get_sitelib g_win32_get_sitelib
87	# undef win32_get_vendorlib
88	# define win32_get_vendorlib g_win32_get_vendorlib
89	# undef getlogin
90	# define getlogin g_getlogin
91	#endif
92
93	static void get_shell(void);
94	static long tokenize(const char str, char dest, char **destv);
95	static int do_spawn2(pTHX_ char *cmd, int exectype);
96	static BOOL has_shell_metachars(char *ptr);
97	static long filetime_to_clock(PFILETIME ft);
98	static BOOL filetime_from_time(PFILETIME ft, time_t t);
99	static char * get_emd_part(SV *leading, char trailing, ...);
100	static void remove_dead_process(long deceased);
101	static long find_pid(int pid);
102	static char * qualified_path(const char *cmd);
103	static char * win32_get_xlib(const char pl, const char xlib,
104	const char *libname);
105
106	#ifdef USE_ITHREADS
107	static void remove_dead_pseudo_process(long child);
108	static long find_pseudo_pid(int pid);
109	#endif
110
111	START_EXTERN_C
112	HANDLE w32_perldll_handle = INVALID_HANDLE_VALUE;
113	char w32_module_name[MAX_PATH+1];
114	END_EXTERN_C
115
116	static DWORD w32_platform = (DWORD)-1;
117
118	#define ONE_K_BUFSIZE 1024
119
120	#ifdef __BORLANDC__
121	/* Silence STDERR grumblings from Borland's math library. */
122	DllExport int
123	_matherr(struct _exception *a)
124	{
125	PERL_UNUSED_VAR(a);
126	return 1;
127	}
128	#endif
129
130	int
131	IsWin95(void)
132	{
133	return (win32_os_id() == VER_PLATFORM_WIN32_WINDOWS);
134	}
135
136	int
137	IsWinNT(void)
138	{
139	return (win32_os_id() == VER_PLATFORM_WIN32_NT);
140	}
141
142	EXTERN_C void
143	set_w32_module_name(void)
144	{
145	char* ptr;
146	GetModuleFileName((HMODULE)((w32_perldll_handle == INVALID_HANDLE_VALUE)
147	? GetModuleHandle(NULL)
148	: w32_perldll_handle),
149	w32_module_name, sizeof(w32_module_name));
150
151	/* remove \\?\ prefix */
152	if (memcmp(w32_module_name, "\\\\?\\", 4) == 0)
153	memmove(w32_module_name, w32_module_name+4, strlen(w32_module_name+4)+1);
154
155	/* try to get full path to binary (which may be mangled when perl is
156	* run from a 16-bit app) */
157	/PerlIO_printf(Perl_debug_log, "Before %s\n", w32_module_name);/
158	(void)win32_longpath(w32_module_name);
159	/PerlIO_printf(Perl_debug_log, "After %s\n", w32_module_name);/
160
161	/* normalize to forward slashes */
162	ptr = w32_module_name;
163	while (*ptr) {
164	if (*ptr == '\\')
165	*ptr = '/';
166	++ptr;
167	}
168	}
169
170	/* svp (if non-NULL) is expected to be POK (valid allocated SvPVX(svp)) */
171	static char*
172	get_regstr_from(HKEY hkey, const char valuename, SV *svp)
173	{
174	/* Retrieve a REG_SZ or REG_EXPAND_SZ from the registry */
175	HKEY handle;
176	DWORD type;
177	const char *subkey = "Software\\Perl";
178	char *str = Nullch;
179	long retval;
180
181	retval = RegOpenKeyEx(hkey, subkey, 0, KEY_READ, &handle);
182	if (retval == ERROR_SUCCESS) {
183	DWORD datalen;
184	retval = RegQueryValueEx(handle, valuename, 0, &type, NULL, &datalen);
185	if (retval == ERROR_SUCCESS
186	&& (type == REG_SZ \|\| type == REG_EXPAND_SZ))
187	{
188	dTHX;
189	if (!*svp)
190	*svp = sv_2mortal(newSVpvn("",0));
191	SvGROW(*svp, datalen);
192	retval = RegQueryValueEx(handle, valuename, 0, NULL,
193	(PBYTE)SvPVX(*svp), &datalen);
194	if (retval == ERROR_SUCCESS) {
195	str = SvPVX(*svp);
196	SvCUR_set(*svp,datalen-1);
197	}
198	}
199	RegCloseKey(handle);
200	}
201	return str;
202	}
203
204	/* svp (if non-NULL) is expected to be POK (valid allocated SvPVX(svp)) */
205	static char*
206	get_regstr(const char valuename, SV *svp)
207	{
208	char *str = get_regstr_from(HKEY_CURRENT_USER, valuename, svp);
209	if (!str)
210	str = get_regstr_from(HKEY_LOCAL_MACHINE, valuename, svp);
211	return str;
212	}
213
214	/* prev_pathp (if non-NULL) is expected to be POK (valid allocated SvPVX(sv)) /
215	static char *
216	get_emd_part(SV *prev_pathp, char trailing_path, ...)
217	{
218	char base[10];
219	va_list ap;
220	char mod_name[MAX_PATH+1];
221	char *ptr;
222	char *optr;
223	char *strip;
224	STRLEN baselen;
225
226	va_start(ap, trailing_path);
227	strip = va_arg(ap, char *);
228
229	sprintf(base, "%d.%d", (int)PERL_REVISION, (int)PERL_VERSION);
230	baselen = strlen(base);
231
232	if (!*w32_module_name) {
233	set_w32_module_name();
234	}
235	strcpy(mod_name, w32_module_name);
236	ptr = strrchr(mod_name, '/');
237	while (ptr && strip) {
238	/* look for directories to skip back */
239	optr = ptr;
240	*ptr = '\0';
241	ptr = strrchr(mod_name, '/');
242	/* avoid stripping component if there is no slash,
243	* or it doesn't match ... */
244	if (!ptr \|\| stricmp(ptr+1, strip) != 0) {
245	/* ... but not if component matches m\|5\.$patchlevel.\| /
246	if (!ptr \|\| !(strip == '5' && (ptr+1) == '5'
247	&& strncmp(strip, base, baselen) == 0
248	&& strncmp(ptr+1, base, baselen) == 0))
249	{
250	*optr = '/';
251	ptr = optr;
252	}
253	}
254	strip = va_arg(ap, char *);
255	}
256	if (!ptr) {
257	ptr = mod_name;
258	*ptr++ = '.';
259	*ptr = '/';
260	}
261	va_end(ap);
262	strcpy(++ptr, trailing_path);
263
264	/* only add directory if it exists */
265	if (GetFileAttributes(mod_name) != (DWORD) -1) {
266	/* directory exists */
267	dTHX;
268	if (!*prev_pathp)
269	*prev_pathp = sv_2mortal(newSVpvn("",0));
270	else if (SvPVX(*prev_pathp))
271	sv_catpvn(*prev_pathp, ";", 1);
272	sv_catpv(*prev_pathp, mod_name);
273	return SvPVX(*prev_pathp);
274	}
275
276	return Nullch;
277	}
278
279	char *
280	win32_get_privlib(const char *pl)
281	{
282	dTHX;
283	char *stdlib = "lib";
284	char buffer[MAX_PATH+1];
285	SV *sv = Nullsv;
286
287	/* $stdlib = $HKCU{"lib-$]"} \|\| $HKLM{"lib-$]"} \|\| $HKCU{"lib"} \|\| $HKLM{"lib"} \|\| ""; */
288	sprintf(buffer, "%s-%s", stdlib, pl);
289	if (!get_regstr(buffer, &sv))
290	(void)get_regstr(stdlib, &sv);
291
292	/* $stdlib .= ";$EMD/../../lib" */
293	return get_emd_part(&sv, stdlib, ARCHNAME, "bin", Nullch);
294	}
295
296	static char *
297	win32_get_xlib(const char pl, const char xlib, const char *libname)
298	{
299	dTHX;
300	char regstr[40];
301	char pathstr[MAX_PATH+1];
302	SV *sv1 = Nullsv;
303	SV *sv2 = Nullsv;
304
305	/* $HKCU{"$xlib-$]"} \|\| $HKLM{"$xlib-$]"} . ---; */
306	sprintf(regstr, "%s-%s", xlib, pl);
307	(void)get_regstr(regstr, &sv1);
308
309	/* $xlib .=
310	* ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/$]/lib"; */
311	sprintf(pathstr, "%s/%s/lib", libname, pl);
312	(void)get_emd_part(&sv1, pathstr, ARCHNAME, "bin", pl, Nullch);
313
314	/* $HKCU{$xlib} \|\| $HKLM{$xlib} . ---; */
315	(void)get_regstr(xlib, &sv2);
316
317	/* $xlib .=
318	* ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/lib"; */
319	sprintf(pathstr, "%s/lib", libname);
320	(void)get_emd_part(&sv2, pathstr, ARCHNAME, "bin", pl, Nullch);
321
322	if (!sv1 && !sv2)
323	return Nullch;
324	if (!sv1)
325	return SvPVX(sv2);
326	if (!sv2)
327	return SvPVX(sv1);
328
329	sv_catpvn(sv1, ";", 1);
330	sv_catsv(sv1, sv2);
331
332	return SvPVX(sv1);
333	}
334
335	char *
336	win32_get_sitelib(const char *pl)
337	{
338	return win32_get_xlib(pl, "sitelib", "site");
339	}
340
341	#ifndef PERL_VENDORLIB_NAME
342	# define PERL_VENDORLIB_NAME "vendor"
343	#endif
344
345	char *
346	win32_get_vendorlib(const char *pl)
347	{
348	return win32_get_xlib(pl, "vendorlib", PERL_VENDORLIB_NAME);
349	}
350
351	static BOOL
352	has_shell_metachars(char *ptr)
353	{
354	int inquote = 0;
355	char quote = '\0';
356
357	/*
358	* Scan string looking for redirection (< or >) or pipe
359	* characters (\|) that are not in a quoted string.
360	* Shell variable interpolation (%VAR%) can also happen inside strings.
361	*/
362	while (*ptr) {
363	switch(*ptr) {
364	case '%':
365	return TRUE;
366	case '\'':
367	case '\"':
368	if (inquote) {
369	if (quote == *ptr) {
370	inquote = 0;
371	quote = '\0';
372	}
373	}
374	else {
375	quote = *ptr;
376	inquote++;
377	}
378	break;
379	case '>':
380	case '<':
381	case '\|':
382	if (!inquote)
383	return TRUE;
384	default:
385	break;
386	}
387	++ptr;
388	}
389	return FALSE;
390	}
391
392	#if !defined(PERL_IMPLICIT_SYS)
393	/* since the current process environment is being updated in util.c
394	* the library functions will get the correct environment
395	*/
396	PerlIO *
397	Perl_my_popen(pTHX_ char cmd, char mode)
398	{
399	#ifdef FIXCMD
400	#define fixcmd(x) { \
401	char *pspace = strchr((x),' '); \
402	if (pspace) { \
403	char *p = (x); \
404	while (p < pspace) { \
405	if (*p == '/') \
406	*p = '\\'; \
407	p++; \
408	} \
409	} \
410	}
411	#else
412	#define fixcmd(x)
413	#endif
414	fixcmd(cmd);
415	PERL_FLUSHALL_FOR_CHILD;
416	return win32_popen(cmd, mode);
417	}
418
419	long
420	Perl_my_pclose(pTHX_ PerlIO *fp)
421	{
422	return win32_pclose(fp);
423	}
424	#endif
425
426	DllExport unsigned long
427	win32_os_id(void)
428	{
429	static OSVERSIONINFO osver;
430
431	if (osver.dwPlatformId != w32_platform) {
432	memset(&osver, 0, sizeof(OSVERSIONINFO));
433	osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
434	GetVersionEx(&osver);
435	w32_platform = osver.dwPlatformId;
436	}
437	return (unsigned long)w32_platform;
438	}
439
440	DllExport int
441	win32_getpid(void)
442	{
443	int pid;
444	#ifdef USE_ITHREADS
445	dTHX;
446	if (w32_pseudo_id)
447	return -((int)w32_pseudo_id);
448	#endif
449	pid = _getpid();
450	/* Windows 9x appears to always reports a pid for threads and processes
451	* that has the high bit set. So we treat the lower 31 bits as the
452	* "real" PID for Perl's purposes. */
453	if (IsWin95() && pid < 0)
454	pid = -pid;
455	return pid;
456	}
457
458	/* Tokenize a string. Words are null-separated, and the list
459	* ends with a doubled null. Any character (except null and
460	* including backslash) may be escaped by preceding it with a
461	* backslash (the backslash will be stripped).
462	* Returns number of words in result buffer.
463	*/
464	static long
465	tokenize(const char str, char dest, char **destv)
466	{
467	char *retstart = Nullch;
468	char **retvstart = 0;
469	int items = -1;
470	if (str) {
471	dTHX;
472	int slen = strlen(str);
473	register char *ret;
474	register char **retv;
475	Newx(ret, slen+2, char);
476	Newx(retv, (slen+3)/2, char*);
477
478	retstart = ret;
479	retvstart = retv;
480	*retv = ret;
481	items = 0;
482	while (*str) {
483	ret = str++;
484	if (ret == '\\' && str)
485	ret = str++;
486	else if (*ret == ' ') {
487	while (*str == ' ')
488	str++;
489	if (ret == retstart)
490	ret--;
491	else {
492	*ret = '\0';
493	++items;
494	if (*str)
495	*++retv = ret+1;
496	}
497	}
498	else if (!*str)
499	++items;
500	ret++;
501	}
502	retvstart[items] = Nullch;
503	*ret++ = '\0';
504	*ret = '\0';
505	}
506	*dest = retstart;
507	*destv = retvstart;
508	return items;
509	}
510
511	static void
512	get_shell(void)
513	{
514	dTHX;
515	if (!w32_perlshell_tokens) {
516	/* we don't use COMSPEC here for two reasons:
517	* 1. the same reason perl on UNIX doesn't use SHELL--rampant and
518	* uncontrolled unportability of the ensuing scripts.
519	* 2. PERL5SHELL could be set to a shell that may not be fit for
520	* interactive use (which is what most programs look in COMSPEC
521	* for).
522	*/
523	const char* defaultshell = (IsWinNT()
524	? "cmd.exe /x/d/c" : "command.com /c");
525	const char *usershell = PerlEnv_getenv("PERL5SHELL");
526	w32_perlshell_items = tokenize(usershell ? usershell : defaultshell,
527	&w32_perlshell_tokens,
528	&w32_perlshell_vec);
529	}
530	}
531
532	int
533	Perl_do_aspawn(pTHX_ SV really, SV mark, SV *sp)
534	{
535	char **argv;
536	char *str;
537	int status;
538	int flag = P_WAIT;
539	int index = 0;
540
541	if (sp <= mark)
542	return -1;
543
544	get_shell();
545	Newx(argv, (sp - mark) + w32_perlshell_items + 2, char*);
546
547	if (SvNIOKp((mark+1)) && !SvPOKp((mark+1))) {
548	++mark;
549	flag = SvIVx(*mark);
550	}
551
552	while (++mark <= sp) {
553	if (mark && (str = SvPV_nolen(mark)))
554	argv[index++] = str;
555	else
556	argv[index++] = "";
557	}
558	argv[index++] = 0;
559
560	status = win32_spawnvp(flag,
561	(const char*)(really ? SvPV_nolen(really) : argv[0]),
562	(const char* const*)argv);
563
564	if (status < 0 && (errno == ENOEXEC \|\| errno == ENOENT)) {
565	/* possible shell-builtin, invoke with shell */
566	int sh_items;
567	sh_items = w32_perlshell_items;
568	while (--index >= 0)
569	argv[index+sh_items] = argv[index];
570	while (--sh_items >= 0)
571	argv[sh_items] = w32_perlshell_vec[sh_items];
572
573	status = win32_spawnvp(flag,
574	(const char*)(really ? SvPV_nolen(really) : argv[0]),
575	(const char* const*)argv);
576	}
577
578	if (flag == P_NOWAIT) {
579	if (IsWin95())
580	PL_statusvalue = -1; /* >16bits hint for pp_system() */
581	}
582	else {
583	if (status < 0) {
584	if (ckWARN(WARN_EXEC))
585	Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't spawn \"%s\": %s", argv[0], strerror(errno));
586	status = 255 * 256;
587	}
588	else
589	status *= 256;
590	PL_statusvalue = status;
591	}
592	Safefree(argv);
593	return (status);
594	}
595
596	/* returns pointer to the next unquoted space or the end of the string */
597	static char*
598	find_next_space(const char *s)
599	{
600	bool in_quotes = FALSE;
601	while (*s) {
602	/* ignore doubled backslashes, or backslash+quote */
603	if (*s == '\\' && (s[1] == '\\' \|\| s[1] == '"')) {
604	s += 2;
605	}
606	/* keep track of when we're within quotes */
607	else if (*s == '"') {
608	s++;
609	in_quotes = !in_quotes;
610	}
611	/* break it up only at spaces that aren't in quotes */
612	else if (!in_quotes && isSPACE(*s))
613	return (char*)s;
614	else
615	s++;
616	}
617	return (char*)s;
618	}
619
620	static int
621	do_spawn2(pTHX_ char *cmd, int exectype)
622	{
623	char **a;
624	char *s;
625	char **argv;
626	int status = -1;
627	BOOL needToTry = TRUE;
628	char *cmd2;
629
630	/* Save an extra exec if possible. See if there are shell
631	* metacharacters in it */
632	if (!has_shell_metachars(cmd)) {
633	Newx(argv, strlen(cmd) / 2 + 2, char*);
634	Newx(cmd2, strlen(cmd) + 1, char);
635	strcpy(cmd2, cmd);
636	a = argv;
637	for (s = cmd2; *s;) {
638	while (s && isSPACE(s))
639	s++;
640	if (*s)
641	*(a++) = s;
642	s = find_next_space(s);
643	if (*s)
644	*s++ = '\0';
645	}
646	*a = Nullch;
647	if (argv[0]) {
648	switch (exectype) {
649	case EXECF_SPAWN:
650	status = win32_spawnvp(P_WAIT, argv[0],
651	(const char* const*)argv);
652	break;
653	case EXECF_SPAWN_NOWAIT:
654	status = win32_spawnvp(P_NOWAIT, argv[0],
655	(const char* const*)argv);
656	break;
657	case EXECF_EXEC:
658	status = win32_execvp(argv[0], (const char* const*)argv);
659	break;
660	}
661	if (status != -1 \|\| errno == 0)
662	needToTry = FALSE;
663	}
664	Safefree(argv);
665	Safefree(cmd2);
666	}
667	if (needToTry) {
668	char **argv;
669	int i = -1;
670	get_shell();
671	Newx(argv, w32_perlshell_items + 2, char*);
672	while (++i < w32_perlshell_items)
673	argv[i] = w32_perlshell_vec[i];
674	argv[i++] = cmd;
675	argv[i] = Nullch;
676	switch (exectype) {
677	case EXECF_SPAWN:
678	status = win32_spawnvp(P_WAIT, argv[0],
679	(const char* const*)argv);
680	break;
681	case EXECF_SPAWN_NOWAIT:
682	status = win32_spawnvp(P_NOWAIT, argv[0],
683	(const char* const*)argv);
684	break;
685	case EXECF_EXEC:
686	status = win32_execvp(argv[0], (const char* const*)argv);
687	break;
688	}
689	cmd = argv[0];
690	Safefree(argv);
691	}
692	if (exectype == EXECF_SPAWN_NOWAIT) {
693	if (IsWin95())
694	PL_statusvalue = -1; /* >16bits hint for pp_system() */
695	}
696	else {
697	if (status < 0) {
698	if (ckWARN(WARN_EXEC))
699	Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s",
700	(exectype == EXECF_EXEC ? "exec" : "spawn"),
701	cmd, strerror(errno));
702	status = 255 * 256;
703	}
704	else
705	status *= 256;
706	PL_statusvalue = status;
707	}
708	return (status);
709	}
710
711	int
712	Perl_do_spawn(pTHX_ char *cmd)
713	{
714	return do_spawn2(aTHX_ cmd, EXECF_SPAWN);
715	}
716
717	int
718	Perl_do_spawn_nowait(pTHX_ char *cmd)
719	{
720	return do_spawn2(aTHX_ cmd, EXECF_SPAWN_NOWAIT);
721	}
722
723	bool
724	Perl_do_exec(pTHX_ char *cmd)
725	{
726	do_spawn2(aTHX_ cmd, EXECF_EXEC);
727	return FALSE;
728	}
729
730	/* The idea here is to read all the directory names into a string table
731	* (separated by nulls) and when one of the other dir functions is called
732	* return the pointer to the current file name.
733	*/
734	DllExport DIR *
735	win32_opendir(char *filename)
736	{
737	dTHX;
738	DIR *dirp;
739	long len;
740	long idx;
741	char scanname[MAX_PATH+3];
742	Stat_t sbuf;
743	WIN32_FIND_DATAA aFindData;
744	WIN32_FIND_DATAW wFindData;
745	HANDLE fh;
746	char buffer[MAX_PATH*2];
747	WCHAR wbuffer[MAX_PATH+1];
748	char* ptr;
749
750	len = strlen(filename);
751	if (len > MAX_PATH)
752	return NULL;
753
754	/* check to see if filename is a directory */
755	if (win32_stat(filename, &sbuf) < 0 \|\| !S_ISDIR(sbuf.st_mode))
756	return NULL;
757
758	/* Get us a DIR structure */
759	Newxz(dirp, 1, DIR);
760
761	/* Create the search pattern */
762	strcpy(scanname, filename);
763
764	/* bare drive name means look in cwd for drive */
765	if (len == 2 && isALPHA(scanname[0]) && scanname[1] == ':') {
766	scanname[len++] = '.';
767	scanname[len++] = '/';
768	}
769	else if (scanname[len-1] != '/' && scanname[len-1] != '\\') {
770	scanname[len++] = '/';
771	}
772	scanname[len++] = '*';
773	scanname[len] = '\0';
774
775	/* do the FindFirstFile call */
776	if (USING_WIDE()) {
777	A2WHELPER(scanname, wbuffer, sizeof(wbuffer));
778	fh = FindFirstFileW(PerlDir_mapW(wbuffer), &wFindData);
779	}
780	else {
781	fh = FindFirstFileA(PerlDir_mapA(scanname), &aFindData);
782	}
783	dirp->handle = fh;
784	if (fh == INVALID_HANDLE_VALUE) {
785	DWORD err = GetLastError();
786	/* FindFirstFile() fails on empty drives! */
787	switch (err) {
788	case ERROR_FILE_NOT_FOUND:
789	return dirp;
790	case ERROR_NO_MORE_FILES:
791	case ERROR_PATH_NOT_FOUND:
792	errno = ENOENT;
793	break;
794	case ERROR_NOT_ENOUGH_MEMORY:
795	errno = ENOMEM;
796	break;
797	default:
798	errno = EINVAL;
799	break;
800	}
801	Safefree(dirp);
802	return NULL;
803	}
804
805	/* now allocate the first part of the string table for
806	* the filenames that we find.
807	*/
808	if (USING_WIDE()) {
809	W2AHELPER(wFindData.cFileName, buffer, sizeof(buffer));
810	ptr = buffer;
811	}
812	else {
813	ptr = aFindData.cFileName;
814	}
815	idx = strlen(ptr)+1;
816	if (idx < 256)
817	dirp->size = 128;
818	else
819	dirp->size = idx;
820	Newx(dirp->start, dirp->size, char);
821	strcpy(dirp->start, ptr);
822	dirp->nfiles++;
823	dirp->end = dirp->curr = dirp->start;
824	dirp->end += idx;
825	return dirp;
826	}
827
828
829	/* Readdir just returns the current string pointer and bumps the
830	* string pointer to the nDllExport entry.
831	*/
832	DllExport struct direct *
833	win32_readdir(DIR *dirp)
834	{
835	long len;
836
837	if (dirp->curr) {
838	/* first set up the structure to return */
839	len = strlen(dirp->curr);
840	strcpy(dirp->dirstr.d_name, dirp->curr);
841	dirp->dirstr.d_namlen = len;
842
843	/* Fake an inode */
844	dirp->dirstr.d_ino = dirp->curr - dirp->start;
845
846	/* Now set up for the next call to readdir */
847	dirp->curr += len + 1;
848	if (dirp->curr >= dirp->end) {
849	dTHX;
850	char* ptr;
851	BOOL res;
852	WIN32_FIND_DATAW wFindData;
853	WIN32_FIND_DATAA aFindData;
854	char buffer[MAX_PATH*2];
855
856	/* finding the next file that matches the wildcard
857	* (which should be all of them in this directory!).
858	*/
859	if (USING_WIDE()) {
860	res = FindNextFileW(dirp->handle, &wFindData);
861	if (res) {
862	W2AHELPER(wFindData.cFileName, buffer, sizeof(buffer));
863	ptr = buffer;
864	}
865	}
866	else {
867	res = FindNextFileA(dirp->handle, &aFindData);
868	if (res)
869	ptr = aFindData.cFileName;
870	}
871	if (res) {
872	long endpos = dirp->end - dirp->start;
873	long newsize = endpos + strlen(ptr) + 1;
874	/* bump the string table size by enough for the
875	* new name and its null terminator */
876	while (newsize > dirp->size) {
877	long curpos = dirp->curr - dirp->start;
878	dirp->size *= 2;
879	Renew(dirp->start, dirp->size, char);
880	dirp->curr = dirp->start + curpos;
881	}
882	strcpy(dirp->start + endpos, ptr);
883	dirp->end = dirp->start + newsize;
884	dirp->nfiles++;
885	}
886	else
887	dirp->curr = NULL;
888	}
889	return &(dirp->dirstr);
890	}
891	else
892	return NULL;
893	}
894
895	/* Telldir returns the current string pointer position */
896	DllExport long
897	win32_telldir(DIR *dirp)
898	{
899	return (dirp->curr - dirp->start);
900	}
901
902
903	/* Seekdir moves the string pointer to a previously saved position
904	* (returned by telldir).
905	*/