#endif
START_EXTERN_C
-extern char * g_win32_get_privlib(const char *pl);
-extern char * g_win32_get_sitelib(const char *pl);
-extern char * g_win32_get_vendorlib(const char *pl);
+extern char * g_win32_get_privlib(const char *pl, STRLEN *const len);
+extern char * g_win32_get_sitelib(const char *pl, STRLEN *const len);
+extern char * g_win32_get_vendorlib(const char *pl,
+ STRLEN *const len);
extern char * g_getlogin(void);
END_EXTERN_C
}
char*
-PerlEnvLibPath(struct IPerlEnv* piPerl, const char *pl)
+PerlEnvLibPath(struct IPerlEnv* piPerl, const char *pl, STRLEN *const len)
{
- return g_win32_get_privlib(pl);
+ return g_win32_get_privlib(pl, len);
}
char*
-PerlEnvSiteLibPath(struct IPerlEnv* piPerl, const char *pl)
+PerlEnvSiteLibPath(struct IPerlEnv* piPerl, const char *pl, STRLEN *const len)
{
- return g_win32_get_sitelib(pl);
+ return g_win32_get_sitelib(pl, len);
}
char*
-PerlEnvVendorLibPath(struct IPerlEnv* piPerl, const char *pl)
+PerlEnvVendorLibPath(struct IPerlEnv* piPerl, const char *pl,
+ STRLEN *const len)
{
- return g_win32_get_vendorlib(pl);
+ return g_win32_get_vendorlib(pl, len);
}
void
return win32_getc(pf);
}
-char*
+STDCHAR*
PerlStdIOGetBase(struct IPerlStdIO* piPerl, FILE* pf)
{
#ifdef FILE_base
FILE *f = pf;
return FILE_base(f);
#else
- return Nullch;
+ return NULL;
#endif
}
#endif
}
-char*
+STDCHAR*
PerlStdIOGetPtr(struct IPerlStdIO* piPerl, FILE* pf)
{
#ifdef USE_STDIO_PTR
FILE *f = pf;
return FILE_ptr(f);
#else
- return Nullch;
+ return NULL;
#endif
}
}
void
-PerlStdIOSetPtr(struct IPerlStdIO* piPerl, FILE* pf, char * ptr)
+PerlStdIOSetPtr(struct IPerlStdIO* piPerl, FILE* pf, STDCHAR * ptr)
{
#ifdef STDIO_PTR_LVALUE
FILE *f = pf;
int
PerlLIOIOCtl(struct IPerlLIO* piPerl, int i, unsigned int u, char *data)
{
- return win32_ioctlsocket((SOCKET)i, (long)u, (u_long*)data);
+ u_long u_long_arg;
+ int retval;
+
+ /* mauke says using memcpy avoids alignment issues */
+ memcpy(&u_long_arg, data, sizeof u_long_arg);
+ retval = win32_ioctlsocket((SOCKET)i, (long)u, &u_long_arg);
+ memcpy(data, &u_long_arg, sizeof u_long_arg);
+ return retval;
}
int
PerlLIOIsatty(struct IPerlLIO* piPerl, int fd)
{
- return isatty(fd);
+ /* The Microsoft isatty() function returns true for *all*
+ * character mode devices, including "nul". Our implementation
+ * should only return true if the handle has a console buffer.
+ */
+ DWORD mode;
+ HANDLE fh = (HANDLE)_get_osfhandle(fd);
+ if (fh == (HANDLE)-1) {
+ /* errno is already set to EBADF */
+ return 0;
+ }
+
+ if (GetConsoleMode(fh, &mode))
+ return 1;
+
+ errno = ENOTTY;
+ return 0;
}
int
int
PerlProcKillpg(struct IPerlProc* piPerl, int pid, int sig)
{
- dTHX;
- Perl_croak(aTHX_ "killpg not implemented!\n");
- return 0;
+ return win32_kill(pid, -sig);
}
int
parent_message_hwnd = w32_message_hwnd;
w32_message_hwnd = win32_create_message_window();
if (parent_message_hwnd != NULL)
- PostMessage(parent_message_hwnd, WM_USER_MESSAGE, w32_pseudo_id, (LONG)w32_message_hwnd);
+ PostMessage(parent_message_hwnd, WM_USER_MESSAGE, w32_pseudo_id, (LPARAM)w32_message_hwnd);
/* push a zero on the stack (we are the child) */
{
{
dJMPENV;
- volatile int oldscope = PL_scopestack_ix;
+ volatile int oldscope = 1; /* We are responsible for all scopes */
restart:
JMPENV_PUSH(status);
switch (status) {
case 0:
CALLRUNOPS(aTHX);
+ /* We may have additional unclosed scopes if fork() was called
+ * from within a BEGIN block. See perlfork.pod for more details.
+ * We cannot clean up these other scopes because they belong to a
+ * different interpreter, but we also cannot leave PL_scopestack_ix
+ * dangling because that can trigger an assertion in perl_destruct().
+ */
+ if (PL_scopestack_ix > oldscope) {
+ PL_scopestack[oldscope-1] = PL_scopestack[PL_scopestack_ix-1];
+ PL_scopestack_ix = oldscope;
+ }
status = 0;
break;
case 2:
if (PL_restartop) {
POPSTACK_TO(PL_mainstack);
PL_op = PL_restartop;
- PL_restartop = Nullop;
+ PL_restartop = (OP*)NULL;
goto restart;
}
PerlIO_printf(Perl_error_log, "panic: restartop\n");
/* XXX hack to avoid perl_destruct() freeing optree */
win32_checkTLS(my_perl);
- PL_main_root = Nullop;
+ PL_main_root = (OP*)NULL;
}
win32_checkTLS(my_perl);
return -1;
}
h = new CPerlHost(*(CPerlHost*)w32_internal_host);
- PerlInterpreter *new_perl = perl_clone_using((PerlInterpreter*)aTHX, 1,
+ PerlInterpreter *new_perl = perl_clone_using((PerlInterpreter*)aTHX,
+ CLONEf_COPY_STACKS,
h->m_pHostperlMem,
h->m_pHostperlMemShared,
h->m_pHostperlMemParse,
Safefree(lpStr);
}
-static char *
-get_valid_filename(pTHX_ WCHAR *widename)
-{
- char *name;
- BOOL use_default = FALSE;
- size_t widelen = wcslen(widename)+1;
- int len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, widename, widelen,
- NULL, 0, NULL, NULL);
- Newx(name, len, char);
- WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, widename, widelen,
- name, len, NULL, &use_default);
- if (use_default) {
- WCHAR *shortname;
- DWORD shortlen = GetShortPathNameW(widename, NULL, 0);
- Newx(shortname, shortlen, WCHAR);
- shortlen = GetShortPathNameW(widename, shortname, shortlen)+1;
- len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, shortname, shortlen,
- NULL, 0, NULL, NULL);
- Renew(name, len, char);
- WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, shortname, shortlen,
- name, len, NULL, NULL);
- Safefree(shortname);
- }
- return name;
-}
-
char*
CPerlHost::GetChildDir(void)
{
char* ptr;
size_t length;
- if (IsWin95()) {
- Newx(ptr, MAX_PATH+1, char);
- m_pvDir->GetCurrentDirectoryA(MAX_PATH+1, ptr);
- }
- else {
- WCHAR path[MAX_PATH+1];
- m_pvDir->GetCurrentDirectoryW(MAX_PATH+1, path);
- ptr = get_valid_filename(aTHX_ path);
- }
+ Newx(ptr, MAX_PATH+1, char);
+ m_pvDir->GetCurrentDirectoryA(MAX_PATH+1, ptr);
length = strlen(ptr);
if (length > 3) {
if ((ptr[length-1] == '\\') || (ptr[length-1] == '/'))
https://perl5.git.perl.org / perl5.git / blobdiff