#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>
#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"
-#ifdef USE_THREADS
+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 *);
pthreads_st_exited,
pthreads_st_detached,
pthreads_st_waited,
+ pthreads_st_norun,
+ pthreads_st_exited_waited,
};
-const char *pthreads_states[] = {
+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;
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_none; /* Ready to reuse */
- MUTEX_UNLOCK(&start_thread_mutex);
+ 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);
- croak("join with a thread with a waiter");
+ 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);
- COND_WAIT(&thread_join_data[tid].cond, NULL);
- COND_DESTROY(&thread_join_data[tid].cond);
- thread_join_data[tid].state = pthreads_st_none; /* Ready to reuse */
- *status = thread_join_data[tid].status;
break;
+ }
default:
MUTEX_UNLOCK(&start_thread_mutex);
- croak("join: unknown thread state: '%s'",
- pthreads_states[thread_join_data[tid].state]);
+ 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 *arg)
+pthread_startit(void *arg1)
{
/* Thread is already started, we need to transfer control only */
- pthreads_startroutine start_routine = *((pthreads_startroutine*)arg);
+ pthr_startit args = *(pthr_startit *)arg1;
int tid = pthread_self();
- void *retval;
-
- arg = ((void**)arg)[1];
+ 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;
Renew(thread_join_data, thread_join_count, thread_join_t);
Zero(thread_join_data + oc, thread_join_count - oc, thread_join_t);
} else {
- Newz(1323, thread_join_data, thread_join_count, thread_join_t);
+ Newxz(thread_join_data, thread_join_count, thread_join_t);
}
}
- if (thread_join_data[tid].state != pthreads_st_none)
- croak("attempt to reuse thread id %i", tid);
+ 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);
- thread_join_data[tid].status = (*start_routine)(arg);
+ 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);
+ COND_SIGNAL(&thread_join_data[tid].cond);
+ thread_join_data[tid].state = pthreads_st_none;
+ *((void**)thread_join_data[tid].status) = rc;
break;
- default:
+ 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 *tid, const pthread_attr_t *attr,
+pthread_create(perl_os_thread *tidp, const pthread_attr_t *attr,
void *(*start_routine)(void*), void *arg)
{
- void *args[2];
+ dTHX;
+ pthr_startit args;
- args[0] = (void*)start_routine;
- args[1] = arg;
+ args.sub = (void*)start_routine;
+ args.arg = arg;
+ args.ctx = PERL_GET_CONTEXT;
MUTEX_LOCK(&start_thread_mutex);
- *tid = _beginthread(pthread_startit, /*stack*/ NULL,
- /*stacksize*/ 10*1024*1024, (void*)args);
- 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 *tid ? 0 : EINVAL;
+ 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);
- croak("detach on a thread with a waiter");
+ 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);
- croak("detach: unknown thread state: '%s'",
- pthreads_states[thread_join_data[tid].state]);
+ 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: */
+/* 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))
- croak("panic: COND_WAIT-reset: rc=%i", rc);
+ Perl_rc = rc, croak_with_os2error("panic: COND_WAIT-reset");
if (m) MUTEX_UNLOCK(m);
if (CheckOSError(DosWaitEventSem(*c,SEM_INDEFINITE_WAIT))
&& (rc != ERROR_INTERRUPT))
- croak("panic: COND_WAIT: rc=%i", rc);
+ croak_with_os2error("panic: COND_WAIT");
if (rc == ERROR_INTERRUPT)
errno = EINTR;
- if (m) MUTEX_LOCK(m);
+ if (m) MUTEX_LOCK(m);
+ return 0;
}
-#endif
+#endif
-/*****************************************************************************/
-/* 2.1 would not resolve symbols on demand, and has no ExtLIBPATH. */
-static PFN ExtFCN[2]; /* Labeled by ord below. */
-static USHORT loadOrd[2] = { 874, 873 }; /* Query=874, Set=873. */
-#define ORD_QUERY_ELP 0
-#define ORD_SET_ELP 1
-struct PMWIN_entries_t PMWIN_entries;
+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},
+};
-APIRET
-loadByOrd(char *modname, ULONG ord)
+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) {
- static HMODULE hdosc = 0;
- BYTE buf[20];
- PFN fcn;
+ PFN fcn = (PFN)-1;
APIRET rc;
- if ((!hdosc && CheckOSError(DosLoadModule(buf, sizeof buf,
- modname, &hdosc)))
- || CheckOSError(DosQueryProcAddr(hdosc, loadOrd[ord], NULL, &fcn)))
- croak("This version of OS/2 does not support %s.%i",
- modname, loadOrd[ord]);
+ 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)
- croak("panic queryaddr");
+ if ((long)ExtFCN[ord] == -1)
+ Perl_croak_nocontext("panic queryaddr");
+ return ExtFCN[ord];
}
void
init_PMWIN_entries(void)
{
- static HMODULE hpmwin = 0;
- static const int ords[] = {
- 763, /* Initialize */
- 716, /* CreateMsgQueue */
- 726, /* DestroyMsgQueue */
- 918, /* PeekMsg */
- 915, /* GetMsg */
- 912, /* DispatchMsg */
- };
- BYTE buf[20];
- int i = 0;
- unsigned long rc;
-
- if (hpmwin)
- return;
+ int i;
- if (CheckOSError(DosLoadModule(buf, sizeof buf, "pmwin", &hpmwin)))
- croak("This version of OS/2 does not support pmwin: error in %s", buf);
- while (i <= 5) {
- if (CheckOSError(DosQueryProcAddr(hpmwin, ords[i], NULL,
- ((PFN*)&PMWIN_entries)+i)))
- croak("This version of OS/2 does not support pmwin.%d", ords[i]);
- 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 signed char priors[] = {0, 1, 3, 2}; /* Last two interchanged,
- self inverse. */
+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;
- New(1322, pbuffer, buf_len, char);
+ 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) {
Safefree(pbuffer);
return 0;
}
- return (PQTOPLEVEL)pbuffer;
+ 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
ULONG prio;
PQTOPLEVEL psi;
+ if (!pid)
+ return PRIO_ERR;
psi = get_sysinfo(pid, QSS_PROCESS);
- if (!psi) {
+ if (!psi)
return PRIO_ERR;
- }
- if (pid != psi->procdata->pid) {
- Safefree(psi);
- croak("panic: wrong pid in sysinfo");
- }
prio = psi->procdata->threads->priority;
Safefree(psi);
return prio;
int
setpriority(int which, int pid, int val)
{
- ULONG rc, prio;
- PQTOPLEVEL psi;
-
- prio = sys_prio(pid);
+ 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)) {
abs(pid)))
? -1 : 0;
}
-/* else return CheckOSError(DosSetPriority((pid < 0) */
-/* ? PRTYS_PROCESSTREE : PRTYS_PROCESS, */
-/* priors[(32 - val) >> 5] + 1, */
-/* (32 - val) % 32 - (prio & 0xFF), */
-/* abs(pid))) */
-/* ? -1 : 0; */
}
int
getpriority(int which /* ignored */, int pid)
{
- TIB *tib;
- PIB *pib;
- ULONG rc, ret;
+ ULONG ret;
if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
- /* DosGetInfoBlocks has old priority! */
-/* if (CheckOSError(DosGetInfoBlocks(&tib, &pib))) return -1; */
-/* if (pid != pib->pib_ulpid) { */
ret = sys_prio(pid);
if (ret == PRIO_ERR) {
return -1;
}
-/* } else */
-/* ret = tib->tib_ptib2->tib2_ulpri; */
return (1 - priors[((ret >> 8) - 1)])*32 - (ret & 0xFF);
}
/*****************************************************************************/
/* spawn */
-/* 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? */
-static int spawn_pid;
-static int spawn_killed;
+
static Signal_t
spawn_sighandler(int sig)
}
static int
-result(int flag, int pid)
+result(pTHX_ int flag, int pid)
{
int r, status;
Signal_t (*ihand)(); /* place to save signal during system() */
#endif
}
-#define EXECF_SPAWN 0
-#define EXECF_EXEC 1
-#define EXECF_TRUEEXEC 2
-#define EXECF_SPAWN_NOWAIT 3
-#define EXECF_SPAWN_BYFLAG 4
-
-/* 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);
-}
+enum execf_t {
+ EXECF_SPAWN,
+ EXECF_EXEC,
+ EXECF_TRUEEXEC,
+ EXECF_SPAWN_NOWAIT,
+ EXECF_SPAWN_BYFLAG,
+ EXECF_SYNC
+};
static ULONG
file_type(char *path)
ULONG apptype;
if (!(_emx_env & 0x200))
- croak("file_type not implemented on DOS"); /* not OS/2. */
+ Perl_croak_nocontext("file_type not implemented on DOS"); /* not OS/2. */
if (CheckOSError(DosQueryAppType(path, &apptype))) {
switch (rc) {
case ERROR_FILE_NOT_FOUND:
return apptype;
}
-static ULONG os2_mytype;
-
/* 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(really, flag, execf, inicmd, addflag)
-SV *really;
-U32 flag;
-U32 execf;
-char *inicmd;
-U32 addflag;
-{
- dTHR;
+do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag)
+{
int trueflag = flag;
int rc, pass = 1;
- char *tmps;
- char buf[256], *s = 0, scrbuf[280];
- char *args[4];
- static char * fargs[4]
+ char *real_name = NULL; /* Shut down the warning */
+ char const * args[4];
+ static const char * const fargs[4]
= { "/bin/sh", "-c", "\"$@\"", "spawn-via-shell", };
- char **argsp = fargs;
- char nargs = 4;
+ const char * const *argsp = fargs;
+ int nargs = 4;
int force_shell;
- int new_stderr = -1, nostderr = 0, fl_stderr;
+ 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;
- if (PL_Argv[0][0] != '/' && PL_Argv[0][0] != '\\'
- && !(PL_Argv[0][0] && PL_Argv[0][1] == ':'
- && (PL_Argv[0][2] == '/' || PL_Argv[0][2] != '\\'))
+ /* 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 */
- /* We should check PERL_SH* and PERLLIB_* as well? */
- if (!really || !*(tmps = SvPV(really, n_a)))
- tmps = PL_Argv[0];
reread:
force_shell = 0;
if (_emx_env & 0x200) { /* OS/2. */
- int type = file_type(tmps);
+ int type = file_type(real_name);
type_again:
if (type == -1) { /* Not found */
errno = ENOENT;
else if (type == -3) { /* Is a directory? */
/* Special-case this */
char tbuf[512];
- int l = strlen(tmps);
+ int l = strlen(real_name);
if (l + 5 <= sizeof tbuf) {
- strcpy(tbuf, tmps);
+ strcpy(tbuf, real_name);
strcpy(tbuf + l, ".exe");
type = file_type(tbuf);
if (type >= -3)
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)
- warn("Starting PM process with flag=%d, mytype=%d",
+ 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);
}
}
if (os2_mytype != 0) { /* not full screen */
if (flag == P_NOWAIT)
flag = P_SESSION;
- else if ((flag & 7) != P_SESSION)
- warn("Starting Full Screen process with flag=%d, mytype=%d",
+ 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);
}
}
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 0
- rc = result(trueflag, spawnvp(flag,tmps,PL_Argv));
+ rc = result(aTHX_ trueflag, spawnvp(flag,real_name,PL_Argv));
#else
if (execf == EXECF_TRUEEXEC)
- rc = execvp(tmps,PL_Argv);
+ rc = execvp(real_name,PL_Argv);
else if (execf == EXECF_EXEC)
- rc = spawnvp(trueflag | P_OVERLAY,tmps,PL_Argv);
+ rc = spawnvp(trueflag | P_OVERLAY,real_name,PL_Argv);
else if (execf == EXECF_SPAWN_NOWAIT)
- rc = spawnvp(flag,tmps,PL_Argv);
+ 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(trueflag,
- spawnvp(flag,tmps,PL_Argv));
+ rc = result(aTHX_ trueflag,
+ spawnvp(flag,real_name,PL_Argv));
#endif
- if (rc < 0 && pass == 1
- && (tmps == PL_Argv[0])) { /* Cannot transfer `really' via shell. */
+ if (rc < 0 && pass == 1) {
do_script:
- {
+ if (real_name == PL_Argv[0]) {
int err = errno;
if (err == ENOENT || err == ENOEXEC) {
char *scr = find_script(PL_Argv[0], TRUE, NULL, 0);
if (scr) {
- FILE *file;
char *s = 0, *s1;
- int l;
+ SV *scrsv = sv_2mortal(newSVpv(scr, 0));
+ SV *bufsv = sv_newmortal();
- l = strlen(scr);
-
- if (l >= sizeof scrbuf) {
- Safefree(scr);
- longbuf:
- warn("Size of scriptname too big: %d", l);
- rc = -1;
- goto finish;
- }
- strcpy(scrbuf, scr);
Safefree(scr);
- scr = scrbuf;
+ scr = SvPV(scrsv, n_a); /* free()ed later */
- file = fopen(scr, "r");
+ file = PerlIO_open(scr, "r");
PL_Argv[0] = scr;
if (!file)
goto panic_file;
- if (!fgets(buf, sizeof buf, file)) { /* Empty... */
- buf[0] = 0;
- fclose(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). */
- if (l + 5 < sizeof scrbuf) {
- strcpy(scrbuf + l, ".exe");
- if (PerlLIO_stat(scrbuf,&PL_statbuf) >= 0
- && !S_ISDIR(PL_statbuf.st_mode)) {
- /* Found */
- tmps = scr;
+ 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
- scrbuf[l] = 0;
- } else
- goto longbuf;
+ } else { /* Restore */
+ SvCUR_set(scrsv, SvCUR(scrsv) - 4);
+ *SvEND(scrsv) = 0;
+ }
}
- if (fclose(file) != 0) { /* Failure */
+ if (PerlIO_close(file) != 0) { /* Failure */
panic_file:
- warn("Error reading \"%s\": %s",
+ if (ckWARN(WARN_EXEC))
+ Perl_warner(aTHX_ packWARN(WARN_EXEC), "Error reading \"%s\": %s",
scr, Strerror(errno));
- buf[0] = 0; /* Not #! */
+ buf = ""; /* Not #! */
goto doshell_args;
}
if (buf[0] == '#') {
s = buf + 8;
}
if (!s) {
- buf[0] = 0; /* Not #! */
+ buf = ""; /* Not #! */
goto doshell_args;
}
*s++ = 0;
}
if (nargs == -1) {
- warn("Too many args on %.*s line of \"%s\"",
+ 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;
- char *exec_args[2];
+ const char *exec_args[2];
if (force_shell
|| (!buf[0] && file)) { /* File without magic */
if (inicmd) { /* No spaces at start! */
s = inicmd;
while (*s && !isSPACE(*s)) {
- if (*s++ = '/') {
+ if (*s++ == '/') {
inicmd = NULL; /* Cannot use */
break;
}
long enough. */
a--;
}
- while (nargs-- >= 0)
- PL_Argv[nargs] = argsp[nargs];
+ 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], '/');
}
}
if (rc < 0 && ckWARN(WARN_EXEC))
- Perl_warner(aTHX_ WARN_EXEC, "Can't %s \"%s\": %s\n",
+ Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s\n",
((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC)
? "spawn" : "exec"),
- PL_Argv[0], Strerror(errno));
+ real_name, Strerror(errno));
+ warned:
if (rc < 0 && (execf != EXECF_SPAWN_NOWAIT)
&& ((trueflag & 0xFF) == P_WAIT))
- rc = 255 << 8; /* Emulate the fork(). */
+ rc = -1;
finish:
if (new_stderr != -1) { /* How can we use error codes? */
/* Try converting 1-arg form to (usually shell-less) multi-arg form. */
int
-do_spawn3(char *cmd, int execf, int flag)
+do_spawn3(pTHX_ char *cmd, int execf, int flag)
{
register char **a;
register char *s;
- char flags[10];
char *shell, *copt, *news = NULL;
- int rc, err, seenspace = 0, mergestderr = 0;
- char fullcmd[MAXNAMLEN + 1];
+ int rc, seenspace = 0, mergestderr = 0;
#ifdef TRYSHELL
if ((shell = getenv("EMXSHELL")) != NULL)
if (strnEQ(cmd,"/bin/sh",7) && isSPACE(cmd[7])) {
STRLEN l = strlen(PL_sh_path);
- New(1302, news, strlen(cmd) - 7 + l + 1, char);
+ Newx(news, strlen(cmd) - 7 + l + 1, char);
strcpy(news, PL_sh_path);
strcpy(news + l, cmd + 7);
cmd = news;
should be smart enough to start itself gloriously. */
doshell:
if (execf == EXECF_TRUEEXEC)
- rc = execl(shell,shell,copt,cmd,(char*)0);
+ 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(flag,shell,shell,copt,cmd,(char*)0);
else {
/* In the ak code internal P_NOWAIT is P_WAIT ??? */
- rc = result(P_WAIT,
- spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0));
+ 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_ WARN_EXEC, "Can't %s \"%s\": %s",
+ Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s",
(execf == EXECF_SPAWN ? "spawn" : "exec"),
shell, Strerror(errno));
- if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */
+ if (rc < 0)
+ rc = -1;
}
if (news)
Safefree(news);
}
/* cmd="a" may lead to "sh", "-c", "\"$@\"", "a", "a.cmd", NULL */
- New(1303,PL_Argv, (s - cmd + 11) / 2, char*);
+ Newx(PL_Argv, (s - cmd + 11) / 2, char*);
PL_Cmd = savepvn(cmd, s-cmd);
a = PL_Argv;
for (s = PL_Cmd; *s;) {
}
*a = Nullch;
if (PL_Argv[0])
- rc = do_spawn_ve(NULL, flag, execf, cmd, mergestderr);
+ rc = do_spawn_ve(aTHX_ NULL, flag, execf, cmd, mergestderr);
else
rc = -1;
if (news)
return rc;
}
-/* Array spawn. */
+/* Array spawn/exec. */
int
-do_aspawn(really,mark,sp)
-SV *really;
-register SV **mark;
-register SV **sp;
+os2_aspawn4(pTHX_ SV *really, register SV **vmark, register SV **vsp, int execing)
{
- dTHR;
+ register SV **mark = (SV **)vmark;
+ register SV **sp = (SV **)vsp;
register char **a;
int rc;
int flag = P_WAIT, flag_set = 0;
STRLEN n_a;
if (sp > mark) {
- New(1301,PL_Argv, sp - mark + 3, char*);
+ Newx(PL_Argv, sp - mark + 3, char*);
a = PL_Argv;
if (mark < sp && SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
}
*a = Nullch;
- if (flag_set && (a == PL_Argv + 1)) { /* One arg? */
- rc = do_spawn3(a[-1], EXECF_SPAWN_BYFLAG, flag);
+ if ( flag_set && (a == PL_Argv + 1)
+ && !really && !execing ) { /* One arg? */
+ rc = do_spawn3(aTHX_ a[-1], EXECF_SPAWN_BYFLAG, flag);
} else
- rc = do_spawn_ve(really, flag, EXECF_SPAWN, NULL, 0);
+ rc = do_spawn_ve(aTHX_ really, flag,
+ (execing ? EXECF_EXEC : EXECF_SPAWN), 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_aspawn4(aTHX_ really, vmark, vsp, 0);
+}
+
+/* Array exec. */
+bool
+Perl_do_aexec(pTHX_ SV* really, SV** vmark, SV** vsp)
+{
+ return os2_aspawn4(aTHX_ really, vmark, vsp, 1);
+}
+
int
-do_spawn(cmd)
-char *cmd;
+os2_do_spawn(pTHX_ char *cmd)
{
- return do_spawn3(cmd, EXECF_SPAWN, 0);
+ return do_spawn3(aTHX_ cmd, EXECF_SPAWN, 0);
}
int
-do_spawn_nowait(cmd)
-char *cmd;
+do_spawn_nowait(pTHX_ char *cmd)
{
- return do_spawn3(cmd, EXECF_SPAWN_NOWAIT,0);
+ return do_spawn3(aTHX_ cmd, EXECF_SPAWN_NOWAIT,0);
}
bool
-do_exec(cmd)
-char *cmd;
+Perl_do_exec(pTHX_ const char *cmd)
{
- do_spawn3(cmd, EXECF_EXEC, 0);
+ do_spawn3(aTHX_ cmd, EXECF_EXEC, 0);
return FALSE;
}
bool
-os2exec(cmd)
-char *cmd;
+os2exec(pTHX_ char *cmd)
{
- return do_spawn3(cmd, EXECF_TRUEEXEC, 0);
+ return do_spawn3(aTHX_ cmd, EXECF_TRUEEXEC, 0);
}
PerlIO *
-my_syspopen(cmd,mode)
-char *cmd;
-char *mode;
+my_syspopen(pTHX_ char *cmd, char *mode)
{
#ifndef USE_POPEN
-
int p[2];
register I32 this, that, newfd;
- register I32 pid, rc;
- PerlIO *res;
+ register I32 pid;
SV *sv;
- int fh_fl;
+ int fh_fl = 0; /* Pacify the warning */
/* `this' is what we use in the parent, `that' in the child. */
this = (*mode == 'w');
fcntl(p[this], F_SETFD, FD_CLOEXEC);
if (newfd != -1)
fcntl(newfd, F_SETFD, FD_CLOEXEC);
- pid = do_spawn_nowait(cmd);
+ 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 */
int
fork(void)
{
- croak(PL_no_func, "Unsupported function fork");
+ Perl_croak_nocontext(PL_no_func, "Unsupported function fork");
errno = EINVAL;
return -1;
}
#endif
/*******************************************************************/
-/* not implemented in EMX 0.9a */
+/* not implemented in EMX 0.9d */
-void * ctermid(x) { return 0; }
+char * ctermid(char *s) { return 0; }
#ifdef MYTTYNAME /* was not in emx0.9a */
void * ttyname(x) { return 0; }
#endif
-/******************************************************************/
-/* my socket forwarders - EMX lib only provides static forwarders */
-
-static HMODULE htcp = 0;
-
-static void *
-tcp0(char *name)
-{
- static BYTE buf[20];
- PFN fcn;
-
- if (!(_emx_env & 0x200)) croak("%s requires OS/2", name); /* Die if not OS/2. */
- if (!htcp)
- DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp);
- if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
- return (void *) ((void * (*)(void)) fcn) ();
- return 0;
-}
-
-static void
-tcp1(char *name, int arg)
-{
- static BYTE buf[20];
- PFN fcn;
-
- if (!(_emx_env & 0x200)) croak("%s requires OS/2", name); /* Die if not OS/2. */
- if (!htcp)
- DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp);
- if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
- ((void (*)(int)) fcn) (arg);
-}
-
-void * gethostent() { return tcp0("GETHOSTENT"); }
-void * getnetent() { return tcp0("GETNETENT"); }
-void * getprotoent() { return tcp0("GETPROTOENT"); }
-void * getservent() { return tcp0("GETSERVENT"); }
-void sethostent(x) { tcp1("SETHOSTENT", x); }
-void setnetent(x) { tcp1("SETNETENT", x); }
-void setprotoent(x) { tcp1("SETPROTOENT", x); }
-void setservent(x) { tcp1("SETSERVENT", x); }
-void endhostent() { tcp0("ENDHOSTENT"); }
-void endnetent() { tcp0("ENDNETENT"); }
-void endprotoent() { tcp0("ENDPROTOENT"); }
-void endservent() { tcp0("ENDSERVENT"); }
-
/*****************************************************************************/
/* not implemented in C Set++ */
#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(char *name, struct stat *st)
+os2_stat(const char *name, struct stat *st)
{
static int ino = SHRT_MAX;
-
- if (stricmp(name, "/dev/con") != 0
- && stricmp(name, "/dev/tty") != 0)
- return stat(name, st);
+ 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
if (rc == ERROR_NOT_ENOUGH_MEMORY) {
return (void *) -1;
} else if ( rc )
- croak("Got an error from DosAllocMem: %li", (long)rc);
+ Perl_croak_nocontext("Got an error from DosAllocMem: %li", (long)rc);
return got;
}
/* tmp path */
-char *tmppath = TMPPATH1;
+const char *tmppath = TMPPATH1;
void
settmppath()
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);
{
dXSARGS;
if (items < 2 || items > 3)
- croak("Usage: File::Copy::syscopy(src,dst,flag=0)");
+ 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;
}
RETVAL = !CheckOSError(DosCopy(src, dst, flag));
- ST(0) = sv_newmortal();
- sv_setiv(ST(0), (IV)RETVAL);
+ XSprePUSH; PUSHi((IV)RETVAL);
}
XSRETURN(1);
}
-#include "patchlevel.h"
+/* APIRET APIENTRY DosReplaceModule (PCSZ pszOld, PCSZ pszNew, PCSZ pszBackup); */
-char *
-mod2fname(sv)
- SV *sv;
-{
- static char fname[9];
- int pos = 6, len, avlen;
- unsigned int sum = 0;
- AV *av;
- SV *svp;
- char *s;
- STRLEN n_a;
+DeclOSFuncByORD(ULONG,replaceModule,ORD_DosReplaceModule,
+ (char *old, char *new, char *backup), (old, new, backup))
- if (!SvROK(sv)) croak("Not a reference given to mod2fname");
- sv = SvRV(sv);
- if (SvTYPE(sv) != SVt_PVAV)
- croak("Not array reference given to mod2fname");
+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_EMPTY;
+}
+
+/* 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");
+ if (total) {
+ int i,j;
+
+ if (GIMME_V != G_ARRAY) {
+ PUSHn(u[0][0]); /* Total ticks on the first processor */
+ XSRETURN(1);
+ }
+ 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)
- croak("Empty array reference given to mod2fname");
+ Perl_croak_nocontext("Empty array reference given to mod2fname");
s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a);
strncpy(fname, s, 8);
}
avlen --;
}
-#ifdef USE_THREADS
- sum++; /* Avoid conflict of DLLs in memory. */
-#endif
- sum += PERL_VERSION * 200 + PERL_SUBVERSION * 2; /* */
+ /* 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';
{
dXSARGS;
if (items != 1)
- croak("Usage: DynaLoader::mod2fname(sv)");
+ Perl_croak_nocontext("Usage: DynaLoader::mod2fname(sv)");
{
SV * sv = ST(0);
char * RETVAL;
+ dXSTARG;
- RETVAL = mod2fname(sv);
- ST(0) = sv_newmortal();
- sv_setpv((SV*)ST(0), RETVAL);
+ RETVAL = mod2fname(aTHX_ sv);
+ sv_setpv(TARG, RETVAL);
+ XSprePUSH; PUSHTARG;
}
XSRETURN(1);
}
char *
os2error(int rc)
{
- static char buf[300];
+ 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;
+ }
+ 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 (DosGetMessage(NULL, 0, buf, sizeof buf - 1, rc, "OSO001.MSG", &len))
- sprintf(buf, "OS/2 system error code %d=0x%x", rc, rc);
+ 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
- buf[len] = '\0';
- if (len > 0 && buf[len - 1] == '\n')
- buf[len - 1] = '\0';
- if (len > 1 && buf[len - 2] == '\r')
- buf[len - 2] = '\0';
- if (len > 2 && buf[len - 3] == '.')
- buf[len - 3] = '\0';
- return buf;
+ 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)
{
- static char *newp, *oldp;
- static int newl, oldl, notfound;
- static char ret[STATIC_FILE_LENGTH+1];
-
+ char *name;
+
+ if (perllib_mangle_installed && (name = perllib_mangle_installed(s,l)))
+ return name;
if (!newp && !notfound) {
- newp = getenv("PERLLIB_PREFIX");
+ 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;
+ char *s, b[300];
oldp = newp;
- while (*newp && !isSPACE(*newp) && *newp != ';') {
- newp++; oldl++; /* Skip digits. */
- }
- while (*newp && (isSPACE(*newp) || *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. */
- }
- newl = strlen(newp);
- if (newl == 0 || oldl == 0) {
- croak("Malformed PERLLIB_PREFIX");
- }
- strcpy(ret, newp);
- s = ret;
- while (*s) {
- if (*s == '\\') *s = '/';
- s++;
- }
- } else {
+ 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) {
+ if (!newp)
return s;
- }
- if (l == 0) {
+ if (l == 0)
l = strlen(s);
- }
- if (l < oldl || strnicmp(oldp, s, oldl) != 0) {
+ if (l < oldl || strnicmp(oldp, s, oldl) != 0)
return s;
- }
- if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH) {
- croak("Malformed PERLLIB_PREFIX");
- }
- strcpy(ret + newl, s + oldl);
- return ret;
+ 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
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;
- if (Perl_os2_initial_mode++)
- return Perl_hmq;
+ Perl_hmq_refcnt = 0; /* Be extra safe */
DosGetInfoBlocks(&tib, &pib);
- Perl_os2_initial_mode = pib->pib_ultype;
- Perl_hmq_refcnt = 1;
- /* Try morphing into a PM application. */
- if (pib->pib_ultype != 3) /* 2 is VIO */
- pib->pib_ultype = 3; /* 3 is PM */
- 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) {
- static int cnt;
- if (cnt++)
- _exit(188); /* Panic can try to create a window. */
- croak("Cannot create a message queue, or morph to a PM application");
+ 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 cnt = 0;
QMSG msg;
- if (Perl_hmq_servers && !force)
+ if (Perl_hmq_servers > 0 && !force)
return 0;
- if (!Perl_hmq_refcnt)
- croak("No message queue");
+ 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)
- croak("QUITing...");
+ Perl_croak_nocontext("QUITing...");
(*PMWIN_entries.DispatchMsg)(Perl_hab, &msg);
}
return cnt;
{
QMSG msg;
- if (Perl_hmq_servers && !force)
+ if (Perl_hmq_servers > 0 && !force)
return 0;
- if (!Perl_hmq_refcnt)
- croak("No message queue");
+ if (Perl_hmq_refcnt <= 0)
+ Perl_croak_nocontext("No message queue");
while ((*PMWIN_entries.GetMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0)) {
if (cntp)
(*cntp)++;
if (msg.msg == WM_CREATE)
return +1;
}
- croak("QUITing...");
+ Perl_croak_nocontext("QUITing...");
}
void
Perl_Deregister_MQ(int serve)
{
- PPIB pib;
- PTIB tib;
+ if (serve & REGISTERMQ_WILL_SERVE)
+ Perl_hmq_servers--;
+
+ if (--Perl_hmq_refcnt <= 0) {
+ unsigned fpflag = _control87(0,0);
- if (--Perl_hmq_refcnt == 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
- warn("Unexpected program mode %d when morphing back from PM",
- pib->pib_ultype);
+ Perl_warn_nocontext("Unexpected program mode %d when morphing back from PM",
+ pib->pib_ultype);
}
}
-extern void dlopen();
-void *fakedl = &dlopen; /* Pull in dynaloading part. */
-
#define sys_is_absolute(path) ( isALPHA((path)[0]) && (path)[1] == ':' \
&& ((path)[2] == '/' || (path)[2] == '\\'))
#define sys_is_rooted _fnisabs
#define sys_chdir(p) (chdir(p) == 0)
#define change_drive(d) (_chdrive(d), (current_drive() == toupper(d)))
-static int DOS_harderr_state = -1;
-
XS(XS_OS2_Error)
{
dXSARGS;
if (items != 2)
- croak("Usage: OS2::Error(harderr, exception)");
+ Perl_croak_nocontext("Usage: OS2::Error(harderr, exception)");
{
int arg1 = SvIV(ST(0));
int arg2 = SvIV(ST(1));
unsigned long rc;
if (CheckOSError(DosError(a)))
- croak("DosError(%d) failed", 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);
XSRETURN(1);
}
-static signed char DOS_suppression_state = -1;
-
XS(XS_OS2_Errors2Drive)
{
dXSARGS;
if (items != 1)
- croak("Usage: OS2::Errors2Drive(drive)");
+ Perl_croak_nocontext("Usage: OS2::Errors2Drive(drive)");
{
STRLEN n_a;
SV *sv = ST(0);
unsigned long rc;
if (suppress && !isALPHA(drive))
- croak("Non-char argument '%c' to OS2::Errors2Drive()", drive);
+ Perl_croak_nocontext("Non-char argument '%c' to OS2::Errors2Drive()", drive);
if (CheckOSError(DosSuppressPopUps((suppress
? SPU_ENABLESUPPRESSION
: SPU_DISABLESUPPRESSION),
drive)))
- croak("DosSuppressPopUps(%c) failed", 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);
XSRETURN(1);
}
-static const char * const si_fields[QSV_MAX] = {
+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_EMPTY;
+}
+
+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;
+ if (!items && CheckWinError(pDevCloseDC(hScreenDC)))
+ Perl_warn_nocontext("DevCloseDC() failed: %s", os2error(Perl_rc));
+ if (rc1)
+ Perl_rc = rc1, croak_with_os2error("DevQueryCaps() failed");
+ 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++;
+ }
+ }
+ XSRETURN(2 * (CAPS_DEVICE_POLYSET_POINTS - CAPS_FAMILY + 1));
+}
+
+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_EMPTY;
+}
+
+#define QSV_MAX_WARP3 QSV_MAX_COMP_LENGTH
+
+static const char * const si_fields[] = {
"MAX_PATH_LENGTH",
"MAX_TEXT_SESSIONS",
"MAX_PM_SESSIONS",
"TIMER_INTERVAL",
"MAX_COMP_LENGTH",
"FOREGROUND_FS_SESSION",
- "FOREGROUND_PROCESS"
+ "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)
- croak("Usage: OS2::SysInfo()");
+ Perl_croak_nocontext("Usage: OS2::SysInfo()");
{
- ULONG si[QSV_MAX] = {0}; /* System Information Data Buffer */
+ /* 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;
+ int i = 0, j = 0, last = QSV_MAX_WARP3;
- if (CheckOSError(DosQuerySysInfo(1L, /* Request all available system */
- QSV_MAX, /* information */
+ if (CheckOSError(DosQuerySysInfo(1L, /* Request documented system */
+ last, /* info for Warp 3 */
(PVOID)si,
sizeof(si))))
- croak("DosQuerySysInfo() failed");
- EXTEND(SP,2*QSV_MAX);
- while (i < QSV_MAX) {
+ 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--;
+ EXTEND(SP,2*last);
+ while (i < last) {
ST(j) = sv_newmortal();
sv_setpv(ST(j++), si_fields[i]);
ST(j) = sv_newmortal();
sv_setiv(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(2 * QSV_MAX);
+ XSRETURN(count);
}
XS(XS_OS2_BootDrive)
{
dXSARGS;
if (items != 0)
- croak("Usage: OS2::BootDrive()");
+ 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("DosQuerySysInfo() failed");
- ST(0) = sv_newmortal();
+ croak_with_os2error("DosQuerySysInfo() failed");
c = 'a' - 1 + si[0];
- sv_setpvn(ST(0), &c, 1);
+ 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_EMPTY;
+}
+
+
+
XS(XS_OS2_MorphPM)
{
dXSARGS;
if (items != 1)
- croak("Usage: OS2::MorphPM(serve)");
+ Perl_croak_nocontext("Usage: OS2::MorphPM(serve)");
{
bool serve = SvOK(ST(0));
unsigned long pmq = perl_hmq_GET(serve);
+ dXSTARG;
- ST(0) = sv_newmortal();
- sv_setiv(ST(0), pmq);
+ XSprePUSH; PUSHi((IV)pmq);
}
XSRETURN(1);
}
{
dXSARGS;
if (items != 1)
- croak("Usage: OS2::UnMorphPM(serve)");
+ Perl_croak_nocontext("Usage: OS2::UnMorphPM(serve)");
{
bool serve = SvOK(ST(0));
{
dXSARGS;
if (items != 1)
- croak("Usage: OS2::Serve_Messages(force)");
+ Perl_croak_nocontext("Usage: OS2::Serve_Messages(force)");
{
bool force = SvOK(ST(0));
unsigned long cnt = Perl_Serve_Messages(force);
+ dXSTARG;
- ST(0) = sv_newmortal();
- sv_setiv(ST(0), cnt);
+ XSprePUSH; PUSHi((IV)cnt);
}
XSRETURN(1);
}
{
dXSARGS;
if (items < 1 || items > 2)
- croak("Usage: OS2::Process_Messages(force [, cnt])");
+ Perl_croak_nocontext("Usage: OS2::Process_Messages(force [, cnt])");
{
bool force = SvOK(ST(0));
unsigned long cnt;
- I32 *cntp = NULL;
+ dXSTARG;
if (items == 2) {
+ I32 cntr;
SV *sv = ST(1);
- int fake = SvIV(sv); /* Force SvIVX */
-
+
+ (void)SvIV(sv); /* Force SvIVX */
if (!SvIOK(sv))
- croak("Can't upgrade count to IV");
- cntp = &SvIVX(sv);
- }
- cnt = Perl_Process_Messages(force, cntp);
- ST(0) = sv_newmortal();
- sv_setiv(ST(0), cnt);
+ 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);
}
{
dXSARGS;
if (items != 0)
- croak("Usage: Cwd::current_drive()");
+ Perl_croak_nocontext("Usage: Cwd::current_drive()");
{
char RETVAL;
+ dXSTARG;
RETVAL = current_drive();
- ST(0) = sv_newmortal();
- sv_setpvn(ST(0), (char *)&RETVAL, 1);
+ sv_setpvn(TARG, (char *)&RETVAL, 1);
+ XSprePUSH; PUSHTARG;
}
XSRETURN(1);
}
{
dXSARGS;
if (items != 1)
- croak("Usage: Cwd::sys_chdir(path)");
+ Perl_croak_nocontext("Usage: Cwd::sys_chdir(path)");
{
STRLEN n_a;
char * path = (char *)SvPV(ST(0),n_a);
{
dXSARGS;
if (items != 1)
- croak("Usage: Cwd::change_drive(d)");
+ Perl_croak_nocontext("Usage: Cwd::change_drive(d)");
{
STRLEN n_a;
char d = (char)*SvPV(ST(0),n_a);
{
dXSARGS;
if (items != 1)
- croak("Usage: Cwd::sys_is_absolute(path)");
+ Perl_croak_nocontext("Usage: Cwd::sys_is_absolute(path)");
{
STRLEN n_a;
char * path = (char *)SvPV(ST(0),n_a);
{
dXSARGS;
if (items != 1)
- croak("Usage: Cwd::sys_is_rooted(path)");
+ Perl_croak_nocontext("Usage: Cwd::sys_is_rooted(path)");
{
STRLEN n_a;
char * path = (char *)SvPV(ST(0),n_a);
{
dXSARGS;
if (items != 1)
- croak("Usage: Cwd::sys_is_relative(path)");
+ Perl_croak_nocontext("Usage: Cwd::sys_is_relative(path)");
{
STRLEN n_a;
char * path = (char *)SvPV(ST(0),n_a);
{
dXSARGS;
if (items != 0)
- croak("Usage: Cwd::sys_cwd()");
+ 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((SV*)ST(0), RETVAL);
+ sv_setpv(ST(0), RETVAL);
+#ifndef INCOMPLETE_TAINTS
+ SvTAINTED_on(ST(0));
+#endif
}
XSRETURN(1);
}
XS(XS_Cwd_sys_abspath)
{
dXSARGS;
- if (items < 1 || items > 2)
- croak("Usage: Cwd::sys_abspath(path, dir = NULL)");
+ if (items > 2)
+ Perl_croak_nocontext("Usage: Cwd::sys_abspath(path = '.', dir = NULL)");
{
STRLEN n_a;
- char * path = (char *)SvPV(ST(0),n_a);
- char * dir;
+ 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;
In all the cases it is safe to drop the drive part
of the path. */
if ( !sys_is_relative(path) ) {
- int is_drived;
-
if ( ( ( sys_is_absolute(dir)
|| (isALPHA(dir[0]) && dir[1] == ':'
&& strnicmp(dir, path,1) == 0))
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_setpv((SV*)ST(0), RETVAL);
+ 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, ULONG type)
+ExtLIBPATH(ULONG ord, PSZ path, IV type, int fatal)
{
- loadByOrd("doscalls",ord); /* Guarantied to load or die! */
- return (*(PELP)ExtFCN[ord])(path, type);
+ 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(type) \
- (CheckOSError(ExtLIBPATH(ORD_QUERY_ELP, to, ((type) ? END_LIBPATH \
- : BEGIN_LIBPATH))) \
- ? NULL : to )
+#define extLibpath(to,type, fatal) \
+ (CheckOSError(ExtLIBPATH(ORD_DosQueryExtLibpath, (to), (type), fatal)) ? NULL : (to) )
-#define extLibpath_set(p,type) \
- (!CheckOSError(ExtLIBPATH(ORD_SET_ELP, (p), ((type) ? END_LIBPATH \
- : BEGIN_LIBPATH))))
+#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)
- croak("Usage: Cwd::extLibpath(type = 0)");
+ Perl_croak_nocontext("Usage: OS2::extLibpath(type = 0)");
{
- bool type;
+ 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_EMPTY;
+}
+
+
+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)
- type = 0;
+ new = MCW_EM;
else {
- type = (int)SvIV(ST(0));
+ new = (unsigned)SvIV(ST(0));
}
- RETVAL = extLibpath(type);
- ST(0) = sv_newmortal();
- sv_setpv((SV*)ST(0), RETVAL);
+ 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_Cwd_extLibpath_set)
+XS(XS_OS2_incrMaxFHandles) /* DosSetRelMaxFH */
{
dXSARGS;
- if (items < 1 || items > 2)
- croak("Usage: Cwd::extLibpath_set(s, type = 0)");
+ if (items < 0 || items > 1)
+ Perl_croak(aTHX_ "Usage: OS2::incrMaxFHandles(delta = 0)");
{
- STRLEN n_a;
- char * s = (char *)SvPV(ST(0),n_a);
- bool type;
- U32 rc;
- bool RETVAL;
+ LONG delta;
+ ULONG RETVAL, rc;
+ dXSTARG;
- if (items < 2)
- type = 0;
- else {
- type = (int)SvIV(ST(1));
- }
+ if (items < 1)
+ delta = 0;
+ else
+ delta = (LONG)SvIV(ST(0));
- RETVAL = extLibpath_set(s, type);
- ST(0) = boolSV(RETVAL);
- if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
+ if (CheckOSError(DosSetRelMaxFH(&delta, &RETVAL)))
+ croak_with_os2error("OS2::incrMaxFHandles(): DosSetRelMaxFH() error");
+ XSprePUSH; PUSHu((UV)RETVAL);
}
XSRETURN(1);
}
int
-Xs_OS2_init()
+Xs_OS2_init(pTHX)
{
char *file = __FILE__;
{
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("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, ";$$");
gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
GvMULTI_on(gv);
#ifdef PERL_IS_AOUT
sv_setiv(GvSV(gv), 1);
-#endif
+#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);
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);
}
-OS2_Perl_data_t OS2_Perl_data;
+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)
{
- char *shell;
+ 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;
- _uflags (_UF_SBRK_MODEL, _UF_SBRK_ARBITRARY);
- if (environ == NULL) {
- environ = env;
- }
- if ( (shell = getenv("PERL_SH_DRIVE")) ) {
- New(1304, PL_sh_path, strlen(SH_PATH) + 1, char);
+ 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;
- if (shell[l-1] == '/' || shell[l-1] == '\\') {
+
+ while (l && (shell[l-1] == '/' || shell[l-1] == '\\'))
l--;
- }
- New(1304, PL_sh_path, l + 8, char);
+ 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
my_tmpnam (char *str)
{
char *p = getenv("TMP"), *tpath;
- int len;
if (!p) p = getenv("TEMP");
tpath = tempnam(p, "pltmp");
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. */
ULONG timeout, handle_type, flag_word;
APIRET rc;
int blocking, shared;
- static int use_my = -1;
+ static int use_my_flock = -1;
- if (use_my == -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 = atoi(s);
+ use_my_flock = atoi(s);
else
- use_my = 1;
+ use_my_flock = 1;
+ }
+ MUTEX_UNLOCK(&perlos2_state_mutex);
}
- if (!(_emx_env & 0x200) || !use_my)
+ if (!(_emx_env & 0x200) || !use_my_flock)
return flock(handle, o); /* Delegate to EMX. */
- // is this a file?
+ /* is this a file? */
if ((DosQueryHType(handle, &handle_type, &flag_word) != 0) ||
(handle_type & 0xFF))
{
errno = EBADF;
return -1;
}
- // set lock/unlock ranges
+ /* set lock/unlock ranges */
rNull.lOffset = rNull.lRange = rFull.lOffset = 0;
rFull.lRange = 0x7FFFFFFF;
- // set timeout for blocking
+ /* set timeout for blocking */
timeout = ((blocking = !(o & LOCK_NB))) ? 100 : 1;
- // shared or exclusive?
+ /* shared or exclusive? */
shared = (o & LOCK_SH) ? 1 : 0;
- // do not block the unlock
+ /* do not block the unlock */
if (o & (LOCK_UN | LOCK_SH | LOCK_EX)) {
rc = DosSetFileLocks(handle, &rFull, &rNull, timeout, shared);
switch (rc) {
errno = ENOLCK;
return -1;
case ERROR_LOCK_VIOLATION:
- break; // not an error
+ break; /* not an error */
case ERROR_INVALID_PARAMETER:
case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
case ERROR_READ_LOCKS_NOT_SUPPORTED:
return -1;
}
}
- // lock may block
+ /* lock may block */
if (o & (LOCK_SH | LOCK_EX)) {
- // for blocking operations
+ /* for blocking operations */
for (;;) {
rc =
DosSetFileLocks(
errno = EINVAL;
return -1;
}
- // give away timeslice
+ /* 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;
+}