diff options
Diffstat (limited to 'gnu/usr.bin/perl/os2')
| -rw-r--r-- | gnu/usr.bin/perl/os2/Changes | 326 | ||||
| -rw-r--r-- | gnu/usr.bin/perl/os2/Makefile.SHs | 2 | ||||
| -rw-r--r-- | gnu/usr.bin/perl/os2/os2.c | 641 | ||||
| -rw-r--r-- | gnu/usr.bin/perl/os2/os2ish.h | 222 | ||||
| -rw-r--r-- | gnu/usr.bin/perl/os2/perl2cmd.pl | 18 |
5 files changed, 1133 insertions, 76 deletions
diff --git a/gnu/usr.bin/perl/os2/Changes b/gnu/usr.bin/perl/os2/Changes index 4c54a28d5cb..3bd33a56c57 100644 --- a/gnu/usr.bin/perl/os2/Changes +++ b/gnu/usr.bin/perl/os2/Changes @@ -489,9 +489,333 @@ After @14577: necessary run-time dynalinking. After @15047: - makes PerlIO preserve the binary/text mode of filehandles chosen by CRT library. (However, TTY handles still are not clean, since switching them to TERMIO mode and back changes the NL translation law at runtime, and PerlIO level does not know this.) + +After @18156: + mkdir() rmdir() tolerate trailing slashes. + "localized" morphing to PM when already morphed would unmorph at end. + Convert \n to \r\n in REXX commands (Classic REXX would allow \r and + \r\n, but not \n as line-ends). + +After @19053: + Better detection of OS/2 in Configure scripts (if c:/ is not readable). + Better Configure support for \\ inside cpp-emited # lineno "filename". + Export pthread-support functions from threaded DLL. + [older change] If perl5.def file is present, the new perl5.def has + compatible ordinals. + OS/2 code compiles with threads enabled; much more robust pthreads + emulation (but some statics still present); survives fork(). + New attributes supported with [f]stat() and chmod() + archived is 0x1000000 = 0100000000 + hidden is 0x2000000 = 0200000000 + system is 0x4000000 = 0400000000 + If extra flag 0x8000000 = 01000000000 is missing during + chmod(), these 3 flags are ignored; this extra flag + is set in the result of stat() [this provides backward + compatibility, as well as transparency of stat()/ + chmod() supporting DOSISH]. + OS/2-specific modules use XSLoader now. + Remove DLLs manually after failing build (link386 would not?!). + Special-case stat()ing "/dev/nul" and "/dev/null" too. + Update dlopen() and friends: preserve i387 flags, better error messages, + support name==NULL (load for "this" DLL); + OS2::DLL does not eval() generated functions, uses closes instead; + new method wrapper_REXX() for DLL objects. + +After @19774: + Use common typemap for OS2:: modules. + New test file os2/perlrexx.cmd (should be run manually; does not it + exit too early???). + Export fork_with_resources(), croak_with_os2error() from DLL. + usleep() availability put in %Config{}. + Combine most (but not all!) statics into one struct. + New load-on-demand C functions + Dos32QueryHeaderInfo + DosTmrQueryFreq + DosTmrQueryTime + WinQueryActiveDesktopPathname + WinInvalidateRect + WinCreateFrameControl + WinQueryClipbrdFmtInfo + WinQueryClipbrdOwner + WinQueryClipbrdViewer + WinQueryClipbrdData + WinOpenClipbrd + WinCloseClipbrd + WinSetClipbrdData + WinSetClipbrdOwner + WinSetClipbrdViewer + WinEnumClipbrdFmts + WinEmptyClipbrd + WinAddAtom + WinFindAtom + WinDeleteAtom + WinQueryAtomUsage + WinQueryAtomName + WinQueryAtomLength + WinQuerySystemAtomTable + WinCreateAtomTable + WinDestroyAtomTable + WinOpenWindowDC + DevOpenDC + DevQueryCaps + DevCloseDC + WinMessageBox + WinMessageBox2 + WinQuerySysValue + WinSetSysValue + WinAlarm + WinFlashWindow + WinLoadPointer + WinQuerySysPointer + Check "\\SEM32\\PMDRAG.SEM" before loading PM-specific DLLs. + Handling of system {realname} was not correct in presence of + exe-type deduction, #!-emulation etc. + Use optimized PUSHTARG etc. XSUB convention. + $^E stringification contains PMERR_INVALID_HWND, PMERR_INVALID_HMQ, + PMERR_CALL_FROM_WRONG_THREAD, PMERR_NO_MSG_QUEUE, + PMERR_NOT_IN_A_PM_SESSION if these errors are not in .MSG file + (at least on Warp3fp42). + PERLLIB_PREFIX augmented by PERLLIB_582_PREFIX, PERLLIB_58_PREFIX, + PERLLIB_5_PREFIX (example for 5.8.2, the first one present is + considered). + New flag bit 0x2 for OS2::MorphPM(): immediately unmorph after creation + of message queue. + (De)Registring MQ preserves i386 flags. + When die()ing inside OS2:: API, include $^E in the message. + New function OS2::Timer(): returns Tmr-timer ticks (about 1MHz) since + start of OS/2, converted to number of seconds (keep in mind + that this timer uses a different crystal than the real-time + clock; thus these values have only weak relationship to the + wall clock time; behaviour with APM on is not defined). + New function OS2::DevCap() [XXX Wrong usage message!!!] + Usage: OS2::DevCap([WHAT, [HOW=0]]); the default for WHAT is + the memory device context, WHAT should be a device context + (as integer) if HOW==0 and a window handle (as integer) if + HOW==1. Returns a hash with keys + 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 + New function OS2::SysValues(which = -1, hwndDesktop = HWND_DESKTOP). + If which != -1, returns the correspondg SysValue. Otherwise + returns a hash with 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 + New function OS2::SysValues_set(which, val, hwndDesktop = HWND_DESKTOP). + Support new keys NUMPROCESSORS MAXHPRMEM MAXHSHMEM MAXPROCESSES + VIRTUALADDRESSLIMIT INT10ENABLE from OS2::SysInfo(); support + up to 10 unnamed values after the last named one. + New function OS2::SysInfoFor(id[,count=1]). [Wrong usage message!!!] + New function OS2::Beep(freq = 440, ms = 100). + New flags mod_name_C_function = 0x100, mod_name_HMODULE = 0x200 in + addition to old mod_name_handle = 0, mod_name_shortname = 1, + mod_name_full = 2 for OS2::DLLname(flag, cv); use an address + (as integer) or module handle instead of cv. + New function OS2::_headerInfo(req,size[,handle,[offset]]). + New function OS2::libPath(); returns the value of LIBPATH. + New function OS2::mytype(which=0) to query current process type: + 0: type immediately after startup or last fork(); + 1: type immediately after startup; + 2: type before the first morphing; + 3: type as set now in the header. + New function OS2::mytype_set(type); + New function OS2::incrMaxFHandles(delta = 0); returns updated value + for the possible number of open file descriptors. + Make check_emx_runtime() thread-safe. + Fix float-to-string conversion in the range .0001..0.1 (would return + in exponential notation, per gcvt()). + Make fork(): a) preserve i387 flags; + b) preverve the dynamically loaded (system) DLLs; + c) preserve morphed status; + Make sleep() work with time > 0xffffffff/1000. + Implement usleep() via _sleep2(); make select() with num_files==0 + thread-safe (via calling DosSleep()). + OS2::Process::Const() manages (MB|MBID|CF|CFI|SPTR)_.* constants too. + New (exported) functions from OS2::Process (some undocumented???): + process_codepage_set + TopLevel + FocusWindow_set_keep_Zorder + ActiveDesktopPathname + InvalidateRect + CreateFrameControl + ClipbrdFmtInfo + ClipbrdOwner + ClipbrdViewer + ClipbrdData + OpenClipbrd + CloseClipbrd + ClipbrdData_set + ClipbrdOwner_set + ClipbrdViewer_set + EnumClipbrdFmts + EmptyClipbrd + AddAtom + FindAtom + DeleteAtom + AtomUsage + AtomName + AtomLength + SystemAtomTable + CreateAtomTable + DestroyAtomTable + _ClipbrdData_set + ClipbrdText + ClipbrdText_set + _MessageBox + MessageBox + _MessageBox2 + MessageBox2 + LoadPointer + SysPointer + Alarm + FlashWindow + Do not use AUTOLOAD in OS2::DLL; moved to OS2::DLL::dll. + New method OS2::DLL->module() (to replace botched ->new() method). + New functions call20(), call20_p(), call20_rp3(), call20_rp3_p(), + call20_Dos(), call20_Win(), call20_Win_0OK(), + call20_Win_0OK_survive() in OS2::DLL to call C functions via + pointers. + +After @20218: + select() workaround broke build of x2p. + New OS2::Process (exported, undocumented) functions: + kbdChar + kbdhChar + kbdStatus + _kbdStatus_set + kbdhStatus + kbdhStatus_set + vioConfig + viohConfig + vioMode + viohMode + viohMode_set + _vioMode_set + _vioState + _vioState_set + vioFont + vioFont_set + Make CheckOS2Error() macro return the error code. + New dynaloaded entry point DosReplaceModule(). + New function OS2::replaceModule(target [, source [, backup]]). + +After @21211: + Make Cwd::sys_abspath() default to '.' and taint the result. + Fix os2_process*.t to work if the default for VIO windows is maximized. + Fix to avoid non-existing PIDs for get_sysinfo() broke pid==0. + Restore default mode for pipes to be TEXT mode. + +After @21379: + New OS2::Process functions: __term_mirror_screen() __term_mirror() + io_term(). + Fix a.out build: special-case thread::shared, pick up all the build + static libraries, not only those for top-level modules. + Fix DLLname() test to work with the static build too. + New dynaloaded entry point RexxRegisterSubcomExe(); make OS2::REXX use + it so it is not linked with REXX*.DLLs any more. + If system "./foo", and empty "./foo" and "./foo.exe" exist, + argv[0] would be set to junk. + Make perl2cmd convert .pl files and keep the command-line switches. + Make XSLoader and Perl-specific parts of DynaLoader to die with static + builds (new variable $OS2::is_static used); + Move perlmain.obj to the DLL; export main() as dll_perlmain(); create + a library libperl_dllmain to translate the exported symbol + back to main(); link the executables with this library instead + of perlmain.obj. + Add /li to link386's options (line number info in the .map file). + Another break from fix to avoid non-existing PIDs for get_sysinfo(). + +After @21574: + Update import libraries when perl version changes (e.g., due to rsync). + New exported symbols dup() and dup2() [the wrappers have workaround + for off-by-one error + double fault in the pre-Nov2003 kernels + when a (wrong) filedescriptor which is limit+1 is dup()ed]. + Enable disabling fd via a FILE* (to avoid close() during fclose()). + New dynaloaded entry point DosPerfSysCall(). + New function OS2::perfSysCall(cmd = CMD_KI_RDCNT, ulParm1= 0, + ulParm2= 0, ulParm3= 0); when called + with cmd == CMD_KI_RDCNT = 0x63 and no other parameters, + returns: in the scalar context: the tick count of processor 1; + in the list context: 4 tick counts per processor: + total/idle/busy/interrupt-time. + with cmd == CMD_KI_GETQTY == 0x41 and no other parameters, + returns the CPU count. Currently in other cases the return + is void. + New executables perl___<number> generated with decreased stack size + (good when virtual memory is low; e.g. floppy boot). + +After 5.8.2 (@21668): + Fixes to installperl scripts to avoid junk output, allow overwrite + of existing files (File::Copy::copy is mapped to DosCopy() + with flags which would not overwrite). + Disable DynaLoading of Perl modules with AOUT build (will core anyway). + For AOUT build: Quick hack to construct directories necessary for + /*/% stuff [maybe better do it from hints/os2.sh?]. + AOUT build: do -D__ST_MT_ERRNO__ to simplify linking with -Zmtd + (e.g., to test GD: gd.dll linked with -Zmtd). + MANIFEST.SKIP was read without a drive part of the filename. + Rename Cwd::extLibpath*() to OS2::... (old names still preserved). + Install perl.lib and perl.a too. + New methods libPath_find(),has_f32(),handle(),fullname() for OS2::DLL. + Enable quad support using long long. + New C exported functions os2_execname(), async_mssleep(), msCounter(), + InfoTable(), dir_subst(), Perl_OS2_handler_install(), + fill_extLibpath(). + async_mssleep() uses some undocumented features which allow usage of + highest possible resolution of sleep() while preserving low + priority (raise of resolution may be not available before + Warp3fp40; resolution is 8ms/CLOCK_SCALE). + usleep() and select(undef,undef,undef,$t) are using this + interface for time up to 0.5sec. + New convenience macros os2win_croak_0OK(rc,msg), os2win_croak(rc,msg), + os2cp_croak(rc,msg). + Supports ~installprefix, ~exe, ~dll in PERLLIB_PREFIX etc (actual + directories are substituted). + New functions OS2::msCounter(), OS2::ms_sleep(), OS2::_InfoTable(). + Checks stack when fixing EMX being under-initialized (-Zomf -Zsys + produces 32K stack???). + New environment variables PERL_BEGINLIBPATH, PERL_PRE_BEGINLIBPATH, + PERL_POST_BEGINLIBPATH, PERL_ENDLIBPATH, + PERL_PRE_ENDLIBPATH PERL_POST_ENDLIBPATH (~-enabled); + PERL_EMXLOAD_SECS. + Better handling of FIRST_MAKEFILE (propagate to subdirs during test, + do not require Makefile.PL present). + perl2cmd converter: do not rewrite if no change. + README.os2 updated with info on building binary distributions and + custom perl executables (but not much else). diff --git a/gnu/usr.bin/perl/os2/Makefile.SHs b/gnu/usr.bin/perl/os2/Makefile.SHs index 2a098c95bc7..ad688b8f374 100644 --- a/gnu/usr.bin/perl/os2/Makefile.SHs +++ b/gnu/usr.bin/perl/os2/Makefile.SHs @@ -288,7 +288,7 @@ aout_clean: aout_install: perl_ aout_install.perl aout_install.perl: perl_ installperl - ./perl_ installperl + ./perl_ installperl --destdir="$(DESTDIR)" perlrexx: $(PERLREXX_DLL) @sh -c true diff --git a/gnu/usr.bin/perl/os2/os2.c b/gnu/usr.bin/perl/os2/os2.c index e8e10d97b7e..776031d17b7 100644 --- a/gnu/usr.bin/perl/os2/os2.c +++ b/gnu/usr.bin/perl/os2/os2.c @@ -12,6 +12,7 @@ #include <os2.h> #include "dlfcn.h" #include <emx/syscalls.h> +#include <sys/emxload.h> #include <sys/uflags.h> @@ -32,6 +33,14 @@ #include "EXTERN.h" #include "perl.h" +enum module_name_how { mod_name_handle, mod_name_shortname, mod_name_full, + mod_name_C_function = 0x100, mod_name_HMODULE = 0x200}; + +/* Find module name to which *this* subroutine is compiled */ +#define module_name(how) module_name_at(&module_name_at, how) + +static SV* module_name_at(void *pp, enum module_name_how how); + void croak_with_os2error(char *s) { @@ -118,6 +127,7 @@ 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; */ @@ -153,7 +163,10 @@ static struct perlos2_state_t { 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 */ @@ -195,10 +208,13 @@ static struct perlos2_state_t { #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 *); @@ -966,7 +982,7 @@ do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag) { int trueflag = flag; int rc, pass = 1; - char *real_name; + char *real_name = NULL; /* Shut down the warning */ char const * args[4]; static const char * const fargs[4] = { "/bin/sh", "-c", "\"$@\"", "spawn-via-shell", }; @@ -2100,34 +2116,50 @@ void CroakWinError(int die, char *name) { FillWinError; - if (die && Perl_rc) { - dTHX; + if (die && Perl_rc) + croak_with_os2error(name ? name : "Win* API call"); +} - Perl_croak(aTHX_ "%s: %s", (name ? name : "Win* API call"), os2error(Perl_rc)); - } +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); } -char * -os2_execname(pTHX) +static char * +execname2buffer(char *buf, STRLEN l, char *oname) { - char buf[300], *p, *o = PL_origargv[0], ok = 1; + char *p, *orig = oname, ok = oname != NULL; - if (_execname(buf, sizeof buf) != 0) - return o; + 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 && *o != '/' && *o != '\\') + if (ok && *oname != '/' && *oname != '\\') ok = 0; - } else if (ok && tolower(*o) != tolower(*p)) + } else if (ok && tolower(*oname) != tolower(*p)) ok = 0; p++; - o++; + oname++; } - if (ok) { /* PL_origargv[0] matches the real name. Use PL_origargv[0]: */ - strcpy(buf, PL_origargv[0]); /* _execname() is always uppercased */ + if (ok) { /* orig matches the real name. Use orig: */ + strcpy(buf, orig); /* _execname() is always uppercased */ p = buf; while (*p) { if (*p == '\\') @@ -2135,61 +2167,238 @@ os2_execname(pTHX) p++; } } - p = savepv(buf); + return buf; +} + +char * +os2_execname(pTHX) +{ + char buf[300], *p = execname2buffer(buf, sizeof buf, PL_origargv[0]); + + p = savepv(p); SAVEFREEPV(p); return p; } +int +Perl_OS2_handler_install(void *handler, enum Perlos2_handler how) +{ + char *s, b[300]; + + switch (how) { + case Perlos2_handler_mangle: + perllib_mangle_installed = (char *(*)(char *s, unsigned int l))handler; + return 1; + case Perlos2_handler_perl_sh: + s = (char *)handler; + s = dir_subst(s, strlen(s), b, sizeof b, 0, "handler_perl_sh"); + perl_sh_installed = savepv(s); + return 1; + case Perlos2_handler_perllib_from: + s = (char *)handler; + s = dir_subst(s, strlen(s), b, sizeof b, 0, "handler_perllib_from"); + oldl = strlen(s); + oldp = savepv(s); + return 1; + case Perlos2_handler_perllib_to: + s = (char *)handler; + s = dir_subst(s, strlen(s), b, sizeof b, 0, "handler_perllib_to"); + newl = strlen(s); + newp = savepv(s); + strcpy(mangle_ret, newp); + s = mangle_ret - 1; + while (*++s) + if (*s == '\\') + *s = '/'; + return 1; + default: + return 0; + } +} + +/* Returns a malloc()ed copy */ +char * +dir_subst(char *s, unsigned int l, char *b, unsigned int bl, enum dir_subst_e flags, char *msg) +{ + char *from, *to = b, *e = b; /* `to' assignment: shut down the warning */ + STRLEN froml = 0, tol = 0, rest = 0; /* froml: likewise */ + + if (l >= 2 && s[0] == '~') { + switch (s[1]) { + case 'i': case 'I': + from = "installprefix"; break; + case 'd': case 'D': + from = "dll"; break; + case 'e': case 'E': + from = "exe"; break; + default: + from = NULL; + froml = l + 1; /* Will not match */ + break; + } + if (from) + froml = strlen(from) + 1; + if (l >= froml && strnicmp(s + 2, from + 1, froml - 2) == 0) { + int strip = 1; + + switch (s[1]) { + case 'i': case 'I': + strip = 0; + tol = strlen(INSTALL_PREFIX); + if (tol >= bl) { + if (flags & dir_subst_fatal) + Perl_croak_nocontext("INSTALL_PREFIX too long: `%s'", INSTALL_PREFIX); + else + return NULL; + } + memcpy(b, INSTALL_PREFIX, tol + 1); + to = b; + e = b + tol; + break; + case 'd': case 'D': + if (flags & dir_subst_fatal) { + dTHX; + + to = dllname2buffer(aTHX_ b, bl); + } else { /* No Perl present yet */ + HMODULE self = find_myself(); + APIRET rc = DosQueryModuleName(self, bl, b); + + if (rc) + return 0; + to = b - 1; + while (*++to) + if (*to == '\\') + *to = '/'; + to = b; + } + break; + case 'e': case 'E': + if (flags & dir_subst_fatal) { + dTHX; + + to = execname2buffer(b, bl, PL_origargv[0]); + } else + to = execname2buffer(b, bl, NULL); + break; + } + if (!to) + return NULL; + if (strip) { + e = strrchr(to, '/'); + if (!e && (flags & dir_subst_fatal)) + Perl_croak_nocontext("%s: Can't parse EXE/DLL name: '%s'", msg, to); + else if (!e) + return NULL; + *e = 0; + } + s += froml; l -= froml; + if (!l) + return to; + if (!tol) + tol = strlen(to); + + while (l >= 3 && (s[0] == '/' || s[0] == '\\') + && s[1] == '.' && s[2] == '.' + && (l == 3 || s[3] == '/' || s[3] == '\\' || s[3] == ';')) { + e = strrchr(b, '/'); + if (!e && (flags & dir_subst_fatal)) + Perl_croak_nocontext("%s: Error stripping dirs from EXE/DLL/INSTALLDIR name", msg); + else if (!e) + return NULL; + *e = 0; + l -= 3; s += 3; + } + if (l && s[0] != '/' && s[0] != '\\' && s[0] != ';') + *e++ = '/'; + } + } /* Else: copy as is */ + if (l && (flags & dir_subst_pathlike)) { + STRLEN i = 0; + + while ( i < l - 2 && s[i] != ';') /* May have ~char after `;' */ + i++; + if (i < l - 2) { /* Found */ + rest = l - i - 1; + l = i + 1; + } + } + if (e + l >= b + bl) { + if (flags & dir_subst_fatal) + Perl_croak_nocontext("%s: name `%s%s' too long", msg, b, s); + else + return NULL; + } + memcpy(e, s, l); + if (rest) { + e = dir_subst(s + l, rest, e + l, bl - (e + l - b), flags, msg); + return e ? b : e; + } + e[l] = 0; + return b; +} + +char * +perllib_mangle_with(char *s, unsigned int l, char *from, unsigned int froml, char *to, unsigned int tol) +{ + if (!to) + return s; + if (l == 0) + l = strlen(s); + if (l < froml || strnicmp(from, s, froml) != 0) + return s; + if (l + tol - froml > STATIC_FILE_LENGTH || tol > STATIC_FILE_LENGTH) + Perl_croak_nocontext("Malformed PERLLIB_PREFIX"); + if (to && to != mangle_ret) + memcpy(mangle_ret, to, tol); + strcpy(mangle_ret + tol, s + froml); + return mangle_ret; +} + char * perllib_mangle(char *s, unsigned int l) { + char *name; + + if (perllib_mangle_installed && (name = perllib_mangle_installed(s,l))) + return name; if (!newp && !notfound) { - newp = getenv("PERLLIB_" STRINGIFY(PERL_REVISION) + newp = getenv(name = "PERLLIB_" STRINGIFY(PERL_REVISION) STRINGIFY(PERL_VERSION) STRINGIFY(PERL_SUBVERSION) "_PREFIX"); if (!newp) - newp = getenv("PERLLIB_" STRINGIFY(PERL_REVISION) + newp = getenv(name = "PERLLIB_" STRINGIFY(PERL_REVISION) STRINGIFY(PERL_VERSION) "_PREFIX"); if (!newp) - newp = getenv("PERLLIB_" STRINGIFY(PERL_REVISION) "_PREFIX"); + newp = getenv(name = "PERLLIB_" STRINGIFY(PERL_REVISION) "_PREFIX"); if (!newp) - newp = getenv("PERLLIB_PREFIX"); + 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) { - Perl_croak_nocontext("Malformed PERLLIB_PREFIX"); - } - strcpy(mangle_ret, newp); - s = mangle_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) { + 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; } @@ -2394,6 +2603,105 @@ XS(XS_OS2_Errors2Drive) XSRETURN(1); } +int +async_mssleep(ULONG ms, int switch_priority) { + /* This is similar to DosSleep(), but has 8ms granularity in time-critical + threads even on Warp3. */ + HEV hevEvent1 = 0; /* Event semaphore handle */ + HTIMER htimerEvent1 = 0; /* Timer handle */ + APIRET rc = NO_ERROR; /* Return code */ + int ret = 1; + ULONG priority = 0, nesting; /* Shut down the warnings */ + PPIB pib; + PTIB tib; + char *e = NULL; + APIRET badrc; + + if (!(_emx_env & 0x200)) /* DOS */ + return !_sleep2(ms); + + os2cp_croak(DosCreateEventSem(NULL, /* Unnamed */ + &hevEvent1, /* Handle of semaphore returned */ + DC_SEM_SHARED, /* Shared needed for DosAsyncTimer */ + FALSE), /* Semaphore is in RESET state */ + "DosCreateEventSem"); + + if (ms >= switch_priority) + switch_priority = 0; + if (switch_priority) { + if (CheckOSError(DosGetInfoBlocks(&tib, &pib))) + switch_priority = 0; + else { + /* In Warp3, to switch scheduling to 8ms step, one needs to do + DosAsyncTimer() in time-critical thread. On laters versions, + more and more cases of wait-for-something are covered. + + It turns out that on Warp3fp42 it is the priority at the time + of DosAsyncTimer() which matters. Let's hope that this works + with later versions too... XXXX + */ + priority = (tib->tib_ptib2->tib2_ulpri); + if ((priority & 0xFF00) == 0x0300) /* already time-critical */ + switch_priority = 0; + /* Make us time-critical. Just modifying TIB is not enough... */ + /* tib->tib_ptib2->tib2_ulpri = 0x0300;*/ + /* We do not want to run at high priority if a signal causes us + to longjmp() out of this section... */ + if (DosEnterMustComplete(&nesting)) + switch_priority = 0; + else + DosSetPriority(PRTYS_THREAD, PRTYC_TIMECRITICAL, 0, 0); + } + } + + if ((badrc = DosAsyncTimer(ms, + (HSEM) hevEvent1, /* Semaphore to post */ + &htimerEvent1))) /* Timer handler (returned) */ + e = "DosAsyncTimer"; + + if (switch_priority && tib->tib_ptib2->tib2_ulpri == 0x0300) { + /* Nobody switched priority while we slept... Ignore errors... */ + /* tib->tib_ptib2->tib2_ulpri = priority; */ /* Get back... */ + if (!(rc = DosSetPriority(PRTYS_THREAD, (priority>>8) & 0xFF, 0, 0))) + rc = DosSetPriority(PRTYS_THREAD, 0, priority & 0xFF, 0); + } + if (switch_priority) + rc = DosExitMustComplete(&nesting); /* Ignore errors */ + + /* The actual blocking call is made with "normal" priority. This way we + should not bother with DosSleep(0) etc. to compensate for us interrupting + higher-priority threads. The goal is to prohibit the system spending too + much time halt()ing, not to run us "no matter what". */ + if (!e) /* Wait for AsyncTimer event */ + badrc = DosWaitEventSem(hevEvent1, SEM_INDEFINITE_WAIT); + + if (e) ; /* Do nothing */ + else if (badrc == ERROR_INTERRUPT) + ret = 0; + else if (badrc) + e = "DosWaitEventSem"; + if ((rc = DosCloseEventSem(hevEvent1)) && !e) { /* Get rid of semaphore */ + e = "DosCloseEventSem"; + badrc = rc; + } + if (e) + os2cp_croak(badrc, e); + return ret; +} + +XS(XS_OS2_ms_sleep) /* for testing only... */ +{ + dXSARGS; + ULONG ms, lim; + + if (items > 2 || items < 1) + Perl_croak_nocontext("Usage: OS2::ms_sleep(wait_ms [, high_priority_limit])"); + ms = SvUV(ST(0)); + lim = items > 1 ? SvUV(ST(1)) : ms + 1; + async_mssleep(ms, lim); + XSRETURN_EMPTY; +} + ULONG (*pDosTmrQueryFreq) (PULONG); ULONG (*pDosTmrQueryTime) (unsigned long long *); @@ -2425,6 +2733,37 @@ XS(XS_OS2_Timer) 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", @@ -3219,11 +3558,13 @@ typedef APIRET (*PELP)(PSZ path, ULONG type); #endif APIRET -ExtLIBPATH(ULONG ord, PSZ path, IV type) +ExtLIBPATH(ULONG ord, PSZ path, IV type, int fatal) { ULONG what; - PFN f = loadByOrdinal(ord, 1); /* Guarantied to load or die! */ + 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) @@ -3233,23 +3574,35 @@ ExtLIBPATH(ULONG ord, PSZ path, IV type) return (*(PELP)f)(path, what); } -#define extLibpath(to,type) \ - (CheckOSError(ExtLIBPATH(ORD_DosQueryExtLibpath, (to), (type))) ? NULL : (to) ) +#define extLibpath(to,type, fatal) \ + (CheckOSError(ExtLIBPATH(ORD_DosQueryExtLibpath, (to), (type), fatal)) ? NULL : (to) ) + +#define extLibpath_set(p,type, fatal) \ + (!CheckOSError(ExtLIBPATH(ORD_DosSetExtLibpath, (p), (type), fatal))) -#define extLibpath_set(p,type) \ - (!CheckOSError(ExtLIBPATH(ORD_DosSetExtLibpath, (p), (type)))) +static void +early_error(char *msg1, char *msg2, char *msg3) +{ /* Buffer overflow detected; there is very little we can do... */ + ULONG rc; + + DosWrite(2, msg1, strlen(msg1), &rc); + DosWrite(2, msg2, strlen(msg2), &rc); + DosWrite(2, msg3, strlen(msg3), &rc); + DosExit(EXIT_PROCESS, 2); +} XS(XS_Cwd_extLibpath) { dXSARGS; if (items < 0 || items > 1) - Perl_croak_nocontext("Usage: Cwd::extLibpath(type = 0)"); + Perl_croak_nocontext("Usage: OS2::extLibpath(type = 0)"); { IV type; char to[1024]; U32 rc; char * RETVAL; dXSTARG; + STRLEN l; if (items < 1) type = 0; @@ -3258,9 +3611,13 @@ XS(XS_Cwd_extLibpath) } to[0] = 1; to[1] = 0; /* Sometimes no error reported */ - RETVAL = extLibpath(to, type); + RETVAL = extLibpath(to, type, 1); /* Make errors fatal */ if (RETVAL && RETVAL[0] == 1 && RETVAL[1] == 0) - Perl_croak_nocontext("panic Cwd::extLibpath parameter"); + 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; } @@ -3271,7 +3628,7 @@ XS(XS_Cwd_extLibpath_set) { dXSARGS; if (items < 1 || items > 2) - Perl_croak_nocontext("Usage: Cwd::extLibpath_set(s, type = 0)"); + Perl_croak_nocontext("Usage: OS2::extLibpath_set(s, type = 0)"); { STRLEN n_a; char * s = (char *)SvPV(ST(0),n_a); @@ -3285,13 +3642,74 @@ XS(XS_Cwd_extLibpath_set) type = SvIV(ST(1)); } - RETVAL = extLibpath_set(s, type); + 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, @@ -3303,9 +3721,6 @@ DeclOSFuncByORD(APIRET, _DosQueryModFromEIP,ORD_DosQueryModFromEIP, ULONG * Offset, ULONG Address), (hmod, obj, BufLen, Buf, Offset, Address)) -enum module_name_how { mod_name_handle, mod_name_shortname, mod_name_full, - mod_name_C_function = 0x100, mod_name_HMODULE = 0x200}; - static SV* module_name_at(void *pp, enum module_name_how how) { @@ -3351,9 +3766,6 @@ module_name_of_cv(SV *cv, enum module_name_how how) return module_name_at(CvXSUB(SvRV(cv)), how); } -/* Find module name to which *this* subroutine is compiled */ -#define module_name(how) module_name_at(&module_name_at, how) - XS(XS_OS2_DLLname) { dXSARGS; @@ -3589,6 +4001,8 @@ Xs_OS2_init(pTHX) 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); @@ -3620,6 +4034,9 @@ Xs_OS2_init(pTHX) 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, "$$;$"); @@ -3741,6 +4158,12 @@ force_init_emx_runtime(EXCEPTIONREGISTRATIONRECORD *preg, ULONG flags) 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 */ @@ -3863,7 +4286,7 @@ extern ULONG __os_version(); /* See system.doc */ void check_emx_runtime(char **env, EXCEPTIONREGISTRATIONRECORD *preg) { - ULONG v_crt, v_emx, count = 0, rc, rc1, maybe_inited = 0; + 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; @@ -4000,7 +4423,8 @@ Perl_OS2_init(char **env) void Perl_OS2_init3(char **env, void **preg, int flags) { - char *shell; + char *shell, *s; + ULONG rc; _uflags (_UF_SBRK_MODEL, _UF_SBRK_ARBITRARY); MALLOC_INIT; @@ -4009,15 +4433,20 @@ Perl_OS2_init3(char **env, void **preg, int flags) settmppath(); OS2_Perl_data.xs_init = &Xs_OS2_init; - if ( (shell = getenv("PERL_SH_DRIVE")) ) { + if (perl_sh_installed) { + int l = strlen(perl_sh_installed); + + New(1304, PL_sh_path, l + 1, char); + memcpy(PL_sh_path, perl_sh_installed, l + 1); + } else if ( (shell = getenv("PERL_SH_DRIVE")) ) { New(1304, 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); strncpy(PL_sh_path, shell, l); strcpy(PL_sh_path + l, "/sh.exe"); @@ -4032,6 +4461,29 @@ Perl_OS2_init3(char **env, void **preg, int flags) 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); } @@ -4460,3 +4912,52 @@ int fork_with_resources() 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; +} diff --git a/gnu/usr.bin/perl/os2/os2ish.h b/gnu/usr.bin/perl/os2/os2ish.h index dbd5d94c876..7b9fabf376c 100644 --- a/gnu/usr.bin/perl/os2/os2ish.h +++ b/gnu/usr.bin/perl/os2/os2ish.h @@ -320,6 +320,11 @@ void my_setpwent (void); void my_endpwent (void); char *gcvt_os2(double value, int digits, char *buffer); +extern int async_mssleep(unsigned long ms, int switch_priority); +extern unsigned long msCounter(void); +extern unsigned long InfoTable(int local); +extern unsigned long find_myself(void); + #define MAX_SLEEP (((1<30) / (1000/4))-1) /* 1<32 msec */ static __inline__ unsigned @@ -360,7 +365,7 @@ struct passwd *my_getpwnam (__const__ char *); #define strtoll _strtoll #define strtoull _strtoull -#define usleep(usec) ((void)_sleep2(((usec)+500)/1000)) +#define usleep(usec) ((void)async_mssleep(((usec)+500)/1000, 500)) /* @@ -751,6 +756,21 @@ enum entries_ordinals { void ResetWinError(void); void CroakWinError(int die, char *name); +enum Perlos2_handler { + Perlos2_handler_mangle = 1, + Perlos2_handler_perl_sh, + Perlos2_handler_perllib_from, + Perlos2_handler_perllib_to, +}; +enum dir_subst_e { + dir_subst_fatal = 1, + dir_subst_pathlike = 2 +}; + +extern int Perl_OS2_handler_install(void *handler, enum Perlos2_handler how); +extern char *dir_subst(char *s, unsigned int l, char *b, unsigned int bl, enum dir_subst_e flags, char *msg); +extern unsigned long fill_extLibpath(int type, char *pre, char *post, int replace, char *msg); + #define PERLLIB_MANGLE(s, n) perllib_mangle((s), (n)) char *perllib_mangle(char *, unsigned int); @@ -761,7 +781,7 @@ static __inline__ int my_select(int nfds, fd_set *readfds, fd_set *writefds, fd_set *exceptfds, struct timeval *timeout) { if (nfds == 0 && timeout && (_emx_env & 0x200)) { - if (DosSleep(1000 * timeout->tv_sec + (timeout->tv_usec + 500)/1000) == 0) + if (async_mssleep(1000 * timeout->tv_sec + (timeout->tv_usec + 500)/1000, 500)) return 0; errno = EINTR; return -1; @@ -784,6 +804,18 @@ int getpriority(int which /* ignored */, int pid); void croak_with_os2error(char *s) __attribute__((noreturn)); +/* void return value */ +#define os2cp_croak(rc,msg) (CheckOSError(rc) && (croak_with_os2error(msg),0)) + +/* propagates rc */ +#define os2win_croak(rc,msg) \ + SaveCroakWinError((expr), 1 /* die */, /* no prefix */, (msg)) + +/* propagates rc; use with functions which may return 0 on success */ +#define os2win_croak_0OK(rc,msg) \ + SaveCroakWinError((ResetWinError, (expr)), \ + 1 /* die */, /* no prefix */, (msg)) + #ifdef PERL_CORE int os2_do_spawn(pTHX_ char *cmd); int os2_do_aspawn(pTHX_ SV *really, SV **vmark, SV **vsp); @@ -853,6 +885,192 @@ int os2_do_aspawn(pTHX_ SV *really, SV **vmark, SV **vsp); #endif +/* ************************************************* */ +#ifndef MAKEPLINFOSEG + +/* From $DDK\base32\rel\os2c\include\base\os2\16bit\infoseg.h + typedefs */ + +/* + * The structure below defines the content and organization of the system + * information segment (InfoSeg). The actual table is statically defined in + * SDATA.ASM. Ring 0, read/write access is obtained by the clock device + * driver using the DevHlp GetDOSVar function. (GetDOSVar returns a ring 0, + * read-only selector to all other requestors.) + * + * In order to prevent an errant process from destroying the infoseg, two + * identical global infosegs are maintained. One is in the tiled shared + * arena and is accessible in user mode (and therefore can potentially be + * overwritten from ring 2), and the other is in the system arena and is + * accessible only in kernel mode. All kernel code (except the clock driver) + * is responsible for updating BOTH copies of the infoseg. The copy kept + * in the system arena is addressable as DOSGROUP:SISData, and the copy + * in the shared arena is addressable via a system arena alias. 16:16 and + * 0:32 pointers to the alias are stored in _Sis2. + */ + +typedef struct InfoSegGDT { + +/* Time (offset 0x00) */ + +unsigned long SIS_BigTime; /* Time from 1-1-1970 in seconds */ +unsigned long SIS_MsCount; /* Freerunning milliseconds counter */ +unsigned char SIS_HrsTime; /* Hours */ +unsigned char SIS_MinTime; /* Minutes */ +unsigned char SIS_SecTime; /* Seconds */ +unsigned char SIS_HunTime; /* Hundredths of seconds */ +unsigned short SIS_TimeZone; /* Timezone in min from GMT (Set to EST) */ +unsigned short SIS_ClkIntrvl; /* Timer interval (units=0.0001 secs) */ + +/* Date (offset 0x10) */ + +unsigned char SIS_DayDate; /* Day-of-month (1-31) */ +unsigned char SIS_MonDate; /* Month (1-12) */ +unsigned short SIS_YrsDate; /* Year (>= 1980) */ +unsigned char SIS_DOWDate; /* Day-of-week (1-1-80 = Tues = 3) */ + +/* Version (offset 0x15) */ + +unsigned char SIS_VerMajor; /* Major version number */ +unsigned char SIS_VerMinor; /* Minor version number */ +unsigned char SIS_RevLettr; /* Revision letter */ + +/* System Status (offset 0x18) */ + +unsigned char SIS_CurScrnGrp; /* Fgnd screen group # */ +unsigned char SIS_MaxScrnGrp; /* Maximum number of screen groups */ +unsigned char SIS_HugeShfCnt; /* Shift count for huge segments */ +unsigned char SIS_ProtMdOnly; /* Protect-mode-only indicator */ +unsigned short SIS_FgndPID; /* Foreground process ID */ + +/* Scheduler Parms (offset 0x1E) */ + +unsigned char SIS_Dynamic; /* Dynamic variation flag (1=enabled) */ +unsigned char SIS_MaxWait; /* Maxwait (seconds) */ +unsigned short SIS_MinSlice; /* Minimum timeslice (milliseconds) */ +unsigned short SIS_MaxSlice; /* Maximum timeslice (milliseconds) */ + +/* Boot Drive (offset 0x24) */ + +unsigned short SIS_BootDrv; /* Drive from which system was booted */ + +/* RAS Major Event Code Table (offset 0x26) */ + +unsigned char SIS_mec_table[32]; /* Table of RAS Major Event Codes (MECs) */ + +/* Additional Session Data (offset 0x46) */ + +unsigned char SIS_MaxVioWinSG; /* Max. no. of VIO windowable SG's */ +unsigned char SIS_MaxPresMgrSG; /* Max. no. of Presentation Manager SG's */ + +/* Error logging Information (offset 0x48) */ + +unsigned short SIS_SysLog; /* Error Logging Status */ + +/* Additional RAS Information (offset 0x4A) */ + +unsigned short SIS_MMIOBase; /* Memory mapped I/O selector */ +unsigned long SIS_MMIOAddr; /* Memory mapped I/O address */ + +/* Additional 2.0 Data (offset 0x50) */ + +unsigned char SIS_MaxVDMs; /* Max. no. of Virtual DOS machines */ +unsigned char SIS_Reserved; + +unsigned char SIS_perf_mec_table[32]; /* varga 6/5/97 Table of Perfomance Major Event Codes (MECS) varga*/ +} GINFOSEG, *PGINFOSEG; + +#define SIS_LEN sizeof(struct InfoSegGDT) + +/* + * InfoSeg LDT Data Segment Structure + * + * The structure below defines the content and organization of the system + * information in a special per-process segment to be accessible by the + * process through the LDT (read-only). + * + * As in the global infoseg, two copies of the current processes local + * infoseg exist, one accessible in both user and kernel mode, the other + * only in kernel mode. Kernel code is responsible for updating BOTH copies. + * Pointers to the local infoseg copy are stored in _Lis2. + * + * Note that only the currently running process has an extra copy of the + * local infoseg. The copy is done at context switch time. + */ + +typedef struct InfoSegLDT { +unsigned short LIS_CurProcID; /* Current process ID */ +unsigned short LIS_ParProcID; /* Process ID of parent */ +unsigned short LIS_CurThrdPri; /* Current thread priority */ +unsigned short LIS_CurThrdID; /* Current thread ID */ +unsigned short LIS_CurScrnGrp; /* Screengroup */ +unsigned char LIS_ProcStatus; /* Process status bits */ +unsigned char LIS_fillbyte1; /* filler byte */ +unsigned short LIS_Fgnd; /* Current process is in foreground */ +unsigned char LIS_ProcType; /* Current process type */ +unsigned char LIS_fillbyte2; /* filler byte */ + +unsigned short LIS_AX; /* @@V1 Environment selector */ +unsigned short LIS_BX; /* @@V1 Offset of command line start */ +unsigned short LIS_CX; /* @@V1 Length of Data Segment */ +unsigned short LIS_DX; /* @@V1 STACKSIZE from the .EXE file */ +unsigned short LIS_SI; /* @@V1 HEAPSIZE from the .EXE file */ +unsigned short LIS_DI; /* @@V1 Module handle of the application */ +unsigned short LIS_DS; /* @@V1 Data Segment Handle of application */ + +unsigned short LIS_PackSel; /* First tiled selector in this EXE */ +unsigned short LIS_PackShrSel; /* First selector above shared arena */ +unsigned short LIS_PackPckSel; /* First selector above packed arena */ +/* #ifdef SMP */ +unsigned long LIS_pTIB; /* Pointer to TIB */ +unsigned long LIS_pPIB; /* Pointer to PIB */ +/* #endif */ +} LINFOSEG, *PLINFOSEG; + +#define LIS_LEN sizeof(struct InfoSegLDT) + + +/* + * Process Type codes + * + * These are the definitons for the codes stored + * in the LIS_ProcType field in the local infoseg. + */ + +#define LIS_PT_FULLSCRN 0 /* Full screen app. */ +#define LIS_PT_REALMODE 1 /* Real mode process */ +#define LIS_PT_VIOWIN 2 /* VIO windowable app. */ +#define LIS_PT_PRESMGR 3 /* Presentation Manager app. */ +#define LIS_PT_DETACHED 4 /* Detached app. */ + + +/* + * + * Process Status Bit Definitions + * + */ + +#define LIS_PS_EXITLIST 0x01 /* In exitlist handler */ + + +/* + * Flags equates for the Global Info Segment + * SIS_SysLog WORD in Global Info Segment + * + * xxxx xxxx xxxx xxx0 Error Logging Disabled + * xxxx xxxx xxxx xxx1 Error Logging Enabled + * + * xxxx xxxx xxxx xx0x Error Logging not available + * xxxx xxxx xxxx xx1x Error Logging available + */ + +#define LF_LOGENABLE 0x0001 /* Logging enabled */ +#define LF_LOGAVAILABLE 0x0002 /* Logging available */ + +#define MAKEPGINFOSEG(sel) ((PGINFOSEG)MAKEP(sel, 0)) +#define MAKEPLINFOSEG(sel) ((PLINFOSEG)MAKEP(sel, 0)) + +#endif /* ndef(MAKEPLINFOSEG) */ + /* ************************************************************ */ #define Dos32QuerySysState DosQuerySysState #define QuerySysState(flags, pid, buf, bufsz) \ diff --git a/gnu/usr.bin/perl/os2/perl2cmd.pl b/gnu/usr.bin/perl/os2/perl2cmd.pl index 4db40a0a313..07529ad8e82 100644 --- a/gnu/usr.bin/perl/os2/perl2cmd.pl +++ b/gnu/usr.bin/perl/os2/perl2cmd.pl @@ -2,6 +2,7 @@ # Note that we cannot put hashbang to be extproc to make Configure work. use Config; +use File::Compare; $dir = shift; $dir =~ s|/|\\|g ; @@ -26,9 +27,11 @@ foreach $file (<$idir/*>) { $base =~ s|\.pl$||; #$file =~ s|/|\\|g ; warn "Clashing output name for $file, skipping" if $seen{$base}++; - print "Processing $file => $dir\\$base.cmd\n"; + my $new = (-f "$dir/$base.cmd" ? '' : ' (new file)'); + print "Processing $file => $dir/$base.cmd$new\n"; + my $ext = ($new ? '.cmd' : '.tcm'); open IN, '<', $file or warn, next; - open OUT, '>', "$dir/$base.cmd" or warn, next; + open OUT, '>', "$dir/$base$ext" or warn, next; my $firstline = <IN>; my $flags = ''; $flags = $2 if $firstline =~ /^#!\s*(\S+)\s+-([^#]+?)\s*(#|$)/; @@ -36,5 +39,16 @@ foreach $file (<$idir/*>) { print OUT $_ while <IN>; close IN or warn, next; close OUT or warn, next; + chmod 0444, "$dir/$base$ext"; + next if $new; + if (compare "$dir/$base$ext", "$dir/$base.cmd") { # different + chmod 0666, "$dir/$base.cmd"; + unlink "$dir/$base.cmd"; + rename "$dir/$base$ext", "$dir/$base.cmd"; + } else { + chmod 0666, "$dir/$base$ext"; + unlink "$dir/$base$ext"; + print "...unchanged...\n"; + } } |