#define INCL_DOS
#define INCL_NOPM
#define INCL_DOSFILEMGR
#define INCL_DOSMEMMGR
#define INCL_DOSERRORS
#define INCL_WINERRORS
#define INCL_WINSYS
/* These 3 are needed for compile if os2.h includes os2tk.h, not os2emx.h */
#define INCL_DOSPROCESS
#define SPU_DISABLESUPPRESSION 0
#define SPU_ENABLESUPPRESSION 1
#include <os2.h>
#include "dlfcn.h"
#include <emx/syscalls.h>
#include <sys/emxload.h>
#include <sys/uflags.h>
/*
* Various Unix compatibility functions for OS/2
*/
#include <stdio.h>
#include <errno.h>
#include <limits.h>
#include <process.h>
#include <fcntl.h>
#include <pwd.h>
#include <grp.h>
#define PERLIO_NOT_STDIO 0
#include "EXTERN.h"
#include "perl.h"
enum module_name_how { mod_name_handle, mod_name_shortname, mod_name_full,
mod_name_C_function = 0x100, mod_name_HMODULE = 0x200};
/* Find module name to which *this* subroutine is compiled */
#define module_name(how) module_name_at(&module_name_at, how)
static SV* module_name_at(void *pp, enum module_name_how how);
void
croak_with_os2error(char *s)
{
Perl_croak_nocontext("%s: %s", s, os2error(Perl_rc));
}
struct PMWIN_entries_t PMWIN_entries;
/*****************************************************************************/
/* 2.1 would not resolve symbols on demand, and has no ExtLIBPATH. */
struct dll_handle_t {
const char *modname;
HMODULE handle;
int requires_pm;
};
static struct dll_handle_t dll_handles[] = {
{"doscalls", 0, 0},
{"tcp32dll", 0, 0},
{"pmwin", 0, 1},
{"rexx", 0, 0},
{"rexxapi", 0, 0},
{"sesmgr", 0, 0},
{"pmshapi", 0, 1},
{"pmwp", 0, 1},
{"pmgpi", 0, 1},
{NULL, 0},
};
enum dll_handle_e {
dll_handle_doscalls,
dll_handle_tcp32dll,
dll_handle_pmwin,
dll_handle_rexx,
dll_handle_rexxapi,
dll_handle_sesmgr,
dll_handle_pmshapi,
dll_handle_pmwp,
dll_handle_pmgpi,
dll_handle_LAST,
};
#define doscalls_handle (dll_handles[dll_handle_doscalls])
#define tcp_handle (dll_handles[dll_handle_tcp32dll])
#define pmwin_handle (dll_handles[dll_handle_pmwin])
#define rexx_handle (dll_handles[dll_handle_rexx])
#define rexxapi_handle (dll_handles[dll_handle_rexxapi])
#define sesmgr_handle (dll_handles[dll_handle_sesmgr])
#define pmshapi_handle (dll_handles[dll_handle_pmshapi])
#define pmwp_handle (dll_handles[dll_handle_pmwp])
#define pmgpi_handle (dll_handles[dll_handle_pmgpi])
/* The following local-scope data is not yet included:
fargs.140 // const => OK
ino.165 // locked - and the access is almost cosmetic
layout_table.260 // startup only, locked
osv_res.257 // startup only, locked
old_esp.254 // startup only, locked
priors // const ==> OK
use_my_flock.283 // locked
emx_init_done.268 // locked
dll_handles // locked
hmtx_emx_init.267 // THIS is the lock for startup
perlos2_state_mutex // THIS is the lock for all the rest
BAD:
perlos2_state // see below
*/
/* The following global-scope data is not yet included:
OS2_Perl_data
pthreads_states // const now?
start_thread_mutex
thread_join_count // protected
thread_join_data // protected
tmppath
pDosVerifyPidTid
Perl_OS2_init3() - should it be protected?
*/
OS2_Perl_data_t OS2_Perl_data;
static struct perlos2_state_t {
int po2__my_pwent; /* = -1; */
int po2_DOS_harderr_state; /* = -1; */
signed char po2_DOS_suppression_state; /* = -1; */
PFN po2_ExtFCN[ORD_NENTRIES]; /* Labeled by ord ORD_*. */
/* struct PMWIN_entries_t po2_PMWIN_entries; */
int po2_emx_wasnt_initialized;
char po2_fname[9];
int po2_rmq_cnt;
int po2_grent_cnt;
char *po2_newp;
char *po2_oldp;
int po2_newl;
int po2_oldl;
int po2_notfound;
char po2_mangle_ret[STATIC_FILE_LENGTH+1];
ULONG po2_os2_dll_fake;
ULONG po2_os2_mytype;
ULONG po2_os2_mytype_ini;
int po2_pidtid_lookup;
struct passwd po2_pw;
int po2_pwent_cnt;
char po2_pthreads_state_buf[80];
char po2_os2error_buf[300];
/* There is no big sense to make it thread-specific, since signals
are delivered to thread 1 only. XXXX Maybe make it into an array? */
int po2_spawn_pid;
int po2_spawn_killed;
jmp_buf po2_at_exit_buf;
int po2_longjmp_at_exit;
int po2_emx_runtime_init; /* If 1, we need to manually init it */
int po2_emx_exception_init; /* If 1, we need to manually set it */
int po2_emx_runtime_secondary;
char* (*po2_perllib_mangle_installed)(char *s, unsigned int l);
char* po2_perl_sh_installed;
PGINFOSEG po2_gTable;
PLINFOSEG po2_lTable;
} perlos2_state = {
-1, /* po2__my_pwent */
-1, /* po2_DOS_harderr_state */
-1, /* po2_DOS_suppression_state */
};
#define Perl_po2() (&perlos2_state)
#define ExtFCN (Perl_po2()->po2_ExtFCN)
/* #define PMWIN_entries (Perl_po2()->po2_PMWIN_entries) */
#define emx_wasnt_initialized (Perl_po2()->po2_emx_wasnt_initialized)
#define fname (Perl_po2()->po2_fname)
#define rmq_cnt (Perl_po2()->po2_rmq_cnt)
#define grent_cnt (Perl_po2()->po2_grent_cnt)
#define newp (Perl_po2()->po2_newp)
#define oldp (Perl_po2()->po2_oldp)
#define newl (Perl_po2()->po2_newl)
#define oldl (Perl_po2()->po2_oldl)
#define notfound (Perl_po2()->po2_notfound)
#define mangle_ret (Perl_po2()->po2_mangle_ret)
#define os2_dll_fake (Perl_po2()->po2_os2_dll_fake)
#define os2_mytype (Perl_po2()->po2_os2_mytype)
#define os2_mytype_ini (Perl_po2()->po2_os2_mytype_ini)
#define pidtid_lookup (Perl_po2()->po2_pidtid_lookup)
#define pw (Perl_po2()->po2_pw)
#define pwent_cnt (Perl_po2()->po2_pwent_cnt)
#define _my_pwent (Perl_po2()->po2__my_pwent)
#define pthreads_state_buf (Perl_po2()->po2_pthreads_state_buf)
#define os2error_buf (Perl_po2()->po2_os2error_buf)
/* There is no big sense to make it thread-specific, since signals
are delivered to thread 1 only. XXXX Maybe make it into an array? */
#define spawn_pid (Perl_po2()->po2_spawn_pid)
#define spawn_killed (Perl_po2()->po2_spawn_killed)
#define DOS_harderr_state (Perl_po2()->po2_DOS_harderr_state)
#define DOS_suppression_state (Perl_po2()->po2_DOS_suppression_state)
#define at_exit_buf (Perl_po2()->po2_at_exit_buf)
#define longjmp_at_exit (Perl_po2()->po2_longjmp_at_exit)
#define emx_runtime_init (Perl_po2()->po2_emx_runtime_init)
#define emx_exception_init (Perl_po2()->po2_emx_exception_init)
#define emx_runtime_secondary (Perl_po2()->po2_emx_runtime_secondary)
#define perllib_mangle_installed (Perl_po2()->po2_perllib_mangle_installed)
#define perl_sh_installed (Perl_po2()->po2_perl_sh_installed)
#define gTable (Perl_po2()->po2_gTable)
#define lTable (Perl_po2()->po2_lTable)
const Perl_PFN * const pExtFCN = (Perl_po2()->po2_ExtFCN);
#if defined(USE_5005THREADS) || defined(USE_ITHREADS)
typedef void (*emx_startroutine)(void *);
typedef void* (*pthreads_startroutine)(void *);
enum pthreads_state {
pthreads_st_none = 0,
pthreads_st_run,
pthreads_st_exited,
pthreads_st_detached,
pthreads_st_waited,
pthreads_st_norun,
pthreads_st_exited_waited,
};
const char * const pthreads_states[] = {
"uninit",
"running",
"exited",
"detached",
"waited for",
"could not start",
"exited, then waited on",
};
enum pthread_exists { pthread_not_existant = -0xff };
static const char*
pthreads_state_string(enum pthreads_state state)
{
if (state < 0 || state >= sizeof(pthreads_states)/sizeof(*pthreads_states)) {
snprintf(pthreads_state_buf, sizeof(pthreads_state_buf),
"unknown thread state %d", (int)state);
return pthreads_state_buf;
}
return pthreads_states[state];
}
typedef struct {
void *status;
perl_cond cond;
enum pthreads_state state;
} thread_join_t;
thread_join_t *thread_join_data;
int thread_join_count;
perl_mutex start_thread_mutex;
static perl_mutex perlos2_state_mutex;
int
pthread_join(perl_os_thread tid, void **status)
{
MUTEX_LOCK(&start_thread_mutex);
if (tid < 1 || tid >= thread_join_count) {
MUTEX_UNLOCK(&start_thread_mutex);
if (tid != pthread_not_existant)
Perl_croak_nocontext("panic: join with a thread with strange ordinal %d", (int)tid);
Perl_warn_nocontext("panic: join with a thread which could not start");
*status = 0;
return 0;
}
switch (thread_join_data[tid].state) {
case pthreads_st_exited:
thread_join_data[tid].state = pthreads_st_exited_waited;
*status = thread_join_data[tid].status;
MUTEX_UNLOCK(&start_thread_mutex);
COND_SIGNAL(&thread_join_data[tid].cond);
break;
case pthreads_st_waited:
MUTEX_UNLOCK(&start_thread_mutex);
Perl_croak_nocontext("join with a thread with a waiter");
break;
case pthreads_st_norun:
{
int state = (int)thread_join_data[tid].status;
thread_join_data[tid].state = pthreads_st_none;
MUTEX_UNLOCK(&start_thread_mutex);
Perl_croak_nocontext("panic: join with a thread which could not run"
" due to attempt of tid reuse (state='%s')",
pthreads_state_string(state));
break;
}
case pthreads_st_run:
{
perl_cond cond;
thread_join_data[tid].state = pthreads_st_waited;
thread_join_data[tid].status = (void *)status;
COND_INIT(&thread_join_data[tid].cond);
cond = thread_join_data[tid].cond;
COND_WAIT(&thread_join_data[tid].cond, &start_thread_mutex);
COND_DESTROY(&cond);
MUTEX_UNLOCK(&start_thread_mutex);
break;
}
default:
MUTEX_UNLOCK(&start_thread_mutex);
Perl_croak_nocontext("panic: join with thread in unknown thread state: '%s'",
pthreads_state_string(thread_join_data[tid].state));
break;
}
return 0;
}
typedef struct {
pthreads_startroutine sub;
void *arg;
void *ctx;
} pthr_startit;
/* The lock is used:
a) Since we temporarily usurp the caller interp, so malloc() may
use it to decide on debugging the call;
b) Since *args is on the caller's stack.
*/
void
pthread_startit(void *arg1)
{
/* Thread is already started, we need to transfer control only */
pthr_startit args = *(pthr_startit *)arg1;
int tid = pthread_self();
void *rc;
int state;
if (tid <= 1) {
/* Can't croak, the setjmp() is not in scope... */
char buf[80];
snprintf(buf, sizeof(buf),
"panic: thread with strange ordinal %d created\n\r", tid);
write(2,buf,strlen(buf));
MUTEX_UNLOCK(&start_thread_mutex);
return;
}
/* Until args.sub resets it, makes debugging Perl_malloc() work: */
PERL_SET_CONTEXT(0);
if (tid >= thread_join_count) {
int oc = thread_join_count;
thread_join_count = tid + 5 + tid/5;
if (thread_join_data) {
Renew(thread_join_data, thread_join_count, thread_join_t);
Zero(thread_join_data + oc, thread_join_count - oc, thread_join_t);
} else {
Newxz(thread_join_data, thread_join_count, thread_join_t);
}
}
if (thread_join_data[tid].state != pthreads_st_none) {
/* Can't croak, the setjmp() is not in scope... */
char buf[80];
snprintf(buf, sizeof(buf),
"panic: attempt to reuse thread id %d (state='%s')\n\r",
tid, pthreads_state_string(thread_join_data[tid].state));
write(2,buf,strlen(buf));
thread_join_data[tid].status = (void*)thread_join_data[tid].state;
thread_join_data[tid].state = pthreads_st_norun;
MUTEX_UNLOCK(&start_thread_mutex);
return;
}
thread_join_data[tid].state = pthreads_st_run;
/* Now that we copied/updated the guys, we may release the caller... */
MUTEX_UNLOCK(&start_thread_mutex);
rc = (*args.sub)(args.arg);
MUTEX_LOCK(&start_thread_mutex);
switch (thread_join_data[tid].state) {
case pthreads_st_waited:
COND_SIGNAL(&thread_join_data[tid].cond);
thread_join_data[tid].state = pthreads_st_none;
*((void**)thread_join_data[tid].status) = rc;
break;
case pthreads_st_detached:
thread_join_data[tid].state = pthreads_st_none;
break;
case pthreads_st_run:
/* Somebody can wait on us; cannot exit, since OS can reuse the tid
and our waiter will get somebody else's status. */
thread_join_data[tid].state = pthreads_st_exited;
thread_join_data[tid].status = rc;
COND_INIT(&thread_join_data[tid].cond);
COND_WAIT(&thread_join_data[tid].cond, &start_thread_mutex);
COND_DESTROY(&thread_join_data[tid].cond);
thread_join_data[tid].state = pthreads_st_none; /* Ready to reuse */
break;
default:
state = thread_join_data[tid].state;
MUTEX_UNLOCK(&start_thread_mutex);
Perl_croak_nocontext("panic: unexpected thread state on exit: '%s'",
pthreads_state_string(state));
}
MUTEX_UNLOCK(&start_thread_mutex);
}
int
pthread_create(perl_os_thread *tidp, const pthread_attr_t *attr,
void *(*start_routine)(void*), void *arg)
{
dTHX;
pthr_startit args;
args.sub = (void*)start_routine;
args.arg = arg;
args.ctx = PERL_GET_CONTEXT;
MUTEX_LOCK(&start_thread_mutex);
/* Test suite creates 31 extra threads;
on machine without shared-memory-hogs this stack sizeis OK with 31: */
*tidp = _beginthread(pthread_startit, /*stack*/ NULL,
/*stacksize*/ 4*1024*1024, (void*)&args);
if (*tidp == -1) {
*tidp = pthread_not_existant;
MUTEX_UNLOCK(&start_thread_mutex);
return EINVAL;
}
MUTEX_LOCK(&start_thread_mutex); /* Wait for init to proceed */
MUTEX_UNLOCK(&start_thread_mutex);
return 0;
}
int
pthread_detach(perl_os_thread tid)
{
MUTEX_LOCK(&start_thread_mutex);
if (tid < 1 || tid >= thread_join_count) {
MUTEX_UNLOCK(&start_thread_mutex);
if (tid != pthread_not_existant)
Perl_croak_nocontext("panic: detach of a thread with strange ordinal %d", (int)tid);
Perl_warn_nocontext("detach of a thread which could not start");
return 0;
}
switch (thread_join_data[tid].state) {
case pthreads_st_waited:
MUTEX_UNLOCK(&start_thread_mutex);
Perl_croak_nocontext("detach on a thread with a waiter");
break;
case pthreads_st_run:
thread_join_data[tid].state = pthreads_st_detached;
MUTEX_UNLOCK(&start_thread_mutex);
break;
case pthreads_st_exited:
MUTEX_UNLOCK(&start_thread_mutex);
COND_SIGNAL(&thread_join_data[tid].cond);
break;
case pthreads_st_detached:
MUTEX_UNLOCK(&start_thread_mutex);
Perl_warn_nocontext("detach on an already detached thread");
break;
case pthreads_st_norun:
{
int state = (int)thread_join_data[tid].status;
thread_join_data[tid].state = pthreads_st_none;
MUTEX_UNLOCK(&start_thread_mutex);
Perl_croak_nocontext("panic: detaching thread which could not run"
" due to attempt of tid reuse (state='%s')",
pthreads_state_string(state));
break;
}
default:
MUTEX_UNLOCK(&start_thread_mutex);
Perl_croak_nocontext("panic: detach of a thread with unknown thread state: '%s'",
pthreads_state_string(thread_join_data[tid].state));
break;
}
return 0;
}
/* This is a very bastardized version; may be OK due to edge trigger of Wait */
int
os2_cond_wait(perl_cond *c, perl_mutex *m)
{
int rc;
STRLEN n_a;
if ((rc = DosResetEventSem(*c,&n_a)) && (rc != ERROR_ALREADY_RESET))
Perl_rc = CheckOSError(rc), croak_with_os2error("panic: COND_WAIT-reset");
if (m) MUTEX_UNLOCK(m);
if (CheckOSError(DosWaitEventSem(*c,SEM_INDEFINITE_WAIT))
&& (rc != ERROR_INTERRUPT))
croak_with_os2error("panic: COND_WAIT");
if (rc == ERROR_INTERRUPT)
errno = EINTR;
if (m) MUTEX_LOCK(m);
return 0;
}
#endif
static int exe_is_aout(void);
/* This should match enum entries_ordinals defined in os2ish.h. */
static const struct {
struct dll_handle_t *dll;
const char *entryname;
int entrypoint;
} loadOrdinals[] = {
{&doscalls_handle, NULL, 874}, /* DosQueryExtLibpath */
{&doscalls_handle, NULL, 873}, /* DosSetExtLibpath */
{&doscalls_handle, NULL, 460}, /* DosVerifyPidTid */
{&tcp_handle, "SETHOSTENT", 0},
{&tcp_handle, "SETNETENT" , 0},
{&tcp_handle, "SETPROTOENT", 0},
{&tcp_handle, "SETSERVENT", 0},
{&tcp_handle, "GETHOSTENT", 0},
{&tcp_handle, "GETNETENT" , 0},
{&tcp_handle, "GETPROTOENT", 0},
{&tcp_handle, "GETSERVENT", 0},
{&tcp_handle, "ENDHOSTENT", 0},
{&tcp_handle, "ENDNETENT", 0},
{&tcp_handle, "ENDPROTOENT", 0},
{&tcp_handle, "ENDSERVENT", 0},
{&pmwin_handle, NULL, 763}, /* WinInitialize */
{&pmwin_handle, NULL, 716}, /* WinCreateMsgQueue */
{&pmwin_handle, NULL, 726}, /* WinDestroyMsgQueue */
{&pmwin_handle, NULL, 918}, /* WinPeekMsg */
{&pmwin_handle, NULL, 915}, /* WinGetMsg */
{&pmwin_handle, NULL, 912}, /* WinDispatchMsg */
{&pmwin_handle, NULL, 753}, /* WinGetLastError */
{&pmwin_handle, NULL, 705}, /* WinCancelShutdown */
/* These are needed in extensions.
How to protect PMSHAPI: it comes through EMX functions? */
{&rexx_handle, "RexxStart", 0},
{&rexx_handle, "RexxVariablePool", 0},
{&rexxapi_handle, "RexxRegisterFunctionExe", 0},
{&rexxapi_handle, "RexxDeregisterFunction", 0},
{&sesmgr_handle, "DOSSMSETTITLE", 0}, /* Would not work runtime-loaded */
{&pmshapi_handle, "PRF32QUERYPROFILESIZE", 0},
{&pmshapi_handle, "PRF32OPENPROFILE", 0},
{&pmshapi_handle, "PRF32CLOSEPROFILE", 0},
{&pmshapi_handle, "PRF32QUERYPROFILE", 0},
{&pmshapi_handle, "PRF32RESET", 0},
{&pmshapi_handle, "PRF32QUERYPROFILEDATA", 0},
{&pmshapi_handle, "PRF32WRITEPROFILEDATA", 0},
/* At least some of these do not work by name, since they need
WIN32 instead of WIN... */
#if 0
These were generated with
nm I:\emx\lib\os2.a | fgrep -f API-list | grep = > API-list-entries
perl -wnle "next unless /^0+\s+E\s+_(\w+)=(\w+).(\d+)/; print qq( ORD_$1,)" API-list-entries > API-list-ORD_
perl -wnle "next unless /^0+\s+E\s+_(\w+)=(\w+).(\d+)/; print qq( {${2}_handle, NULL, $3},\t\t/* $1 */)" WinSwitch-API-list-entries >API-list-entry
#endif
{&pmshapi_handle, NULL, 123}, /* WinChangeSwitchEntry */
{&pmshapi_handle, NULL, 124}, /* WinQuerySwitchEntry */
{&pmshapi_handle, NULL, 125}, /* WinQuerySwitchHandle */
{&pmshapi_handle, NULL, 126}, /* WinQuerySwitchList */
{&pmshapi_handle, NULL, 131}, /* WinSwitchToProgram */
{&pmwin_handle, NULL, 702}, /* WinBeginEnumWindows */
{&pmwin_handle, NULL, 737}, /* WinEndEnumWindows */
{&pmwin_handle, NULL, 740}, /* WinEnumDlgItem */
{&pmwin_handle, NULL, 756}, /* WinGetNextWindow */
{&pmwin_handle, NULL, 768}, /* WinIsChild */
{&pmwin_handle, NULL, 799}, /* WinQueryActiveWindow */
{&pmwin_handle, NULL, 805}, /* WinQueryClassName */
{&pmwin_handle, NULL, 817}, /* WinQueryFocus */
{&pmwin_handle, NULL, 834}, /* WinQueryWindow */
{&pmwin_handle, NULL, 837}, /* WinQueryWindowPos */
{&pmwin_handle, NULL, 838}, /* WinQueryWindowProcess */
{&pmwin_handle, NULL, 841}, /* WinQueryWindowText */
{&pmwin_handle, NULL, 842}, /* WinQueryWindowTextLength */
{&pmwin_handle, NULL, 860}, /* WinSetFocus */
{&pmwin_handle, NULL, 875}, /* WinSetWindowPos */
{&pmwin_handle, NULL, 877}, /* WinSetWindowText */
{&pmwin_handle, NULL, 883}, /* WinShowWindow */
{&pmwin_handle, NULL, 772}, /* WinIsWindow */
{&pmwin_handle, NULL, 899}, /* WinWindowFromId */
{&pmwin_handle, NULL, 900}, /* WinWindowFromPoint */
{&pmwin_handle, NULL, 919}, /* WinPostMsg */
{&pmwin_handle, NULL, 735}, /* WinEnableWindow */
{&pmwin_handle, NULL, 736}, /* WinEnableWindowUpdate */
{&pmwin_handle, NULL, 773}, /* WinIsWindowEnabled */
{&pmwin_handle, NULL, 774}, /* WinIsWindowShowing */
{&pmwin_handle, NULL, 775}, /* WinIsWindowVisible */
{&pmwin_handle, NULL, 839}, /* WinQueryWindowPtr */
{&pmwin_handle, NULL, 843}, /* WinQueryWindowULong */
{&pmwin_handle, NULL, 844}, /* WinQueryWindowUShort */
{&pmwin_handle, NULL, 874}, /* WinSetWindowBits */
{&pmwin_handle, NULL, 876}, /* WinSetWindowPtr */
{&pmwin_handle, NULL, 878}, /* WinSetWindowULong */
{&pmwin_handle, NULL, 879}, /* WinSetWindowUShort */
{&pmwin_handle, NULL, 813}, /* WinQueryDesktopWindow */
{&pmwin_handle, NULL, 851}, /* WinSetActiveWindow */
{&doscalls_handle, NULL, 360}, /* DosQueryModFromEIP */
{&doscalls_handle, NULL, 582}, /* Dos32QueryHeaderInfo */
{&doscalls_handle, NULL, 362}, /* DosTmrQueryFreq */
{&doscalls_handle, NULL, 363}, /* DosTmrQueryTime */
{&pmwp_handle, NULL, 262}, /* WinQueryActiveDesktopPathname */
{&pmwin_handle, NULL, 765}, /* WinInvalidateRect */
{&pmwin_handle, NULL, 906}, /* WinCreateFrameControl */
{&pmwin_handle, NULL, 807}, /* WinQueryClipbrdFmtInfo */
{&pmwin_handle, NULL, 808}, /* WinQueryClipbrdOwner */
{&pmwin_handle, NULL, 809}, /* WinQueryClipbrdViewer */
{&pmwin_handle, NULL, 806}, /* WinQueryClipbrdData */
{&pmwin_handle, NULL, 793}, /* WinOpenClipbrd */
{&pmwin_handle, NULL, 707}, /* WinCloseClipbrd */
{&pmwin_handle, NULL, 854}, /* WinSetClipbrdData */
{&pmwin_handle, NULL, 855}, /* WinSetClipbrdOwner */
{&pmwin_handle, NULL, 856}, /* WinSetClipbrdViewer */
{&pmwin_handle, NULL, 739}, /* WinEnumClipbrdFmts */
{&pmwin_handle, NULL, 733}, /* WinEmptyClipbrd */
{&pmwin_handle, NULL, 700}, /* WinAddAtom */
{&pmwin_handle, NULL, 744}, /* WinFindAtom */
{&pmwin_handle, NULL, 721}, /* WinDeleteAtom */
{&pmwin_handle, NULL, 803}, /* WinQueryAtomUsage */
{&pmwin_handle, NULL, 802}, /* WinQueryAtomName */
{&pmwin_handle, NULL, 801}, /* WinQueryAtomLength */
{&pmwin_handle, NULL, 830}, /* WinQuerySystemAtomTable */
{&pmwin_handle, NULL, 714}, /* WinCreateAtomTable */
{&pmwin_handle, NULL, 724}, /* WinDestroyAtomTable */
{&pmwin_handle, NULL, 794}, /* WinOpenWindowDC */
{&pmgpi_handle, NULL, 610}, /* DevOpenDC */
{&pmgpi_handle, NULL, 606}, /* DevQueryCaps */
{&pmgpi_handle, NULL, 604}, /* DevCloseDC */
{&pmwin_handle, NULL, 789}, /* WinMessageBox */
{&pmwin_handle, NULL, 1015}, /* WinMessageBox2 */
{&pmwin_handle, NULL, 829}, /* WinQuerySysValue */
{&pmwin_handle, NULL, 873}, /* WinSetSysValue */
{&pmwin_handle, NULL, 701}, /* WinAlarm */
{&pmwin_handle, NULL, 745}, /* WinFlashWindow */
{&pmwin_handle, NULL, 780}, /* WinLoadPointer */
{&pmwin_handle, NULL, 828}, /* WinQuerySysPointer */
{&doscalls_handle, NULL, 417}, /* DosReplaceModule */
{&doscalls_handle, NULL, 976}, /* DosPerfSysCall */
{&rexxapi_handle, "RexxRegisterSubcomExe", 0},
};
HMODULE
loadModule(const char *modname, int fail)
{
HMODULE h = (HMODULE)dlopen(modname, 0);
if (!h && fail)
Perl_croak_nocontext("Error loading module '%s': %s",
modname, dlerror());
return h;
}
/* const char* const ptypes[] = { "FS", "DOS", "VIO", "PM", "DETACH" }; */
static int
my_type()
{
int rc;
TIB *tib;
PIB *pib;
if (!(_emx_env & 0x200)) return 1; /* not OS/2. */
if (CheckOSError(DosGetInfoBlocks(&tib, &pib)))
return -1;
return (pib->pib_ultype);
}
static void
my_type_set(int type)
{
int rc;
TIB *tib;
PIB *pib;
if (!(_emx_env & 0x200))
Perl_croak_nocontext("Can't set type on DOS"); /* not OS/2. */
if (CheckOSError(DosGetInfoBlocks(&tib, &pib)))
croak_with_os2error("Error getting info blocks");
pib->pib_ultype = type;
}
PFN
loadByOrdinal(enum entries_ordinals ord, int fail)
{
if (sizeof(loadOrdinals)/sizeof(loadOrdinals[0]) != ORD_NENTRIES)
Perl_croak_nocontext(
"Wrong size of loadOrdinals array: expected %d, actual %d",
sizeof(loadOrdinals)/sizeof(loadOrdinals[0]), ORD_NENTRIES);
if (ExtFCN[ord] == NULL) {
PFN fcn = (PFN)-1;
APIRET rc;
if (!loadOrdinals[ord].dll->handle) {
if (loadOrdinals[ord].dll->requires_pm && my_type() < 2) { /* FS */
char *s = getenv("PERL_ASIF_PM");
if (!s || !atoi(s)) {
/* The module will not function well without PM.
The usual way to detect PM is the existence of the mutex
\SEM32\PMDRAG.SEM. */
HMTX hMtx = 0;
if (CheckOSError(DosOpenMutexSem("\\SEM32\\PMDRAG.SEM",
&hMtx)))
Perl_croak_nocontext("Looks like we have no PM; will not load DLL %s without $ENV{PERL_ASIF_PM}",
loadOrdinals[ord].dll->modname);
DosCloseMutexSem(hMtx);
}
}
MUTEX_LOCK(&perlos2_state_mutex);
loadOrdinals[ord].dll->handle
= loadModule(loadOrdinals[ord].dll->modname, fail);
MUTEX_UNLOCK(&perlos2_state_mutex);
}
if (!loadOrdinals[ord].dll->handle)
return 0; /* Possible with FAIL==0 only */
if (CheckOSError(DosQueryProcAddr(loadOrdinals[ord].dll->handle,
loadOrdinals[ord].entrypoint,
loadOrdinals[ord].entryname,&fcn))) {
char buf[20], *s = (char*)loadOrdinals[ord].entryname;
if (!fail)
return 0;
if (!s)
sprintf(s = buf, "%d", loadOrdinals[ord].entrypoint);
Perl_croak_nocontext(
"This version of OS/2 does not support %s.%s",
loadOrdinals[ord].dll->modname, s);
}
ExtFCN[ord] = fcn;
}
if ((long)ExtFCN[ord] == -1)
Perl_croak_nocontext("panic queryaddr");
return ExtFCN[ord];
}
void
init_PMWIN_entries(void)
{
int i;
for (i = ORD_WinInitialize; i <= ORD_WinCancelShutdown; i++)
((PFN*)&PMWIN_entries)[i - ORD_WinInitialize] = loadByOrdinal(i, 1);
}
/*****************************************************/
/* socket forwarders without linking with tcpip DLLs */
DeclFuncByORD(struct hostent *, gethostent, ORD_GETHOSTENT, (void), ())
DeclFuncByORD(struct netent *, getnetent, ORD_GETNETENT, (void), ())
DeclFuncByORD(struct protoent *, getprotoent, ORD_GETPROTOENT, (void), ())
DeclFuncByORD(struct servent *, getservent, ORD_GETSERVENT, (void), ())
DeclVoidFuncByORD(sethostent, ORD_SETHOSTENT, (int x), (x))
DeclVoidFuncByORD(setnetent, ORD_SETNETENT, (int x), (x))
DeclVoidFuncByORD(setprotoent, ORD_SETPROTOENT, (int x), (x))
DeclVoidFuncByORD(setservent, ORD_SETSERVENT, (int x), (x))
DeclVoidFuncByORD(endhostent, ORD_ENDHOSTENT, (void), ())
DeclVoidFuncByORD(endnetent, ORD_ENDNETENT, (void), ())
DeclVoidFuncByORD(endprotoent, ORD_ENDPROTOENT, (void), ())
DeclVoidFuncByORD(endservent, ORD_ENDSERVENT, (void), ())
/* priorities */
static const signed char priors[] = {0, 1, 3, 2}; /* Last two interchanged,
self inverse. */
#define QSS_INI_BUFFER 1024
ULONG (*pDosVerifyPidTid) (PID pid, TID tid);
PQTOPLEVEL
get_sysinfo(ULONG pid, ULONG flags)
{
char *pbuffer;
ULONG rc, buf_len = QSS_INI_BUFFER;
PQTOPLEVEL psi;
if (pid) {
if (!pidtid_lookup) {
pidtid_lookup = 1;
*(PFN*)&pDosVerifyPidTid = loadByOrdinal(ORD_DosVerifyPidTid, 0);
}
if (pDosVerifyPidTid) { /* Warp3 or later */
/* Up to some fixpak QuerySysState() kills the system if a non-existent
pid is used. */
if (CheckOSError(pDosVerifyPidTid(pid, 1)))
return 0;
}
}
Newx(pbuffer, buf_len, char);
/* QSS_PROCESS | QSS_MODULE | QSS_SEMAPHORES | QSS_SHARED */
rc = QuerySysState(flags, pid, pbuffer, buf_len);
while (rc == ERROR_BUFFER_OVERFLOW) {
Renew(pbuffer, buf_len *= 2, char);
rc = QuerySysState(flags, pid, pbuffer, buf_len);
}
if (rc) {
FillOSError(rc);
Safefree(pbuffer);
return 0;
}
psi = (PQTOPLEVEL)pbuffer;
if (psi && pid && psi->procdata && pid != psi->procdata->pid) {
Safefree(psi);
Perl_croak_nocontext("panic: wrong pid in sysinfo");
}
return psi;
}
#define PRIO_ERR 0x1111
static ULONG
sys_prio(pid)
{
ULONG prio;
PQTOPLEVEL psi;
if (!pid)
return PRIO_ERR;
psi = get_sysinfo(pid, QSS_PROCESS);
if (!psi)
return PRIO_ERR;
prio = psi->procdata->threads->priority;
Safefree(psi);
return prio;
}
int
setpriority(int which, int pid, int val)
{
ULONG rc, prio = sys_prio(pid);
if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
if (priors[(32 - val) >> 5] + 1 == (prio >> 8)) {
/* Do not change class. */
return CheckOSError(DosSetPriority((pid < 0)
? PRTYS_PROCESSTREE : PRTYS_PROCESS,
0,
(32 - val) % 32 - (prio & 0xFF),
abs(pid)))
? -1 : 0;
} else /* if ((32 - val) % 32 == (prio & 0xFF)) */ {
/* Documentation claims one can change both class and basevalue,
* but I find it wrong. */
/* Change class, but since delta == 0 denotes absolute 0, correct. */
if (CheckOSError(DosSetPriority((pid < 0)
? PRTYS_PROCESSTREE : PRTYS_PROCESS,
priors[(32 - val) >> 5] + 1,
0,
abs(pid))))
return -1;
if ( ((32 - val) % 32) == 0 ) return 0;
return CheckOSError(DosSetPriority((pid < 0)
? PRTYS_PROCESSTREE : PRTYS_PROCESS,
0,
(32 - val) % 32,
abs(pid)))
? -1 : 0;
}
}
int
getpriority(int which /* ignored */, int pid)
{
ULONG ret;
if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
ret = sys_prio(pid);
if (ret == PRIO_ERR) {
return -1;
}
return (1 - priors[((ret >> 8) - 1)])*32 - (ret & 0xFF);
}
/*****************************************************************************/
/* spawn */
static Signal_t
spawn_sighandler(int sig)
{
/* Some programs do not arrange for the keyboard signals to be
delivered to them. We need to deliver the signal manually. */
/* We may get a signal only if
a) kid does not receive keyboard signal: deliver it;
b) kid already died, and we get a signal. We may only hope
that the pid number was not reused.
*/
if (spawn_killed)
sig = SIGKILL; /* Try harder. */
kill(spawn_pid, sig);
spawn_killed = 1;
}
static int
result(pTHX_ int flag, int pid)
{
int r, status;
Signal_t (*ihand)(); /* place to save signal during system() */
Signal_t (*qhand)(); /* place to save signal during system() */
#ifndef __EMX__
RESULTCODES res;
int rpid;
#endif
if (pid < 0 || flag != 0)
return pid;
#ifdef __EMX__
spawn_pid = pid;
spawn_killed = 0;
ihand = rsignal(SIGINT, &spawn_sighandler);
qhand = rsignal(SIGQUIT, &spawn_sighandler);
do {
r = wait4pid(pid, &status, 0);
} while (r == -1 && errno == EINTR);
rsignal(SIGINT, ihand);
rsignal(SIGQUIT, qhand);
PL_statusvalue = (U16)status;
if (r < 0)
return -1;
return status & 0xFFFF;
#else
ihand = rsignal(SIGINT, SIG_IGN);
r = DosWaitChild(DCWA_PROCESS, DCWW_WAIT, &res, &rpid, pid);
rsignal(SIGINT, ihand);
PL_statusvalue = res.codeResult << 8 | res.codeTerminate;
if (r)
return -1;
return PL_statusvalue;
#endif
}
enum execf_t {
EXECF_SPAWN,
EXECF_EXEC,
EXECF_TRUEEXEC,
EXECF_SPAWN_NOWAIT,
EXECF_SPAWN_BYFLAG,
EXECF_SYNC
};
static ULONG
file_type(char *path)
{
int rc;
ULONG apptype;
if (!(_emx_env & 0x200))
Perl_croak_nocontext("file_type not implemented on DOS"); /* not OS/2. */
if (CheckOSError(DosQueryAppType(path, &apptype))) {
switch (rc) {
case ERROR_FILE_NOT_FOUND:
case ERROR_PATH_NOT_FOUND:
return -1;
case ERROR_ACCESS_DENIED: /* Directory with this name found? */
return -3;
default: /* Found, but not an
executable, or some other
read error. */
return -2;
}
}
return apptype;
}
/* Spawn/exec a program, revert to shell if needed. */
/* global PL_Argv[] contains arguments. */
extern ULONG _emx_exception ( EXCEPTIONREPORTRECORD *,
EXCEPTIONREGISTRATIONRECORD *,
CONTEXTRECORD *,
void *);
int
do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag)
{
int trueflag = flag;
int rc, pass = 1;
char *real_name = NULL; /* Shut down the warning */
char const * args[4];
static const char * const fargs[4]
= { "/bin/sh", "-c", "\"$@\"", "spawn-via-shell", };
const char * const *argsp = fargs;
int nargs = 4;
int force_shell;
int new_stderr = -1, nostderr = 0;
int fl_stderr = 0;
STRLEN n_a;
char *buf;
PerlIO *file;
if (flag == P_WAIT)
flag = P_NOWAIT;
if (really && !*(real_name = SvPV(really, n_a)))
really = Nullsv;
retry:
if (strEQ(PL_Argv[0],"/bin/sh"))
PL_Argv[0] = PL_sh_path;
/* We should check PERL_SH* and PERLLIB_* as well? */
if (!really || pass >= 2)
real_name = PL_Argv[0];
if (real_name[0] != '/' && real_name[0] != '\\'
&& !(real_name[0] && real_name[1] == ':'
&& (real_name[2] == '/' || real_name[2] != '\\'))
) /* will spawnvp use PATH? */
TAINT_ENV(); /* testing IFS here is overkill, probably */
reread:
force_shell = 0;
if (_emx_env & 0x200) { /* OS/2. */
int type = file_type(real_name);
type_again:
if (type == -1) { /* Not found */
errno = ENOENT;
rc = -1;
goto do_script;
}
else if (type == -2) { /* Not an EXE */
errno = ENOEXEC;
rc = -1;
goto do_script;
}
else if (type == -3) { /* Is a directory? */
/* Special-case this */
char tbuf[512];
int l = strlen(real_name);
if (l + 5 <= sizeof tbuf) {
strcpy(tbuf, real_name);
strcpy(tbuf + l, ".exe");
type = file_type(tbuf);
if (type >= -3)
goto type_again;
}
errno = ENOEXEC;
rc = -1;
goto do_script;
}
switch (type & 7) {
/* Ignore WINDOWCOMPAT and FAPI, start them the same type we are. */
case FAPPTYP_WINDOWAPI:
{ /* Apparently, kids are started basing on startup type, not the morphed type */
if (os2_mytype != 3) { /* not PM */
if (flag == P_NOWAIT)
flag = P_PM;
else if ((flag & 7) != P_PM && (flag & 7) != P_SESSION && ckWARN(WARN_EXEC))
Perl_warner(aTHX_ packWARN(WARN_EXEC), "Starting PM process with flag=%d, mytype=%d",
flag, os2_mytype);
}
}
break;
case FAPPTYP_NOTWINDOWCOMPAT:
{
if (os2_mytype != 0) { /* not full screen */
if (flag == P_NOWAIT)
flag = P_SESSION;
else if ((flag & 7) != P_SESSION && ckWARN(WARN_EXEC))
Perl_warner(aTHX_ packWARN(WARN_EXEC), "Starting Full Screen process with flag=%d, mytype=%d",
flag, os2_mytype);
}
}
break;
case FAPPTYP_NOTSPEC:
/* Let the shell handle this... */
force_shell = 1;
buf = ""; /* Pacify a warning */
file = 0; /* Pacify a warning */
goto doshell_args;
break;
}
}
if (addflag) {
addflag = 0;
new_stderr = dup(2); /* Preserve stderr */
if (new_stderr == -1) {
if (errno == EBADF)
nostderr = 1;
else {
rc = -1;
goto finish;
}
} else
fl_stderr = fcntl(2, F_GETFD);
rc = dup2(1,2);
if (rc == -1)
goto finish;
fcntl(new_stderr, F_SETFD, FD_CLOEXEC);
}
#if 0
rc = result(aTHX_ trueflag, spawnvp(flag,real_name,PL_Argv));
#else
if (execf == EXECF_TRUEEXEC)
rc = execvp(real_name,PL_Argv);
else if (execf == EXECF_EXEC)
rc = spawnvp(trueflag | P_OVERLAY,real_name,PL_Argv);
else if (execf == EXECF_SPAWN_NOWAIT)
rc = spawnvp(flag,real_name,PL_Argv);
else if (execf == EXECF_SYNC)
rc = spawnvp(trueflag,real_name,PL_Argv);
else /* EXECF_SPAWN, EXECF_SPAWN_BYFLAG */
rc = result(aTHX_ trueflag,
spawnvp(flag,real_name,PL_Argv));
#endif
if (rc < 0 && pass == 1) {
do_script:
if (real_name == PL_Argv[0]) {
int err = errno;
if (err == ENOENT || err == ENOEXEC) {
/* No such file, or is a script. */
/* Try adding script extensions to the file name, and
search on PATH. */
char *scr = find_script(PL_Argv[0], TRUE, NULL, 0);
if (scr) {
char *s = 0, *s1;
SV *scrsv = sv_2mortal(newSVpv(scr, 0));
SV *bufsv = sv_newmortal();
Safefree(scr);
scr = SvPV(scrsv, n_a); /* free()ed later */
file = PerlIO_open(scr, "r");
PL_Argv[0] = scr;
if (!file)
goto panic_file;
buf = sv_gets(bufsv, file, 0 /* No append */);
if (!buf)
buf = ""; /* XXX Needed? */
if (!buf[0]) { /* Empty... */
PerlIO_close(file);
/* Special case: maybe from -Zexe build, so
there is an executable around (contrary to
documentation, DosQueryAppType sometimes (?)
does not append ".exe", so we could have
reached this place). */
sv_catpv(scrsv, ".exe");
PL_Argv[0] = scr = SvPV(scrsv, n_a); /* Reload */
if (PerlLIO_stat(scr,&PL_statbuf) >= 0
&& !S_ISDIR(PL_statbuf.st_mode)) { /* Found */
real_name = scr;
pass++;
goto reread;
} else { /* Restore */
SvCUR_set(scrsv, SvCUR(scrsv) - 4);
*SvEND(scrsv) = 0;
}
}
if (PerlIO_close(file) != 0) { /* Failure */
panic_file:
if (ckWARN(WARN_EXEC))
Perl_warner(aTHX_ packWARN(WARN_EXEC), "Error reading \"%s\": %s",
scr, Strerror(errno));
buf = ""; /* Not #! */
goto doshell_args;
}
if (buf[0] == '#') {
if (buf[1] == '!')
s = buf + 2;
} else if (buf[0] == 'e') {
if (strnEQ(buf, "extproc", 7)
&& isSPACE(buf[7]))
s = buf + 8;
} else if (buf[0] == 'E') {
if (strnEQ(buf, "EXTPROC", 7)
&& isSPACE(buf[7]))
s = buf + 8;
}
if (!s) {
buf = ""; /* Not #! */
goto doshell_args;
}
s1 = s;
nargs = 0;
argsp = args;
while (1) {
/* Do better than pdksh: allow a few args,
strip trailing whitespace. */
while (isSPACE(*s))
s++;
if (*s == 0)
break;
if (nargs == 4) {
nargs = -1;
break;
}
args[nargs++] = s;
while (*s && !isSPACE(*s))
s++;
if (*s == 0)
break;
*s++ = 0;
}
if (nargs == -1) {
Perl_warner(aTHX_ packWARN(WARN_EXEC), "Too many args on %.*s line of \"%s\"",
s1 - buf, buf, scr);
nargs = 4;
argsp = fargs;
}
/* Can jump from far, buf/file invalid if force_shell: */
doshell_args:
{
char **a = PL_Argv;
const char *exec_args[2];
if (force_shell
|| (!buf[0] && file)) { /* File without magic */
/* In fact we tried all what pdksh would
try. There is no point in calling
pdksh, we may just emulate its logic. */
char *shell = getenv("EXECSHELL");
char *shell_opt = NULL;
if (!shell) {
char *s;
shell_opt = "/c";
shell = getenv("OS2_SHELL");
if (inicmd) { /* No spaces at start! */
s = inicmd;
while (*s && !isSPACE(*s)) {
if (*s++ == '/') {
inicmd = NULL; /* Cannot use */
break;
}
}
}
if (!inicmd) {
s = PL_Argv[0];
while (*s) {
/* Dosish shells will choke on slashes
in paths, fortunately, this is
important for zeroth arg only. */
if (*s == '/')
*s = '\\';
s++;
}
}
}
/* If EXECSHELL is set, we do not set */
if (!shell)
shell = ((_emx_env & 0x200)
? "c:/os2/cmd.exe"
: "c:/command.com");
nargs = shell_opt ? 2 : 1; /* shell file args */
exec_args[0] = shell;
exec_args[1] = shell_opt;
argsp = exec_args;
if (nargs == 2 && inicmd) {
/* Use the original cmd line */
/* XXXX This is good only until we refuse
quoted arguments... */
PL_Argv[0] = inicmd;
PL_Argv[1] = Nullch;
}
} else if (!buf[0] && inicmd) { /* No file */
/* Start with the original cmdline. */
/* XXXX This is good only until we refuse
quoted arguments... */
PL_Argv[0] = inicmd;
PL_Argv[1] = Nullch;
nargs = 2; /* shell -c */
}
while (a[1]) /* Get to the end */
a++;
a++; /* Copy finil NULL too */
while (a >= PL_Argv) {
*(a + nargs) = *a; /* PL_Argv was preallocated to be
long enough. */
a--;
}
while (--nargs >= 0) /* XXXX Discard const... */
PL_Argv[nargs] = (char*)argsp[nargs];
/* Enable pathless exec if #! (as pdksh). */
pass = (buf[0] == '#' ? 2 : 3);
goto retry;
}
}
/* Not found: restore errno */
errno = err;
}
} else if (errno == ENOEXEC) { /* Cannot transfer `real_name' via shell. */
if (rc < 0 && ckWARN(WARN_EXEC))
Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s script `%s' with ARGV[0] being `%s'",
((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC)
? "spawn" : "exec"),
real_name, PL_Argv[0]);
goto warned;
} else if (errno == ENOENT) { /* Cannot transfer `real_name' via shell. */
if (rc < 0 && ckWARN(WARN_EXEC))
Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s `%s' with ARGV[0] being `%s' (looking for executables only, not found)",
((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC)
? "spawn" : "exec"),
real_name, PL_Argv[0]);
goto warned;
}
} else if (rc < 0 && pass == 2 && errno == ENOENT) { /* File not found */
char *no_dir = strrchr(PL_Argv[0], '/');
/* Do as pdksh port does: if not found with /, try without
path. */
if (no_dir) {
PL_Argv[0] = no_dir + 1;
pass++;
goto retry;
}
}
if (rc < 0 && ckWARN(WARN_EXEC))
Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s\n",
((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC)
? "spawn" : "exec"),
real_name, Strerror(errno));
warned:
if (rc < 0 && (execf != EXECF_SPAWN_NOWAIT)
&& ((trueflag & 0xFF) == P_WAIT))
rc = -1;
finish:
if (new_stderr != -1) { /* How can we use error codes? */
dup2(new_stderr, 2);
close(new_stderr);
fcntl(2, F_SETFD, fl_stderr);
} else if (nostderr)
close(2);
return rc;
}
/* Try converting 1-arg form to (usually shell-less) multi-arg form. */
int
do_spawn3(pTHX_ char *cmd, int execf, int flag)
{
register char **a;
register char *s;
char *shell, *copt, *news = NULL;
int rc, seenspace = 0, mergestderr = 0;
#ifdef TRYSHELL
if ((shell = getenv("EMXSHELL")) != NULL)
copt = "-c";
else if ((shell = getenv("SHELL")) != NULL)
copt = "-c";
else if ((shell = getenv("COMSPEC")) != NULL)
copt = "/C";
else
shell = "cmd.exe";
#else
/* Consensus on perl5-porters is that it is _very_ important to
have a shell which will not change between computers with the
same architecture, to avoid "action on a distance".
And to have simple build, this shell should be sh. */
shell = PL_sh_path;
copt = "-c";
#endif
while (*cmd && isSPACE(*cmd))
cmd++;
if (strnEQ(cmd,"/bin/sh",7) && isSPACE(cmd[7])) {
STRLEN l = strlen(PL_sh_path);
Newx(news, strlen(cmd) - 7 + l + 1, char);
strcpy(news, PL_sh_path);
strcpy(news + l, cmd + 7);
cmd = news;
}
/* save an extra exec if possible */
/* see if there are shell metacharacters in it */
if (*cmd == '.' && isSPACE(cmd[1]))
goto doshell;
if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
goto doshell;
for (s = cmd; *s && isALPHA(*s); s++) ; /* catch VAR=val gizmo */
if (*s == '=')
goto doshell;
for (s = cmd; *s; s++) {
if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
if (*s == '\n' && s[1] == '\0') {
*s = '\0';
break;
} else if (*s == '\\' && !seenspace) {
continue; /* Allow backslashes in names */
} else if (*s == '>' && s >= cmd + 3
&& s[-1] == '2' && s[1] == '&' && s[2] == '1'
&& isSPACE(s[-2]) ) {
char *t = s + 3;
while (*t && isSPACE(*t))
t++;
if (!*t) {
s[-2] = '\0';
mergestderr = 1;
break; /* Allow 2>&1 as the last thing */
}
}
/* We do not convert this to do_spawn_ve since shell
should be smart enough to start itself gloriously. */
doshell:
if (execf == EXECF_TRUEEXEC)
rc = execl(shell,shell,copt,cmd,(char*)0);
else if (execf == EXECF_EXEC)
rc = spawnl(P_OVERLAY,shell,shell,copt,cmd,(char*)0);
else if (execf == EXECF_SPAWN_NOWAIT)
rc = spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0);
else if (execf == EXECF_SPAWN_BYFLAG)
rc = spawnl(flag,shell,shell,copt,cmd,(char*)0);
else {
/* In the ak code internal P_NOWAIT is P_WAIT ??? */
if (execf == EXECF_SYNC)
rc = spawnl(P_WAIT,shell,shell,copt,cmd,(char*)0);
else
rc = result(aTHX_ P_WAIT,
spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0));
if (rc < 0 && ckWARN(WARN_EXEC))
Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s",
(execf == EXECF_SPAWN ? "spawn" : "exec"),
shell, Strerror(errno));
if (rc < 0)
rc = -1;
}
if (news)
Safefree(news);
return rc;
} else if (*s == ' ' || *s == '\t') {
seenspace = 1;
}
}
/* cmd="a" may lead to "sh", "-c", "\"$@\"", "a", "a.cmd", NULL */
Newx(PL_Argv, (s - cmd + 11) / 2, char*);
PL_Cmd = savepvn(cmd, s-cmd);
a = PL_Argv;
for (s = PL_Cmd; *s;) {
while (*s && isSPACE(*s)) s++;
if (*s)
*(a++) = s;
while (*s && !isSPACE(*s)) s++;
if (*s)
*s++ = '\0';
}
*a = Nullch;
if (PL_Argv[0])
rc = do_spawn_ve(aTHX_ NULL, flag, execf, cmd, mergestderr);
else
rc = -1;
if (news)
Safefree(news);
do_execfree();
return rc;
}
#define ASPAWN_WAIT 0
#define ASPAWN_EXEC 1
#define ASPAWN_NOWAIT 2
/* Array spawn/exec. */
int
os2_aspawn_4(pTHX_ SV *really, register SV **args, I32 cnt, int execing)
{
register SV **argp = (SV **)args;
register SV **last = argp + cnt;
register char **a;
int rc;
int flag = P_WAIT, flag_set = 0;
STRLEN n_a;
if (cnt) {
Newx(PL_Argv, cnt + 3, char*); /* 3 extra to expand #! */
a = PL_Argv;
if (cnt > 1 && SvNIOKp(*argp) && !SvPOKp(*argp)) {
flag = SvIVx(*argp);
flag_set = 1;
} else
--argp;
while (++argp < last) {
if (*argp)
*a++ = SvPVx(*argp, n_a);
else
*a++ = "";
}
*a = Nullch;
if ( flag_set && (a == PL_Argv + 1)
&& !really && execing == ASPAWN_WAIT ) { /* One arg? */
rc = do_spawn3(aTHX_ a[-1], EXECF_SPAWN_BYFLAG, flag);
} else {
const int execf[3] = {EXECF_SPAWN, EXECF_EXEC, EXECF_SPAWN_NOWAIT};
rc = do_spawn_ve(aTHX_ really, flag, execf[execing], NULL, 0);
}
} else
rc = -1;
do_execfree();
return rc;
}
/* Array spawn. */
int
os2_do_aspawn(pTHX_ SV *really, register SV **vmark, register SV **vsp)
{
return os2_aspawn_4(aTHX_ really, vmark + 1, vsp - vmark, ASPAWN_WAIT);
}
/* Array exec. */
bool
Perl_do_aexec(pTHX_ SV* really, SV** vmark, SV** vsp)
{
return os2_aspawn_4(aTHX_ really, vmark + 1, vsp - vmark, ASPAWN_EXEC);
}
int
os2_do_spawn(pTHX_ char *cmd)
{
return do_spawn3(aTHX_ cmd, EXECF_SPAWN, 0);
}
int
do_spawn_nowait(pTHX_ char *cmd)
{
return do_spawn3(aTHX_ cmd, EXECF_SPAWN_NOWAIT,0);
}
bool
Perl_do_exec(pTHX_ const char *cmd)
{
do_spawn3(aTHX_ cmd, EXECF_EXEC, 0);
return FALSE;
}
bool
os2exec(pTHX_ char *cmd)
{
return do_spawn3(aTHX_ cmd, EXECF_TRUEEXEC, 0);
}
PerlIO *
my_syspopen4(pTHX_ char *cmd, char *mode, I32 cnt, SV** args)
{
#ifndef USE_POPEN
int p[2];
register I32 this, that, newfd;
register I32 pid;
SV *sv;
int fh_fl = 0; /* Pacify the warning */
/* `this' is what we use in the parent, `that' in the child. */
this = (*mode == 'w');
that = !this;
if (PL_tainting) {
taint_env();
taint_proper("Insecure %s%s", "EXEC");
}
if (pipe(p) < 0)
return Nullfp;
/* Now we need to spawn the child. */
if (p[this] == (*mode == 'r')) { /* if fh 0/1 was initially closed. */
int new = dup(p[this]);
if (new == -1)
goto closepipes;
close(p[this]);
p[this] = new;
}
newfd = dup(*mode == 'r'); /* Preserve std* */
if (newfd == -1) {
/* This cannot happen due to fh being bad after pipe(), since
pipe() should have created fh 0 and 1 even if they were
initially closed. But we closed p[this] before. */
if (errno != EBADF) {
closepipes:
close(p[0]);
close(p[1]);
return Nullfp;
}
} else
fh_fl = fcntl(*mode == 'r', F_GETFD);
if (p[that] != (*mode == 'r')) { /* if fh 0/1 was initially closed. */
dup2(p[that], *mode == 'r');
close(p[that]);
}
/* Where is `this' and newfd now? */
fcntl(p[this], F_SETFD, FD_CLOEXEC);
if (newfd != -1)
fcntl(newfd, F_SETFD, FD_CLOEXEC);
if (cnt) { /* Args: "Real cmd", before first arg, the last, execing */
pid = os2_aspawn_4(aTHX_ Nullsv, args, cnt, ASPAWN_NOWAIT);
} else
pid = do_spawn_nowait(aTHX_ cmd);
if (newfd == -1)
close(*mode == 'r'); /* It was closed initially */
else if (newfd != (*mode == 'r')) { /* Probably this check is not needed */
dup2(newfd, *mode == 'r'); /* Return std* back. */
close(newfd);
fcntl(*mode == 'r', F_SETFD, fh_fl);
} else
fcntl(*mode == 'r', F_SETFD, fh_fl);
if (p[that] == (*mode == 'r'))
close(p[that]);
if (pid == -1) {
close(p[this]);
return Nullfp;
}
if (p[that] < p[this]) { /* Make fh as small as possible */
dup2(p[this], p[that]);
close(p[this]);
p[this] = p[that];
}
sv = *av_fetch(PL_fdpid,p[this],TRUE);
(void)SvUPGRADE(sv,SVt_IV);
SvIVX(sv) = pid;
PL_forkprocess = pid;
return PerlIO_fdopen(p[this], mode);
#else /* USE_POPEN */
PerlIO *res;
SV *sv;
if (cnt)
Perl_croak(aTHX_ "List form of piped open not implemented");
# ifdef TRYSHELL
res = popen(cmd, mode);
# else
char *shell = getenv("EMXSHELL");
my_setenv("EMXSHELL", PL_sh_path);
res = popen(cmd, mode);
my_setenv("EMXSHELL", shell);
# endif
sv = *av_fetch(PL_fdpid, PerlIO_fileno(res), TRUE);
(void)SvUPGRADE(sv,SVt_IV);
SvIVX(sv) = -1; /* A cooky. */
return res;
#endif /* USE_POPEN */
}
PerlIO *
my_syspopen(pTHX_ char *cmd, char *mode)
{
return my_syspopen4(aTHX_ cmd, mode, 0, NULL);
}
/******************************************************************/
#ifndef HAS_FORK
int
fork(void)
{
Perl_croak_nocontext(PL_no_func, "Unsupported function fork");
errno = EINVAL;
return -1;
}
#endif
/*******************************************************************/
/* not implemented in EMX 0.9d */
char * ctermid(char *s) { return 0; }
#ifdef MYTTYNAME /* was not in emx0.9a */
void * ttyname(x) { return 0; }
#endif
/*****************************************************************************/
/* not implemented in C Set++ */
#ifndef __EMX__
int setuid(x) { errno = EINVAL; return -1; }
int setgid(x) { errno = EINVAL; return -1; }
#endif
/*****************************************************************************/
/* stat() hack for char/block device */
#if OS2_STAT_HACK
enum os2_stat_extra { /* EMX 0.9d fix 4 defines up to 0100000 */
os2_stat_archived = 0x1000000, /* 0100000000 */
os2_stat_hidden = 0x2000000, /* 0200000000 */
os2_stat_system = 0x4000000, /* 0400000000 */
os2_stat_force = 0x8000000, /* Do not ignore flags on chmod */
};
#define OS2_STAT_SPECIAL (os2_stat_system | os2_stat_archived | os2_stat_hidden)
static void
massage_os2_attr(struct stat *st)
{
if ( ((st->st_mode & S_IFMT) != S_IFREG
&& (st->st_mode & S_IFMT) != S_IFDIR)
|| !(st->st_attr & (FILE_ARCHIVED | FILE_HIDDEN | FILE_SYSTEM)))
return;
if ( st->st_attr & FILE_ARCHIVED )
st->st_mode |= (os2_stat_archived | os2_stat_force);
if ( st->st_attr & FILE_HIDDEN )
st->st_mode |= (os2_stat_hidden | os2_stat_force);
if ( st->st_attr & FILE_SYSTEM )
st->st_mode |= (os2_stat_system | os2_stat_force);
}
/* First attempt used DosQueryFSAttach which crashed the system when
used with 5.001. Now just look for /dev/. */
int
os2_stat(const char *name, struct stat *st)
{
static int ino = SHRT_MAX;
STRLEN l = strlen(name);
if ( ( l < 8 || l > 9) || strnicmp(name, "/dev/", 5) != 0
|| ( stricmp(name + 5, "con") != 0
&& stricmp(name + 5, "tty") != 0
&& stricmp(name + 5, "nul") != 0
&& stricmp(name + 5, "null") != 0) ) {
int s = stat(name, st);
if (s)
return s;
massage_os2_attr(st);
return 0;
}
memset(st, 0, sizeof *st);
st->st_mode = S_IFCHR|0666;
MUTEX_LOCK(&perlos2_state_mutex);
st->st_ino = (ino-- & 0x7FFF);
MUTEX_UNLOCK(&perlos2_state_mutex);
st->st_nlink = 1;
return 0;
}
int
os2_fstat(int handle, struct stat *st)
{
int s = fstat(handle, st);
if (s)
return s;
massage_os2_attr(st);
return 0;
}
#undef chmod
int
os2_chmod (const char *name, int pmode) /* Modelled after EMX src/lib/io/chmod.c */
{
int attr, rc;
if (!(pmode & os2_stat_force))
return chmod(name, pmode);
attr = __chmod (name, 0, 0); /* Get attributes */
if (attr < 0)
return -1;
if (pmode & S_IWRITE)
attr &= ~FILE_READONLY;
else
attr |= FILE_READONLY;
/* New logic */
attr &= ~(FILE_ARCHIVED | FILE_HIDDEN | FILE_SYSTEM);
if ( pmode & os2_stat_archived )
attr |= FILE_ARCHIVED;
if ( pmode & os2_stat_hidden )
attr |= FILE_HIDDEN;
if ( pmode & os2_stat_system )
attr |= FILE_SYSTEM;
rc = __chmod (name, 1, attr);
if (rc >= 0) rc = 0;
return rc;
}
#endif
#ifdef USE_PERL_SBRK
/* SBRK() emulation, mostly moved to malloc.c. */
void *
sys_alloc(int size) {
void *got;
APIRET rc = DosAllocMem(&got, size, PAG_COMMIT | PAG_WRITE);
if (rc == ERROR_NOT_ENOUGH_MEMORY) {
return (void *) -1;
} else if ( rc )
Perl_croak_nocontext("Got an error from DosAllocMem: %li", (long)rc);
return got;
}
#endif /* USE_PERL_SBRK */
/* tmp path */
const char *tmppath = TMPPATH1;
void
settmppath()
{
char *p = getenv("TMP"), *tpath;
int len;
if (!p) p = getenv("TEMP");
if (!p) p = getenv("TMPDIR");
if (!p) return;
len = strlen(p);
tpath = (char *)malloc(len + strlen(TMPPATH1) + 2);
if (tpath) {
strcpy(tpath, p);
tpath[len] = '/';
strcpy(tpath + len + 1, TMPPATH1);
tmppath = tpath;
}
}
#include "XSUB.h"
XS(XS_File__Copy_syscopy)
{
dXSARGS;
if (items < 2 || items > 3)
Perl_croak_nocontext("Usage: File::Copy::syscopy(src,dst,flag=0)");
{
STRLEN n_a;
char * src = (char *)SvPV(ST(0),n_a);
char * dst = (char *)SvPV(ST(1),n_a);
U32 flag;
int RETVAL, rc;
dXSTARG;
if (items < 3)
flag = 0;
else {
flag = (unsigned long)SvIV(ST(2));
}
RETVAL = !CheckOSError(DosCopy(src, dst, flag));
XSprePUSH; PUSHi((IV)RETVAL);
}
XSRETURN(1);
}
/* APIRET APIENTRY DosReplaceModule (PCSZ pszOld, PCSZ pszNew, PCSZ pszBackup); */
DeclOSFuncByORD(ULONG,replaceModule,ORD_DosReplaceModule,
(char *old, char *new, char *backup), (old, new, backup))
XS(XS_OS2_replaceModule); /* prototype to pass -Wmissing-prototypes */
XS(XS_OS2_replaceModule)
{
dXSARGS;
if (items < 1 || items > 3)
Perl_croak(aTHX_ "Usage: OS2::replaceModule(target [, source [, backup]])");
{
char * target = (char *)SvPV_nolen(ST(0));
char * source = (items < 2) ? Nullch : (char *)SvPV_nolen(ST(1));
char * backup = (items < 3) ? Nullch : (char *)SvPV_nolen(ST(2));
if (!replaceModule(target, source, backup))
croak_with_os2error("replaceModule() error");
}
XSRETURN_YES;
}
/* APIRET APIENTRY DosPerfSysCall(ULONG ulCommand, ULONG ulParm1,
ULONG ulParm2, ULONG ulParm3); */
DeclOSFuncByORD(ULONG,perfSysCall,ORD_DosPerfSysCall,
(ULONG ulCommand, ULONG ulParm1, ULONG ulParm2, ULONG ulParm3),
(ulCommand, ulParm1, ulParm2, ulParm3))
#ifndef CMD_KI_RDCNT
# define CMD_KI_RDCNT 0x63
#endif
#ifndef CMD_KI_GETQTY
# define CMD_KI_GETQTY 0x41
#endif
#ifndef QSV_NUMPROCESSORS
# define QSV_NUMPROCESSORS 26
#endif
typedef unsigned long long myCPUUTIL[4]; /* time/idle/busy/intr */
/*
NO_OUTPUT ULONG
perfSysCall(ULONG ulCommand, ULONG ulParm1, ULONG ulParm2, ULONG ulParm3)
PREINIT:
ULONG rc;
POSTCALL:
if (!RETVAL)
croak_with_os2error("perfSysCall() error");
*/
static int
numprocessors(void)
{
ULONG res;
if (DosQuerySysInfo(QSV_NUMPROCESSORS, QSV_NUMPROCESSORS, (PVOID)&res, sizeof(res)))
return 1; /* Old system? */
return res;
}
XS(XS_OS2_perfSysCall); /* prototype to pass -Wmissing-prototypes */
XS(XS_OS2_perfSysCall)
{
dXSARGS;
if (items < 0 || items > 4)
Perl_croak(aTHX_ "Usage: OS2::perfSysCall(ulCommand = CMD_KI_RDCNT, ulParm1= 0, ulParm2= 0, ulParm3= 0)");
SP -= items;
{
dXSTARG;
ULONG RETVAL, ulCommand, ulParm1, ulParm2, ulParm3, res;
myCPUUTIL u[64];
int total = 0, tot2 = 0;
if (items < 1)
ulCommand = CMD_KI_RDCNT;
else {
ulCommand = (ULONG)SvUV(ST(0));
}
if (items < 2) {
total = (ulCommand == CMD_KI_RDCNT ? numprocessors() : 0);
ulParm1 = (total ? (ULONG)u : 0);
if (total > C_ARRAY_LENGTH(u))
croak("Unexpected number of processors: %d", total);
} else {
ulParm1 = (ULONG)SvUV(ST(1));
}
if (items < 3) {
tot2 = (ulCommand == CMD_KI_GETQTY);
ulParm2 = (tot2 ? (ULONG)&res : 0);
} else {
ulParm2 = (ULONG)SvUV(ST(2));
}
if (items < 4)
ulParm3 = 0;
else {
ulParm3 = (ULONG)SvUV(ST(3));
}
RETVAL = perfSysCall(ulCommand, ulParm1, ulParm2, ulParm3);
if (!RETVAL)
croak_with_os2error("perfSysCall() error");
XSprePUSH;
if (total) {
int i,j;
if (GIMME_V != G_ARRAY) {
PUSHn(u[0][0]); /* Total ticks on the first processor */
XSRETURN(1);
}
EXTEND(SP, 4*total);
for (i=0; i < total; i++)
for (j=0; j < 4; j++)
PUSHs(sv_2mortal(newSVnv(u[i][j])));
XSRETURN(4*total);
}
if (tot2) {
PUSHu(res);
XSRETURN(1);
}
}
XSRETURN_EMPTY;
}
#define PERL_PATCHLEVEL_H_IMPLICIT /* Do not init local_patches. */
#include "patchlevel.h"
#undef PERL_PATCHLEVEL_H_IMPLICIT
char *
mod2fname(pTHX_ SV *sv)
{
int pos = 6, len, avlen;
unsigned int sum = 0;
char *s;
STRLEN n_a;
if (!SvROK(sv)) Perl_croak_nocontext("Not a reference given to mod2fname");
sv = SvRV(sv);
if (SvTYPE(sv) != SVt_PVAV)
Perl_croak_nocontext("Not array reference given to mod2fname");
avlen = av_len((AV*)sv);
if (avlen < 0)
Perl_croak_nocontext("Empty array reference given to mod2fname");
s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a);
strncpy(fname, s, 8);
len = strlen(s);
if (len < 6) pos = len;
while (*s) {
sum = 33 * sum + *(s++); /* Checksumming first chars to
* get the capitalization into c.s. */
}
avlen --;
while (avlen >= 0) {
s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a);
while (*s) {
sum = 33 * sum + *(s++); /* 7 is primitive mod 13. */
}
avlen --;
}
/* We always load modules as *specific* DLLs, and with the full name.
When loading a specific DLL by its full name, one cannot get a
different DLL, even if a DLL with the same basename is loaded already.
Thus there is no need to include the version into the mangling scheme. */
#if 0
sum += PERL_VERSION * 200 + PERL_SUBVERSION * 2; /* Up to 5.6.1 */
#else
# ifndef COMPATIBLE_VERSION_SUM /* Binary compatibility with the 5.00553 binary */
# define COMPATIBLE_VERSION_SUM (5 * 200 + 53 * 2)
# endif
sum += COMPATIBLE_VERSION_SUM;
#endif
fname[pos] = 'A' + (sum % 26);
fname[pos + 1] = 'A' + (sum / 26 % 26);
fname[pos + 2] = '\0';
return (char *)fname;
}
XS(XS_DynaLoader_mod2fname)
{
dXSARGS;
if (items != 1)
Perl_croak_nocontext("Usage: DynaLoader::mod2fname(sv)");
{
SV * sv = ST(0);
char * RETVAL;
dXSTARG;
RETVAL = mod2fname(aTHX_ sv);
sv_setpv(TARG, RETVAL);
XSprePUSH; PUSHTARG;
}
XSRETURN(1);
}
char *
os2error(int rc)
{
dTHX;
ULONG len;
char *s;
int number = SvTRUE(get_sv("OS2::nsyserror", TRUE));
if (!(_emx_env & 0x200)) return ""; /* Nop if not OS/2. */
if (rc == 0)
return "";
if (number) {
sprintf(os2error_buf, "SYS%04d=%#x: ", rc, rc);
s = os2error_buf + strlen(os2error_buf);
} else
s = os2error_buf;
if (DosGetMessage(NULL, 0, s, sizeof(os2error_buf) - 1 - (s-os2error_buf),
rc, "OSO001.MSG", &len)) {
char *name = "";
if (!number) {
sprintf(os2error_buf, "SYS%04d=%#x: ", rc, rc);
s = os2error_buf + strlen(os2error_buf);
}
switch (rc) {
case PMERR_INVALID_HWND:
name = "PMERR_INVALID_HWND";
break;
case PMERR_INVALID_HMQ:
name = "PMERR_INVALID_HMQ";
break;
case PMERR_CALL_FROM_WRONG_THREAD:
name = "PMERR_CALL_FROM_WRONG_THREAD";
break;
case PMERR_NO_MSG_QUEUE:
name = "PMERR_NO_MSG_QUEUE";
break;
case PMERR_NOT_IN_A_PM_SESSION:
name = "PMERR_NOT_IN_A_PM_SESSION";
break;
case PMERR_INVALID_ATOM:
name = "PMERR_INVALID_ATOM";
break;
case PMERR_INVALID_HATOMTBL:
name = "PMERR_INVALID_HATOMTMB";
break;
case PMERR_INVALID_INTEGER_ATOM:
name = "PMERR_INVALID_INTEGER_ATOM";
break;
case PMERR_INVALID_ATOM_NAME:
name = "PMERR_INVALID_ATOM_NAME";
break;
case PMERR_ATOM_NAME_NOT_FOUND:
name = "PMERR_ATOM_NAME_NOT_FOUND";
break;
}
sprintf(s, "%s%s[No description found in OSO001.MSG]",
name, (*name ? "=" : ""));
} else {
s[len] = '\0';
if (len && s[len - 1] == '\n')
s[--len] = 0;
if (len && s[len - 1] == '\r')
s[--len] = 0;
if (len && s[len - 1] == '.')
s[--len] = 0;
if (len >= 10 && number && strnEQ(s, os2error_buf, 7)
&& s[7] == ':' && s[8] == ' ')
/* Some messages start with SYSdddd:, some not */
Move(s + 9, s, (len -= 9) + 1, char);
}
return os2error_buf;
}
void
ResetWinError(void)
{
WinError_2_Perl_rc;
}
void
CroakWinError(int die, char *name)
{
FillWinError;
if (die && Perl_rc)
croak_with_os2error(name ? name : "Win* API call");
}
static char *
dllname2buffer(pTHX_ char *buf, STRLEN l)
{
char *o;
STRLEN ll;
SV *dll = Nullsv;
dll = module_name(mod_name_full);
o = SvPV(dll, ll);
if (ll < l)
memcpy(buf,o,ll);
SvREFCNT_dec(dll);
return (ll >= l ? "???" : buf);
}
static char *
execname2buffer(char *buf, STRLEN l, char *oname)
{
char *p, *orig = oname, ok = oname != NULL;
if (_execname(buf, l) != 0) {
if (!oname || strlen(oname) >= l)
return oname;
strcpy(buf, oname);
ok = 0;
}
p = buf;
while (*p) {
if (*p == '\\')
*p = '/';
if (*p == '/') {
if (ok && *oname != '/' && *oname != '\\')
ok = 0;
} else if (ok && tolower(*oname) != tolower(*p))
ok = 0;
p++;
oname++;
}
if (ok) { /* orig matches the real name. Use orig: */
strcpy(buf, orig); /* _execname() is always uppercased */
p = buf;
while (*p) {
if (*p == '\\')
*p = '/';
p++;
}
}
return buf;
}
char *
os2_execname(pTHX)
{
char buf[300], *p = execname2buffer(buf, sizeof buf, PL_origargv[0]);
p = savepv(p);
SAVEFREEPV(p);
return p;
}
int
Perl_OS2_handler_install(void *handler, enum Perlos2_handler how)
{
char *s, b[300];
switch (how) {
case Perlos2_handler_mangle:
perllib_mangle_installed = (char *(*)(char *s, unsigned int l))handler;
return 1;
case Perlos2_handler_perl_sh:
s = (char *)handler;
s = dir_subst(s, strlen(s), b, sizeof b, 0, "handler_perl_sh");
perl_sh_installed = savepv(s);
return 1;
case Perlos2_handler_perllib_from:
s = (char *)handler;
s = dir_subst(s, strlen(s), b, sizeof b, 0, "handler_perllib_from");
oldl = strlen(s);
oldp = savepv(s);
return 1;
case Perlos2_handler_perllib_to:
s = (char *)handler;
s = dir_subst(s, strlen(s), b, sizeof b, 0, "handler_perllib_to");
newl = strlen(s);
newp = savepv(s);
strcpy(mangle_ret, newp);
s = mangle_ret - 1;
while (*++s)
if (*s == '\\')
*s = '/';
return 1;
default:
return 0;
}
}
/* Returns a malloc()ed copy */
char *
dir_subst(char *s, unsigned int l, char *b, unsigned int bl, enum dir_subst_e flags, char *msg)
{
char *from, *to = b, *e = b; /* `to' assignment: shut down the warning */
STRLEN froml = 0, tol = 0, rest = 0; /* froml: likewise */
if (l >= 2 && s[0] == '~') {
switch (s[1]) {
case 'i': case 'I':
from = "installprefix"; break;
case 'd': case 'D':
from = "dll"; break;
case 'e': case 'E':
from = "exe"; break;
default:
from = NULL;
froml = l + 1; /* Will not match */
break;
}
if (from)
froml = strlen(from) + 1;
if (l >= froml && strnicmp(s + 2, from + 1, froml - 2) == 0) {
int strip = 1;
switch (s[1]) {
case 'i': case 'I':
strip = 0;
tol = strlen(INSTALL_PREFIX);
if (tol >= bl) {
if (flags & dir_subst_fatal)
Perl_croak_nocontext("INSTALL_PREFIX too long: `%s'", INSTALL_PREFIX);
else
return NULL;
}
memcpy(b, INSTALL_PREFIX, tol + 1);
to = b;
e = b + tol;
break;
case 'd': case 'D':
if (flags & dir_subst_fatal) {
dTHX;
to = dllname2buffer(aTHX_ b, bl);
} else { /* No Perl present yet */
HMODULE self = find_myself();
APIRET rc = DosQueryModuleName(self, bl, b);
if (rc)
return 0;
to = b - 1;
while (*++to)
if (*to == '\\')
*to = '/';
to = b;
}
break;
case 'e': case 'E':
if (flags & dir_subst_fatal) {
dTHX;
to = execname2buffer(b, bl, PL_origargv[0]);
} else
to = execname2buffer(b, bl, NULL);
break;
}
if (!to)
return NULL;
if (strip) {
e = strrchr(to, '/');
if (!e && (flags & dir_subst_fatal))
Perl_croak_nocontext("%s: Can't parse EXE/DLL name: '%s'", msg, to);
else if (!e)
return NULL;
*e = 0;
}
s += froml; l -= froml;
if (!l)
return to;
if (!tol)
tol = strlen(to);
while (l >= 3 && (s[0] == '/' || s[0] == '\\')
&& s[1] == '.' && s[2] == '.'
&& (l == 3 || s[3] == '/' || s[3] == '\\' || s[3] == ';')) {
e = strrchr(b, '/');
if (!e && (flags & dir_subst_fatal))
Perl_croak_nocontext("%s: Error stripping dirs from EXE/DLL/INSTALLDIR name", msg);
else if (!e)
return NULL;
*e = 0;
l -= 3; s += 3;
}
if (l && s[0] != '/' && s[0] != '\\' && s[0] != ';')
*e++ = '/';
}
} /* Else: copy as is */
if (l && (flags & dir_subst_pathlike)) {
STRLEN i = 0;
while ( i < l - 2 && s[i] != ';') /* May have ~char after `;' */
i++;
if (i < l - 2) { /* Found */
rest = l - i - 1;
l = i + 1;
}
}
if (e + l >= b + bl) {
if (flags & dir_subst_fatal)
Perl_croak_nocontext("%s: name `%s%s' too long", msg, b, s);
else
return NULL;
}
memcpy(e, s, l);
if (rest) {
e = dir_subst(s + l, rest, e + l, bl - (e + l - b), flags, msg);
return e ? b : e;
}
e[l] = 0;
return b;
}
char *
perllib_mangle_with(char *s, unsigned int l, char *from, unsigned int froml, char *to, unsigned int tol)
{
if (!to)
return s;
if (l == 0)
l = strlen(s);
if (l < froml || strnicmp(from, s, froml) != 0)
return s;
if (l + tol - froml > STATIC_FILE_LENGTH || tol > STATIC_FILE_LENGTH)
Perl_croak_nocontext("Malformed PERLLIB_PREFIX");
if (to && to != mangle_ret)
memcpy(mangle_ret, to, tol);
strcpy(mangle_ret + tol, s + froml);
return mangle_ret;
}
char *
perllib_mangle(char *s, unsigned int l)
{
char *name;
if (perllib_mangle_installed && (name = perllib_mangle_installed(s,l)))
return name;
if (!newp && !notfound) {
newp = getenv(name = "PERLLIB_" STRINGIFY(PERL_REVISION)
STRINGIFY(PERL_VERSION) STRINGIFY(PERL_SUBVERSION)
"_PREFIX");
if (!newp)
newp = getenv(name = "PERLLIB_" STRINGIFY(PERL_REVISION)
STRINGIFY(PERL_VERSION) "_PREFIX");
if (!newp)
newp = getenv(name = "PERLLIB_" STRINGIFY(PERL_REVISION) "_PREFIX");
if (!newp)
newp = getenv(name = "PERLLIB_PREFIX");
if (newp) {
char *s, b[300];
oldp = newp;
while (*newp && !isSPACE(*newp) && *newp != ';')
newp++; /* Skip old name. */
oldl = newp - oldp;
s = dir_subst(oldp, oldl, b, sizeof b, dir_subst_fatal, name);
oldp = savepv(s);
oldl = strlen(s);
while (*newp && (isSPACE(*newp) || *newp == ';'))
newp++; /* Skip whitespace. */
Perl_OS2_handler_install((void *)newp, Perlos2_handler_perllib_to);
if (newl == 0 || oldl == 0)
Perl_croak_nocontext("Malformed %s", name);
} else
notfound = 1;
}
if (!newp)
return s;
if (l == 0)
l = strlen(s);
if (l < oldl || strnicmp(oldp, s, oldl) != 0)
return s;
if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH)
Perl_croak_nocontext("Malformed PERLLIB_PREFIX");
strcpy(mangle_ret + newl, s + oldl);
return mangle_ret;
}
unsigned long
Perl_hab_GET() /* Needed if perl.h cannot be included */
{
return perl_hab_GET();
}
static void
Create_HMQ(int serve, char *message) /* Assumes morphing */
{
unsigned fpflag = _control87(0,0);
init_PMWIN_entries();
/* 64 messages if before OS/2 3.0, ignored otherwise */
Perl_hmq = (*PMWIN_entries.CreateMsgQueue)(perl_hab_GET(), 64);
if (!Perl_hmq) {
dTHX;
SAVEINT(rmq_cnt); /* Allow catch()ing. */
if (rmq_cnt++)
_exit(188); /* Panic can try to create a window. */
CroakWinError(1, message ? message : "Cannot create a message queue");
}
if (serve != -1)
(*PMWIN_entries.CancelShutdown)(Perl_hmq, !serve);
/* We may have loaded some modules */
_control87(fpflag, MCW_EM); /* Some modules reset FP flags on (un)load */
}
#define REGISTERMQ_WILL_SERVE 1
#define REGISTERMQ_IMEDIATE_UNMORPH 2
HMQ
Perl_Register_MQ(int serve)
{
if (Perl_hmq_refcnt <= 0) {
PPIB pib;
PTIB tib;
Perl_hmq_refcnt = 0; /* Be extra safe */
DosGetInfoBlocks(&tib, &pib);
if (!Perl_morph_refcnt) {
Perl_os2_initial_mode = pib->pib_ultype;
/* Try morphing into a PM application. */
if (pib->pib_ultype != 3) /* 2 is VIO */
pib->pib_ultype = 3; /* 3 is PM */
}
Create_HMQ(-1, /* We do CancelShutdown ourselves */
"Cannot create a message queue, or morph to a PM application");
if ((serve & REGISTERMQ_IMEDIATE_UNMORPH)) {
if (!Perl_morph_refcnt && Perl_os2_initial_mode != 3)
pib->pib_ultype = Perl_os2_initial_mode;
}
}
if (serve & REGISTERMQ_WILL_SERVE) {
if ( Perl_hmq_servers <= 0 /* Safe to inform us on shutdown, */
&& Perl_hmq_refcnt > 0 ) /* this was switched off before... */
(*PMWIN_entries.CancelShutdown)(Perl_hmq, 0);
Perl_hmq_servers++;
} else if (!Perl_hmq_servers) /* Do not inform us on shutdown */
(*PMWIN_entries.CancelShutdown)(Perl_hmq, 1);
Perl_hmq_refcnt++;
if (!(serve & REGISTERMQ_IMEDIATE_UNMORPH))
Perl_morph_refcnt++;
return Perl_hmq;
}
int
Perl_Serve_Messages(int force)
{
int cnt = 0;
QMSG msg;
if (Perl_hmq_servers > 0 && !force)
return 0;
if (Perl_hmq_refcnt <= 0)
Perl_croak_nocontext("No message queue");
while ((*PMWIN_entries.PeekMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0, PM_REMOVE)) {
cnt++;
if (msg.msg == WM_QUIT)
Perl_croak_nocontext("QUITing...");
(*PMWIN_entries.DispatchMsg)(Perl_hab, &msg);
}
return cnt;
}
int
Perl_Process_Messages(int force, I32 *cntp)
{
QMSG msg;
if (Perl_hmq_servers > 0 && !force)
return 0;
if (Perl_hmq_refcnt <= 0)
Perl_croak_nocontext("No message queue");
while ((*PMWIN_entries.GetMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0)) {
if (cntp)
(*cntp)++;
(*PMWIN_entries.DispatchMsg)(Perl_hab, &msg);
if (msg.msg == WM_DESTROY)
return -1;
if (msg.msg == WM_CREATE)
return +1;
}
Perl_croak_nocontext("QUITing...");
}
void
Perl_Deregister_MQ(int serve)
{
if (serve & REGISTERMQ_WILL_SERVE)
Perl_hmq_servers--;
if (--Perl_hmq_refcnt <= 0) {
unsigned fpflag = _control87(0,0);
init_PMWIN_entries(); /* To be extra safe */
(*PMWIN_entries.DestroyMsgQueue)(Perl_hmq);
Perl_hmq = 0;
/* We may have (un)loaded some modules */
_control87(fpflag, MCW_EM); /* Some modules reset FP flags on (un)load */
} else if ((serve & REGISTERMQ_WILL_SERVE) && Perl_hmq_servers <= 0)
(*PMWIN_entries.CancelShutdown)(Perl_hmq, 1); /* Last server exited */
if (!(serve & REGISTERMQ_IMEDIATE_UNMORPH) && (--Perl_morph_refcnt <= 0)) {
/* Try morphing back from a PM application. */
PPIB pib;
PTIB tib;
DosGetInfoBlocks(&tib, &pib);
if (pib->pib_ultype == 3) /* 3 is PM */
pib->pib_ultype = Perl_os2_initial_mode;
else
Perl_warn_nocontext("Unexpected program mode %d when morphing back from PM",
pib->pib_ultype);
}
}
#define sys_is_absolute(path) ( isALPHA((path)[0]) && (path)[1] == ':' \
&& ((path)[2] == '/' || (path)[2] == '\\'))
#define sys_is_rooted _fnisabs
#define sys_is_relative _fnisrel
#define current_drive _getdrive
#undef chdir /* Was _chdir2. */
#define sys_chdir(p) (chdir(p) == 0)
#define change_drive(d) (_chdrive(d), (current_drive() == toupper(d)))
XS(XS_OS2_Error)
{
dXSARGS;
if (items != 2)
Perl_croak_nocontext("Usage: OS2::Error(harderr, exception)");
{
int arg1 = SvIV(ST(0));
int arg2 = SvIV(ST(1));
int a = ((arg1 ? FERR_ENABLEHARDERR : FERR_DISABLEHARDERR)
| (arg2 ? FERR_ENABLEEXCEPTION : FERR_DISABLEEXCEPTION));
int RETVAL = ((arg1 ? 1 : 0) | (arg2 ? 2 : 0));
unsigned long rc;
if (CheckOSError(DosError(a)))
Perl_croak_nocontext("DosError(%d) failed: %s", a, os2error(Perl_rc));
ST(0) = sv_newmortal();
if (DOS_harderr_state >= 0)
sv_setiv(ST(0), DOS_harderr_state);
DOS_harderr_state = RETVAL;
}
XSRETURN(1);
}
XS(XS_OS2_Errors2Drive)
{
dXSARGS;
if (items != 1)
Perl_croak_nocontext("Usage: OS2::Errors2Drive(drive)");
{
STRLEN n_a;
SV *sv = ST(0);
int suppress = SvOK(sv);
char *s = suppress ? SvPV(sv, n_a) : NULL;
char drive = (s ? *s : 0);
unsigned long rc;
if (suppress && !isALPHA(drive))
Perl_croak_nocontext("Non-char argument '%c' to OS2::Errors2Drive()", drive);
if (CheckOSError(DosSuppressPopUps((suppress
? SPU_ENABLESUPPRESSION
: SPU_DISABLESUPPRESSION),
drive)))
Perl_croak_nocontext("DosSuppressPopUps(%c) failed: %s", drive,
os2error(Perl_rc));
ST(0) = sv_newmortal();
if (DOS_suppression_state > 0)
sv_setpvn(ST(0), &DOS_suppression_state, 1);
else if (DOS_suppression_state == 0)
sv_setpvn(ST(0), "", 0);
DOS_suppression_state = drive;
}
XSRETURN(1);
}
int
async_mssleep(ULONG ms, int switch_priority) {
/* This is similar to DosSleep(), but has 8ms granularity in time-critical
threads even on Warp3. */
HEV hevEvent1 = 0; /* Event semaphore handle */
HTIMER htimerEvent1 = 0; /* Timer handle */
APIRET rc = NO_ERROR; /* Return code */
int ret = 1;
ULONG priority = 0, nesting; /* Shut down the warnings */
PPIB pib;
PTIB tib;
char *e = NULL;
APIRET badrc;
if (!(_emx_env & 0x200)) /* DOS */
return !_sleep2(ms);
os2cp_croak(DosCreateEventSem(NULL, /* Unnamed */
&hevEvent1, /* Handle of semaphore returned */
DC_SEM_SHARED, /* Shared needed for DosAsyncTimer */
FALSE), /* Semaphore is in RESET state */
"DosCreateEventSem");
if (ms >= switch_priority)
switch_priority = 0;
if (switch_priority) {
if (CheckOSError(DosGetInfoBlocks(&tib, &pib)))
switch_priority = 0;
else {
/* In Warp3, to switch scheduling to 8ms step, one needs to do
DosAsyncTimer() in time-critical thread. On laters versions,
more and more cases of wait-for-something are covered.
It turns out that on Warp3fp42 it is the priority at the time
of DosAsyncTimer() which matters. Let's hope that this works
with later versions too... XXXX
*/
priority = (tib->tib_ptib2->tib2_ulpri);
if ((priority & 0xFF00) == 0x0300) /* already time-critical */
switch_priority = 0;
/* Make us time-critical. Just modifying TIB is not enough... */
/* tib->tib_ptib2->tib2_ulpri = 0x0300;*/
/* We do not want to run at high priority if a signal causes us
to longjmp() out of this section... */
if (DosEnterMustComplete(&nesting))
switch_priority = 0;
else
DosSetPriority(PRTYS_THREAD, PRTYC_TIMECRITICAL, 0, 0);
}
}
if ((badrc = DosAsyncTimer(ms,
(HSEM) hevEvent1, /* Semaphore to post */
&htimerEvent1))) /* Timer handler (returned) */
e = "DosAsyncTimer";
if (switch_priority && tib->tib_ptib2->tib2_ulpri == 0x0300) {
/* Nobody switched priority while we slept... Ignore errors... */
/* tib->tib_ptib2->tib2_ulpri = priority; */ /* Get back... */
if (!(rc = DosSetPriority(PRTYS_THREAD, (priority>>8) & 0xFF, 0, 0)))
rc = DosSetPriority(PRTYS_THREAD, 0, priority & 0xFF, 0);
}
if (switch_priority)
rc = DosExitMustComplete(&nesting); /* Ignore errors */
/* The actual blocking call is made with "normal" priority. This way we
should not bother with DosSleep(0) etc. to compensate for us interrupting
higher-priority threads. The goal is to prohibit the system spending too
much time halt()ing, not to run us "no matter what". */
if (!e) /* Wait for AsyncTimer event */
badrc = DosWaitEventSem(hevEvent1, SEM_INDEFINITE_WAIT);
if (e) ; /* Do nothing */
else if (badrc == ERROR_INTERRUPT)
ret = 0;
else if (badrc)
e = "DosWaitEventSem";
if ((rc = DosCloseEventSem(hevEvent1)) && !e) { /* Get rid of semaphore */
e = "DosCloseEventSem";
badrc = rc;
}
if (e)
os2cp_croak(badrc, e);
return ret;
}
XS(XS_OS2_ms_sleep) /* for testing only... */
{
dXSARGS;
ULONG ms, lim;
if (items > 2 || items < 1)
Perl_croak_nocontext("Usage: OS2::ms_sleep(wait_ms [, high_priority_limit])");
ms = SvUV(ST(0));
lim = items > 1 ? SvUV(ST(1)) : ms + 1;
async_mssleep(ms, lim);
XSRETURN_YES;
}
ULONG (*pDosTmrQueryFreq) (PULONG);
ULONG (*pDosTmrQueryTime) (unsigned long long *);
XS(XS_OS2_Timer)
{
dXSARGS;
static ULONG freq;
unsigned long long count;
ULONG rc;
if (items != 0)
Perl_croak_nocontext("Usage: OS2::Timer()");
if (!freq) {
*(PFN*)&pDosTmrQueryFreq = loadByOrdinal(ORD_DosTmrQueryFreq, 0);
*(PFN*)&pDosTmrQueryTime = loadByOrdinal(ORD_DosTmrQueryTime, 0);
MUTEX_LOCK(&perlos2_state_mutex);
if (!freq)
if (CheckOSError(pDosTmrQueryFreq(&freq)))
croak_with_os2error("DosTmrQueryFreq");
MUTEX_UNLOCK(&perlos2_state_mutex);
}
if (CheckOSError(pDosTmrQueryTime(&count)))
croak_with_os2error("DosTmrQueryTime");
{
dXSTARG;
XSprePUSH; PUSHn(((NV)count)/freq);
}
XSRETURN(1);
}
XS(XS_OS2_msCounter)
{
dXSARGS;
if (items != 0)
Perl_croak_nocontext("Usage: OS2::msCounter()");
{
dXSTARG;
XSprePUSH; PUSHu(msCounter());
}
XSRETURN(1);
}
XS(XS_OS2__InfoTable)
{
dXSARGS;
int is_local = 0;
if (items > 1)
Perl_croak_nocontext("Usage: OS2::_infoTable([isLocal])");
if (items == 1)
is_local = (int)SvIV(ST(0));
{
dXSTARG;
XSprePUSH; PUSHu(InfoTable(is_local));
}
XSRETURN(1);
}
static const char * const dc_fields[] = {
"FAMILY",
"IO_CAPS",
"TECHNOLOGY",
"DRIVER_VERSION",
"WIDTH",
"HEIGHT",
"WIDTH_IN_CHARS",
"HEIGHT_IN_CHARS",
"HORIZONTAL_RESOLUTION",
"VERTICAL_RESOLUTION",
"CHAR_WIDTH",
"CHAR_HEIGHT",
"SMALL_CHAR_WIDTH",
"SMALL_CHAR_HEIGHT",
"COLORS",
"COLOR_PLANES",
"COLOR_BITCOUNT",
"COLOR_TABLE_SUPPORT",
"MOUSE_BUTTONS",
"FOREGROUND_MIX_SUPPORT",
"BACKGROUND_MIX_SUPPORT",
"VIO_LOADABLE_FONTS",
"WINDOW_BYTE_ALIGNMENT",
"BITMAP_FORMATS",
"RASTER_CAPS",
"MARKER_HEIGHT",
"MARKER_WIDTH",
"DEVICE_FONTS",
"GRAPHICS_SUBSET",
"GRAPHICS_VERSION",
"GRAPHICS_VECTOR_SUBSET",
"DEVICE_WINDOWING",
"ADDITIONAL_GRAPHICS",
"PHYS_COLORS",
"COLOR_INDEX",
"GRAPHICS_CHAR_WIDTH",
"GRAPHICS_CHAR_HEIGHT",
"HORIZONTAL_FONT_RES",
"VERTICAL_FONT_RES",
"DEVICE_FONT_SIM",
"LINEWIDTH_THICK",
"DEVICE_POLYSET_POINTS",
};
enum {
DevCap_dc, DevCap_hwnd
};
HDC (*pWinOpenWindowDC) (HWND hwnd);
HMF (*pDevCloseDC) (HDC hdc);
HDC (*pDevOpenDC) (HAB hab, LONG lType, PCSZ pszToken, LONG lCount,
PDEVOPENDATA pdopData, HDC hdcComp);
BOOL (*pDevQueryCaps) (HDC hdc, LONG lStart, LONG lCount, PLONG alArray);
XS(XS_OS2_DevCap)
{
dXSARGS;
if (items > 2)
Perl_croak_nocontext("Usage: OS2::DevCap()");
{
/* Device Capabilities Data Buffer (10 extra w.r.t. Warp 4.5) */
LONG si[CAPS_DEVICE_POLYSET_POINTS - CAPS_FAMILY + 1];
int i = 0, j = 0, how = DevCap_dc;
HDC hScreenDC;
DEVOPENSTRUC doStruc= {0L, (PSZ)"DISPLAY", NULL, 0L, 0L, 0L, 0L, 0L, 0L};
ULONG rc1 = NO_ERROR;
HWND hwnd;
static volatile int devcap_loaded;
if (!devcap_loaded) {
*(PFN*)&pWinOpenWindowDC = loadByOrdinal(ORD_WinOpenWindowDC, 0);
*(PFN*)&pDevOpenDC = loadByOrdinal(ORD_DevOpenDC, 0);
*(PFN*)&pDevCloseDC = loadByOrdinal(ORD_DevCloseDC, 0);
*(PFN*)&pDevQueryCaps = loadByOrdinal(ORD_DevQueryCaps, 0);
devcap_loaded = 1;
}
if (items >= 2)
how = SvIV(ST(1));
if (!items) { /* Get device contents from PM */
hScreenDC = pDevOpenDC(perl_hab_GET(), OD_MEMORY, (PSZ)"*", 0,
(PDEVOPENDATA)&doStruc, NULLHANDLE);
if (CheckWinError(hScreenDC))
croak_with_os2error("DevOpenDC() failed");
} else if (how == DevCap_dc)
hScreenDC = (HDC)SvIV(ST(0));
else { /* DevCap_hwnd */
if (!Perl_hmq)
Perl_croak(aTHX_ "Getting a window's device context without a message queue would lock PM");
hwnd = (HWND)SvIV(ST(0));
hScreenDC = pWinOpenWindowDC(hwnd); /* No need to DevCloseDC() */
if (CheckWinError(hScreenDC))
croak_with_os2error("WinOpenWindowDC() failed");
}
if (CheckWinError(pDevQueryCaps(hScreenDC,
CAPS_FAMILY, /* W3 documented caps */
CAPS_DEVICE_POLYSET_POINTS
- CAPS_FAMILY + 1,
si)))
rc1 = Perl_rc;
else {
EXTEND(SP,2*(CAPS_DEVICE_POLYSET_POINTS - CAPS_FAMILY + 1));
while (i < CAPS_DEVICE_POLYSET_POINTS - CAPS_FAMILY + 1) {
ST(j) = sv_newmortal();
sv_setpv(ST(j++), dc_fields[i]);
ST(j) = sv_newmortal();
sv_setiv(ST(j++), si[i]);
i++;
}
i = CAPS_DEVICE_POLYSET_POINTS + 1;
while (i < CAPS_DEVICE_POLYSET_POINTS + 11) { /* Just in case... */
LONG l;
if (CheckWinError(pDevQueryCaps(hScreenDC, i, 1, &l)))
break;
EXTEND(SP, j + 2);
ST(j) = sv_newmortal();
sv_setiv(ST(j++), i);
ST(j) = sv_newmortal();
sv_setiv(ST(j++), l);
i++;
}
}
if (!items && CheckWinError(pDevCloseDC(hScreenDC)))
Perl_warn_nocontext("DevCloseDC() failed: %s", os2error(Perl_rc));
if (rc1)
Perl_rc = rc1, croak_with_os2error("DevQueryCaps() failed");
XSRETURN(j);
}
}
LONG (*pWinQuerySysValue) (HWND hwndDesktop, LONG iSysValue);
BOOL (*pWinSetSysValue) (HWND hwndDesktop, LONG iSysValue, LONG lValue);
const char * const sv_keys[] = {
"SWAPBUTTON",
"DBLCLKTIME",
"CXDBLCLK",
"CYDBLCLK",
"CXSIZEBORDER",
"CYSIZEBORDER",
"ALARM",
"7",
"8",
"CURSORRATE",
"FIRSTSCROLLRATE",
"SCROLLRATE",
"NUMBEREDLISTS",
"WARNINGFREQ",
"NOTEFREQ",
"ERRORFREQ",
"WARNINGDURATION",
"NOTEDURATION",
"ERRORDURATION",
"19",
"CXSCREEN",
"CYSCREEN",
"CXVSCROLL",
"CYHSCROLL",
"CYVSCROLLARROW",
"CXHSCROLLARROW",
"CXBORDER",
"CYBORDER",
"CXDLGFRAME",
"CYDLGFRAME",
"CYTITLEBAR",
"CYVSLIDER",
"CXHSLIDER",
"CXMINMAXBUTTON",
"CYMINMAXBUTTON",
"CYMENU",
"CXFULLSCREEN",
"CYFULLSCREEN",
"CXICON",
"CYICON",
"CXPOINTER",
"CYPOINTER",
"DEBUG",
"CPOINTERBUTTONS",
"POINTERLEVEL",
"CURSORLEVEL",
"TRACKRECTLEVEL",
"CTIMERS",
"MOUSEPRESENT",
"CXALIGN",
"CYALIGN",
"DESKTOPWORKAREAYTOP",
"DESKTOPWORKAREAYBOTTOM",
"DESKTOPWORKAREAXRIGHT",
"DESKTOPWORKAREAXLEFT",
"55",
"NOTRESERVED",
"EXTRAKEYBEEP",
"SETLIGHTS",
"INSERTMODE",
"60",
"61",
"62",
"63",
"MENUROLLDOWNDELAY",
"MENUROLLUPDELAY",
"ALTMNEMONIC",
"TASKLISTMOUSEACCESS",
"CXICONTEXTWIDTH",
"CICONTEXTLINES",
"CHORDTIME",
"CXCHORD",
"CYCHORD",
"CXMOTIONSTART",
"CYMOTIONSTART",
"BEGINDRAG",
"ENDDRAG",
"SINGLESELECT",
"OPEN",
"CONTEXTMENU",
"CONTEXTHELP",
"TEXTEDIT",
"BEGINSELECT",
"ENDSELECT",
"BEGINDRAGKB",
"ENDDRAGKB",
"SELECTKB",
"OPENKB",
"CONTEXTMENUKB",
"CONTEXTHELPKB",
"TEXTEDITKB",
"BEGINSELECTKB",
"ENDSELECTKB",
"ANIMATION",
"ANIMATIONSPEED",
"MONOICONS",
"KBDALTERED",
"PRINTSCREEN", /* 97, the last one on one of the DDK header */
"LOCKSTARTINPUT",
"DYNAMICDRAG",
"100",
"101",
"102",
"103",
"104",
"105",
"106",
"107",
/* "CSYSVALUES",*/
/* In recent DDK the limit is 108 */
};
XS(XS_OS2_SysValues)
{
dXSARGS;
if (items > 2)
Perl_croak_nocontext("Usage: OS2::SysValues(which = -1, hwndDesktop = HWND_DESKTOP)");
{
int i = 0, j = 0, which = -1;
HWND hwnd = HWND_DESKTOP;
static volatile int sv_loaded;
LONG RETVAL;
if (!sv_loaded) {
*(PFN*)&pWinQuerySysValue = loadByOrdinal(ORD_WinQuerySysValue, 0);
sv_loaded = 1;
}
if (items == 2)
hwnd = (HWND)SvIV(ST(1));
if (items >= 1)
which = (int)SvIV(ST(0));
if (which == -1) {
EXTEND(SP,2*C_ARRAY_LENGTH(sv_keys));
while (i < C_ARRAY_LENGTH(sv_keys)) {
ResetWinError();
RETVAL = pWinQuerySysValue(hwnd, i);
if ( !RETVAL
&& !(sv_keys[i][0] >= '0' && sv_keys[i][0] <= '9'
&& i <= SV_PRINTSCREEN) ) {
FillWinError;
if (Perl_rc) {
if (i > SV_PRINTSCREEN)
break; /* May be not present on older systems */
croak_with_os2error("SysValues():");
}
}
ST(j) = sv_newmortal();
sv_setpv(ST(j++), sv_keys[i]);
ST(j) = sv_newmortal();
sv_setiv(ST(j++), RETVAL);
i++;
}
XSRETURN(2 * i);
} else {
dXSTARG;
ResetWinError();
RETVAL = pWinQuerySysValue(hwnd, which);
if (!RETVAL) {
FillWinError;
if (Perl_rc)
croak_with_os2error("SysValues():");
}
XSprePUSH; PUSHi((IV)RETVAL);
}
}
}
XS(XS_OS2_SysValues_set)
{
dXSARGS;
if (items < 2 || items > 3)
Perl_croak_nocontext("Usage: OS2::SysValues_set(which, val, hwndDesktop = HWND_DESKTOP)");
{
int which = (int)SvIV(ST(0));
LONG val = (LONG)SvIV(ST(1));
HWND hwnd = HWND_DESKTOP;
static volatile int svs_loaded;
if (!svs_loaded) {
*(PFN*)&pWinSetSysValue = loadByOrdinal(ORD_WinSetSysValue, 0);
svs_loaded = 1;
}
if (items == 3)
hwnd = (HWND)SvIV(ST(2));
if (CheckWinError(pWinSetSysValue(hwnd, which, val)))
croak_with_os2error("SysValues_set()");
}
XSRETURN_YES;
}
#define QSV_MAX_WARP3 QSV_MAX_COMP_LENGTH
static const char * const si_fields[] = {
"MAX_PATH_LENGTH",
"MAX_TEXT_SESSIONS",
"MAX_PM_SESSIONS",
"MAX_VDM_SESSIONS",
"BOOT_DRIVE",
"DYN_PRI_VARIATION",
"MAX_WAIT",
"MIN_SLICE",
"MAX_SLICE",
"PAGE_SIZE",
"VERSION_MAJOR",
"VERSION_MINOR",
"VERSION_REVISION",
"MS_COUNT",
"TIME_LOW",
"TIME_HIGH",
"TOTPHYSMEM",
"TOTRESMEM",
"TOTAVAILMEM",
"MAXPRMEM",
"MAXSHMEM",
"TIMER_INTERVAL",
"MAX_COMP_LENGTH",
"FOREGROUND_FS_SESSION",
"FOREGROUND_PROCESS", /* Warp 3 toolkit defines up to this */
"NUMPROCESSORS",
"MAXHPRMEM",
"MAXHSHMEM",
"MAXPROCESSES",
"VIRTUALADDRESSLIMIT",
"INT10ENABLED", /* From $TOOLKIT-ddk\DDK\video\rel\os2c\include\base\os2\bsedos.h */
};
XS(XS_OS2_SysInfo)
{
dXSARGS;
if (items != 0)
Perl_croak_nocontext("Usage: OS2::SysInfo()");
{
/* System Information Data Buffer (10 extra w.r.t. Warp 4.5) */
ULONG si[C_ARRAY_LENGTH(si_fields) + 10];
APIRET rc = NO_ERROR; /* Return code */
int i = 0, j = 0, last = QSV_MAX_WARP3;
if (CheckOSError(DosQuerySysInfo(1L, /* Request documented system */
last, /* info for Warp 3 */
(PVOID)si,
sizeof(si))))
croak_with_os2error("DosQuerySysInfo() failed");
while (++last <= C_ARRAY_LENGTH(si)) {
if (CheckOSError(DosQuerySysInfo(last, last, /* One entry only */
(PVOID)(si+last-1),
sizeof(*si)))) {
if (Perl_rc != ERROR_INVALID_PARAMETER)
croak_with_os2error("DosQuerySysInfo() failed");
break;
}
}
last--; /* Count of successfully processed offsets */
EXTEND(SP,2*last);
while (i < last) {
ST(j) = sv_newmortal();
if (i < C_ARRAY_LENGTH(si_fields))
sv_setpv(ST(j++), si_fields[i]);
else
sv_setiv(ST(j++), i + 1);
ST(j) = sv_newmortal();
sv_setuv(ST(j++), si[i]);
i++;
}
XSRETURN(2 * last);
}
}
XS(XS_OS2_SysInfoFor)
{
dXSARGS;
int count = (items == 2 ? (int)SvIV(ST(1)) : 1);
if (items < 1 || items > 2)
Perl_croak_nocontext("Usage: OS2::SysInfoFor(id[,count])");
{
/* System Information Data Buffer (10 extra w.r.t. Warp 4.5) */
ULONG si[C_ARRAY_LENGTH(si_fields) + 10];
APIRET rc = NO_ERROR; /* Return code */
int i = 0;
int start = (int)SvIV(ST(0));
if (count > C_ARRAY_LENGTH(si) || count <= 0)
Perl_croak(aTHX_ "unexpected count %d for OS2::SysInfoFor()", count);
if (CheckOSError(DosQuerySysInfo(start,
start + count - 1,
(PVOID)si,
sizeof(si))))
croak_with_os2error("DosQuerySysInfo() failed");
EXTEND(SP,count);
while (i < count) {
ST(i) = sv_newmortal();
sv_setiv(ST(i), si[i]);
i++;
}
}
XSRETURN(count);
}
XS(XS_OS2_BootDrive)
{
dXSARGS;
if (items != 0)
Perl_croak_nocontext("Usage: OS2::BootDrive()");
{
ULONG si[1] = {0}; /* System Information Data Buffer */
APIRET rc = NO_ERROR; /* Return code */
char c;
dXSTARG;
if (CheckOSError(DosQuerySysInfo(QSV_BOOT_DRIVE, QSV_BOOT_DRIVE,
(PVOID)si, sizeof(si))))
croak_with_os2error("DosQuerySysInfo() failed");
c = 'a' - 1 + si[0];
sv_setpvn(TARG, &c, 1);
XSprePUSH; PUSHTARG;
}
XSRETURN(1);
}
XS(XS_OS2_Beep)
{
dXSARGS;
if (items > 2) /* Defaults as for WinAlarm(ERROR) */
Perl_croak_nocontext("Usage: OS2::Beep(freq = 440, ms = 100)");
{
ULONG freq = (items > 0 ? (ULONG)SvUV(ST(0)) : 440);
ULONG ms = (items > 1 ? (ULONG)SvUV(ST(1)) : 100);
ULONG rc;
if (CheckOSError(DosBeep(freq, ms)))
croak_with_os2error("SysValues_set()");
}
XSRETURN_YES;
}
XS(XS_OS2_MorphPM)
{
dXSARGS;
if (items != 1)
Perl_croak_nocontext("Usage: OS2::MorphPM(serve)");
{
bool serve = SvOK(ST(0));
unsigned long pmq = perl_hmq_GET(serve);
dXSTARG;
XSprePUSH; PUSHi((IV)pmq);
}
XSRETURN(1);
}
XS(XS_OS2_UnMorphPM)
{
dXSARGS;
if (items != 1)
Perl_croak_nocontext("Usage: OS2::UnMorphPM(serve)");
{
bool serve = SvOK(ST(0));
perl_hmq_UNSET(serve);
}
XSRETURN(0);
}
XS(XS_OS2_Serve_Messages)
{
dXSARGS;
if (items != 1)
Perl_croak_nocontext("Usage: OS2::Serve_Messages(force)");
{
bool force = SvOK(ST(0));
unsigned long cnt = Perl_Serve_Messages(force);
dXSTARG;
XSprePUSH; PUSHi((IV)cnt);
}
XSRETURN(1);
}
XS(XS_OS2_Process_Messages)
{
dXSARGS;
if (items < 1 || items > 2)
Perl_croak_nocontext("Usage: OS2::Process_Messages(force [, cnt])");
{
bool force = SvOK(ST(0));
unsigned long cnt;
dXSTARG;
if (items == 2) {
I32 cntr;
SV *sv = ST(1);
(void)SvIV(sv); /* Force SvIVX */
if (!SvIOK(sv))
Perl_croak_nocontext("Can't upgrade count to IV");
cntr = SvIVX(sv);
cnt = Perl_Process_Messages(force, &cntr);
SvIVX(sv) = cntr;
} else {
cnt = Perl_Process_Messages(force, NULL);
}
XSprePUSH; PUSHi((IV)cnt);
}
XSRETURN(1);
}
XS(XS_Cwd_current_drive)
{
dXSARGS;
if (items != 0)
Perl_croak_nocontext("Usage: Cwd::current_drive()");
{
char RETVAL;
dXSTARG;
RETVAL = current_drive();
sv_setpvn(TARG, (char *)&RETVAL, 1);
XSprePUSH; PUSHTARG;
}
XSRETURN(1);
}
XS(XS_Cwd_sys_chdir)
{
dXSARGS;
if (items != 1)
Perl_croak_nocontext("Usage: Cwd::sys_chdir(path)");
{
STRLEN n_a;
char * path = (char *)SvPV(ST(0),n_a);
bool RETVAL;
RETVAL = sys_chdir(path);
ST(0) = boolSV(RETVAL);
if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
}
XSRETURN(1);
}
XS(XS_Cwd_change_drive)
{
dXSARGS;
if (items != 1)
Perl_croak_nocontext("Usage: Cwd::change_drive(d)");
{
STRLEN n_a;
char d = (char)*SvPV(ST(0),n_a);
bool RETVAL;
RETVAL = change_drive(d);
ST(0) = boolSV(RETVAL);
if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
}
XSRETURN(1);
}
XS(XS_Cwd_sys_is_absolute)
{
dXSARGS;
if (items != 1)
Perl_croak_nocontext("Usage: Cwd::sys_is_absolute(path)");
{
STRLEN n_a;
char * path = (char *)SvPV(ST(0),n_a);
bool RETVAL;
RETVAL = sys_is_absolute(path);
ST(0) = boolSV(RETVAL);
if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
}
XSRETURN(1);
}
XS(XS_Cwd_sys_is_rooted)
{
dXSARGS;
if (items != 1)
Perl_croak_nocontext("Usage: Cwd::sys_is_rooted(path)");
{
STRLEN n_a;
char * path = (char *)SvPV(ST(0),n_a);
bool RETVAL;
RETVAL = sys_is_rooted(path);
ST(0) = boolSV(RETVAL);
if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
}
XSRETURN(1);
}
XS(XS_Cwd_sys_is_relative)
{
dXSARGS;
if (items != 1)
Perl_croak_nocontext("Usage: Cwd::sys_is_relative(path)");
{
STRLEN n_a;
char * path = (char *)SvPV(ST(0),n_a);
bool RETVAL;
RETVAL = sys_is_relative(path);
ST(0) = boolSV(RETVAL);
if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
}
XSRETURN(1);
}
XS(XS_Cwd_sys_cwd)
{
dXSARGS;
if (items != 0)
Perl_croak_nocontext("Usage: Cwd::sys_cwd()");
{
char p[MAXPATHLEN];
char * RETVAL;
/* Can't use TARG, since tainting behaves differently */
RETVAL = _getcwd2(p, MAXPATHLEN);
ST(0) = sv_newmortal();
sv_setpv(ST(0), RETVAL);
#ifndef INCOMPLETE_TAINTS
SvTAINTED_on(ST(0));
#endif
}
XSRETURN(1);
}
XS(XS_Cwd_sys_abspath)
{
dXSARGS;
if (items > 2)
Perl_croak_nocontext("Usage: Cwd::sys_abspath(path = '.', dir = NULL)");
{
STRLEN n_a;
char * path = items ? (char *)SvPV(ST(0),n_a) : ".";
char * dir, *s, *t, *e;
char p[MAXPATHLEN];
char * RETVAL;
int l;
SV *sv;
if (items < 2)
dir = NULL;
else {
dir = (char *)SvPV(ST(1),n_a);
}
if (path[0] == '.' && (path[1] == '/' || path[1] == '\\')) {
path += 2;
}
if (dir == NULL) {
if (_abspath(p, path, MAXPATHLEN) == 0) {
RETVAL = p;
} else {
RETVAL = NULL;
}
} else {
/* Absolute with drive: */
if ( sys_is_absolute(path) ) {
if (_abspath(p, path, MAXPATHLEN) == 0) {
RETVAL = p;
} else {
RETVAL = NULL;
}
} else if (path[0] == '/' || path[0] == '\\') {
/* Rooted, but maybe on different drive. */
if (isALPHA(dir[0]) && dir[1] == ':' ) {
char p1[MAXPATHLEN];
/* Need to prepend the drive. */
p1[0] = dir[0];
p1[1] = dir[1];
Copy(path, p1 + 2, strlen(path) + 1, char);
RETVAL = p;
if (_abspath(p, p1, MAXPATHLEN) == 0) {
RETVAL = p;
} else {
RETVAL = NULL;
}
} else if (_abspath(p, path, MAXPATHLEN) == 0) {
RETVAL = p;
} else {
RETVAL = NULL;
}
} else {
/* Either path is relative, or starts with a drive letter. */
/* If the path starts with a drive letter, then dir is
relevant only if
a/b) it is absolute/x:relative on the same drive.
c) path is on current drive, and dir is rooted
In all the cases it is safe to drop the drive part
of the path. */
if ( !sys_is_relative(path) ) {
if ( ( ( sys_is_absolute(dir)
|| (isALPHA(dir[0]) && dir[1] == ':'
&& strnicmp(dir, path,1) == 0))
&& strnicmp(dir, path,1) == 0)
|| ( !(isALPHA(dir[0]) && dir[1] == ':')
&& toupper(path[0]) == current_drive())) {
path += 2;
} else if (_abspath(p, path, MAXPATHLEN) == 0) {
RETVAL = p; goto done;
} else {
RETVAL = NULL; goto done;
}
}
{
/* Need to prepend the absolute path of dir. */
char p1[MAXPATHLEN];
if (_abspath(p1, dir, MAXPATHLEN) == 0) {
int l = strlen(p1);
if (p1[ l - 1 ] != '/') {
p1[ l ] = '/';
l++;
}
Copy(path, p1 + l, strlen(path) + 1, char);
if (_abspath(p, p1, MAXPATHLEN) == 0) {
RETVAL = p;
} else {
RETVAL = NULL;
}
} else {
RETVAL = NULL;
}
}
done:
}
}
if (!RETVAL)
XSRETURN_EMPTY;
/* Backslashes are already converted to slashes. */
/* Remove trailing slashes */
l = strlen(RETVAL);
while (l > 0 && RETVAL[l-1] == '/')
l--;
ST(0) = sv_newmortal();
sv_setpvn( sv = (SV*)ST(0), RETVAL, l);
/* Remove duplicate slashes, skipping the first three, which
may be parts of a server-based path */
s = t = 3 + SvPV_force(sv, n_a);
e = SvEND(sv);
/* Do not worry about multibyte chars here, this would contradict the
eventual UTFization, and currently most other places break too... */
while (s < e) {
if (s[0] == t[-1] && s[0] == '/')
s++; /* Skip duplicate / */
else
*t++ = *s++;
}
if (t < e) {
*t = 0;
SvCUR_set(sv, t - SvPVX(sv));
}
#ifndef INCOMPLETE_TAINTS
if (!items)
SvTAINTED_on(ST(0));
#endif
}
XSRETURN(1);
}
typedef APIRET (*PELP)(PSZ path, ULONG type);
/* Kernels after 2000/09/15 understand this too: */
#ifndef LIBPATHSTRICT
# define LIBPATHSTRICT 3
#endif
APIRET
ExtLIBPATH(ULONG ord, PSZ path, IV type, int fatal)
{
ULONG what;
PFN f = loadByOrdinal(ord, fatal); /* if fatal: load or die! */
if (!f) /* Impossible with fatal */
return Perl_rc;
if (type > 0)
what = END_LIBPATH;
else if (type == 0)
what = BEGIN_LIBPATH;
else
what = LIBPATHSTRICT;
return (*(PELP)f)(path, what);
}
#define extLibpath(to,type, fatal) \
(CheckOSError(ExtLIBPATH(ORD_DosQueryExtLibpath, (to), (type), fatal)) ? NULL : (to) )
#define extLibpath_set(p,type, fatal) \
(!CheckOSError(ExtLIBPATH(ORD_DosSetExtLibpath, (p), (type), fatal)))
static void
early_error(char *msg1, char *msg2, char *msg3)
{ /* Buffer overflow detected; there is very little we can do... */
ULONG rc;
DosWrite(2, msg1, strlen(msg1), &rc);
DosWrite(2, msg2, strlen(msg2), &rc);
DosWrite(2, msg3, strlen(msg3), &rc);
DosExit(EXIT_PROCESS, 2);
}
XS(XS_Cwd_extLibpath)
{
dXSARGS;
if (items < 0 || items > 1)
Perl_croak_nocontext("Usage: OS2::extLibpath(type = 0)");
{
IV type;
char to[1024];
U32 rc;
char * RETVAL;
dXSTARG;
STRLEN l;
if (items < 1)
type = 0;
else {
type = SvIV(ST(0));
}
to[0] = 1; to[1] = 0; /* Sometimes no error reported */
RETVAL = extLibpath(to, type, 1); /* Make errors fatal */
if (RETVAL && RETVAL[0] == 1 && RETVAL[1] == 0)
Perl_croak_nocontext("panic OS2::extLibpath parameter");
l = strlen(to);
if (l >= sizeof(to))
early_error("Buffer overflow while getting BEGIN/ENDLIBPATH: `",
to, "'\r\n"); /* Will not return */
sv_setpv(TARG, RETVAL);
XSprePUSH; PUSHTARG;
}
XSRETURN(1);
}
XS(XS_Cwd_extLibpath_set)
{
dXSARGS;
if (items < 1 || items > 2)
Perl_croak_nocontext("Usage: OS2::extLibpath_set(s, type = 0)");
{
STRLEN n_a;
char * s = (char *)SvPV(ST(0),n_a);
IV type;
U32 rc;
bool RETVAL;
if (items < 2)
type = 0;
else {
type = SvIV(ST(1));
}
RETVAL = extLibpath_set(s, type, 1); /* Make errors fatal */
ST(0) = boolSV(RETVAL);
if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
}
XSRETURN(1);
}
ULONG
fill_extLibpath(int type, char *pre, char *post, int replace, char *msg)
{
char buf[2048], *to = buf, buf1[300], *s;
STRLEN l;
ULONG rc;
if (!pre && !post)
return 0;
if (pre) {
pre = dir_subst(pre, strlen(pre), buf1, sizeof buf1, dir_subst_pathlike, msg);
if (!pre)
return ERROR_INVALID_PARAMETER;
l = strlen(pre);
if (l >= sizeof(buf)/2)
return ERROR_BUFFER_OVERFLOW;
s = pre - 1;
while (*++s)
if (*s == '/')
*s = '\\'; /* Be extra causious */
memcpy(to, pre, l);
if (!l || to[l-1] != ';')
to[l++] = ';';
to += l;
}
if (!replace) {
to[0] = 1; to[1] = 0; /* Sometimes no error reported */
rc = ExtLIBPATH(ORD_DosQueryExtLibpath, to, type, 0); /* Do not croak */
if (rc)
return rc;
if (to[0] == 1 && to[1] == 0)
return ERROR_INVALID_PARAMETER;
to += strlen(to);
if (buf + sizeof(buf) - 1 <= to) /* Buffer overflow */
early_error("Buffer overflow while getting BEGIN/ENDLIBPATH: `",
buf, "'\r\n"); /* Will not return */
if (to > buf && to[-1] != ';')
*to++ = ';';
}
if (post) {
post = dir_subst(post, strlen(post), buf1, sizeof buf1, dir_subst_pathlike, msg);
if (!post)
return ERROR_INVALID_PARAMETER;
l = strlen(post);
if (l + to - buf >= sizeof(buf) - 1)
return ERROR_BUFFER_OVERFLOW;
s = post - 1;
while (*++s)
if (*s == '/')
*s = '\\'; /* Be extra causious */
memcpy(to, post, l);
if (!l || to[l-1] != ';')
to[l++] = ';';
to += l;
}
*to = 0;
rc = ExtLIBPATH(ORD_DosSetExtLibpath, buf, type, 0); /* Do not croak */
return rc;
}
/* Input: Address, BufLen
APIRET APIENTRY
DosQueryModFromEIP (HMODULE * hmod, ULONG * obj, ULONG BufLen, PCHAR Buf,
ULONG * Offset, ULONG Address);
*/
DeclOSFuncByORD(APIRET, _DosQueryModFromEIP,ORD_DosQueryModFromEIP,
(HMODULE * hmod, ULONG * obj, ULONG BufLen, PCHAR Buf,
ULONG * Offset, ULONG Address),
(hmod, obj, BufLen, Buf, Offset, Address))
static SV*
module_name_at(void *pp, enum module_name_how how)
{
dTHX;
char buf[MAXPATHLEN];
char *p = buf;
HMODULE mod;
ULONG obj, offset, rc, addr = (ULONG)pp;
if (how & mod_name_HMODULE) {
if ((how & ~mod_name_HMODULE) == mod_name_shortname)
Perl_croak(aTHX_ "Can't get short module name from a handle");
mod = (HMODULE)pp;
how &= ~mod_name_HMODULE;
} else if (!_DosQueryModFromEIP(&mod, &obj, sizeof(buf), buf, &offset, addr))
return &PL_sv_undef;
if (how == mod_name_handle)
return newSVuv(mod);
/* Full name... */
if ( how != mod_name_shortname
&& CheckOSError(DosQueryModuleName(mod, sizeof(buf), buf)) )
return &PL_sv_undef;
while (*p) {
if (*p == '\\')
*p = '/';
p++;
}
return newSVpv(buf, 0);
}
static SV*
module_name_of_cv(SV *cv, enum module_name_how how)
{
if (!cv || !SvROK(cv) || SvTYPE(SvRV(cv)) != SVt_PVCV || !CvXSUB(SvRV(cv))) {
dTHX;
if (how & mod_name_C_function)
return module_name_at((void*)SvIV(cv), how & ~mod_name_C_function);
else if (how & mod_name_HMODULE)
return module_name_at((void*)SvIV(cv), how);
Perl_croak(aTHX_ "Not an XSUB reference");
}
return module_name_at(CvXSUB(SvRV(cv)), how);
}
XS(XS_OS2_DLLname)
{
dXSARGS;
if (items > 2)
Perl_croak(aTHX_ "Usage: OS2::DLLname( [ how, [\\&xsub] ] )");
{
SV * RETVAL;
int how;
if (items < 1)
how = mod_name_full;
else {
how = (int)SvIV(ST(0));
}
if (items < 2)
RETVAL = module_name(how);
else
RETVAL = module_name_of_cv(ST(1), how);
ST(0) = RETVAL;
sv_2mortal(ST(0));
}
XSRETURN(1);
}
DeclOSFuncByORD(INT, _Dos32QueryHeaderInfo, ORD_Dos32QueryHeaderInfo,
(ULONG r1, ULONG r2, PVOID buf, ULONG szbuf, ULONG fnum),
(r1, r2, buf, szbuf, fnum))
XS(XS_OS2__headerInfo)
{
dXSARGS;
if (items > 4 || items < 2)
Perl_croak(aTHX_ "Usage: OS2::_headerInfo(req,size[,handle,[offset]])");
{
ULONG req = (ULONG)SvIV(ST(0));
STRLEN size = (STRLEN)SvIV(ST(1)), n_a;
ULONG handle = (items >= 3 ? (ULONG)SvIV(ST(2)) : 0);
ULONG offset = (items >= 4 ? (ULONG)SvIV(ST(3)) : 0);
if (size <= 0)
Perl_croak(aTHX_ "OS2::_headerInfo(): unexpected size: %d", (int)size);
ST(0) = newSVpvn("",0);
SvGROW(ST(0), size + 1);
sv_2mortal(ST(0));
if (!_Dos32QueryHeaderInfo(handle, offset, SvPV(ST(0), n_a), size, req))
Perl_croak(aTHX_ "OS2::_headerInfo(%ld,%ld,%ld,%ld) error: %s",
req, size, handle, offset, os2error(Perl_rc));
SvCUR_set(ST(0), size);
*SvEND(ST(0)) = 0;
}
XSRETURN(1);
}
#define DQHI_QUERYLIBPATHSIZE 4
#define DQHI_QUERYLIBPATH 5
XS(XS_OS2_libPath)
{
dXSARGS;
if (items != 0)
Perl_croak(aTHX_ "Usage: OS2::libPath()");
{
ULONG size;
STRLEN n_a;
if (!_Dos32QueryHeaderInfo(0, 0, &size, sizeof(size),
DQHI_QUERYLIBPATHSIZE))
Perl_croak(aTHX_ "OS2::_headerInfo(%ld,%ld,%ld,%ld) error: %s",
DQHI_QUERYLIBPATHSIZE, sizeof(size), 0, 0,
os2error(Perl_rc));
ST(0) = newSVpvn("",0);
SvGROW(ST(0), size + 1);
sv_2mortal(ST(0));
/* We should be careful: apparently, this entry point does not
pay attention to the size argument, so may overwrite
unrelated data! */
if (!_Dos32QueryHeaderInfo(0, 0, SvPV(ST(0), n_a), size,
DQHI_QUERYLIBPATH))
Perl_croak(aTHX_ "OS2::_headerInfo(%ld,%ld,%ld,%ld) error: %s",
DQHI_QUERYLIBPATH, size, 0, 0, os2error(Perl_rc));
SvCUR_set(ST(0), size);
*SvEND(ST(0)) = 0;
}
XSRETURN(1);
}
#define get_control87() _control87(0,0)
#define set_control87 _control87
XS(XS_OS2__control87)
{
dXSARGS;
if (items != 2)
Perl_croak(aTHX_ "Usage: OS2::_control87(new,mask)");
{
unsigned new = (unsigned)SvIV(ST(0));
unsigned mask = (unsigned)SvIV(ST(1));
unsigned RETVAL;
dXSTARG;
RETVAL = _control87(new, mask);
XSprePUSH; PUSHi((IV)RETVAL);
}
XSRETURN(1);
}
XS(XS_OS2_mytype)
{
dXSARGS;
int which = 0;
if (items < 0 || items > 1)
Perl_croak(aTHX_ "Usage: OS2::mytype([which])");
if (items == 1)
which = (int)SvIV(ST(0));
{
unsigned RETVAL;
dXSTARG;
switch (which) {
case 0:
RETVAL = os2_mytype; /* Reset after fork */
break;
case 1:
RETVAL = os2_mytype_ini; /* Before any fork */
break;
case 2:
RETVAL = Perl_os2_initial_mode; /* Before first morphing */
break;
case 3:
RETVAL = my_type(); /* Morphed type */
break;
default:
Perl_croak(aTHX_ "OS2::mytype(which): unknown which=%d", which);
}
XSprePUSH; PUSHi((IV)RETVAL);
}
XSRETURN(1);
}
XS(XS_OS2_mytype_set)
{
dXSARGS;
int type;
if (items == 1)
type = (int)SvIV(ST(0));
else
Perl_croak(aTHX_ "Usage: OS2::mytype_set(type)");
my_type_set(type);
XSRETURN_YES;
}
XS(XS_OS2_get_control87)
{
dXSARGS;
if (items != 0)
Perl_croak(aTHX_ "Usage: OS2::get_control87()");
{
unsigned RETVAL;
dXSTARG;
RETVAL = get_control87();
XSprePUSH; PUSHi((IV)RETVAL);
}
XSRETURN(1);
}
XS(XS_OS2_set_control87)
{
dXSARGS;
if (items < 0 || items > 2)
Perl_croak(aTHX_ "Usage: OS2::set_control87(new=MCW_EM, mask=MCW_EM)");
{
unsigned new;
unsigned mask;
unsigned RETVAL;
dXSTARG;
if (items < 1)
new = MCW_EM;
else {
new = (unsigned)SvIV(ST(0));
}
if (items < 2)
mask = MCW_EM;
else {
mask = (unsigned)SvIV(ST(1));
}
RETVAL = set_control87(new, mask);
XSprePUSH; PUSHi((IV)RETVAL);
}
XSRETURN(1);
}
XS(XS_OS2_incrMaxFHandles) /* DosSetRelMaxFH */
{
dXSARGS;
if (items < 0 || items > 1)
Perl_croak(aTHX_ "Usage: OS2::incrMaxFHandles(delta = 0)");
{
LONG delta;
ULONG RETVAL, rc;
dXSTARG;
if (items < 1)
delta = 0;
else
delta = (LONG)SvIV(ST(0));
if (CheckOSError(DosSetRelMaxFH(&delta, &RETVAL)))
croak_with_os2error("OS2::incrMaxFHandles(): DosSetRelMaxFH() error");
XSprePUSH; PUSHu((UV)RETVAL);
}
XSRETURN(1);
}
/* wait>0: force wait, wait<0: force nowait;
if restore, save/restore flags; otherwise flags are in oflags.
Returns 1 if connected, 0 if not (due to nowait); croaks on error. */
static ULONG
connectNPipe(ULONG hpipe, int wait, ULONG restore, ULONG oflags)
{
ULONG ret = ERROR_INTERRUPT, rc, flags;
if (restore && wait)
os2cp_croak(DosQueryNPHState(hpipe, &oflags), "DosQueryNPHState()");
/* DosSetNPHState fails if more bits than NP_NOWAIT|NP_READMODE_MESSAGE */
oflags &= (NP_NOWAIT | NP_READMODE_MESSAGE);
flags = (oflags & ~NP_NOWAIT) | (wait > 0 ? NP_WAIT : NP_NOWAIT);
/* We know (o)flags unless wait == 0 && restore */
if (wait && (flags != oflags))
os2cp_croak(DosSetNPHState(hpipe, flags), "DosSetNPHState()");
while (ret == ERROR_INTERRUPT)
ret = DosConnectNPipe(hpipe);
(void)CheckOSError(ret);
if (restore && wait && (flags != oflags))
os2cp_croak(DosSetNPHState(hpipe, oflags), "DosSetNPHState() back");
/* We know flags unless wait == 0 && restore */
if ( ((wait || restore) ? (flags & NP_NOWAIT) : 1)
&& (ret == ERROR_PIPE_NOT_CONNECTED) )
return 0; /* normal return value */
if (ret == NO_ERROR)
return 1;
croak_with_os2error("DosConnectNPipe()");
}
/* With a lot of manual editing:
NO_OUTPUT ULONG
DosCreateNPipe(PCSZ pszName, OUTLIST HPIPE hpipe, ULONG ulOpenMode, int connect = 1, int count = 1, ULONG ulInbufLength = 8192, ULONG ulOutbufLength = ulInbufLength, ULONG ulPipeMode = count | NP_NOWAIT | NP_TYPE_BYTE | NP_READMODE_BYTE, ULONG ulTimeout = 0)
PREINIT:
ULONG rc;
C_ARGS:
pszName, &hpipe, ulOpenMode, ulPipeMode, ulInbufLength, ulOutbufLength, ulTimeout
POSTCALL:
if (CheckOSError(RETVAL))
croak_with_os2error("OS2::mkpipe() error");
*/
XS(XS_OS2_pipe); /* prototype to pass -Wmissing-prototypes */
XS(XS_OS2_pipe)
{
dXSARGS;
if (items < 2 || items > 8)
Perl_croak(aTHX_ "Usage: OS2::pipe(pszName, ulOpenMode, connect= 1, count= 1, ulInbufLength= 8192, ulOutbufLength= ulInbufLength, ulPipeMode= count | NP_NOWAIT | NP_TYPE_BYTE | NP_READMODE_BYTE, ulTimeout= 0)");
{
ULONG RETVAL;
PCSZ pszName = ( SvOK(ST(0)) ? (PCSZ)SvPV(ST(0),PL_na) : NULL );
HPIPE hpipe;
SV *OpenMode = ST(1);
ULONG ulOpenMode;
int connect = 0, count, message_r = 0, message = 0, b = 0;
ULONG ulInbufLength, ulOutbufLength, ulPipeMode, ulTimeout, rc;
STRLEN len;
char *s, buf[10], *s1, *perltype = Nullch;
PerlIO *perlio;
double timeout;
if (!pszName || !*pszName)
Perl_croak(aTHX_ "OS2::pipe(): empty pipe name");
s = SvPV(OpenMode, len);
if (len == 4 && strEQ(s, "wait")) { /* DosWaitNPipe() */
ULONG ms = 0xFFFFFFFF, ret = ERROR_INTERRUPT; /* Indefinite */
if (items == 3) {
timeout = (double)SvNV(ST(2));
ms = timeout * 1000;
if (timeout < 0)
ms = 0xFFFFFFFF; /* Indefinite */
else if (timeout && !ms)
ms = 1;
} else if (items > 3)
Perl_croak(aTHX_ "OS2::pipe(): too many arguments for wait-for-connect: %ld", (long)items);
while (ret == ERROR_INTERRUPT)
ret = DosWaitNPipe(pszName, ms); /* XXXX Update ms? */
os2cp_croak(ret, "DosWaitNPipe()");
XSRETURN_YES;
}
if (len == 4 && strEQ(s, "call")) { /* DosCallNPipe() */
ULONG ms = 0xFFFFFFFF, got; /* Indefinite */
STRLEN l;
char *s;
char buf[8192];
STRLEN ll = sizeof(buf);
char *b = buf;
if (items < 3 || items > 5)
Perl_croak(aTHX_ "usage: OS2::pipe(pszName, 'call', write [, timeout= 0xFFFFFFFF, buffsize = 8192])");
s = SvPV(ST(2), l);
if (items >= 4) {
timeout = (double)SvNV(ST(3));
ms = timeout * 1000;
if (timeout < 0)
ms = 0xFFFFFFFF; /* Indefinite */
else if (timeout && !ms)
ms = 1;
}
if (items >= 5) {
STRLEN lll = SvUV(ST(4));
SV *sv = NEWSV(914, lll);
sv_2mortal(sv);
ll = lll;
b = SvPVX(sv);
}
os2cp_croak(DosCallNPipe(pszName, s, l, b, ll, &got, ms),
"DosCallNPipe()");
XSRETURN_PVN(b, got);
}
s1 = buf;
if (len && len <= 3 && !(*s >= '0' && *s <= '9')) {
int r, w, R, W;
r = strchr(s, 'r') != 0;
w = strchr(s, 'w') != 0;
R = strchr(s, 'R') != 0;
W = strchr(s, 'W') != 0;
b = strchr(s, 'b') != 0;
if (r + w + R + W + b != len || (r && R) || (w && W))
Perl_croak(aTHX_ "OS2::pipe(): unknown OpenMode argument: `%s'", s);
if ((r || R) && (w || W))
ulOpenMode = NP_INHERIT | NP_NOWRITEBEHIND | NP_ACCESS_DUPLEX;
else if (r || R)
ulOpenMode = NP_INHERIT | NP_NOWRITEBEHIND | NP_ACCESS_INBOUND;
else
ulOpenMode = NP_INHERIT | NP_NOWRITEBEHIND | NP_ACCESS_OUTBOUND;
if (R)
message = message_r = 1;
if (W)
message = 1;
else if (w && R)
Perl_croak(aTHX_ "OS2::pipe(): can't have message read mode for non-message pipes");
} else
ulOpenMode = (ULONG)SvUV(OpenMode); /* ST(1) */
if ( (ulOpenMode & 0x3) == NP_ACCESS_DUPLEX
|| (ulOpenMode & 0x3) == NP_ACCESS_INBOUND )
*s1++ = 'r';
if ( (ulOpenMode & 0x3) == NP_ACCESS_DUPLEX )
*s1++ = '+';
if ( (ulOpenMode & 0x3) == NP_ACCESS_OUTBOUND )
*s1++ = 'w';
if (b)
*s1++ = 'b';
*s1 = 0;
if ( (ulOpenMode & 0x3) == NP_ACCESS_DUPLEX )
perltype = "+<&";
else if ( (ulOpenMode & 0x3) == NP_ACCESS_OUTBOUND )
perltype = ">&";
else
perltype = "<&";
if (items < 3)
connect = -1; /* no wait */
else if (SvTRUE(ST(2))) {
s = SvPV(ST(2), len);
if (len == 6 && strEQ(s, "nowait"))
connect = -1; /* no wait */
else if (len == 4 && strEQ(s, "wait"))
connect = 1; /* wait */
else
Perl_croak(aTHX_ "OS2::pipe(): unknown connect argument: `%s'", s);
}
if (items < 4)
count = 1;
else
count = (int)SvIV(ST(3));
if (items < 5)
ulInbufLength = 8192;
else
ulInbufLength = (ULONG)SvUV(ST(4));
if (items < 6)
ulOutbufLength = ulInbufLength;
else
ulOutbufLength = (ULONG)SvUV(ST(5));
if (count < -1 || count == 0 || count >= 255)
Perl_croak(aTHX_ "OS2::pipe(): count should be -1 or between 1 and 254: %ld", (long)count);
if (count < 0 )
count = 255; /* Unlimited */
ulPipeMode = count;
if (items < 7)
ulPipeMode |= (NP_WAIT
| (message ? NP_TYPE_MESSAGE : NP_TYPE_BYTE)
| (message_r ? NP_READMODE_MESSAGE : NP_READMODE_BYTE));
else
ulPipeMode |= (ULONG)SvUV(ST(6));
if (items < 8)
timeout = 0;
else
timeout = (double)SvNV(ST(7));
ulTimeout = timeout * 1000;
if (timeout < 0)
ulTimeout = 0xFFFFFFFF; /* Indefinite */
else if (timeout && !ulTimeout)
ulTimeout = 1;
RETVAL = DosCreateNPipe(pszName, &hpipe, ulOpenMode, ulPipeMode, ulInbufLength, ulOutbufLength, ulTimeout);
if (CheckOSError(RETVAL))
croak_with_os2error("OS2::pipe(): DosCreateNPipe() error");
if (connect)
connectNPipe(hpipe, connect, 1, 0); /* XXXX wait, retval */
hpipe = __imphandle(hpipe);
perlio = PerlIO_fdopen(hpipe, buf);
ST(0) = sv_newmortal();
{
GV *gv = newGVgen("OS2::pipe");
if ( do_open(gv, perltype, strlen(perltype), FALSE, 0, 0, perlio) )
sv_setsv(ST(0), sv_bless(newRV((SV*)gv), gv_stashpv("IO::Handle",1)));
else
ST(0) = &PL_sv_undef;
}
}
XSRETURN(1);
}
XS(XS_OS2_pipeCntl); /* prototype to pass -Wmissing-prototypes */
XS(XS_OS2_pipeCntl)
{
dXSARGS;
if (items < 2 || items > 3)
Perl_croak(aTHX_ "Usage: OS2::pipeCntl(pipe, op [, wait])");
{
ULONG rc;
PerlIO *perlio = IoIFP(sv_2io(ST(0)));
IV fn = PerlIO_fileno(perlio);
HPIPE hpipe = (HPIPE)fn;
STRLEN len;
char *s = SvPV(ST(1), len);
int wait = 0, disconnect = 0, connect = 0, message = -1, query = 0;
int peek = 0, state = 0, info = 0;
if (fn < 0)
Perl_croak(aTHX_ "OS2::pipeCntl(): not a pipe");
if (items == 3)
wait = (SvTRUE(ST(2)) ? 1 : -1);
switch (len) {
case 4:
if (strEQ(s, "byte"))
message = 0;
else if (strEQ(s, "peek"))
peek = 1;
else if (strEQ(s, "info"))
info = 1;
else
goto unknown;
break;
case 5:
if (strEQ(s, "reset"))
disconnect = connect = 1;
else if (strEQ(s, "state"))
query = 1;
else
goto unknown;
break;
case 7:
if (strEQ(s, "connect"))
connect = 1;
else if (strEQ(s, "message"))
message = 1;
else
goto unknown;
break;
case 9:
if (!strEQ(s, "readstate"))
goto unknown;
state = 1;
break;
case 10:
if (!strEQ(s, "disconnect"))
goto unknown;
disconnect = 1;
break;
default:
unknown:
Perl_croak(aTHX_ "OS2::pipeCntl(): unknown argument: `%s'", s);
break;
}
if (items == 3 && !connect)
Perl_croak(aTHX_ "OS2::pipeCntl(): no wait argument for `%s'", s);
XSprePUSH; /* Do not need arguments any more */
if (disconnect) {
os2cp_croak(DosDisConnectNPipe(hpipe), "OS2::pipeCntl(): DosDisConnectNPipe()");
PerlIO_clearerr(perlio);
}
if (connect) {
if (!connectNPipe(hpipe, wait , 1, 0))
XSRETURN_IV(-1);
}
if (query) {
ULONG flags;
os2cp_croak(DosQueryNPHState(hpipe, &flags), "DosQueryNPHState()");
XSRETURN_UV(flags);
}
if (peek || state || info) {
ULONG BytesRead, PipeState;
AVAILDATA BytesAvail;
os2cp_croak( DosPeekNPipe(hpipe, NULL, 0, &BytesRead, &BytesAvail,
&PipeState), "DosPeekNPipe() for state");
if (state) {
EXTEND(SP, 3);
PUSHs(newSVuv(PipeState));
/* Bytes (available/in-message) */
PUSHs(newSViv(BytesAvail.cbpipe));
PUSHs(newSViv(BytesAvail.cbmessage));
XSRETURN(3);
} else if (info) {
/* L S S C C C/Z*
ID of the (remote) computer
buffers (out/in)
instances (max/actual)
*/
struct pipe_info_t {
ULONG id; /* char id[4]; */
PIPEINFO pInfo;
char buf[512];
} b;
int size;
os2cp_croak( DosQueryNPipeInfo(hpipe, 1, &b.pInfo, sizeof(b) - STRUCT_OFFSET(struct pipe_info_t, pInfo)),
"DosQueryNPipeInfo(1)");
os2cp_croak( DosQueryNPipeInfo(hpipe, 2, &b.id, sizeof(b.id)),
"DosQueryNPipeInfo(2)");
size = b.pInfo.cbName;
/* Trailing 0 is included in cbName - undocumented; so
one should always extract with Z* */
if (size) /* name length 254 or less */
size--;
else
size = strlen(b.pInfo.szName);
EXTEND(SP, 6);
PUSHs(newSVpvn(b.pInfo.szName, size));
PUSHs(newSVuv(b.id));
PUSHs(newSViv(b.pInfo.cbOut));
PUSHs(newSViv(b.pInfo.cbIn));
PUSHs(newSViv(b.pInfo.cbMaxInst));
PUSHs(newSViv(b.pInfo.cbCurInst));
XSRETURN(6);
} else if (BytesAvail.cbpipe == 0) {
XSRETURN_NO;
} else {
SV *tmp = NEWSV(914, BytesAvail.cbpipe);
char *s = SvPVX(tmp);
sv_2mortal(tmp);
os2cp_croak( DosPeekNPipe(hpipe, s, BytesAvail.cbpipe, &BytesRead,
&BytesAvail, &PipeState), "DosPeekNPipe()");
SvCUR_set(tmp, BytesRead);
*SvEND(tmp) = 0;
SvPOK_on(tmp);
XSprePUSH; PUSHs(tmp);
XSRETURN(1);
}
}
if (message > -1) {
ULONG oflags, flags;
os2cp_croak(DosQueryNPHState(hpipe, &oflags), "DosQueryNPHState()");
/* DosSetNPHState fails if more bits than NP_NOWAIT|NP_READMODE_MESSAGE */
oflags &= (NP_NOWAIT | NP_READMODE_MESSAGE);
flags = (oflags & NP_NOWAIT)
| (message ? NP_READMODE_MESSAGE : NP_READMODE_BYTE);
if (flags != oflags)
os2cp_croak(DosSetNPHState(hpipe, flags), "DosSetNPHState()");
}
}
XSRETURN_YES;
}
/*
NO_OUTPUT ULONG
DosOpen(PCSZ pszFileName, OUTLIST HFILE hFile, OUTLIST ULONG ulAction, ULONG ulOpenFlags, ULONG ulOpenMode = OPEN_ACTION_OPEN_IF_EXISTS | OPEN_ACTION_FAIL_IF_NEW, ULONG ulAttribute = FILE_NORMAL, ULONG ulFileSize = 0, PEAOP2 pEABuf = NULL);
PREINIT:
ULONG rc;
C_ARGS:
pszFileName, &hFile, &ulAction, ulFileSize, ulAttribute, ulOpenFlags, ulOpenMode, pEABuf
POSTCALL:
if (CheckOSError(RETVAL))
croak_with_os2error("OS2::open() error");
*/
XS(XS_OS2_open); /* prototype to pass -Wmissing-prototypes */
XS(XS_OS2_open)
{
dXSARGS;
if (items < 2 || items > 6)
Perl_croak(aTHX_ "Usage: OS2::open(pszFileName, ulOpenMode, ulOpenFlags= OPEN_ACTION_OPEN_IF_EXISTS | OPEN_ACTION_FAIL_IF_NEW, ulAttribute= FILE_NORMAL, ulFileSize= 0, pEABuf= NULL)");
{
#line 39 "pipe.xs"
ULONG rc;
#line 113 "pipe.c"
ULONG RETVAL;
PCSZ pszFileName = ( SvOK(ST(0)) ? (PCSZ)SvPV(ST(0),PL_na) : NULL );
HFILE hFile;
ULONG ulAction;
ULONG ulOpenMode = (ULONG)SvUV(ST(1));
ULONG ulOpenFlags;
ULONG ulAttribute;
ULONG ulFileSize;
PEAOP2 pEABuf;
if (items < 3)
ulOpenFlags = OPEN_ACTION_OPEN_IF_EXISTS | OPEN_ACTION_FAIL_IF_NEW;
else {
ulOpenFlags = (ULONG)SvUV(ST(2));
}
if (items < 4)
ulAttribute = FILE_NORMAL;
else {
ulAttribute = (ULONG)SvUV(ST(3));
}
if (items < 5)
ulFileSize = 0;
else {
ulFileSize = (ULONG)SvUV(ST(4));
}
if (items < 6)
pEABuf = NULL;
else {
pEABuf = (PEAOP2)SvUV(ST(5));
}
RETVAL = DosOpen(pszFileName, &hFile, &ulAction, ulFileSize, ulAttribute, ulOpenFlags, ulOpenMode, pEABuf);
if (CheckOSError(RETVAL))
croak_with_os2error("OS2::open() error");
XSprePUSH; EXTEND(SP,2);
PUSHs(sv_newmortal());
sv_setuv(ST(0), (UV)hFile);
PUSHs(sv_newmortal());
sv_setuv(ST(1), (UV)ulAction);
}
XSRETURN(2);
}
int
Xs_OS2_init(pTHX)
{
char *file = __FILE__;
{
GV *gv;
if (_emx_env & 0x200) { /* OS/2 */
newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file);
newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file);
newXS("OS2::extLibpath", XS_Cwd_extLibpath, file);
newXS("OS2::extLibpath_set", XS_Cwd_extLibpath_set, file);
}
newXS("OS2::Error", XS_OS2_Error, file);
newXS("OS2::Errors2Drive", XS_OS2_Errors2Drive, file);
newXS("OS2::SysInfo", XS_OS2_SysInfo, file);
newXSproto("OS2::DevCap", XS_OS2_DevCap, file, ";$$");
newXSproto("OS2::SysInfoFor", XS_OS2_SysInfoFor, file, "$;$");
newXS("OS2::BootDrive", XS_OS2_BootDrive, file);
newXS("OS2::MorphPM", XS_OS2_MorphPM, file);
newXS("OS2::UnMorphPM", XS_OS2_UnMorphPM, file);
newXS("OS2::Serve_Messages", XS_OS2_Serve_Messages, file);
newXS("OS2::Process_Messages", XS_OS2_Process_Messages, file);
newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file);
newXS("Cwd::current_drive", XS_Cwd_current_drive, file);
newXS("Cwd::sys_chdir", XS_Cwd_sys_chdir, file);
newXS("Cwd::change_drive", XS_Cwd_change_drive, file);
newXS("Cwd::sys_is_absolute", XS_Cwd_sys_is_absolute, file);
newXS("Cwd::sys_is_rooted", XS_Cwd_sys_is_rooted, file);
newXS("Cwd::sys_is_relative", XS_Cwd_sys_is_relative, file);
newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file);
newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, file);
newXS("OS2::replaceModule", XS_OS2_replaceModule, file);
newXS("OS2::perfSysCall", XS_OS2_perfSysCall, file);
newXSproto("OS2::_control87", XS_OS2__control87, file, "$$");
newXSproto("OS2::get_control87", XS_OS2_get_control87, file, "");
newXSproto("OS2::set_control87", XS_OS2_set_control87, file, ";$$");
newXSproto("OS2::DLLname", XS_OS2_DLLname, file, ";$$");
newXSproto("OS2::mytype", XS_OS2_mytype, file, ";$");
newXSproto("OS2::mytype_set", XS_OS2_mytype_set, file, "$");
newXSproto("OS2::_headerInfo", XS_OS2__headerInfo, file, "$$;$$");
newXSproto("OS2::libPath", XS_OS2_libPath, file, "");
newXSproto("OS2::Timer", XS_OS2_Timer, file, "");
newXSproto("OS2::msCounter", XS_OS2_msCounter, file, "");
newXSproto("OS2::ms_sleep", XS_OS2_ms_sleep, file, "$;$");
newXSproto("OS2::_InfoTable", XS_OS2__InfoTable, file, ";$");
newXSproto("OS2::incrMaxFHandles", XS_OS2_incrMaxFHandles, file, ";$");
newXSproto("OS2::SysValues", XS_OS2_SysValues, file, ";$$");
newXSproto("OS2::SysValues_set", XS_OS2_SysValues_set, file, "$$;$");
newXSproto("OS2::Beep", XS_OS2_Beep, file, ";$$");
newXSproto("OS2::pipe", XS_OS2_pipe, file, "$$;$$$$$$");
newXSproto("OS2::pipeCntl", XS_OS2_pipeCntl, file, "$$;$");
newXSproto("OS2::open", XS_OS2_open, file, "$$;$$$$");
gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
GvMULTI_on(gv);
#ifdef PERL_IS_AOUT
sv_setiv(GvSV(gv), 1);
#endif
gv = gv_fetchpv("OS2::is_static", TRUE, SVt_PV);
GvMULTI_on(gv);
#ifdef PERL_IS_AOUT
sv_setiv(GvSV(gv), 1);
#endif
gv = gv_fetchpv("OS2::can_fork", TRUE, SVt_PV);
GvMULTI_on(gv);
sv_setiv(GvSV(gv), exe_is_aout());
gv = gv_fetchpv("OS2::emx_rev", TRUE, SVt_PV);
GvMULTI_on(gv);
sv_setiv(GvSV(gv), _emx_rev);
sv_setpv(GvSV(gv), _emx_vprt);
SvIOK_on(GvSV(gv));
gv = gv_fetchpv("OS2::emx_env", TRUE, SVt_PV);
GvMULTI_on(gv);
sv_setiv(GvSV(gv), _emx_env);
gv = gv_fetchpv("OS2::os_ver", TRUE, SVt_PV);
GvMULTI_on(gv);
sv_setnv(GvSV(gv), _osmajor + 0.001 * _osminor);
gv = gv_fetchpv("OS2::nsyserror", TRUE, SVt_PV);
GvMULTI_on(gv);
sv_setiv(GvSV(gv), 1); /* DEFAULT: Show number on syserror */
}
return 0;
}
extern void _emx_init(void*);
static void jmp_out_of_atexit(void);
#define FORCE_EMX_INIT_CONTRACT_ARGV 1
#define FORCE_EMX_INIT_INSTALL_ATEXIT 2
static void
my_emx_init(void *layout) {
static volatile void *old_esp = 0; /* Cannot be on stack! */
/* Can't just call emx_init(), since it moves the stack pointer */
/* It also busts a lot of registers, so be extra careful */
__asm__( "pushf\n"
"pusha\n"
"movl %%esp, %1\n"
"push %0\n"
"call __emx_init\n"
"movl %1, %%esp\n"
"popa\n"
"popf\n" : : "r" (layout), "m" (old_esp) );
}
struct layout_table_t {
ULONG text_base;
ULONG text_end;
ULONG data_base;
ULONG data_end;
ULONG bss_base;
ULONG bss_end;
ULONG heap_base;
ULONG heap_end;
ULONG heap_brk;
ULONG heap_off;
ULONG os2_dll;
ULONG stack_base;
ULONG stack_end;
ULONG flags;
ULONG reserved[2];
char options[64];
};
static ULONG
my_os_version() {
static ULONG osv_res; /* Cannot be on stack! */
/* Can't just call __os_version(), since it does not follow C
calling convention: it busts a lot of registers, so be extra careful */
__asm__( "pushf\n"
"pusha\n"
"call ___os_version\n"
"movl %%eax, %0\n"
"popa\n"
"popf\n" : "=m" (osv_res) );
return osv_res;
}
static void
force_init_emx_runtime(EXCEPTIONREGISTRATIONRECORD *preg, ULONG flags)
{
/* Calling emx_init() will bust the top of stack: it installs an
exception handler and puts argv data there. */
char *oldarg, *oldenv;
void *oldstackend, *oldstack;
PPIB pib;
PTIB tib;
ULONG rc, error = 0, out;
char buf[512];
static struct layout_table_t layout_table;
struct {
char buf[48*1024]; /* _emx_init() requires 32K, cmd.exe has 64K only */
double alignment1;
EXCEPTIONREGISTRATIONRECORD xreg;
} *newstack;
char *s;
layout_table.os2_dll = (ULONG)&os2_dll_fake;
layout_table.flags = 0x02000002; /* flags: application, OMF */
DosGetInfoBlocks(&tib, &pib);
oldarg = pib->pib_pchcmd;
oldenv = pib->pib_pchenv;
oldstack = tib->tib_pstack;
oldstackend = tib->tib_pstacklimit;
if ( (char*)&s < (char*)oldstack + 4*1024
|| (char *)oldstackend < (char*)oldstack + 52*1024 )
early_error("It is a lunacy to try to run EMX Perl ",
"with less than 64K of stack;\r\n",
" at least with non-EMX starter...\r\n");
/* Minimize the damage to the stack via reducing the size of argv. */
if (flags & FORCE_EMX_INIT_CONTRACT_ARGV) {
pib->pib_pchcmd = "\0\0"; /* Need 3 concatenated strings */
pib->pib_pchcmd = "\0"; /* Ended by an extra \0. */
}
newstack = alloca(sizeof(*newstack));
/* Emulate the stack probe */
s = ((char*)newstack) + sizeof(*newstack);
while (s > (char*)newstack) {
s[-1] = 0;
s -= 4096;
}
/* Reassigning stack is documented to work */
tib->tib_pstack = (void*)newstack;
tib->tib_pstacklimit = (void*)((char*)newstack + sizeof(*newstack));
/* Can't just call emx_init(), since it moves the stack pointer */
my_emx_init((void*)&layout_table);
/* Remove the exception handler, cannot use it - too low on the stack.
Check whether it is inside the new stack. */
buf[0] = 0;
if (tib->tib_pexchain >= tib->tib_pstacklimit
|| tib->tib_pexchain < tib->tib_pstack) {
error = 1;
sprintf(buf,
"panic: ExceptionHandler misplaced: not %#lx <= %#lx < %#lx\n",
(unsigned long)tib->tib_pstack,
(unsigned long)tib->tib_pexchain,
(unsigned long)tib->tib_pstacklimit);
goto finish;
}
if (tib->tib_pexchain != &(newstack->xreg)) {
sprintf(buf, "ExceptionHandler misplaced: %#lx != %#lx\n",
(unsigned long)tib->tib_pexchain,
(unsigned long)&(newstack->xreg));
}
rc = DosUnsetExceptionHandler((EXCEPTIONREGISTRATIONRECORD *)tib->tib_pexchain);
if (rc)
sprintf(buf + strlen(buf),
"warning: DosUnsetExceptionHandler rc=%#lx=%lu\n", rc, rc);
if (preg) {
/* ExceptionRecords should be on stack, in a correct order. Sigh... */
preg->prev_structure = 0;
preg->ExceptionHandler = _emx_exception;
rc = DosSetExceptionHandler(preg);
if (rc) {
sprintf(buf + strlen(buf),
"warning: DosSetExceptionHandler rc=%#lx=%lu\n", rc, rc);
DosWrite(2, buf, strlen(buf), &out);
emx_exception_init = 1; /* Do it around spawn*() calls */
}
} else
emx_exception_init = 1; /* Do it around spawn*() calls */
finish:
/* Restore the damage */
pib->pib_pchcmd = oldarg;
pib->pib_pchcmd = oldenv;
tib->tib_pstacklimit = oldstackend;
tib->tib_pstack = oldstack;
emx_runtime_init = 1;
if (buf[0])
DosWrite(2, buf, strlen(buf), &out);
if (error)
exit(56);
}
static void
jmp_out_of_atexit(void)
{
if (longjmp_at_exit)
longjmp(at_exit_buf, 1);
}
extern void _CRT_term(void);
void
Perl_OS2_term(void **p, int exitstatus, int flags)
{
if (!emx_runtime_secondary)
return;
/* The principal executable is not running the same CRTL, so there
is nobody to shutdown *this* CRTL except us... */
if (flags & FORCE_EMX_DEINIT_EXIT) {
if (p && !emx_exception_init)
DosUnsetExceptionHandler((EXCEPTIONREGISTRATIONRECORD *)p);
/* Do not run the executable's CRTL's termination routines */
exit(exitstatus); /* Run at-exit, flush buffers, etc */
}
/* Run at-exit list, and jump out at the end */
if ((flags & FORCE_EMX_DEINIT_RUN_ATEXIT) && !setjmp(at_exit_buf)) {
longjmp_at_exit = 1;
exit(exitstatus); /* The first pass through "if" */
}
/* Get here if we managed to jump out of exit(), or did not run atexit. */
longjmp_at_exit = 0; /* Maybe exit() is called again? */
#if 0 /* _atexit_n is not exported */
if (flags & FORCE_EMX_DEINIT_RUN_ATEXIT)
_atexit_n = 0; /* Remove the atexit() handlers */
#endif
/* Will segfault on program termination if we leave this dangling... */
if (p && !emx_exception_init)
DosUnsetExceptionHandler((EXCEPTIONREGISTRATIONRECORD *)p);
/* Typically there is no need to do this, done from _DLL_InitTerm() */
if (flags & FORCE_EMX_DEINIT_CRT_TERM)
_CRT_term(); /* Flush buffers, etc. */
/* Now it is a good time to call exit() in the caller's CRTL... */
}
#include <emx/startup.h>
extern ULONG __os_version(); /* See system.doc */
void
check_emx_runtime(char **env, EXCEPTIONREGISTRATIONRECORD *preg)
{
ULONG v_crt, v_emx, count = 0, rc = NO_ERROR, rc1, maybe_inited = 0;
static HMTX hmtx_emx_init = NULLHANDLE;
static int emx_init_done = 0;
/* If _environ is not set, this code sits in a DLL which
uses a CRT DLL which not compatible with the executable's
CRT library. Some parts of the DLL are not initialized.
*/
if (_environ != NULL)
return; /* Properly initialized */
/* It is not DOS, so we may use OS/2 API now */
/* Some data we manipulate is static; protect ourselves from
calling the same API from a different thread. */
DosEnterMustComplete(&count);
rc1 = DosEnterCritSec();
if (!hmtx_emx_init)
rc = DosCreateMutexSem(NULL, &hmtx_emx_init, 0, TRUE); /*Create owned*/
else
maybe_inited = 1;
if (rc != NO_ERROR)
hmtx_emx_init = NULLHANDLE;
if (rc1 == NO_ERROR)
DosExitCritSec();
DosExitMustComplete(&count);
while (maybe_inited) { /* Other thread did or is doing the same now */
if (emx_init_done)
return;
rc = DosRequestMutexSem(hmtx_emx_init,
(ULONG) SEM_INDEFINITE_WAIT); /* Timeout (none) */
if (rc == ERROR_INTERRUPT)
continue;
if (rc != NO_ERROR) {
char buf[80];
ULONG out;
sprintf(buf,
"panic: EMX backdoor init: DosRequestMutexSem error: %lu=%#lx\n", rc, rc);
DosWrite(2, buf, strlen(buf), &out);
return;
}
DosReleaseMutexSem(hmtx_emx_init);
return;
}
/* If the executable does not use EMX.DLL, EMX.DLL is not completely
initialized either. Uninitialized EMX.DLL returns 0 in the low
nibble of __os_version(). */
v_emx = my_os_version();
/* _osmajor and _osminor are normally set in _DLL_InitTerm of CRT DLL
(=>_CRT_init=>_entry2) via a call to __os_version(), then
reset when the EXE initialization code calls _text=>_init=>_entry2.
The first time they are wrongly set to 0; the second time the
EXE initialization code had already called emx_init=>initialize1
which correctly set version_major, version_minor used by
__os_version(). */
v_crt = (_osmajor | _osminor);
if ((_emx_env & 0x200) && !(v_emx & 0xFFFF)) { /* OS/2, EMX uninit. */
force_init_emx_runtime( preg,
FORCE_EMX_INIT_CONTRACT_ARGV
| FORCE_EMX_INIT_INSTALL_ATEXIT );
emx_wasnt_initialized = 1;
/* Update CRTL data basing on now-valid EMX runtime data */
if (!v_crt) { /* The only wrong data are the versions. */
v_emx = my_os_version(); /* *Now* it works */
*(unsigned char *)&_osmajor = v_emx & 0xFF; /* Cast out const */
*(unsigned char *)&_osminor = (v_emx>>8) & 0xFF;
}
}
emx_runtime_secondary = 1;
/* if (flags & FORCE_EMX_INIT_INSTALL_ATEXIT) */
atexit(jmp_out_of_atexit); /* Allow run of atexit() w/o exit() */
if (env == NULL) { /* Fetch from the process info block */
int c = 0;
PPIB pib;
PTIB tib;
char *e, **ep;
DosGetInfoBlocks(&tib, &pib);
e = pib->pib_pchenv;
while (*e) { /* Get count */
c++;
e = e + strlen(e) + 1;
}
Newx(env, c + 1, char*);
ep = env;
e = pib->pib_pchenv;
while (c--) {
*ep++ = e;
e = e + strlen(e) + 1;
}
*ep = NULL;
}
_environ = _org_environ = env;
emx_init_done = 1;
if (hmtx_emx_init)
DosReleaseMutexSem(hmtx_emx_init);
}
#define ENTRY_POINT 0x10000
static int
exe_is_aout(void)
{
struct layout_table_t *layout;
if (emx_wasnt_initialized)
return 0;
/* Now we know that the principal executable is an EMX application
- unless somebody did already play with delayed initialization... */
/* With EMX applications to determine whether it is AOUT one needs
to examine the start of the executable to find "layout" */
if ( *(unsigned char*)ENTRY_POINT != 0x68 /* PUSH n */
|| *(unsigned char*)(ENTRY_POINT+5) != 0xe8 /* CALL */
|| *(unsigned char*)(ENTRY_POINT+10) != 0xeb /* JMP */
|| *(unsigned char*)(ENTRY_POINT+12) != 0xe8) /* CALL */
return 0; /* ! EMX executable */
/* Fix alignment */
Copy((char*)(ENTRY_POINT+1), &layout, 1, struct layout_table_t*);
return !(layout->flags & 2);
}
void
Perl_OS2_init(char **env)
{
Perl_OS2_init3(env, 0, 0);
}
void
Perl_OS2_init3(char **env, void **preg, int flags)
{
char *shell, *s;
ULONG rc;
_uflags (_UF_SBRK_MODEL, _UF_SBRK_ARBITRARY);
MALLOC_INIT;
check_emx_runtime(env, (EXCEPTIONREGISTRATIONRECORD *)preg);
settmppath();
OS2_Perl_data.xs_init = &Xs_OS2_init;
if (perl_sh_installed) {
int l = strlen(perl_sh_installed);
Newx(PL_sh_path, l + 1, char);
memcpy(PL_sh_path, perl_sh_installed, l + 1);
} else if ( (shell = getenv("PERL_SH_DRIVE")) ) {
Newx(PL_sh_path, strlen(SH_PATH) + 1, char);
strcpy(PL_sh_path, SH_PATH);
PL_sh_path[0] = shell[0];
} else if ( (shell = getenv("PERL_SH_DIR")) ) {
int l = strlen(shell), i;
while (l && (shell[l-1] == '/' || shell[l-1] == '\\'))
l--;
Newx(PL_sh_path, l + 8, char);
strncpy(PL_sh_path, shell, l);
strcpy(PL_sh_path + l, "/sh.exe");
for (i = 0; i < l; i++) {
if (PL_sh_path[i] == '\\') PL_sh_path[i] = '/';
}
}
#if defined(USE_5005THREADS) || defined(USE_ITHREADS)
MUTEX_INIT(&start_thread_mutex);
MUTEX_INIT(&perlos2_state_mutex);
#endif
os2_mytype = my_type(); /* Do it before morphing. Needed? */
os2_mytype_ini = os2_mytype;
Perl_os2_initial_mode = -1; /* Uninit */
s = getenv("PERL_BEGINLIBPATH");
if (s)
rc = fill_extLibpath(0, s, NULL, 1, "PERL_BEGINLIBPATH");
else
rc = fill_extLibpath(0, getenv("PERL_PRE_BEGINLIBPATH"), getenv("PERL_POST_BEGINLIBPATH"), 0, "PERL_(PRE/POST)_BEGINLIBPATH");
if (!rc) {
s = getenv("PERL_ENDLIBPATH");
if (s)
rc = fill_extLibpath(1, s, NULL, 1, "PERL_ENDLIBPATH");
else
rc = fill_extLibpath(1, getenv("PERL_PRE_ENDLIBPATH"), getenv("PERL_POST_ENDLIBPATH"), 0, "PERL_(PRE/POST)_ENDLIBPATH");
}
if (rc) {
char buf[1024];
snprintf(buf, sizeof buf, "Error setting BEGIN/ENDLIBPATH: %s\n",
os2error(rc));
DosWrite(2, buf, strlen(buf), &rc);
exit(2);
}
_emxload_env("PERL_EMXLOAD_SECS");
/* Some DLLs reset FP flags on load. We may have been linked with them */
_control87(MCW_EM, MCW_EM);
}
int
fd_ok(int fd)
{
static ULONG max_fh = 0;
if (!(_emx_env & 0x200)) return 1; /* not OS/2. */
if (fd >= max_fh) { /* Renew */
LONG delta = 0;
if (DosSetRelMaxFH(&delta, &max_fh)) /* Assume it OK??? */
return 1;
}
return fd < max_fh;
}
/* Kernels up to Oct 2003 trap on (invalid) dup(max_fh); [off-by-one + double fault]. */
int
dup2(int from, int to)
{
if (fd_ok(from < to ? to : from))
return _dup2(from, to);
errno = EBADF;
return -1;
}
int
dup(int from)
{
if (fd_ok(from))
return _dup(from);
errno = EBADF;
return -1;
}
#undef tmpnam
#undef tmpfile
char *
my_tmpnam (char *str)
{
char *p = getenv("TMP"), *tpath;
if (!p) p = getenv("TEMP");
tpath = tempnam(p, "pltmp");
if (str && tpath) {
strcpy(str, tpath);
return str;
}
return tpath;
}
FILE *
my_tmpfile ()
{
struct stat s;
stat(".", &s);
if (s.st_mode & S_IWOTH) {
return tmpfile();
}
return fopen(my_tmpnam(NULL), "w+b"); /* Race condition, but
grants TMP. */
}
#undef rmdir
/* EMX flavors do not tolerate trailing slashes. t/op/mkdir.t has many
trailing slashes, so we need to support this as well. */
int
my_rmdir (__const__ char *s)
{
char b[MAXPATHLEN];
char *buf = b;
STRLEN l = strlen(s);
int rc;
if (s[l-1] == '/' || s[l-1] == '\\') { /* EMX mkdir fails... */
if (l >= sizeof b)
Newx(buf, l + 1, char);
strcpy(buf,s);
while (l > 1 && (s[l-1] == '/' || s[l-1] == '\\'))
l--;
buf[l] = 0;
s = buf;
}
rc = rmdir(s);
if (b != buf)
Safefree(buf);
return rc;
}
#undef mkdir
int
my_mkdir (__const__ char *s, long perm)
{
char b[MAXPATHLEN];
char *buf = b;
STRLEN l = strlen(s);
int rc;
if (s[l-1] == '/' || s[l-1] == '\\') { /* EMX mkdir fails... */
if (l >= sizeof b)
Newx(buf, l + 1, char);
strcpy(buf,s);
while (l > 1 && (s[l-1] == '/' || s[l-1] == '\\'))
l--;
buf[l] = 0;
s = buf;
}
rc = mkdir(s, perm);
if (b != buf)
Safefree(buf);
return rc;
}
#undef flock
/* This code was contributed by Rocco Caputo. */
int
my_flock(int handle, int o)
{
FILELOCK rNull, rFull;
ULONG timeout, handle_type, flag_word;
APIRET rc;
int blocking, shared;
static int use_my_flock = -1;
if (use_my_flock == -1) {
MUTEX_LOCK(&perlos2_state_mutex);
if (use_my_flock == -1) {
char *s = getenv("USE_PERL_FLOCK");
if (s)
use_my_flock = atoi(s);
else
use_my_flock = 1;
}
MUTEX_UNLOCK(&perlos2_state_mutex);
}
if (!(_emx_env & 0x200) || !use_my_flock)
return flock(handle, o); /* Delegate to EMX. */
/* is this a file? */
if ((DosQueryHType(handle, &handle_type, &flag_word) != 0) ||
(handle_type & 0xFF))
{
errno = EBADF;
return -1;
}
/* set lock/unlock ranges */
rNull.lOffset = rNull.lRange = rFull.lOffset = 0;
rFull.lRange = 0x7FFFFFFF;
/* set timeout for blocking */
timeout = ((blocking = !(o & LOCK_NB))) ? 100 : 1;
/* shared or exclusive? */
shared = (o & LOCK_SH) ? 1 : 0;
/* do not block the unlock */
if (o & (LOCK_UN | LOCK_SH | LOCK_EX)) {
rc = DosSetFileLocks(handle, &rFull, &rNull, timeout, shared);
switch (rc) {
case 0:
errno = 0;
return 0;
case ERROR_INVALID_HANDLE:
errno = EBADF;
return -1;
case ERROR_SHARING_BUFFER_EXCEEDED:
errno = ENOLCK;
return -1;
case ERROR_LOCK_VIOLATION:
break; /* not an error */
case ERROR_INVALID_PARAMETER:
case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
case ERROR_READ_LOCKS_NOT_SUPPORTED:
errno = EINVAL;
return -1;
case ERROR_INTERRUPT:
errno = EINTR;
return -1;
default:
errno = EINVAL;
return -1;
}
}
/* lock may block */
if (o & (LOCK_SH | LOCK_EX)) {
/* for blocking operations */
for (;;) {
rc =
DosSetFileLocks(
handle,
&rNull,
&rFull,
timeout,
shared
);
switch (rc) {
case 0:
errno = 0;
return 0;
case ERROR_INVALID_HANDLE:
errno = EBADF;
return -1;
case ERROR_SHARING_BUFFER_EXCEEDED:
errno = ENOLCK;
return -1;
case ERROR_LOCK_VIOLATION:
if (!blocking) {
errno = EWOULDBLOCK;
return -1;
}
break;
case ERROR_INVALID_PARAMETER:
case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
case ERROR_READ_LOCKS_NOT_SUPPORTED:
errno = EINVAL;
return -1;
case ERROR_INTERRUPT:
errno = EINTR;
return -1;
default:
errno = EINVAL;
return -1;
}
/* give away timeslice */
DosSleep(1);
}
}
errno = 0;
return 0;
}
static int
use_my_pwent(void)
{
if (_my_pwent == -1) {
char *s = getenv("USE_PERL_PWENT");
if (s)
_my_pwent = atoi(s);
else
_my_pwent = 1;
}
return _my_pwent;
}
#undef setpwent
#undef getpwent
#undef endpwent
void
my_setpwent(void)
{
if (!use_my_pwent()) {
setpwent(); /* Delegate to EMX. */
return;
}
pwent_cnt = 0;
}
void
my_endpwent(void)
{
if (!use_my_pwent()) {
endpwent(); /* Delegate to EMX. */
return;
}
}
struct passwd *
my_getpwent (void)
{
if (!use_my_pwent())
return getpwent(); /* Delegate to EMX. */
if (pwent_cnt++)
return 0; /* Return one entry only */
return getpwuid(0);
}
void
setgrent(void)
{
grent_cnt = 0;
}
void
endgrent(void)
{
}
struct group *
getgrent (void)
{
if (grent_cnt++)
return 0; /* Return one entry only */
return getgrgid(0);
}
#undef getpwuid
#undef getpwnam
/* Too long to be a crypt() of anything, so it is not-a-valid pw_passwd. */
static const char pw_p[] = "Jf0Wb/BzMFvk7K7lrzK";
static struct passwd *
passw_wrap(struct passwd *p)
{
char *s;
if (!p || (p->pw_passwd && *p->pw_passwd)) /* Not a dangerous password */
return p;
pw = *p;
s = getenv("PW_PASSWD");
if (!s)
s = (char*)pw_p; /* Make match impossible */
pw.pw_passwd = s;
return &pw;
}
struct passwd *
my_getpwuid (uid_t id)
{
return passw_wrap(getpwuid(id));
}
struct passwd *
my_getpwnam (__const__ char *n)
{
return passw_wrap(getpwnam(n));
}
char *
gcvt_os2 (double value, int digits, char *buffer)
{
double absv = value > 0 ? value : -value;
/* EMX implementation is lousy between 0.1 and 0.0001 (uses exponents below
0.1), 1-digit stuff is ok below 0.001; multi-digit below 0.0001. */
int buggy;
absv *= 10000;
buggy = (absv < 1000 && (absv >= 10 || (absv > 1 && floor(absv) != absv)));
if (buggy) {
char pat[12];
sprintf(pat, "%%.%dg", digits);
sprintf(buffer, pat, value);
return buffer;
}
return gcvt (value, digits, buffer);
}
#undef fork
int fork_with_resources()
{
#if (defined(USE_5005THREADS) || defined(USE_ITHREADS)) && !defined(USE_SLOW_THREAD_SPECIFIC)
dTHX;
void *ctx = PERL_GET_CONTEXT;
#endif
unsigned fpflag = _control87(0,0);
int rc = fork();
if (rc == 0) { /* child */
#if (defined(USE_5005THREADS) || defined(USE_ITHREADS)) && !defined(USE_SLOW_THREAD_SPECIFIC)
ALLOC_THREAD_KEY; /* Acquire the thread-local memory */
PERL_SET_CONTEXT(ctx); /* Reinit the thread-local memory */
#endif
{ /* Reload loaded-on-demand DLLs */
struct dll_handle_t *dlls = dll_handles;
while (dlls->modname) {
char dllname[260], fail[260];
ULONG rc;
if (!dlls->handle) { /* Was not loaded */
dlls++;
continue;
}
/* It was loaded in the parent. We need to reload it. */
rc = DosQueryModuleName(dlls->handle, sizeof(dllname), dllname);
if (rc) {
Perl_warn_nocontext("Can't find DLL name for the module `%s' by the handle %d, rc=%lu=%#lx",
dlls->modname, (int)dlls->handle, rc, rc);
dlls++;
continue;
}
rc = DosLoadModule(fail, sizeof fail, dllname, &dlls->handle);
if (rc)
Perl_warn_nocontext("Can't load DLL `%s', possible problematic module `%s'",
dllname, fail);
dlls++;
}
}
{ /* Support message queue etc. */
os2_mytype = my_type();
/* Apparently, subprocesses (in particular, fork()) do not
inherit the morphed state, so os2_mytype is the same as
os2_mytype_ini. */
if (Perl_os2_initial_mode != -1
&& Perl_os2_initial_mode != os2_mytype) {
/* XXXX ??? */
}
}
if (Perl_HAB_set)
(void)_obtain_Perl_HAB;
if (Perl_hmq_refcnt) {
if (my_type() != 3)
my_type_set(3);
Create_HMQ(Perl_hmq_servers != 0,
"Cannot create a message queue on fork");
}
/* We may have loaded some modules */
_control87(fpflag, MCW_EM); /* Some modules reset FP flags on (un)load */
}
return rc;
}
/* APIRET APIENTRY DosGetInfoSeg(PSEL pselGlobal, PSEL pselLocal); */
ULONG _THUNK_FUNCTION(Dos16GetInfoSeg)(USHORT *pGlobal, USHORT *pLocal);
APIRET APIENTRY
myDosGetInfoSeg(PGINFOSEG *pGlobal, PLINFOSEG *pLocal)
{
APIRET rc;
USHORT gSel, lSel; /* Will not cross 64K boundary */
rc = ((USHORT)
(_THUNK_PROLOG (4+4);
_THUNK_FLAT (&gSel);
_THUNK_FLAT (&lSel);
_THUNK_CALL (Dos16GetInfoSeg)));
if (rc)
return rc;
*pGlobal = MAKEPGINFOSEG(gSel);
*pLocal = MAKEPLINFOSEG(lSel);
return rc;
}
static void
GetInfoTables(void)
{
ULONG rc = 0;
MUTEX_LOCK(&perlos2_state_mutex);
if (!gTable)
rc = myDosGetInfoSeg(&gTable, &lTable);
MUTEX_UNLOCK(&perlos2_state_mutex);
os2cp_croak(rc, "Dos16GetInfoSeg");
}
ULONG
msCounter(void)
{ /* XXXX Is not lTable thread-specific? */
if (!gTable)
GetInfoTables();
return gTable->SIS_MsCount;
}
ULONG
InfoTable(int local)
{
if (!gTable)
GetInfoTables();
return local ? (ULONG)lTable : (ULONG)gTable;
}