* License or the Artistic License, as specified in the README file.
*/
-#ifndef UNDER_CE
#define CHECK_HOST_INTERP
-#endif
#ifndef ___PerlHost_H___
#define ___PerlHost_H___
-#ifndef UNDER_CE
#include <signal.h>
-#endif
+#include <wchar.h>
#include "iperlsys.h"
#include "vmem.h"
#include "vdir.h"
+#ifndef WC_NO_BEST_FIT_CHARS
+# define WC_NO_BEST_FIT_CHARS 0x00000400
+#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_getlogin(void);
+extern char * g_getlogin(void);
END_EXTERN_C
class CPerlHost
return IPERL2HOST(piPerl)->IsLocked();
}
-struct IPerlMem perlMem =
+const struct IPerlMem perlMem =
{
PerlMemMalloc,
PerlMemRealloc,
return IPERL2HOST(piPerl)->IsLockedShared();
}
-struct IPerlMem perlMemShared =
+const struct IPerlMem perlMemShared =
{
PerlMemSharedMalloc,
PerlMemSharedRealloc,
return IPERL2HOST(piPerl)->IsLockedParse();
}
-struct IPerlMem perlMemParse =
+const struct IPerlMem perlMemParse =
{
PerlMemParseMalloc,
PerlMemParseRealloc,
}
char*
-PerlEnvLibPath(struct IPerlEnv* piPerl, const char *pl)
+PerlEnvLibPath(struct IPerlEnv* piPerl, WIN32_NO_REGISTRY_M_(const char *pl) STRLEN *const len)
{
- return g_win32_get_privlib(pl);
+ return win32_get_privlib(WIN32_NO_REGISTRY_M_(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 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 win32_get_vendorlib(pl, len);
}
void
win32_get_child_IO(ptr);
}
-struct IPerlEnv perlEnv =
+const struct IPerlEnv perlEnv =
{
PerlEnvGetenv,
PerlEnvPutenv,
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
}
char*
-PerlStdIOGets(struct IPerlStdIO* piPerl, FILE* pf, char* s, int n)
+PerlStdIOGets(struct IPerlStdIO* piPerl, char* s, int n, FILE* pf)
{
return win32_fgets(s, n, pf);
}
int
-PerlStdIOPutc(struct IPerlStdIO* piPerl, FILE* pf, int c)
+PerlStdIOPutc(struct IPerlStdIO* piPerl, int c, FILE* pf)
{
return win32_fputc(c, pf);
}
int
-PerlStdIOPuts(struct IPerlStdIO* piPerl, FILE* pf, const char *s)
+PerlStdIOPuts(struct IPerlStdIO* piPerl, const char *s, FILE* pf)
{
return win32_fputs(s, pf);
}
}
void
-PerlStdIOSetPtr(struct IPerlStdIO* piPerl, FILE* pf, char * ptr)
+PerlStdIOSetPtr(struct IPerlStdIO* piPerl, FILE* pf, STDCHAR * ptr)
{
#ifdef STDIO_PTR_LVALUE
FILE *f = pf;
FILE*
PerlStdIOFdupopen(struct IPerlStdIO* piPerl, FILE* pf)
{
-#ifndef UNDER_CE
FILE* pfdup;
fpos_t pos;
char mode[3];
int fileno = win32_dup(win32_fileno(pf));
/* open the file in the same mode */
-#ifdef __BORLANDC__
- if((pf)->flags & _F_READ) {
+ if (PERLIO_FILE_flag(pf) & PERLIO_FILE_flag_RD) {
mode[0] = 'r';
mode[1] = 0;
}
- else if((pf)->flags & _F_WRIT) {
+ else if (PERLIO_FILE_flag(pf) & PERLIO_FILE_flag_WR) {
mode[0] = 'a';
mode[1] = 0;
}
- else if((pf)->flags & _F_RDWR) {
+ else if (PERLIO_FILE_flag(pf) & PERLIO_FILE_flag_RW) {
mode[0] = 'r';
mode[1] = '+';
mode[2] = 0;
}
-#else
- if((pf)->_flag & _IOREAD) {
- mode[0] = 'r';
- mode[1] = 0;
- }
- else if((pf)->_flag & _IOWRT) {
- mode[0] = 'a';
- mode[1] = 0;
- }
- else if((pf)->_flag & _IORW) {
- mode[0] = 'r';
- mode[1] = '+';
- mode[2] = 0;
- }
-#endif
/* it appears that the binmode is attached to the
* file descriptor so binmode files will be handled
fsetpos(pfdup, &pos);
}
return pfdup;
-#else
- return 0;
-#endif
}
-struct IPerlStdIO perlStdIO =
+const struct IPerlStdIO perlStdIO =
{
PerlStdIOStdin,
PerlStdIOStdout,
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);
+ return win32_isatty(fd);
}
int
int
PerlLIOLstat(struct IPerlLIO* piPerl, const char *path, Stat_t *buffer)
{
- return win32_stat(path, buffer);
+ return win32_lstat(path, buffer);
}
char*
return win32_write(handle, buffer, count);
}
-struct IPerlLIO perlLIO =
+const struct IPerlLIO perlLIO =
{
PerlLIOAccess,
PerlLIOChmod,
return IPERL2HOST(piPerl)->MapPathW(path);
}
-struct IPerlDir perlDir =
+const struct IPerlDir perlDir =
{
PerlDirMakedir,
PerlDirChdir,
struct hostent*
PerlSockGethostent(struct IPerlSock* piPerl)
{
- dTHX;
- Perl_croak(aTHX_ "gethostent not implemented!\n");
+ win32_croak_not_implemented("gethostent");
return NULL;
}
return win32_ioctlsocket(s, cmd, argp);
}
-struct IPerlSock perlSock =
+const struct IPerlSock perlSock =
{
PerlSockHtonl,
PerlSockHtons,
return win32_crypt(clear, salt);
}
-void
+PERL_CALLCONV_NO_RET void
PerlProcExit(struct IPerlProc* piPerl, int status)
{
exit(status);
}
-void
+PERL_CALLCONV_NO_RET void
PerlProc_Exit(struct IPerlProc* piPerl, int status)
{
_exit(status);
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
PerlProcPauseProc(struct IPerlProc* piPerl)
{
- return win32_sleep((32767L << 16) + 32767);
+ return win32_pause();
}
PerlIO*
win32_start_child(LPVOID arg)
{
PerlInterpreter *my_perl = (PerlInterpreter*)arg;
- GV *tmpgv;
int status;
HWND parent_message_hwnd;
#ifdef PERL_SYNC_FORK
PERL_SET_THX(my_perl);
win32_checkTLS(my_perl);
- /* set $$ to pseudo id */
#ifdef PERL_SYNC_FORK
w32_pseudo_id = id;
#else
w32_pseudo_id = GetCurrentThreadId();
- if (IsWin95()) {
- int pid = (int)w32_pseudo_id;
- if (pid < 0)
- w32_pseudo_id = -pid;
- }
#endif
- if (tmpgv = gv_fetchpv("$", TRUE, SVt_PV)) {
- SV *sv = GvSV(tmpgv);
- SvREADONLY_off(sv);
- sv_setiv(sv, -(IV)w32_pseudo_id);
- SvREADONLY_on(sv);
- }
#ifdef PERL_USES_PL_PIDSTATUS
hv_clear(PL_pidstatus);
#endif
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:
LEAVE;
FREETMPS;
PL_curstash = PL_defstash;
- if (PL_endav && !PL_minus_c)
+ if (PL_curstash != PL_defstash) {
+ SvREFCNT_dec(PL_curstash);
+ PL_curstash = (HV *)SvREFCNT_inc(PL_defstash);
+ }
+ if (PL_endav && !PL_minus_c) {
+ PERL_SET_PHASE(PERL_PHASE_END);
call_list(oldscope, PL_endav);
+ }
status = STATUS_EXIT;
break;
case 3:
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);
int
PerlProcFork(struct IPerlProc* piPerl)
{
- dTHX;
#ifdef USE_ITHREADS
+ dTHX;
DWORD id;
HANDLE handle;
CPerlHost *h;
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,
errno = EAGAIN;
return -1;
}
- if (IsWin95()) {
- int pid = (int)id;
- if (pid < 0)
- id = -pid;
- }
w32_pseudo_child_handles[w32_num_pseudo_children] = handle;
w32_pseudo_child_pids[w32_num_pseudo_children] = id;
+ w32_pseudo_child_sigterm[w32_num_pseudo_children] = 0;
++w32_num_pseudo_children;
# endif
return -(int)id;
#else
- Perl_croak(aTHX_ "fork() not implemented!\n");
+ win32_croak_not_implemented("fork()");
return -1;
#endif /* USE_ITHREADS */
}
int
PerlProcLastHost(struct IPerlProc* piPerl)
{
+ /* this dTHX is unused in an optimized build since CPerlHost::num_hosts
+ is a static */
dTHX;
CPerlHost *h = (CPerlHost*)w32_internal_host;
return h->LastHost();
}
-struct IPerlProc perlProc =
+const struct IPerlProc perlProc =
{
PerlProcAbort,
PerlProcCrypt,
LPSTR*
CPerlHost::Lookup(LPCSTR lpStr)
{
-#ifdef UNDER_CE
- if (!m_lppEnvList || !m_dwEnvCount)
- return NULL;
-#endif
if (!lpStr)
return NULL;
return (LPSTR*)bsearch(&lpStr, m_lppEnvList, m_dwEnvCount, sizeof(LPSTR), lookup);
void
CPerlHost::Add(LPCSTR lpStr)
{
- dTHX;
- char szBuffer[1024];
LPSTR *lpPtr;
- int index, length = strlen(lpStr)+1;
-
- for(index = 0; lpStr[index] != '\0' && lpStr[index] != '='; ++index)
- szBuffer[index] = lpStr[index];
-
- szBuffer[index] = '\0';
+ STRLEN length = strlen(lpStr)+1;
// replacing ?
- lpPtr = Lookup(szBuffer);
+ lpPtr = Lookup(lpStr);
if (lpPtr != NULL) {
// must allocate things via host memory allocation functions
// rather than perl's Renew() et al, as the perl interpreter
void
CPerlHost::FreeLocalEnvironmentStrings(LPSTR lpStr)
{
- dTHX;
Safefree(lpStr);
}
char*
CPerlHost::GetChildDir(void)
{
- dTHX;
- int length;
char* ptr;
+ size_t length;
+
Newx(ptr, MAX_PATH+1, char);
- if(ptr) {
- m_pvDir->GetCurrentDirectoryA(MAX_PATH+1, ptr);
- length = strlen(ptr);
- if (length > 3) {
- if ((ptr[length-1] == '\\') || (ptr[length-1] == '/'))
- ptr[length-1] = 0;
- }
+ m_pvDir->GetCurrentDirectoryA(MAX_PATH+1, ptr);
+ length = strlen(ptr);
+ if (length > 3) {
+ if ((ptr[length-1] == '\\') || (ptr[length-1] == '/'))
+ ptr[length-1] = 0;
}
return ptr;
}
void
CPerlHost::FreeChildDir(char* pStr)
{
- dTHX;
Safefree(pStr);
}
LPSTR
CPerlHost::CreateLocalEnvironmentStrings(VDir &vDir)
{
- dTHX;
LPSTR lpStr, lpPtr, lpEnvPtr, lpTmp, lpLocalEnv, lpAllocPtr;
DWORD dwSize, dwEnvIndex;
int nLength, compVal;
// get the process environment strings
- lpAllocPtr = lpTmp = (LPSTR)GetEnvironmentStrings();
+ lpAllocPtr = lpTmp = (LPSTR)win32_getenvironmentstrings();
// step over current directory stuff
while(*lpTmp == '=')
}
// release the process environment strings
- FreeEnvironmentStrings(lpAllocPtr);
+ win32_freeenvironmentstrings(lpAllocPtr);
return lpPtr;
}
void
CPerlHost::Reset(void)
{
- dTHX;
if(m_lppEnvList != NULL) {
for(DWORD index = 0; index < m_dwEnvCount; ++index) {
Free(m_lppEnvList[index]);
void
CPerlHost::Clearenv(void)
{
- dTHX;
char ch;
LPSTR lpPtr, lpStr, lpEnvPtr;
if (m_lppEnvList != NULL) {
}
/* get the process environment strings */
- lpStr = lpEnvPtr = (LPSTR)GetEnvironmentStrings();
+ lpStr = lpEnvPtr = (LPSTR)win32_getenvironmentstrings();
/* step over current directory stuff */
while(*lpStr == '=')
lpStr += strlen(lpStr) + 1;
}
- FreeEnvironmentStrings(lpEnvPtr);
+ win32_freeenvironmentstrings(lpEnvPtr);
}
char*
CPerlHost::Getenv(const char *varname)
{
- dTHX;
if (!m_bTopLevel) {
char *pEnv = Find(varname);
if (pEnv && *pEnv)
int
CPerlHost::Putenv(const char *envstring)
{
- dTHX;
Add(envstring);
if (m_bTopLevel)
return win32_putenv(envstring);
int
CPerlHost::Chdir(const char *dirname)
{
- dTHX;
int ret;
if (!dirname) {
errno = ENOENT;
https://perl5.git.perl.org / perl5.git / blobdiff