X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=win32%2Fwin32.c;h=efb52d92a9e578ad2d7820325fa98f5109dbd81f;hb=dff6d3cd91bb8f94ad6445629f3bfb07c761a04e;hp=480dfeb9877a8f02e16a6ede0a6465bb09495935;hpb=79cb57f6e01f91d8fff40d69caa187aaa669671b;p=p5sagit%2Fp5-mst-13.2.git diff --git a/win32/win32.c b/win32/win32.c index 480dfeb..efb52d9 100644 --- a/win32/win32.c +++ b/win32/win32.c @@ -35,18 +35,16 @@ #define PerlIO FILE #endif +#include #include "EXTERN.h" #include "perl.h" #define NO_XSLOCKS -#ifdef PERL_OBJECT -extern CPerlObj* pPerl; -#endif +#define PERL_NO_GET_CONTEXT #include "XSUB.h" #include "Win32iop.h" #include -#include #ifndef __GNUC__ /* assert.h conflicts with #define of assert in perl.h */ #include @@ -68,38 +66,46 @@ extern CPerlObj* pPerl; int _CRT_glob = 0; #endif +#ifdef __BORLANDC__ +# define _stat stat +# define _utimbuf utimbuf +#endif + #define EXECF_EXEC 1 #define EXECF_SPAWN 2 #define EXECF_SPAWN_NOWAIT 3 +#if defined(PERL_IMPLICIT_SYS) +# undef win32_get_privlib +# define win32_get_privlib g_win32_get_privlib +# undef win32_get_sitelib +# define win32_get_sitelib g_win32_get_sitelib +# undef do_spawn +# define do_spawn g_do_spawn +# undef getlogin +# define getlogin g_getlogin +#endif + #if defined(PERL_OBJECT) -#undef win32_get_privlib -#define win32_get_privlib g_win32_get_privlib -#undef win32_get_sitelib -#define win32_get_sitelib g_win32_get_sitelib -#undef do_aspawn -#define do_aspawn g_do_aspawn -#undef do_spawn -#define do_spawn g_do_spawn -#undef do_exec -#define do_exec g_do_exec -#undef getlogin -#define getlogin g_getlogin +# undef do_aspawn +# define do_aspawn g_do_aspawn +# undef Perl_do_exec +# define Perl_do_exec g_do_exec #endif -static DWORD os_id(void); static void get_shell(void); -static long tokenize(char *str, char **dest, char ***destv); +static long tokenize(const char *str, char **dest, char ***destv); int do_spawn2(char *cmd, int exectype); static BOOL has_shell_metachars(char *ptr); static long filetime_to_clock(PFILETIME ft); static BOOL filetime_from_time(PFILETIME ft, time_t t); -static char * get_emd_part(char *leading, char *trailing, ...); +static char * get_emd_part(SV **leading, char *trailing, ...); static void remove_dead_process(long deceased); static long find_pid(int pid); static char * qualified_path(const char *cmd); HANDLE w32_perldll_handle = INVALID_HANDLE_VALUE; +char w32_module_name[MAX_PATH+1]; static DWORD w32_platform = (DWORD)-1; #ifdef USE_THREADS @@ -126,57 +132,62 @@ static char crypt_buffer[30]; #endif int -IsWin95(void) { - return (os_id() == VER_PLATFORM_WIN32_WINDOWS); +IsWin95(void) +{ + return (win32_os_id() == VER_PLATFORM_WIN32_WINDOWS); } int -IsWinNT(void) { - return (os_id() == VER_PLATFORM_WIN32_NT); +IsWinNT(void) +{ + return (win32_os_id() == VER_PLATFORM_WIN32_NT); } -char* -GetRegStrFromKey(HKEY hkey, const char *lpszValueName, char** ptr, DWORD* lpDataLen) -{ /* Retrieve a REG_SZ or REG_EXPAND_SZ from the registry */ +/* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */ +static char* +get_regstr_from(HKEY hkey, const char *valuename, SV **svp) +{ + /* Retrieve a REG_SZ or REG_EXPAND_SZ from the registry */ HKEY handle; DWORD type; const char *subkey = "Software\\Perl"; + char *str = Nullch; long retval; retval = RegOpenKeyEx(hkey, subkey, 0, KEY_READ, &handle); - if (retval == ERROR_SUCCESS){ - retval = RegQueryValueEx(handle, lpszValueName, 0, &type, NULL, lpDataLen); + if (retval == ERROR_SUCCESS) { + DWORD datalen; + retval = RegQueryValueEx(handle, valuename, 0, &type, NULL, &datalen); if (retval == ERROR_SUCCESS && type == REG_SZ) { - if (*ptr) { - Renew(*ptr, *lpDataLen, char); - } - else { - New(1312, *ptr, *lpDataLen, char); - } - retval = RegQueryValueEx(handle, lpszValueName, 0, NULL, (PBYTE)*ptr, lpDataLen); - if (retval != ERROR_SUCCESS) { - Safefree(*ptr); - *ptr = Nullch; + dTHXo; + if (!*svp) + *svp = sv_2mortal(newSVpvn("",0)); + SvGROW(*svp, datalen); + retval = RegQueryValueEx(handle, valuename, 0, NULL, + (PBYTE)SvPVX(*svp), &datalen); + if (retval == ERROR_SUCCESS) { + str = SvPVX(*svp); + SvCUR_set(*svp,datalen-1); } } RegCloseKey(handle); } - return *ptr; + return str; } -char* -GetRegStr(const char *lpszValueName, char** ptr, DWORD* lpDataLen) +/* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */ +static char* +get_regstr(const char *valuename, SV **svp) { - *ptr = GetRegStrFromKey(HKEY_CURRENT_USER, lpszValueName, ptr, lpDataLen); - if (*ptr == Nullch) - { - *ptr = GetRegStrFromKey(HKEY_LOCAL_MACHINE, lpszValueName, ptr, lpDataLen); - } - return *ptr; + char *str = get_regstr_from(HKEY_CURRENT_USER, valuename, svp); + if (!str) + str = get_regstr_from(HKEY_LOCAL_MACHINE, valuename, svp); + return str; } +/* *prev_pathp (if non-NULL) is expected to be POK (valid allocated SvPVX(sv)) */ static char * -get_emd_part(char *prev_path, char *trailing_path, ...) +get_emd_part(SV **prev_pathp, char *trailing_path, ...) { char base[10]; va_list ap; @@ -192,19 +203,42 @@ get_emd_part(char *prev_path, char *trailing_path, ...) sprintf(base, "%5.3f", (double)PERL_REVISION + ((double)PERL_VERSION / (double)1000)); - GetModuleFileName((HMODULE)((w32_perldll_handle == INVALID_HANDLE_VALUE) - ? GetModuleHandle(NULL) : w32_perldll_handle), - mod_name, sizeof(mod_name)); - ptr = strrchr(mod_name, '\\'); + if (!*w32_module_name) { + GetModuleFileName((HMODULE)((w32_perldll_handle == INVALID_HANDLE_VALUE) + ? GetModuleHandle(NULL) + : w32_perldll_handle), + w32_module_name, sizeof(w32_module_name)); + + /* try to get full path to binary (which may be mangled when perl is + * run from a 16-bit app) */ + /*PerlIO_printf(Perl_debug_log, "Before %s\n", w32_module_name);*/ + (void)win32_longpath(w32_module_name); + /*PerlIO_printf(Perl_debug_log, "After %s\n", w32_module_name);*/ + + /* normalize to forward slashes */ + ptr = w32_module_name; + while (*ptr) { + if (*ptr == '\\') + *ptr = '/'; + ++ptr; + } + } + strcpy(mod_name, w32_module_name); + ptr = strrchr(mod_name, '/'); while (ptr && strip) { /* look for directories to skip back */ optr = ptr; *ptr = '\0'; - ptr = strrchr(mod_name, '\\'); + ptr = strrchr(mod_name, '/'); + /* avoid stripping component if there is no slash, + * or it doesn't match ... */ if (!ptr || stricmp(ptr+1, strip) != 0) { - if(!(*strip == '5' && *(ptr+1) == '5' && strncmp(strip, base, 5) == 0 - && strncmp(ptr+1, base, 5) == 0)) { - *optr = '\\'; + /* ... but not if component matches 5.00X* */ + if (!ptr || !(*strip == '5' && *(ptr+1) == '5' + && strncmp(strip, base, 5) == 0 + && strncmp(ptr+1, base, 5) == 0)) + { + *optr = '/'; ptr = optr; } } @@ -213,91 +247,87 @@ get_emd_part(char *prev_path, char *trailing_path, ...) if (!ptr) { ptr = mod_name; *ptr++ = '.'; - *ptr = '\\'; + *ptr = '/'; } va_end(ap); strcpy(++ptr, trailing_path); /* only add directory if it exists */ - if(GetFileAttributes(mod_name) != (DWORD) -1) { + if (GetFileAttributes(mod_name) != (DWORD) -1) { /* directory exists */ - newsize = strlen(mod_name) + 1; - if (prev_path) { - oldsize = strlen(prev_path) + 1; - newsize += oldsize; /* includes plus 1 for ';' */ - Renew(prev_path, newsize, char); - prev_path[oldsize-1] = ';'; - strcpy(&prev_path[oldsize], mod_name); - } - else { - New(1311, prev_path, newsize, char); - strcpy(prev_path, mod_name); - } + dTHXo; + if (!*prev_pathp) + *prev_pathp = sv_2mortal(newSVpvn("",0)); + sv_catpvn(*prev_pathp, ";", 1); + sv_catpv(*prev_pathp, mod_name); + return SvPVX(*prev_pathp); } - return prev_path; + return Nullch; } char * win32_get_privlib(char *pl) { + dTHXo; char *stdlib = "lib"; char buffer[MAX_PATH+1]; - char *path = Nullch; - DWORD datalen; + SV *sv = Nullsv; /* $stdlib = $HKCU{"lib-$]"} || $HKLM{"lib-$]"} || $HKCU{"lib"} || $HKLM{"lib"} || ""; */ sprintf(buffer, "%s-%s", stdlib, pl); - path = GetRegStr(buffer, &path, &datalen); - if (!path) - path = GetRegStr(stdlib, &path, &datalen); + if (!get_regstr(buffer, &sv)) + (void)get_regstr(stdlib, &sv); /* $stdlib .= ";$EMD/../../lib" */ - return get_emd_part(path, stdlib, ARCHNAME, "bin", Nullch); + return get_emd_part(&sv, stdlib, ARCHNAME, "bin", Nullch); } char * win32_get_sitelib(char *pl) { + dTHXo; char *sitelib = "sitelib"; char regstr[40]; char pathstr[MAX_PATH+1]; DWORD datalen; - char *path1 = Nullch; - char *path2 = Nullch; int len, newsize; + SV *sv1 = Nullsv; + SV *sv2 = Nullsv; /* $HKCU{"sitelib-$]"} || $HKLM{"sitelib-$]"} . ---; */ sprintf(regstr, "%s-%s", sitelib, pl); - path1 = GetRegStr(regstr, &path1, &datalen); + (void)get_regstr(regstr, &sv1); /* $sitelib .= * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/site/$]/lib"; */ - sprintf(pathstr, "site\\%s\\lib", pl); - path1 = get_emd_part(path1, pathstr, ARCHNAME, "bin", pl, Nullch); + sprintf(pathstr, "site/%s/lib", pl); + (void)get_emd_part(&sv1, pathstr, ARCHNAME, "bin", pl, Nullch); + if (!sv1 && strlen(pl) == 7) { + /* pl may have been SUBVERSION-specific; try again without + * SUBVERSION */ + sprintf(pathstr, "site/%.5s/lib", pl); + (void)get_emd_part(&sv1, pathstr, ARCHNAME, "bin", pl, Nullch); + } /* $HKCU{'sitelib'} || $HKLM{'sitelib'} . ---; */ - path2 = GetRegStr(sitelib, &path2, &datalen); + (void)get_regstr(sitelib, &sv2); /* $sitelib .= * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/site/lib"; */ - path2 = get_emd_part(path2, "site\\lib", ARCHNAME, "bin", pl, Nullch); - - if (!path1) - return path2; - - if (!path2) - return path1; + (void)get_emd_part(&sv2, "site/lib", ARCHNAME, "bin", pl, Nullch); - len = strlen(path1); - newsize = len + strlen(path2) + 2; /* plus one for ';' */ + if (!sv1 && !sv2) + return Nullch; + if (!sv1) + return SvPVX(sv2); + if (!sv2) + return SvPVX(sv1); - Renew(path1, newsize, char); - path1[len++] = ';'; - strcpy(&path1[len], path2); + sv_catpvn(sv1, ";", 1); + sv_catsv(sv1, sv2); - Safefree(path2); - return path1; + return SvPVX(sv1); } @@ -342,12 +372,12 @@ has_shell_metachars(char *ptr) return FALSE; } -#if !defined(PERL_OBJECT) +#if !defined(PERL_IMPLICIT_SYS) /* since the current process environment is being updated in util.c * the library functions will get the correct environment */ PerlIO * -my_popen(char *cmd, char *mode) +Perl_my_popen(pTHX_ char *cmd, char *mode) { #ifdef FIXCMD #define fixcmd(x) { \ @@ -365,20 +395,19 @@ my_popen(char *cmd, char *mode) #define fixcmd(x) #endif fixcmd(cmd); - win32_fflush(stdout); - win32_fflush(stderr); + PERL_FLUSHALL_FOR_CHILD; return win32_popen(cmd, mode); } long -my_pclose(PerlIO *fp) +Perl_my_pclose(pTHX_ PerlIO *fp) { return win32_pclose(fp); } #endif -static DWORD -os_id(void) +DllExport unsigned long +win32_os_id(void) { static OSVERSIONINFO osver; @@ -388,7 +417,7 @@ os_id(void) GetVersionEx(&osver); w32_platform = osver.dwPlatformId; } - return (w32_platform); + return (unsigned long)w32_platform; } /* Tokenize a string. Words are null-separated, and the list @@ -398,12 +427,13 @@ os_id(void) * Returns number of words in result buffer. */ static long -tokenize(char *str, char **dest, char ***destv) +tokenize(const char *str, char **dest, char ***destv) { char *retstart = Nullch; char **retvstart = 0; int items = -1; if (str) { + dTHXo; int slen = strlen(str); register char *ret; register char **retv; @@ -446,6 +476,7 @@ tokenize(char *str, char **dest, char ***destv) static void get_shell(void) { + dTHXo; if (!w32_perlshell_tokens) { /* we don't use COMSPEC here for two reasons: * 1. the same reason perl on UNIX doesn't use SHELL--rampant and @@ -454,8 +485,9 @@ get_shell(void) * interactive use (which is what most programs look in COMSPEC * for). */ - char* defaultshell = (IsWinNT() ? "cmd.exe /x/c" : "command.com /c"); - char *usershell = getenv("PERL5SHELL"); + const char* defaultshell = (IsWinNT() + ? "cmd.exe /x/c" : "command.com /c"); + const char *usershell = getenv("PERL5SHELL"); w32_perlshell_items = tokenize(usershell ? usershell : defaultshell, &w32_perlshell_tokens, &w32_perlshell_vec); @@ -465,6 +497,7 @@ get_shell(void) int do_aspawn(void *vreally, void **vmark, void **vsp) { + dTHXo; SV *really = (SV*)vreally; SV **mark = (SV**)vmark; SV **sp = (SV**)vsp; @@ -513,8 +546,9 @@ do_aspawn(void *vreally, void **vmark, void **vsp) if (flag != P_NOWAIT) { if (status < 0) { - if (PL_dowarn) - warn("Can't spawn \"%s\": %s", argv[0], strerror(errno)); + dTHR; + if (ckWARN(WARN_EXEC)) + Perl_warner(aTHX_ WARN_EXEC, "Can't spawn \"%s\": %s", argv[0], strerror(errno)); status = 255 * 256; } else @@ -528,6 +562,7 @@ do_aspawn(void *vreally, void **vmark, void **vsp) int do_spawn2(char *cmd, int exectype) { + dTHXo; char **a; char *s; char **argv; @@ -543,11 +578,11 @@ do_spawn2(char *cmd, int exectype) strcpy(cmd2, cmd); a = argv; for (s = cmd2; *s;) { - while (*s && isspace(*s)) + while (*s && isSPACE(*s)) s++; if (*s) *(a++) = s; - while (*s && !isspace(*s)) + while (*s && !isSPACE(*s)) s++; if (*s) *s++ = '\0'; @@ -600,8 +635,9 @@ do_spawn2(char *cmd, int exectype) } if (exectype != EXECF_SPAWN_NOWAIT) { if (status < 0) { - if (PL_dowarn) - warn("Can't %s \"%s\": %s", + dTHR; + if (ckWARN(WARN_EXEC)) + Perl_warner(aTHX_ WARN_EXEC, "Can't %s \"%s\": %s", (exectype == EXECF_EXEC ? "exec" : "spawn"), cmd, strerror(errno)); status = 255 * 256; @@ -626,7 +662,7 @@ do_spawn_nowait(char *cmd) } bool -do_exec(char *cmd) +Perl_do_exec(pTHX_ char *cmd) { do_spawn2(cmd, EXECF_EXEC); return FALSE; @@ -636,16 +672,21 @@ do_exec(char *cmd) * (separated by nulls) and when one of the other dir functions is called * return the pointer to the current file name. */ -DIR * +DllExport DIR * win32_opendir(char *filename) { - DIR *p; + dTHXo; + DIR *dirp; long len; long idx; char scanname[MAX_PATH+3]; struct stat sbuf; - WIN32_FIND_DATA FindData; + WIN32_FIND_DATAA aFindData; + WIN32_FIND_DATAW wFindData; HANDLE fh; + char buffer[MAX_PATH*2]; + WCHAR wbuffer[MAX_PATH]; + char* ptr; len = strlen(filename); if (len > MAX_PATH) @@ -656,69 +697,83 @@ win32_opendir(char *filename) return NULL; /* Get us a DIR structure */ - Newz(1303, p, 1, DIR); - if (p == NULL) - return NULL; + Newz(1303, dirp, 1, DIR); /* Create the search pattern */ strcpy(scanname, filename); - if (scanname[len-1] != '/' && scanname[len-1] != '\\') + + /* bare drive name means look in cwd for drive */ + if (len == 2 && isALPHA(scanname[0]) && scanname[1] == ':') { + scanname[len++] = '.'; scanname[len++] = '/'; + } + else if (scanname[len-1] != '/' && scanname[len-1] != '\\') { + scanname[len++] = '/'; + } scanname[len++] = '*'; scanname[len] = '\0'; /* do the FindFirstFile call */ - fh = FindFirstFile(scanname, &FindData); + if (USING_WIDE()) { + A2WHELPER(scanname, wbuffer, sizeof(wbuffer)); + fh = FindFirstFileW(wbuffer, &wFindData); + } + else { + fh = FindFirstFileA(scanname, &aFindData); + } + dirp->handle = fh; if (fh == INVALID_HANDLE_VALUE) { + DWORD err = GetLastError(); /* FindFirstFile() fails on empty drives! */ - if (GetLastError() == ERROR_FILE_NOT_FOUND) - return p; - Safefree( p); + switch (err) { + case ERROR_FILE_NOT_FOUND: + return dirp; + case ERROR_NO_MORE_FILES: + case ERROR_PATH_NOT_FOUND: + errno = ENOENT; + break; + case ERROR_NOT_ENOUGH_MEMORY: + errno = ENOMEM; + break; + default: + errno = EINVAL; + break; + } + Safefree(dirp); return NULL; } /* now allocate the first part of the string table for * the filenames that we find. */ - idx = strlen(FindData.cFileName)+1; - New(1304, p->start, idx, char); - if (p->start == NULL) - croak("opendir: malloc failed!\n"); - strcpy(p->start, FindData.cFileName); - p->nfiles++; - - /* loop finding all the files that match the wildcard - * (which should be all of them in this directory!). - * the variable idx should point one past the null terminator - * of the previous string found. - */ - while (FindNextFile(fh, &FindData)) { - len = strlen(FindData.cFileName); - /* bump the string table size by enough for the - * new name and it's null terminator - */ - Renew(p->start, idx+len+1, char); - if (p->start == NULL) - croak("opendir: malloc failed!\n"); - strcpy(&p->start[idx], FindData.cFileName); - p->nfiles++; - idx += len+1; + if (USING_WIDE()) { + W2AHELPER(wFindData.cFileName, buffer, sizeof(buffer)); + ptr = buffer; + } + else { + ptr = aFindData.cFileName; } - FindClose(fh); - p->size = idx; - p->curr = p->start; - return p; + idx = strlen(ptr)+1; + if (idx < 256) + dirp->size = 128; + else + dirp->size = idx; + New(1304, dirp->start, dirp->size, char); + strcpy(dirp->start, ptr); + dirp->nfiles++; + dirp->end = dirp->curr = dirp->start; + dirp->end += idx; + return dirp; } /* Readdir just returns the current string pointer and bumps the * string pointer to the nDllExport entry. */ -struct direct * +DllExport struct direct * win32_readdir(DIR *dirp) { - int len; - static int dummy = 0; + long len; if (dirp->curr) { /* first set up the structure to return */ @@ -727,14 +782,51 @@ win32_readdir(DIR *dirp) dirp->dirstr.d_namlen = len; /* Fake an inode */ - dirp->dirstr.d_ino = dummy++; + dirp->dirstr.d_ino = dirp->curr - dirp->start; - /* Now set up for the nDllExport call to readdir */ + /* Now set up for the next call to readdir */ dirp->curr += len + 1; - if (dirp->curr >= (dirp->start + dirp->size)) { - dirp->curr = NULL; + if (dirp->curr >= dirp->end) { + dTHXo; + char* ptr; + BOOL res; + WIN32_FIND_DATAW wFindData; + WIN32_FIND_DATAA aFindData; + char buffer[MAX_PATH*2]; + + /* finding the next file that matches the wildcard + * (which should be all of them in this directory!). + */ + if (USING_WIDE()) { + res = FindNextFileW(dirp->handle, &wFindData); + if (res) { + W2AHELPER(wFindData.cFileName, buffer, sizeof(buffer)); + ptr = buffer; + } + } + else { + res = FindNextFileA(dirp->handle, &aFindData); + if (res) + ptr = aFindData.cFileName; + } + if (res) { + long endpos = dirp->end - dirp->start; + long newsize = endpos + strlen(ptr) + 1; + /* bump the string table size by enough for the + * new name and it's null terminator */ + while (newsize > dirp->size) { + long curpos = dirp->curr - dirp->start; + dirp->size *= 2; + Renew(dirp->start, dirp->size, char); + dirp->curr = dirp->start + curpos; + } + strcpy(dirp->start + endpos, ptr); + dirp->end = dirp->start + newsize; + dirp->nfiles++; + } + else + dirp->curr = NULL; } - return &(dirp->dirstr); } else @@ -742,33 +834,36 @@ win32_readdir(DIR *dirp) } /* Telldir returns the current string pointer position */ -long +DllExport long win32_telldir(DIR *dirp) { - return (long) dirp->curr; + return (dirp->curr - dirp->start); } /* Seekdir moves the string pointer to a previously saved position - *(Saved by telldir). + * (returned by telldir). */ -void +DllExport void win32_seekdir(DIR *dirp, long loc) { - dirp->curr = (char *)loc; + dirp->curr = dirp->start + loc; } /* Rewinddir resets the string pointer to the start */ -void +DllExport void win32_rewinddir(DIR *dirp) { dirp->curr = dirp->start; } /* free the memory allocated by opendir */ -int +DllExport int win32_closedir(DIR *dirp) { + dTHXo; + if (dirp->handle != INVALID_HANDLE_VALUE) + FindClose(dirp->handle); Safefree(dirp->start); Safefree(dirp); return 1; @@ -828,7 +923,7 @@ setgid(gid_t agid) char * getlogin(void) { - dTHR; + dTHXo; char *buf = getlogin_buffer; DWORD size = sizeof(getlogin_buffer); if (GetUserName(buf,&size)) @@ -846,6 +941,7 @@ chown(const char *path, uid_t owner, gid_t group) static long find_pid(int pid) { + dTHXo; long child; for (child = 0 ; child < w32_num_children ; ++child) { if (w32_child_pids[child] == pid) @@ -858,6 +954,7 @@ static void remove_dead_process(long child) { if (child >= 0) { + dTHXo; CloseHandle(w32_child_handles[child]); Copy(&w32_child_handles[child+1], &w32_child_handles[child], (w32_num_children-child-1), HANDLE); @@ -895,31 +992,55 @@ win32_sleep(unsigned int t) DllExport int win32_stat(const char *path, struct stat *buffer) { + dTHXo; char t[MAX_PATH+1]; - const char *p = path; int l = strlen(path); int res; + WCHAR wbuffer[MAX_PATH]; if (l > 1) { switch(path[l - 1]) { + /* FindFirstFile() and stat() are buggy with a trailing + * backslash, so change it to a forward slash :-( */ case '\\': - case '/': - if (path[l - 2] != ':') { - strncpy(t, path, l - 1); - t[l - 1] = 0; - p = t; - }; + strncpy(t, path, l-1); + t[l - 1] = '/'; + t[l] = '\0'; + path = t; + break; + /* FindFirstFile() is buggy with "x:", so add a dot :-( */ + case ':': + if (l == 2 && isALPHA(path[0])) { + t[0] = path[0]; t[1] = ':'; t[2] = '.'; t[3] = '\0'; + l = 3; + path = t; + } + break; } } - res = stat(p,buffer); + if (USING_WIDE()) { + A2WHELPER(path, wbuffer, sizeof(wbuffer)); + res = _wstat(wbuffer, (struct _stat *)buffer); + } + else { + res = stat(path, buffer); + } if (res < 0) { /* CRT is buggy on sharenames, so make sure it really isn't. * XXX using GetFileAttributesEx() will enable us to set * buffer->st_*time (but note that's not available on the * Windows of 1995) */ - DWORD r = GetFileAttributes(p); + DWORD r; + if (USING_WIDE()) { + r = GetFileAttributesW(wbuffer); + } + else { + r = GetFileAttributesA(path); + } if (r != 0xffffffff && (r & FILE_ATTRIBUTE_DIRECTORY)) { - buffer->st_mode |= S_IFDIR | S_IREAD; + /* buffer may still contain old garbage since stat() failed */ + Zero(buffer, 1, struct stat); + buffer->st_mode = S_IFDIR | S_IREAD; errno = 0; if (!(r & FILE_ATTRIBUTE_READONLY)) buffer->st_mode |= S_IWRITE | S_IEXEC; @@ -927,11 +1048,13 @@ win32_stat(const char *path, struct stat *buffer) } } else { - if (l == 3 && path[l-2] == ':' - && (path[l-1] == '\\' || path[l-1] == '/')) + if (l == 3 && isALPHA(path[0]) && path[1] == ':' + && (path[2] == '\\' || path[2] == '/')) { /* The drive can be inaccessible, some _stat()s are buggy */ - if (!GetVolumeInformation(path,NULL,0,NULL,NULL,NULL,NULL,0)) { + if (USING_WIDE() + ? !GetVolumeInformationW(wbuffer,NULL,0,NULL,NULL,NULL,NULL,0) + : !GetVolumeInformationA(path,NULL,0,NULL,NULL,NULL,NULL,0)) { errno = ENOENT; return -1; } @@ -958,78 +1081,182 @@ win32_stat(const char *path, struct stat *buffer) return res; } +/* Find the longname of a given path. path is destructively modified. + * It should have space for at least MAX_PATH characters. */ +DllExport char * +win32_longpath(char *path) +{ + WIN32_FIND_DATA fdata; + HANDLE fhand; + char tmpbuf[MAX_PATH+1]; + char *tmpstart = tmpbuf; + char *start = path; + char sep; + if (!path) + return Nullch; + + /* drive prefix */ + if (isALPHA(path[0]) && path[1] == ':' && + (path[2] == '/' || path[2] == '\\')) + { + start = path + 2; + *tmpstart++ = path[0]; + *tmpstart++ = ':'; + } + /* UNC prefix */ + else if ((path[0] == '/' || path[0] == '\\') && + (path[1] == '/' || path[1] == '\\')) + { + start = path + 2; + *tmpstart++ = path[0]; + *tmpstart++ = path[1]; + /* copy machine name */ + while (*start && *start != '/' && *start != '\\') + *tmpstart++ = *start++; + if (*start) { + *tmpstart++ = *start; + start++; + /* copy share name */ + while (*start && *start != '/' && *start != '\\') + *tmpstart++ = *start++; + } + } + sep = *start++; + if (sep == '/' || sep == '\\') + *tmpstart++ = sep; + *tmpstart = '\0'; + while (sep) { + /* walk up to slash */ + while (*start && *start != '/' && *start != '\\') + ++start; + + /* discard doubled slashes */ + while (*start && (start[1] == '/' || start[1] == '\\')) + ++start; + sep = *start; + + /* stop and find full name of component */ + *start = '\0'; + fhand = FindFirstFile(path,&fdata); + if (fhand != INVALID_HANDLE_VALUE) { + strcpy(tmpstart, fdata.cFileName); + tmpstart += strlen(fdata.cFileName); + if (sep) + *tmpstart++ = sep; + *tmpstart = '\0'; + *start++ = sep; + FindClose(fhand); + } + else { + /* failed a step, just return without side effects */ + /*PerlIO_printf(Perl_debug_log, "Failed to find %s\n", path);*/ + *start = sep; + return Nullch; + } + } + strcpy(path,tmpbuf); + return path; +} + #ifndef USE_WIN32_RTL_ENV DllExport char * win32_getenv(const char *name) { - static char *curitem = Nullch; /* XXX threadead */ - static DWORD curlen = 0; /* XXX threadead */ + dTHXo; + WCHAR wBuffer[MAX_PATH]; DWORD needlen; - if (!curitem) { - curlen = 512; - New(1305,curitem,curlen,char); - } + SV *curitem = Nullsv; - needlen = GetEnvironmentVariable(name,curitem,curlen); + if (USING_WIDE()) { + A2WHELPER(name, wBuffer, sizeof(wBuffer)); + needlen = GetEnvironmentVariableW(wBuffer, NULL, 0); + } + else + needlen = GetEnvironmentVariableA(name,NULL,0); if (needlen != 0) { - while (needlen > curlen) { - Renew(curitem,needlen,char); - curlen = needlen; - needlen = GetEnvironmentVariable(name,curitem,curlen); + curitem = sv_2mortal(newSVpvn("", 0)); + if (USING_WIDE()) { + SV *acuritem; + do { + SvGROW(curitem, (needlen+1)*sizeof(WCHAR)); + needlen = GetEnvironmentVariableW(wBuffer, + (WCHAR*)SvPVX(curitem), + needlen); + } while (needlen >= SvLEN(curitem)/sizeof(WCHAR)); + SvCUR_set(curitem, (needlen*sizeof(WCHAR))+1); + acuritem = sv_2mortal(newSVsv(curitem)); + W2AHELPER((WCHAR*)SvPVX(acuritem), SvPVX(curitem), SvCUR(curitem)); + } + else { + do { + SvGROW(curitem, needlen+1); + needlen = GetEnvironmentVariableA(name,SvPVX(curitem), + needlen); + } while (needlen >= SvLEN(curitem)); + SvCUR_set(curitem, needlen); } } else { /* allow any environment variables that begin with 'PERL' to be stored in the registry */ - if (curitem) - *curitem = '\0'; - - if (strncmp(name, "PERL", 4) == 0) { - if (curitem) { - Safefree(curitem); - curitem = Nullch; - curlen = 0; - } - curitem = GetRegStr(name, &curitem, &curlen); - } + if (strncmp(name, "PERL", 4) == 0) + (void)get_regstr(name, &curitem); } - if (curitem && *curitem == '\0') - return Nullch; + if (curitem && SvCUR(curitem)) + return SvPVX(curitem); - return curitem; + return Nullch; } DllExport int win32_putenv(const char *name) { + dTHXo; char* curitem; char* val; - int relval = -1; - if(name) { - New(1309,curitem,strlen(name)+1,char); - strcpy(curitem, name); - val = strchr(curitem, '='); - if(val) { - /* The sane way to deal with the environment. - * Has these advantages over putenv() & co.: - * * enables us to store a truly empty value in the - * environment (like in UNIX). - * * we don't have to deal with RTL globals, bugs and leaks. - * * Much faster. - * Why you may want to enable USE_WIN32_RTL_ENV: - * * environ[] and RTL functions will not reflect changes, - * which might be an issue if extensions want to access - * the env. via RTL. This cuts both ways, since RTL will - * not see changes made by extensions that call the Win32 - * functions directly, either. - * GSAR 97-06-07 - */ - *val++ = '\0'; - if(SetEnvironmentVariable(curitem, *val ? val : NULL)) - relval = 0; + WCHAR* wCuritem; + WCHAR* wVal; + int length, relval = -1; + + if (name) { + if (USING_WIDE()) { + length = strlen(name)+1; + New(1309,wCuritem,length,WCHAR); + A2WHELPER(name, wCuritem, length*sizeof(WCHAR)); + wVal = wcschr(wCuritem, '='); + if(wVal) { + *wVal++ = '\0'; + if(SetEnvironmentVariableW(wCuritem, *wVal ? wVal : NULL)) + relval = 0; + } + Safefree(wCuritem); + } + else { + New(1309,curitem,strlen(name)+1,char); + strcpy(curitem, name); + val = strchr(curitem, '='); + if(val) { + /* The sane way to deal with the environment. + * Has these advantages over putenv() & co.: + * * enables us to store a truly empty value in the + * environment (like in UNIX). + * * we don't have to deal with RTL globals, bugs and leaks. + * * Much faster. + * Why you may want to enable USE_WIN32_RTL_ENV: + * * environ[] and RTL functions will not reflect changes, + * which might be an issue if extensions want to access + * the env. via RTL. This cuts both ways, since RTL will + * not see changes made by extensions that call the Win32 + * functions directly, either. + * GSAR 97-06-07 + */ + *val++ = '\0'; + if(SetEnvironmentVariableA(curitem, *val ? val : NULL)) + relval = 0; + } + Safefree(curitem); } - Safefree(curitem); } return relval; } @@ -1070,14 +1297,13 @@ win32_times(struct tms *timebuf) return 0; } -/* fix utime() so it works on directories in NT - * thanks to Jan Dubois - */ +/* fix utime() so it works on directories in NT */ static BOOL filetime_from_time(PFILETIME pFileTime, time_t Time) { - struct tm *pTM = gmtime(&Time); + struct tm *pTM = localtime(&Time); SYSTEMTIME SystemTime; + FILETIME LocalTime; if (pTM == NULL) return FALSE; @@ -1090,19 +1316,29 @@ filetime_from_time(PFILETIME pFileTime, time_t Time) SystemTime.wSecond = pTM->tm_sec; SystemTime.wMilliseconds = 0; - return SystemTimeToFileTime(&SystemTime, pFileTime); + return SystemTimeToFileTime(&SystemTime, &LocalTime) && + LocalFileTimeToFileTime(&LocalTime, pFileTime); } DllExport int win32_utime(const char *filename, struct utimbuf *times) { + dTHXo; HANDLE handle; FILETIME ftCreate; FILETIME ftAccess; FILETIME ftWrite; struct utimbuf TimeBuffer; + WCHAR wbuffer[MAX_PATH]; - int rc = utime(filename,times); + int rc; + if (USING_WIDE()) { + A2WHELPER(filename, wbuffer, sizeof(wbuffer)); + rc = _wutime(wbuffer, (struct _utimbuf*)times); + } + else { + rc = utime(filename, times); + } /* EACCES: path specifies directory or readonly file */ if (rc == 0 || errno != EACCES /* || !IsWinNT() */) return rc; @@ -1114,9 +1350,16 @@ win32_utime(const char *filename, struct utimbuf *times) } /* This will (and should) still fail on readonly files */ - handle = CreateFile(filename, GENERIC_READ | GENERIC_WRITE, - FILE_SHARE_READ | FILE_SHARE_DELETE, NULL, - OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL); + if (USING_WIDE()) { + handle = CreateFileW(wbuffer, GENERIC_READ | GENERIC_WRITE, + FILE_SHARE_READ | FILE_SHARE_DELETE, NULL, + OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL); + } + else { + handle = CreateFileA(filename, GENERIC_READ | GENERIC_WRITE, + FILE_SHARE_READ | FILE_SHARE_DELETE, NULL, + OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL); + } if (handle == INVALID_HANDLE_VALUE) return rc; @@ -1200,7 +1443,12 @@ win32_uname(struct utsname *name) SYSTEM_INFO info; char *arch; GetSystemInfo(&info); + +#if defined(__BORLANDC__) || defined(__MINGW32__) + switch (info.u.s.wProcessorArchitecture) { +#else switch (info.wProcessorArchitecture) { +#endif case PROCESSOR_ARCHITECTURE_INTEL: arch = "x86"; break; case PROCESSOR_ARCHITECTURE_MIPS: @@ -1220,6 +1468,7 @@ win32_uname(struct utsname *name) DllExport int win32_waitpid(int pid, int *status, int flags) { + dTHXo; int retval = -1; if (pid == -1) return win32_wait(status); @@ -1257,6 +1506,7 @@ win32_wait(int *status) /* XXX this wait emulation only knows about processes * spawned via win32_spawnvp(P_NOWAIT, ...). */ + dTHXo; int i, retval; DWORD exitcode, waitcode; @@ -1293,9 +1543,10 @@ static UINT timerid = 0; static VOID CALLBACK TimerProc(HWND win, UINT msg, UINT id, DWORD time) { - KillTimer(NULL,timerid); - timerid=0; - sighandler(14); + dTHXo; + KillTimer(NULL,timerid); + timerid=0; + sighandler(14); } DllExport unsigned int @@ -1310,11 +1561,12 @@ win32_alarm(unsigned int sec) * Snag is unless something is looking at the message queue * nothing happens :-( */ + dTHXo; if (sec) { timerid = SetTimer(NULL,timerid,sec*1000,(TIMERPROC)TimerProc); if (!timerid) - croak("Cannot set timer"); + Perl_croak_nocontext("Cannot set timer"); } else { @@ -1335,6 +1587,7 @@ extern char * des_fcrypt(const char *txt, const char *salt, char *cbuf); DllExport char * win32_crypt(const char *txt, const char *salt) { + dTHXo; #ifdef HAVE_DES_FCRYPT dTHR; return des_fcrypt(txt, salt, crypt_buffer); @@ -1459,7 +1712,8 @@ win32_flock(int fd, int oper) HANDLE fh; if (!IsWinNT()) { - croak("flock() unimplemented on this platform"); + dTHXo; + Perl_croak_nocontext("flock() unimplemented on this platform"); return -1; } fh = (HANDLE)_get_osfhandle(fd); @@ -1557,7 +1811,7 @@ win32_strerror(int e) DWORD source = 0; if (e < 0 || e > sys_nerr) { - dTHR; + dTHXo; if (e < 0) e = GetLastError(); @@ -1579,21 +1833,27 @@ win32_str_os_error(void *sv, DWORD dwErr) |FORMAT_MESSAGE_IGNORE_INSERTS |FORMAT_MESSAGE_FROM_SYSTEM, NULL, dwErr, 0, (char *)&sMsg, 1, NULL); + /* strip trailing whitespace and period */ if (0 < dwLen) { - while (0 < dwLen && isspace(sMsg[--dwLen])) - ; + do { + --dwLen; /* dwLen doesn't include trailing null */ + } while (0 < dwLen && isSPACE(sMsg[dwLen])); if ('.' != sMsg[dwLen]) dwLen++; - sMsg[dwLen]= '\0'; + sMsg[dwLen] = '\0'; } if (0 == dwLen) { sMsg = (char*)LocalAlloc(0, 64/**sizeof(TCHAR)*/); - dwLen = sprintf(sMsg, - "Unknown error #0x%lX (lookup 0x%lX)", - dwErr, GetLastError()); + if (sMsg) + dwLen = sprintf(sMsg, + "Unknown error #0x%lX (lookup 0x%lX)", + dwErr, GetLastError()); + } + if (sMsg) { + dTHXo; + sv_setpvn((SV*)sv, sMsg, dwLen); + LocalFree(sMsg); } - sv_setpvn((SV*)sv, sMsg, dwLen); - LocalFree(sMsg); } @@ -1639,11 +1899,25 @@ win32_fwrite(const void *buf, size_t size, size_t count, FILE *fp) return fwrite(buf, size, count, fp); } +#define MODE_SIZE 10 + DllExport FILE * win32_fopen(const char *filename, const char *mode) { + dTHXo; + WCHAR wMode[MODE_SIZE], wBuffer[MAX_PATH]; + + if (!*filename) + return NULL; + if (stricmp(filename, "/dev/null")==0) - return fopen("NUL", mode); + filename = "NUL"; + + if (USING_WIDE()) { + A2WHELPER(mode, wMode, sizeof(wMode)); + A2WHELPER(filename, wBuffer, sizeof(wBuffer)); + return _wfopen(wBuffer, wMode); + } return fopen(filename, mode); } @@ -1653,16 +1927,30 @@ win32_fopen(const char *filename, const char *mode) #endif DllExport FILE * -win32_fdopen( int handle, const char *mode) +win32_fdopen(int handle, const char *mode) { + dTHXo; + WCHAR wMode[MODE_SIZE]; + if (USING_WIDE()) { + A2WHELPER(mode, wMode, sizeof(wMode)); + return _wfdopen(handle, wMode); + } return fdopen(handle, (char *) mode); } DllExport FILE * -win32_freopen( const char *path, const char *mode, FILE *stream) +win32_freopen(const char *path, const char *mode, FILE *stream) { + dTHXo; + WCHAR wMode[MODE_SIZE], wBuffer[MAX_PATH]; if (stricmp(path, "/dev/null")==0) - return freopen("NUL", mode, stream); + path = "NUL"; + + if (USING_WIDE()) { + A2WHELPER(mode, wMode, sizeof(wMode)); + A2WHELPER(path, wBuffer, sizeof(wBuffer)); + return _wfreopen(wBuffer, wMode, stream); + } return freopen(path, mode, stream); } @@ -1828,17 +2116,23 @@ win32_popen(const char *command, const char *mode) win32_close(p[child]); /* start the child */ - if ((childpid = do_spawn_nowait((char*)command)) == -1) - goto cleanup; + { + dTHXo; + if ((childpid = do_spawn_nowait((char*)command)) == -1) + goto cleanup; - /* revert stdfd to whatever it was before */ - if (win32_dup2(oldfd, stdfd) == -1) - goto cleanup; + /* revert stdfd to whatever it was before */ + if (win32_dup2(oldfd, stdfd) == -1) + goto cleanup; - /* close saved handle */ - win32_close(oldfd); + /* close saved handle */ + win32_close(oldfd); - sv_setiv(*av_fetch(w32_fdpid, p[parent], TRUE), childpid); + sv_setiv(*av_fetch(w32_fdpid, p[parent], TRUE), childpid); + + /* set process id so that it can be returned by perl's open() */ + PL_forkprocess = childpid; + } /* we have an fd, return a file stream */ return (win32_fdopen(p[parent], (char *)mode)); @@ -1866,7 +2160,7 @@ win32_pclose(FILE *pf) #ifdef USE_RTL_POPEN return _pclose(pf); #else - + dTHXo; int childpid, status; SV *sv; @@ -1895,12 +2189,25 @@ win32_pclose(FILE *pf) DllExport int win32_rename(const char *oname, const char *newname) { + WCHAR wOldName[MAX_PATH]; + WCHAR wNewName[MAX_PATH]; + BOOL bResult; /* XXX despite what the documentation says about MoveFileEx(), * it doesn't work under Windows95! */ if (IsWinNT()) { - if (!MoveFileEx(oname,newname, - MOVEFILE_COPY_ALLOWED|MOVEFILE_REPLACE_EXISTING)) { + dTHXo; + if (USING_WIDE()) { + A2WHELPER(oname, wOldName, sizeof(wOldName)); + A2WHELPER(newname, wNewName, sizeof(wNewName)); + bResult = MoveFileExW(wOldName,wNewName, + MOVEFILE_COPY_ALLOWED|MOVEFILE_REPLACE_EXISTING); + } + else { + bResult = MoveFileExA(oname,newname, + MOVEFILE_COPY_ALLOWED|MOVEFILE_REPLACE_EXISTING); + } + if (!bResult) { DWORD err = GetLastError(); switch (err) { case ERROR_BAD_NET_NAME: @@ -2014,15 +2321,22 @@ win32_tell(int fd) DllExport int win32_open(const char *path, int flag, ...) { + dTHXo; va_list ap; int pmode; + WCHAR wBuffer[MAX_PATH]; va_start(ap, flag); pmode = va_arg(ap, int); va_end(ap); if (stricmp(path, "/dev/null")==0) - return open("NUL", flag, pmode); + path = "NUL"; + + if (USING_WIDE()) { + A2WHELPER(path, wBuffer, sizeof(wBuffer)); + return _wopen(wBuffer, flag, pmode); + } return open(path,flag,pmode); } @@ -2083,6 +2397,7 @@ win32_chdir(const char *dir) static char * create_command_line(const char* command, const char * const *args) { + dTHXo; int index; char *cmd, *ptr, *arg; STRLEN len = strlen(command) + 1; @@ -2093,14 +2408,11 @@ create_command_line(const char* command, const char * const *args) New(1310, cmd, len, char); ptr = cmd; strcpy(ptr, command); - ptr += strlen(ptr); - *ptr++ = ' '; for (index = 0; (arg = (char*)args[index]) != NULL; ++index) { - strcpy(ptr, arg); ptr += strlen(ptr); - if ((char*)args[index+1] != NULL) - *ptr++ = ' '; + *ptr++ = ' '; + strcpy(ptr, arg); } return cmd; @@ -2109,6 +2421,7 @@ create_command_line(const char* command, const char * const *args) static char * qualified_path(const char *cmd) { + dTHXo; char *pathstr; char *fullcmd, *curfullcmd; STRLEN cmdlen = 0; @@ -2193,6 +2506,35 @@ GIVE_UP: return Nullch; } +/* The following are just place holders. + * Some hosts may provide and environment that the OS is + * not tracking, therefore, these host must provide that + * environment and the current directory to CreateProcess + */ + +void* +get_childenv(void) +{ + return NULL; +} + +void +free_childenv(void* d) +{ +} + +char* +get_childdir(void) +{ + return NULL; +} + +void +free_childdir(char* d) +{ +} + + /* XXX this needs to be made more compatible with the spawnvp() * provided by the various RTLs. In particular, searching for * *.{com,bat,cmd} files (as done by the RTLs) is unimplemented. @@ -2210,7 +2552,10 @@ win32_spawnvp(int mode, const char *cmdname, const char *const *argv) #ifdef USE_RTL_SPAWNVP return spawnvp(mode, cmdname, (char * const *)argv); #else + dTHXo; DWORD ret; + void* env; + char* dir; STARTUPINFO StartupInfo; PROCESS_INFORMATION ProcessInformation; DWORD create = 0; @@ -2219,6 +2564,9 @@ win32_spawnvp(int mode, const char *cmdname, const char *const *argv) ? &argv[1] : argv); char *fullcmd = Nullch; + env = PerlEnv_get_childenv(); + dir = PerlEnv_get_childdir(); + switch(mode) { case P_NOWAIT: /* asynch + remember result */ if (w32_num_children >= MAXIMUM_WAIT_OBJECTS) { @@ -2236,7 +2584,18 @@ win32_spawnvp(int mode, const char *cmdname, const char *const *argv) } memset(&StartupInfo,0,sizeof(StartupInfo)); StartupInfo.cb = sizeof(StartupInfo); - StartupInfo.wShowWindow = SW_SHOWDEFAULT; + StartupInfo.hStdInput = GetStdHandle(STD_INPUT_HANDLE); + StartupInfo.hStdOutput = GetStdHandle(STD_OUTPUT_HANDLE); + StartupInfo.hStdError = GetStdHandle(STD_ERROR_HANDLE); + if (StartupInfo.hStdInput != INVALID_HANDLE_VALUE && + StartupInfo.hStdOutput != INVALID_HANDLE_VALUE && + StartupInfo.hStdError != INVALID_HANDLE_VALUE) + { + StartupInfo.dwFlags |= STARTF_USESTDHANDLES; + } + else { + create |= CREATE_NEW_CONSOLE; + } RETRY: if (!CreateProcess(cmdname, /* search PATH to find executable */ @@ -2245,8 +2604,8 @@ RETRY: NULL, /* thread attributes */ TRUE, /* inherit handles */ create, /* creation flags */ - NULL, /* inherit environment */ - NULL, /* inherit cwd */ + (LPVOID)env, /* inherit environment */ + dir, /* inherit cwd */ &StartupInfo, &ProcessInformation)) { @@ -2281,7 +2640,10 @@ RETRY: } CloseHandle(ProcessInformation.hThread); + RETVAL: + PerlEnv_free_childenv(env); + PerlEnv_free_childdir(dir); Safefree(cmd); Safefree(fullcmd); return (int)ret; @@ -2488,6 +2850,52 @@ win32_get_osfhandle(int fd) return _get_osfhandle(fd); } +DllExport void* +win32_dynaload(const char* filename) +{ + dTHXo; + HMODULE hModule; + if (USING_WIDE()) { + WCHAR wfilename[MAX_PATH]; + A2WHELPER(filename, wfilename, sizeof(wfilename)); + hModule = LoadLibraryExW(wfilename, NULL, LOAD_WITH_ALTERED_SEARCH_PATH); + } + else { + hModule = LoadLibraryExA(filename, NULL, LOAD_WITH_ALTERED_SEARCH_PATH); + } + return hModule; +} + +DllExport int +win32_add_host(char *nameId, void *data) +{ + /* + * This must be called before the script is parsed, + * therefore no locking of threads is needed + */ + dTHXo; + struct host_link *link; + New(1314, link, 1, struct host_link); + link->host_data = data; + link->nameId = nameId; + link->next = w32_host_link; + w32_host_link = link; + return 1; +} + +DllExport void * +win32_get_host_data(char *nameId) +{ + dTHXo; + struct host_link *link = w32_host_link; + while(link) { + if(strEQ(link->nameId, nameId)) + return link->host_data; + link = link->next; + } + return Nullch; +} + /* * Extras. */ @@ -2521,7 +2929,7 @@ XS(w32_SetCwd) { dXSARGS; if (items != 1) - croak("usage: Win32::SetCurrentDirectory($cwd)"); + Perl_croak(aTHX_ "usage: Win32::SetCurrentDirectory($cwd)"); if (SetCurrentDirectory(SvPV_nolen(ST(0)))) XSRETURN_YES; @@ -2559,7 +2967,7 @@ XS(w32_SetLastError) { dXSARGS; if (items != 1) - croak("usage: Win32::SetLastError($error)"); + Perl_croak(aTHX_ "usage: Win32::SetLastError($error)"); SetLastError(SvIV(ST(0))); XSRETURN_EMPTY; } @@ -2703,7 +3111,7 @@ XS(w32_FormatMessage) char msgbuf[1024]; if (items != 1) - croak("usage: Win32::FormatMessage($errno)"); + Perl_croak(aTHX_ "usage: Win32::FormatMessage($errno)"); if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, &source, SvIV(ST(0)), 0, @@ -2723,7 +3131,7 @@ XS(w32_Spawn) BOOL bSuccess = FALSE; if (items != 3) - croak("usage: Win32::Spawn($cmdName, $args, $PID)"); + Perl_croak(aTHX_ "usage: Win32::Spawn($cmdName, $args, $PID)"); cmd = SvPV_nolen(ST(0)); args = SvPV_nolen(ST(1)); @@ -2756,8 +3164,11 @@ static XS(w32_GetTickCount) { dXSARGS; + DWORD msec = GetTickCount(); EXTEND(SP,1); - XSRETURN_IV(GetTickCount()); + if ((IV)msec > 0) + XSRETURN_IV(msec); + XSRETURN_NV(msec); } static @@ -2768,7 +3179,7 @@ XS(w32_GetShortPathName) DWORD len; if (items != 1) - croak("usage: Win32::GetShortPathName($longPathName)"); + Perl_croak(aTHX_ "usage: Win32::GetShortPathName($longPathName)"); shortpath = sv_mortalcopy(ST(0)); SvUPGRADE(shortpath, SVt_PV); @@ -2796,7 +3207,7 @@ XS(w32_GetFullPathName) DWORD len; if (items != 1) - croak("usage: Win32::GetFullPathName($filename)"); + Perl_croak(aTHX_ "usage: Win32::GetFullPathName($filename)"); filename = ST(0); fullpath = sv_mortalcopy(filename); @@ -2822,18 +3233,53 @@ XS(w32_GetFullPathName) } static +XS(w32_GetLongPathName) +{ + dXSARGS; + SV *path; + char tmpbuf[MAX_PATH+1]; + char *pathstr; + STRLEN len; + + if (items != 1) + Perl_croak(aTHX_ "usage: Win32::GetLongPathName($pathname)"); + + path = ST(0); + pathstr = SvPV(path,len); + strcpy(tmpbuf, pathstr); + pathstr = win32_longpath(tmpbuf); + if (pathstr) { + ST(0) = sv_2mortal(newSVpvn(pathstr, strlen(pathstr))); + XSRETURN(1); + } + XSRETURN_EMPTY; +} + +static XS(w32_Sleep) { dXSARGS; if (items != 1) - croak("usage: Win32::Sleep($milliseconds)"); + Perl_croak(aTHX_ "usage: Win32::Sleep($milliseconds)"); Sleep(SvIV(ST(0))); XSRETURN_YES; } +static +XS(w32_CopyFile) +{ + dXSARGS; + if (items != 3) + Perl_croak(aTHX_ "usage: Win32::CopyFile($from, $to, $overwrite)"); + if (CopyFile(SvPV_nolen(ST(0)), SvPV_nolen(ST(1)), !SvTRUE(ST(2)))) + XSRETURN_YES; + XSRETURN_NO; +} + void -Perl_init_os_extras() +Perl_init_os_extras(void) { + dTHXo; char *file = __FILE__; dXSUB_SYS; @@ -2861,6 +3307,8 @@ Perl_init_os_extras() newXS("Win32::GetTickCount", w32_GetTickCount, file); newXS("Win32::GetShortPathName", w32_GetShortPathName, file); newXS("Win32::GetFullPathName", w32_GetFullPathName, file); + newXS("Win32::GetLongPathName", w32_GetLongPathName, file); + newXS("Win32::CopyFile", w32_CopyFile, file); newXS("Win32::Sleep", w32_Sleep, file); /* XXX Bloat Alert! The following Activeware preloads really @@ -2914,3 +3362,4 @@ win32_strip_return(SV *sv) } #endif +