#include <string.h>
#include <stdarg.h>
#include <float.h>
+#include <time.h>
+#if defined(_MSC_VER) || defined(__MINGW32__)
+#include <sys/utime.h>
+#else
+#include <utime.h>
+#endif
#ifdef __GNUC__
/* Mingw32 defaults to globing command line
#define EXECF_SPAWN_NOWAIT 3
static DWORD os_id(void);
-static char * get_shell(void);
+static void get_shell(void);
+static long tokenize(char *str, char **dest, char ***destv);
static int do_spawn2(char *cmd, int exectype);
static BOOL has_redirection(char *ptr);
static long filetime_to_clock(PFILETIME ft);
+static BOOL filetime_from_time(PFILETIME ft, time_t t);
-BOOL w32_env_probed = FALSE;
+char * w32_perlshell_tokens = Nullch;
+char ** w32_perlshell_vec;
+long w32_perlshell_items = -1;
DWORD w32_platform = (DWORD)-1;
-char w32_shellpath[MAX_PATH+1];
char w32_perllib_root[MAX_PATH+1];
HANDLE w32_perldll_handle = INVALID_HANDLE_VALUE;
#ifndef __BORLANDC__
return (w32_platform);
}
-/* XXX PERL5SHELL must be tokenized to allow switches to be passed */
-static char *
+/* Tokenize a string. Words are null-separated, and the list
+ * ends with a doubled null. Any character (except null and
+ * including backslash) may be escaped by preceding it with a
+ * backslash (the backslash will be stripped).
+ * Returns number of words in result buffer.
+ */
+static long
+tokenize(char *str, char **dest, char ***destv)
+{
+ char *retstart = Nullch;
+ char **retvstart = 0;
+ int items = -1;
+ if (str) {
+ int slen = strlen(str);
+ register char *ret;
+ register char **retv;
+ New(1307, ret, slen+2, char);
+ New(1308, retv, (slen+3)/2, char*);
+
+ retstart = ret;
+ retvstart = retv;
+ *retv = ret;
+ items = 0;
+ while (*str) {
+ *ret = *str++;
+ if (*ret == '\\' && *str)
+ *ret = *str++;
+ else if (*ret == ' ') {
+ while (*str == ' ')
+ str++;
+ if (ret == retstart)
+ ret--;
+ else {
+ *ret = '\0';
+ ++items;
+ if (*str)
+ *++retv = ret+1;
+ }
+ }
+ else if (!*str)
+ ++items;
+ ret++;
+ }
+ retvstart[items] = Nullch;
+ *ret++ = '\0';
+ *ret = '\0';
+ }
+ *dest = retstart;
+ *destv = retvstart;
+ return items;
+}
+
+static void
get_shell(void)
{
- if (!w32_env_probed) {
- char* defaultshell = (IsWinNT() ? "cmd.exe" : "command.com");
+ 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
* uncontrolled unportability of the ensuing scripts.
* interactive use (which is what most programs look in COMSPEC
* for).
*/
- char *usershell = getenv("PERL5SHELL");
-
- w32_env_probed = TRUE;
- strcpy(w32_shellpath, usershell ? usershell : defaultshell);
+ char* defaultshell = (IsWinNT() ? "cmd.exe /x/c" : "command.com /c");
+ char *usershell = getenv("PERL5SHELL");
+ w32_perlshell_items = tokenize(usershell ? usershell : defaultshell,
+ &w32_perlshell_tokens,
+ &w32_perlshell_vec);
}
- return w32_shellpath;
}
int
if (sp <= mark)
return -1;
- New(1301, argv, (sp - mark) + 4, char*);
+ get_shell();
+ New(1306, argv, (sp - mark) + w32_perlshell_items + 2, char*);
if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
++mark;
if (status < 0 && errno == ENOEXEC) {
/* possible shell-builtin, invoke with shell */
- int sh_items = 2;
+ int sh_items;
+ sh_items = w32_perlshell_items;
while (--index >= 0)
argv[index+sh_items] = argv[index];
- if (IsWinNT())
- argv[--sh_items] = "/x/c"; /* always enable command extensions */
- else
- argv[--sh_items] = "/c";
- argv[--sh_items] = get_shell();
+ while (--sh_items >= 0)
+ argv[sh_items] = w32_perlshell_vec[sh_items];
status = win32_spawnvp(flag,
(really ? SvPV(really,na) : argv[0]),
(const char* const*)argv);
}
- Safefree(argv);
if (status < 0) {
if (dowarn)
warn("Can't spawn \"%s\": %s", argv[0], strerror(errno));
}
else if (flag != P_NOWAIT)
status *= 256;
+ Safefree(argv);
return (statusvalue = status);
}
*s++ = '\0';
}
*a = Nullch;
- if(argv[0]) {
+ if (argv[0]) {
switch (exectype) {
case EXECF_SPAWN:
status = win32_spawnvp(P_WAIT, argv[0],
Safefree(cmd2);
}
if (needToTry) {
- char *argv[4];
- int i = 0;
- argv[i++] = get_shell();
- if (IsWinNT())
- argv[i++] = "/x/c";
- else
- argv[i++] = "/c";
+ char **argv;
+ int i = -1;
+ get_shell();
+ New(1306, argv, w32_perlshell_items + 2, char*);
+ while (++i < w32_perlshell_items)
+ argv[i] = w32_perlshell_vec[i];
argv[i++] = cmd;
argv[i] = Nullch;
switch (exectype) {
status = win32_execvp(argv[0], (const char* const*)argv);
break;
}
+ cmd = argv[0];
+ Safefree(argv);
}
if (status < 0) {
if (dowarn)
warn("Can't %s \"%s\": %s",
(exectype == EXECF_EXEC ? "exec" : "spawn"),
- argv[0], strerror(errno));
+ cmd, strerror(errno));
status = 255 * 256;
}
else if (exectype != EXECF_SPAWN_NOWAIT)
/* check to see if filename is a directory */
if (win32_stat(filename, &sbuf) < 0 || (sbuf.st_mode & S_IFDIR) == 0) {
- return NULL;
+ /* CRT is buggy on sharenames, so make sure it really isn't */
+ DWORD r = GetFileAttributes(filename);
+ if (r == 0xffffffff || !(r & FILE_ATTRIBUTE_DIRECTORY))
+ return NULL;
}
/* get the file system characteristics */
return 0;
}
+/* fix utime() so it works on directories in NT
+ * thanks to Jan Dubois <jan.dubois@ibm.net>
+ */
+static BOOL
+filetime_from_time(PFILETIME pFileTime, time_t Time)
+{
+ struct tm *pTM = gmtime(&Time);
+ SYSTEMTIME SystemTime;
+
+ if (pTM == NULL)
+ return FALSE;
+
+ SystemTime.wYear = pTM->tm_year + 1900;
+ SystemTime.wMonth = pTM->tm_mon + 1;
+ SystemTime.wDay = pTM->tm_mday;
+ SystemTime.wHour = pTM->tm_hour;
+ SystemTime.wMinute = pTM->tm_min;
+ SystemTime.wSecond = pTM->tm_sec;
+ SystemTime.wMilliseconds = 0;
+
+ return SystemTimeToFileTime(&SystemTime, pFileTime);
+}
+
+DllExport int
+win32_utime(const char *filename, struct utimbuf *times)
+{
+ HANDLE handle;
+ FILETIME ftCreate;
+ FILETIME ftAccess;
+ FILETIME ftWrite;
+ struct utimbuf TimeBuffer;
+
+ int rc = utime(filename,times);
+ /* EACCES: path specifies directory or readonly file */
+ if (rc == 0 || errno != EACCES /* || !IsWinNT() */)
+ return rc;
+
+ if (times == NULL) {
+ times = &TimeBuffer;
+ time(×->actime);
+ times->modtime = times->actime;
+ }
+
+ /* 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 (handle == INVALID_HANDLE_VALUE)
+ return rc;
+
+ if (GetFileTime(handle, &ftCreate, &ftAccess, &ftWrite) &&
+ filetime_from_time(&ftAccess, times->actime) &&
+ filetime_from_time(&ftWrite, times->modtime) &&
+ SetFileTime(handle, &ftCreate, &ftAccess, &ftWrite))
+ {
+ rc = 0;
+ }
+
+ CloseHandle(handle);
+ return rc;
+}
+
DllExport int
win32_wait(int *status)
{
return strerror(e);
}
+DllExport void
+win32_str_os_error(void *sv, DWORD dwErr)
+{
+ DWORD dwLen;
+ char *sMsg;
+ dwLen = FormatMessageA(FORMAT_MESSAGE_ALLOCATE_BUFFER
+ |FORMAT_MESSAGE_IGNORE_INSERTS
+ |FORMAT_MESSAGE_FROM_SYSTEM, NULL,
+ dwErr, 0, (char *)&sMsg, 1, NULL);
+ if (0 < dwLen) {
+ while (0 < dwLen && isspace(sMsg[--dwLen]))
+ ;
+ if ('.' != sMsg[dwLen])
+ dwLen++;
+ sMsg[dwLen]= '\0';
+ }
+ if (0 == dwLen) {
+ sMsg = LocalAlloc(0, 64/**sizeof(TCHAR)*/);
+ dwLen = sprintf(sMsg,
+ "Unknown error #0x%lX (lookup 0x%lX)",
+ dwErr, GetLastError());
+ }
+ sv_setpvn((SV*)sv, sMsg, dwLen);
+ LocalFree(sMsg);
+}
+
+
DllExport int
win32_fprintf(FILE *fp, const char *format, ...)
{
XSRETURN(1);
}
+static
+XS(w32_Sleep)
+{
+ dXSARGS;
+ if (items != 1)
+ croak("usage: Win32::Sleep($milliseconds)");
+ Sleep(SvIV(ST(0)));
+ XSRETURN_YES;
+}
+
void
Perl_init_os_extras()
{
char *file = __FILE__;
dXSUB_SYS;
- /* XXX should be removed after checking with Nick */
- newXS("Win32::GetCurrentDirectory", w32_GetCwd, file);
-
/* these names are Activeware compatible */
newXS("Win32::GetCwd", w32_GetCwd, file);
newXS("Win32::SetCwd", w32_SetCwd, file);
newXS("Win32::Spawn", w32_Spawn, file);
newXS("Win32::GetTickCount", w32_GetTickCount, file);
newXS("Win32::GetShortPathName", w32_GetShortPathName, file);
+ newXS("Win32::Sleep", w32_Sleep, file);
/* XXX Bloat Alert! The following Activeware preloads really
* ought to be part of Win32::Sys::*, so they're not included
}
#endif
-
-
-
-
-
-
-
-
projects / p5sagit/p5-mst-13.2.git / blobdiff