summaryrefslogtreecommitdiff
path: root/os2
diff options
context:
space:
mode:
authorIlya Zakharevich <ilya@math.berkeley.edu>2003-06-14 10:49:57 -0700
committerJarkko Hietaniemi <jhi@iki.fi>2003-06-15 17:08:02 +0000
commit622913ab81739f4a9419ed541a122ff2495c8ab1 (patch)
tree06a71ddf809f0904979a43c23c68dae3939718db /os2
parent41be1fbddbbc49a5c34acad74f2905b11dd0ced0 (diff)
downloadperl-622913ab81739f4a9419ed541a122ff2495c8ab1.tar.gz
OS2 patches
Message-ID: <20030615004956.GA28272@math.berkeley.edu> p4raw-id: //depot/perl@19789
Diffstat (limited to 'os2')
-rw-r--r--os2/OS2/Process/Makefile.PL2
-rw-r--r--os2/OS2/Process/Process.pm276
-rw-r--r--os2/OS2/Process/Process.xs400
-rw-r--r--os2/OS2/REXX/DLL/DLL.pm239
-rw-r--r--os2/OS2/REXX/DLL/DLL.xs100
-rw-r--r--os2/OS2/REXX/t/rx_emxrv.t39
-rw-r--r--os2/OS2/REXX/t/rx_objcall.t7
-rw-r--r--os2/OS2/typemap (renamed from os2/OS2/PrfDB/typemap)20
-rw-r--r--os2/dl_os2.c102
-rw-r--r--os2/os2.c1402
-rw-r--r--os2/os2ish.h86
-rw-r--r--os2/perlrexx.cmd68
12 files changed, 2384 insertions, 357 deletions
diff --git a/os2/OS2/Process/Makefile.PL b/os2/OS2/Process/Makefile.PL
index 6a59d1f013..c24af0c1ed 100644
--- a/os2/OS2/Process/Makefile.PL
+++ b/os2/OS2/Process/Makefile.PL
@@ -32,7 +32,7 @@ sub create_constants {
'--skip-strict', '--skip-warnings', # likewise
'--skip-ppport', # will not work without dynaloading.
# Most useful for OS2::Process:
- '-M^(HWND|WM|SC|SWP|WC|PROG|QW|EDI|WS|QWS|QWP|QWL|FF|FI|LS|FS|FCF|BS|MS|TBM|CF|CFI|FID)_',
+ '-M^(HWND|WM|SC|SWP|WC|PROG|QW|EDI|WS|QWS|QWP|QWL|FF|FI|LS|FS|FCF|BS|MS|TBM|CF|CFI|FID|MB|MBID|CF|CFI|SPTR)_',
'-F', '-DINCL_NLS -DINCL_BASE -DINCL_PM', # Define more symbols
'os2emx.h' # EMX version of OS/2 API
and warn("Can't build module with contants, falling back to no constants"),
diff --git a/os2/OS2/Process/Process.pm b/os2/OS2/Process/Process.pm
index 29e4d9b433..956e8fd935 100644
--- a/os2/OS2/Process/Process.pm
+++ b/os2/OS2/Process/Process.pm
@@ -101,6 +101,7 @@ our @EXPORT = qw(
ChildWindows
out_codepage
out_codepage_set
+ process_codepage_set
in_codepage
in_codepage_set
cursor
@@ -124,6 +125,45 @@ our @EXPORT = qw(
SetWindowPtr
SetWindowULong
SetWindowUShort
+ 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
get_title
set_title
@@ -178,7 +218,7 @@ sub import {
my $ini = @_;
@_ = ($class,
map {
- /^(HWND|WM|SC|SWP|WC|PROG|QW|EDI|WS|QWS|QWP|QWL|FF|FI|LS|FS|FCF|BS|MS|TBM|CF|CFI|FID)_/ ? const_import($_) : $_
+ /^(HWND|WM|SC|SWP|WC|PROG|QW|EDI|WS|QWS|QWP|QWL|FF|FI|LS|FS|FCF|BS|MS|TBM|CF|CFI|FID|MB|MBID|CF|CFI|SPTR)_/ ? const_import($_) : $_
} @_);
goto &Exporter::import if @_ > 1 or $ini == 0;
}
@@ -335,6 +375,117 @@ sub ChildWindows (;$) {
@kids;
}
+sub TopLevel ($) {
+ my $d = DesktopWindow;
+ my $w = shift;
+ while (1) {
+ my $p = QueryWindow $w, 5; # QW_PARENT;
+ return $w if not $p or $p == $d;
+ $w = $p;
+ }
+}
+
+sub FocusWindow_set_keep_Zorder ($) {
+ my $w = shift;
+ my $t = TopLevel $w;
+ my $b = hWindowPos($t)->{behind}; # we are behind this
+ EnableWindowUpdate($t, 0);
+ FocusWindow_set($w);
+# sleep 1; # Make flicker stronger when present
+ hWindowPos_set {behind => $b}, $t;
+ EnableWindowUpdate($t, 1);
+}
+
+sub ClipbrdText (@) {
+ my $morph = OS2::localMorphPM->new(0);
+ OpenClipbrd();
+ my $txt = unpack 'p', pack 'L', ClipbrdData @_;
+ CloseClipbrd();
+ $txt;
+}
+
+sub ClipbrdText_set ($;$) {
+ my $morph = OS2::localMorphPM->new(0);
+ OpenClipbrd();
+ EmptyClipbrd(); # It may contain other types
+ my ($txt, $no_convert_nl) = (shift, shift);
+ ClipbrdData_set($txt, !$no_convert_nl, @_);
+ CloseClipbrd();
+}
+
+sub MessageBox ($;$$$$$) {
+ my $morph = OS2::localMorphPM->new(0);
+ die "MessageBox needs text" unless @_;
+ push @_ , ($0 eq '-e' ? "Perl one-liner's message" : "$0 message") if @_ == 1;
+ &_MessageBox;
+}
+
+my %pointers;
+
+sub get_pointer ($;$$) {
+ my $id = $_[0];
+ return $pointers{$id} if exists $pointers{$id};
+ $pointers{$id} = &SysPointer;
+}
+
+# $button needs to be of the form 'String', ['String'] or ['String', flag].
+# If ['String'], it is assumed the default button; same for 'String' if $only
+# is set.
+sub process_MB2 ($$;$) {
+ die "process_MB2() needs 2 arguments, got '@_'" unless @_ == 2 or @_ == 3;
+ my ($button, $ret, $only) = @_;
+ # default is BS_PUSHBUTTON, add BS_DEFAULT if $only is set
+ $button = [$button, $only ? 0x400 : 0] unless ref $button eq 'ARRAY';
+ push @$button, 0x400 if @$button == 1; # BS_PUSHBUTTON|BS_DEFAULT
+ die "Button needs to be of the form 'String', ['String'] or ['String', flag]"
+ unless @$button == 2;
+ pack "Z71 x L l", $button->[0], $ret, $button->[1]; # name, retval, flag
+}
+
+# If one button, make it the default one even if it is of 'String' => val form.
+# If icon is of the form 'SP#<number>', load this via SysPointer.
+sub process_MB2_INFO ($;$$$) {
+ my $l = 0;
+ my $out;
+ die "process_MB2_INFO() needs 1..4 arguments" unless @_ and @_ < 5;
+ my $buttons = shift;
+ die "Buttons array should consist of pairs" if @$buttons % 2;
+
+ push @_, 0 unless @_; # Icon id (pointer)
+ # Box flags (MB_MOVABLE and MB_INFORMATION or MB_CUSTOMICON)
+ push @_, ($_[0] ? 0x4080 : 0x4030) unless @_ > 1;
+ push @_, 0 unless @_ > 2; # Notify window
+
+ my ($icon, $style, $notify) = (shift, shift, shift);
+ $icon = get_pointer $1 if $icon =~ /^SP#(\d+)\z/;
+ $out = pack "L L L L", # icon, #buttons, style, notify, buttons
+ $icon, @$buttons/2, $style, $notify;
+ $out .= join '',
+ map process_MB2($buttons->[2*$_], $buttons->[2*$_+1], @$buttons == 2),
+ 0..@$buttons/2-1;
+ pack('L', length(pack 'L', 0) + length $out) . $out;
+}
+
+# MessageBox2 'Try this', OS2::Process::process_MB2_INFO([['Dismiss', 0] => 0x1000], OS2::Process::get_pointer(22),0x4080,0), 'me', 1, 0, 0
+# or the shortcut
+# MessageBox2 'Try this', [[['Dismiss', 0] => 0x1000], 'SP#22'], 'me'
+# 0x80 means MB_CUSTOMICON (does not focus?!). This focuses:
+# MessageBox2 'Try this', [[['Dismiss',0x400] => 0x1000], 0, 0x4030,0]
+# 0x400 means BS_DEFAULT. This is the same as the shortcut
+# MessageBox2 'Try this', [[Dismiss => 0x1000]]
+sub MessageBox2 ($;$$$$$) {
+ my $morph = OS2::localMorphPM->new(0);
+ die "MessageBox needs text" unless @_;
+ push @_ , [[Dismiss => 0x1000], # Name, retval (BS_PUSHBUTTON|BS_DEFAULT)
+ #0, # get_pointer(11), # SPTR_ICONINFORMATION
+ #0x4030, # MB_MOVEABLE | MB_INFORMATION
+ #0, # Notify window; was 1==HWND_DESKTOP
+ ] if @_ == 1;
+ push @_ , ($0 eq '-e' ? "Perl one-liner's message" : "$0's message") if @_ == 2;
+ $_[1] = &process_MB2_INFO(@{$_[1]}) if ref($_[1]) eq 'ARRAY';
+ &_MessageBox2;
+}
+
# backward compatibility
*set_title = \&Title_set;
*get_title = \&Title;
@@ -551,7 +702,19 @@ gets a buffer with characters and attributes of the screen.
=item C<screen_set($buffer)>
-restores the screen given the result of screen().
+restores the screen given the result of screen(). E.g., if the file
+C<$file> contains the sceen contents, then
+
+ open IN, $file or die;
+ binmode IN;
+ read IN, $in, -s IN;
+ $s = screen;
+ $in .= qq(\0) x (length($s) - length $in);
+ substr($in, length $s) = '';
+ screen_set $in;
+
+will restore the screen content even if the height of the window
+changed (if the width changed, more manipulation is needed).
=back
@@ -705,9 +868,9 @@ titlebar of the current window.
sets text of the titlebar and task switch menu of the current process' window
via direct manipulation of the windows' texts.
-=item C<SwitchToProgram($sw_entry)>
+=item C<SwitchToProgram([$sw_entry])>
-switch to session given by a switch list handle.
+switch to session given by a switch list handle (defaults to the entry of our process).
Use of this function causes another window (and its related windows)
of a PM session to appear on the front of the screen, or a switch to
@@ -824,10 +987,18 @@ to use. E.g, the first entry in program_entries() is the C<Ctrl-Esc> list.
To show an application, use either one of
WinShowWindow( $hwnd, 1 );
- SetFocus( $hwnd );
+ FocusWindow_set( $hwnd );
SwitchToProgram($switch_handle);
-(Which work with alternative focus-to-front policies?) Requires (morphing to) PM.
+(Which work with alternative focus-to-front policies?) Requires
+(morphing to) PM.
+
+Switching focus to currently-unfocused window moves the window to the
+front in Z-order; use FocusWindow_set_keep_Zorder() to avoid this.
+
+=item C<FocusWindow_set_keep_Zorder($hwnd)>
+
+same as FocusWindow_set(), but preserves the Z-order of windows.
=item C<ActiveWindow([$parentHwnd])>
@@ -1013,6 +1184,16 @@ item list when beginning is reached.
=back
+=item DesktopWindow()
+
+gets the actual window handle of the PM desktop; most APIs accept the
+pseudo-handle C<HWND_DESKTOP> instead. Keep in mind that the WPS
+desktop (one with WindowText() being C<"Desktop">) is a different beast?!
+
+=item TopLevel($hwnd)
+
+gets the toplevel window of $hwnd.
+
=item ResetWinError()
Resets $^E. One may need to call it before the C<Win*>-class APIs which may
@@ -1031,6 +1212,77 @@ This function is normally not needed. Not exported by default.
=back
+=head2 Control of the PM data
+
+=over
+
+=item ActiveDesktopPathname()
+
+gets the path of the directory which corresponds to Desktop.
+
+=item ClipbrdText()
+
+gets the content of the clipboard. An optional argument is the format
+of the data in the clipboard (defaults to C<CF_TEXT>).
+
+Note that the usual convention is to have clipboard data with
+C<"\r\n"> as line separators.
+
+=item ClipbrdText_set($txt)
+
+sets the text content of the clipboard. Unless the optional argument
+is TRUE, will convert newlines to C<"\r\n">. Another optional
+argument is the format of the data in the clipboard (defaults to
+C<CF_TEXT>).
+
+=item InvalidateRect
+
+=item CreateFrameControl
+
+=item ClipbrdFmtInfo
+
+=item ClipbrdOwner
+
+=item ClipbrdViewer
+
+=item ClipbrdData
+
+=item OpenClipbrd
+
+=item CloseClipbrd
+
+=item ClipbrdData_set
+
+=item ClipbrdOwner_set
+
+=item ClipbrdViewer_set
+
+=item EnumClipbrdFmts
+
+=item EmptyClipbrd
+
+=item AddAtom
+
+=item FindAtom
+
+=item DeleteAtom
+
+=item AtomUsage
+
+=item AtomName
+
+=item AtomLength
+
+=item SystemAtomTable
+
+=item CreateAtomTable
+
+=item DestroyAtomTable
+
+Low-level methods to access clipboard and the atom table(s).
+
+=back
+
=head1 OS2::localMorphPM class
This class morphs the process to PM for the duration of the given scope.
@@ -1072,12 +1324,14 @@ Add tests for:
scrsize
scrsize_set
-Document:
-Query/SetWindowULong/Short/Ptr, SetWindowBits.
+Document and test: Query/SetWindowULong/Short/Ptr, SetWindowBits.
+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
-Implement InvalidateRect,
-CreateFrameControl. ClipbrdFmtInfo, ClipbrdData, OpenClipbrd, CloseClipbrd,
-ClipbrdData_set, EnumClipbrdFmt, EmptyClipbrd. SOMETHINGFROMMR.
+Implement SOMETHINGFROMMR.
>But I wish to change the default button if the user enters some
diff --git a/os2/OS2/Process/Process.xs b/os2/OS2/Process/Process.xs
index 1e75951c5d..97e5d2f695 100644
--- a/os2/OS2/Process/Process.xs
+++ b/os2/OS2/Process/Process.xs
@@ -7,6 +7,8 @@
#define INCL_WININPUT
#define INCL_VIO
#define INCL_KBD
+#define INCL_WINCLIPBOARD
+#define INCL_WINATOM
#include <os2.h>
#include "EXTERN.h"
@@ -234,12 +236,14 @@ file_type(char *path)
if (!(_emx_env & 0x200))
croak("file_type not implemented on DOS"); /* not OS/2. */
if (CheckOSError(DosQueryAppType(path, &apptype))) {
+#if 0
if (rc == ERROR_INVALID_EXE_SIGNATURE)
croak("Invalid EXE signature");
else if (rc == ERROR_EXE_MARKED_INVALID) {
croak("EXE marked invalid");
}
- croak("DosQueryAppType err %ld", rc);
+#endif
+ croak_with_os2error("DosQueryAppType");
}
return apptype;
@@ -260,7 +264,7 @@ DeclFuncByORD(ULONG, XmyWinSwitchToProgram, ORD_WinSwitchToProgram,
#define myWinSwitchToProgram(hsw) (!CheckOSError(XmyWinSwitchToProgram(hsw)))
-
+/* These function croak if the return value is 0. */
DeclWinFunc_CACHE(HWND, QueryWindow, (HWND hwnd, LONG cmd), (hwnd, cmd))
DeclWinFunc_CACHE(BOOL, QueryWindowPos, (HWND hwnd, PSWP pswp),
(hwnd, pswp))
@@ -300,6 +304,63 @@ DeclWinFunc_CACHE(HWND, EnumDlgItem, (HWND hwndDlg, HWND hwnd, ULONG code),
DeclWinFunc_CACHE(HWND, QueryDesktopWindow, (HAB hab, HDC hdc), (hab, hdc));
DeclWinFunc_CACHE(BOOL, SetActiveWindow, (HWND hwndDesktop, HWND hwnd),
(hwndDesktop, hwnd));
+DeclWinFunc_CACHE(BOOL, QueryActiveDesktopPathname, (PSZ pszPathName, ULONG ulSize),
+ (pszPathName, ulSize));
+DeclWinFunc_CACHE(BOOL, InvalidateRect,
+ (HWND hwnd, /*RECTL*/ char *prcl, BOOL fIncludeChildren),
+ (hwnd, prcl, fIncludeChildren));
+DeclWinFunc_CACHE(BOOL, CreateFrameControls,
+ (HWND hwndFrame, /*PFRAMECDATA*/ char* pfcdata, PCSZ pszTitle),
+ (hwndFrame, pfcdata, pszTitle));
+DeclWinFunc_CACHE(BOOL, OpenClipbrd, (HAB hab), (hab));
+DeclWinFunc_CACHE(BOOL, EmptyClipbrd, (HAB hab), (hab));
+DeclWinFunc_CACHE(BOOL, CloseClipbrd, (HAB hab), (hab));
+DeclWinFunc_CACHE(HWND, QueryClipbrdViewer, (HAB hab), (hab));
+DeclWinFunc_CACHE(HWND, QueryClipbrdOwner, (HAB hab), (hab));
+DeclWinFunc_CACHE(BOOL, QueryClipbrdFmtInfo, (HAB hab, ULONG fmt, PULONG prgfFmtInfo), (hab, fmt, prgfFmtInfo));
+DeclWinFunc_CACHE(ULONG, QueryClipbrdData, (HAB hab, ULONG fmt), (hab, fmt));
+DeclWinFunc_CACHE(HWND, SetClipbrdViewer, (HAB hab, HWND hwnd), (hab, hwnd));
+DeclWinFunc_CACHE(HWND, SetClipbrdOwner, (HAB hab, HWND hwnd), (hab, hwnd));
+DeclWinFunc_CACHE(ULONG, EnumClipbrdFmts, (HAB hab, ULONG fmt), (hab, fmt));
+DeclWinFunc_CACHE(ATOM, AddAtom, (HATOMTBL hAtomTbl, PCSZ pszAtomName),
+ (hAtomTbl, pszAtomName));
+DeclWinFunc_CACHE(ATOM, FindAtom, (HATOMTBL hAtomTbl, PCSZ pszAtomName),
+ (hAtomTbl, pszAtomName));
+DeclWinFunc_CACHE(ATOM, DeleteAtom, (HATOMTBL hAtomTbl, PCSZ pszAtomName),
+ (hAtomTbl, pszAtomName));
+DeclWinFunc_CACHE(ULONG, QueryAtomUsage, (HATOMTBL hAtomTbl, ATOM atom),
+ (hAtomTbl, atom));
+DeclWinFunc_CACHE(ULONG, QueryAtomLength, (HATOMTBL hAtomTbl, ATOM atom),
+ (hAtomTbl, atom));
+DeclWinFunc_CACHE(ULONG, QueryAtomName,
+ (HATOMTBL hAtomTbl, ATOM atom, PSZ pchBuffer, ULONG cchBufferMax),
+ (hAtomTbl, atom, pchBuffer, cchBufferMax));
+DeclWinFunc_CACHE(HATOMTBL, QuerySystemAtomTable, (VOID), ());
+DeclWinFunc_CACHE(HATOMTBL, CreateAtomTable, (ULONG initial, ULONG buckets),
+ (initial, buckets));
+DeclWinFunc_CACHE(HATOMTBL, DestroyAtomTable, (HATOMTBL hAtomTbl), (hAtomTbl));
+DeclWinFunc_CACHE(ULONG, MessageBox, (HWND hwndParent, HWND hwndOwner, PCSZ pszText, PCSZ pszCaption, ULONG idWindow, ULONG flStyle), (hwndParent, hwndOwner, pszText, pszCaption, idWindow, flStyle));
+DeclWinFunc_CACHE(ULONG, MessageBox2,
+ (HWND hwndParent, HWND hwndOwner, PCSZ pszText,
+ PCSZ pszCaption, ULONG idWindow, PMB2INFO pmb2info),
+ (hwndParent, hwndOwner, pszText, pszCaption, idWindow, pmb2info));
+DeclWinFunc_CACHE(HPOINTER, LoadPointer,
+ (HWND hwndDesktop, HMODULE hmod, ULONG idres),
+ (hwndDesktop, hmod, idres));
+DeclWinFunc_CACHE(HPOINTER, QuerySysPointer,
+ (HWND hwndDesktop, LONG lId, BOOL fCopy),
+ (hwndDesktop, lId, fCopy));
+DeclWinFunc_CACHE(BOOL, Alarm, (HWND hwndDesktop, ULONG rgfType), (hwndDesktop, rgfType));
+DeclWinFunc_CACHE(BOOL, FlashWindow, (HWND hwndFrame, BOOL fFlash), (hwndFrame, fFlash));
+
+
+/* These functions do not croak on error */
+DeclWinFunc_CACHE_survive(BOOL, SetClipbrdData,
+ (HAB hab, ULONG ulData, ULONG fmt, ULONG rgfFmtInfo),
+ (hab, ulData, fmt, rgfFmtInfo));
+
+#define get_InvalidateRect InvalidateRect
+#define get_CreateFrameControls CreateFrameControls
/* These functions may return 0 on success; check $^E/Perl_rc on res==0: */
DeclWinFunc_CACHE_resetError(PVOID, QueryWindowPtr, (HWND hwnd, LONG index),
@@ -334,6 +395,9 @@ HWND (*pWinWindowFromPoint)(HWND hwnd, __const__ POINTL *pptl, BOOL fChildren);
#define WindowPos_set(hwnd, x, y, fl, cx, cy, hwndInsertBehind) \
SetWindowPos(hwnd, hwndInsertBehind, x, y, cx, cy, fl)
#define myWinQueryWindowPtr(hwnd, i) ((ULONG)QueryWindowPtr(hwnd, i))
+#define _ClipbrdData_set SetClipbrdData
+#define ClipbrdOwner_set SetClipbrdOwner
+#define ClipbrdViewer_set SetClipbrdViewer
int
WindowText_set(HWND hwnd, char* text)
@@ -355,7 +419,7 @@ myQueryWindowText(HWND hwnd)
}
sv = newSVpvn("", 0);
SvGROW(sv, l + 1);
- len = WinQueryWindowText(hwnd, l + 1, SvPV_force(sv, n_a));
+ len = QueryWindowText(hwnd, l + 1, SvPV_force(sv, n_a));
if (len != l) {
Safefree(sv);
croak("WinQueryWindowText() uncompatible with WinQueryWindowTextLength()");
@@ -411,20 +475,29 @@ WindowFromPoint(long x, long y, HWND hwnd, BOOL fChildren)
return SaveWinError(pWinWindowFromPoint(hwnd, &ppl, fChildren));
}
-static void
-fill_swentry(SWENTRY *swentryp, HWND hwnd, PID pid)
+static HSWITCH
+switch_of(HWND hwnd, PID pid)
{
- int rc;
HSWITCH hSwitch;
if (!(_emx_env & 0x200))
croak("switch_entry not implemented on DOS"); /* not OS/2. */
if (CheckWinError(hSwitch =
myWinQuerySwitchHandle(hwnd, pid)))
- croak("WinQuerySwitchHandle: %s", os2error(Perl_rc));
+ croak_with_os2error("WinQuerySwitchHandle");
+ return hSwitch;
+}
+
+
+static void
+fill_swentry(SWENTRY *swentryp, HWND hwnd, PID pid)
+{
+ int rc;
+ HSWITCH hSwitch = switch_of(hwnd, pid);
+
swentryp->hswitch = hSwitch;
if (CheckOSError(myWinQuerySwitchEntry(hSwitch, &swentryp->swctl)))
- croak("WinQuerySwitchEntry err %ld", rc);
+ croak_with_os2error("WinQuerySwitchEntry");
}
static void
@@ -433,6 +506,103 @@ fill_swentry_default(SWENTRY *swentryp)
fill_swentry(swentryp, NULLHANDLE, getpid());
}
+static SV*
+myWinQueryActiveDesktopPathname()
+{
+ SV *buf = newSVpv("",0);
+ STRLEN n_a;
+
+ SvGROW(buf, MAXPATHLEN);
+ QueryActiveDesktopPathname(SvPV(buf,n_a), MAXPATHLEN);
+ SvCUR_set(buf, strlen(SvPV(buf, n_a)));
+ return buf;
+}
+
+SV *
+myWinQueryAtomName(ATOM atom, HATOMTBL hAtomTbl)
+{
+ ULONG len = QueryAtomLength(hAtomTbl, atom);
+ SV *sv = newSVpvn("",0);
+ STRLEN n_a;
+
+ SvGROW(sv, len + 1);
+ QueryAtomName(hAtomTbl, atom, SvPV(sv, n_a), len);
+ SvCUR_set(sv, len);
+ *SvEND(sv) = 0;
+ return sv;
+}
+
+#define myWinQueryClipbrdFmtInfo QueryClipbrdFmtInfo
+
+/* Put data into shared memory, then call SetClipbrdData */
+void
+ClipbrdData_set(SV *sv, int convert_nl, unsigned long fmt, unsigned long rgfFmtInfo, HAB hab)
+{
+ STRLEN len;
+ char *buf = SvPV_force(sv, len);
+ char *pByte = 0, *s = buf, c;
+ ULONG nls = 0, rc;
+
+ if (convert_nl) {
+ while ((c = *s++)) {
+ if (c == '\r' && *s == '\n')
+ s++;
+ else if (c == '\n')
+ nls++;
+ }
+ }
+
+ if (CheckOSError(DosAllocSharedMem((PPVOID)&pByte, 0, len + nls + 1,
+ PAG_WRITE | PAG_COMMIT | OBJ_GIVEABLE | OBJ_GETTABLE)))
+ croak_with_os2error("ClipbrdData_set: DosAllocSharedMem error");
+
+ if (!nls)
+ memcpy(pByte, buf, len + 1);
+ else {
+ char *t = pByte, *e = buf + len;
+
+ while (buf < e) {
+ c = *t++ = *buf++;
+ if (c == '\n' && (t == pByte + 1 || t[-2] != '\r'))
+ t[-1] = '\r', *t++ = '\n';
+ }
+ }
+
+ if (!SetClipbrdData(hab, (ULONG)pByte, fmt, rgfFmtInfo)) {
+ DosFreeMem((PPVOID)&pByte);
+ croak_with_os2error("ClipbrdData_set: WinSetClipbrdData error");
+ }
+}
+
+#if 0
+
+ULONG
+myWinMessageBox(HWND hwndParent, HWND hwndOwner, PCSZ pszText, PCSZ pszCaption, ULONG idWindow, ULONG flStyle)
+{
+ ULONG rc = MessageBox(hwndParent, hwndOwner, pszText, pszCaption,
+ idWindow, flStyle);
+
+ if (rc == MBID_ERROR)
+ rc = 0;
+ if (CheckWinError(rc))
+ croak_with_os2error("MessageBox");
+ return rc;
+}
+
+ULONG
+myWinMessageBox2(HWND hwndParent, HWND hwndOwner, PCSZ pszText,
+ PCSZ pszCaption, ULONG idWindow, PMB2INFO pmb2info)
+{
+ ULONG rc = MessageBox2(hwndParent, hwndOwner, pszText, pszCaption, idWindow, pmb2info);
+
+ if (rc == MBID_ERROR)
+ rc = 0;
+ if (CheckWinError(rc))
+ croak_with_os2error("MessageBox2");
+ return rc;
+}
+#endif
+
/* static ULONG (* APIENTRY16 pDosSmSetTitle)(ULONG, PSZ); */
ULONG _THUNK_FUNCTION(DosSmSetTitle)(ULONG, PSZ);
@@ -508,7 +678,7 @@ set_title2(char *s)
#endif
SV *
-process_swentry(unsigned long pid, unsigned long hwnd)
+process_swentry(unsigned long pid, HWND hwnd)
{
SWENTRY swentry;
@@ -660,7 +830,7 @@ cursor(int *sp, int *ep, int *wp, int *ap)
VIO_FROM_VIOB;
if (CheckOSError(VioGetCurType( vio, 0 )))
- croak("VioGetCurType() error");
+ croak_with_os2error("VioGetCurType() error");
*sp = vio->yStart;
*ep = vio->cEnd;
@@ -706,7 +876,7 @@ bufsize(void)
vio->cb = sizeof(*vio);
if (CheckOSError(VioGetMode( vio, 0 )))
- croak("Can't get size of buffer for screen");
+ croak_with_os2error("Can't get size of buffer for screen");
#if 0 /* buf=323552247, full=1118455, partial=0 */
croak("Lengths: buf=%d, full=%d, partial=%d",vio->buf_length,vio->full_length,vio->partial_length);
return newSVpvn((char*)vio->buf_addr, vio->full_length);
@@ -766,7 +936,7 @@ process_codepages()
ULONG cps[4], cp, rc;
if (CheckOSError(DosQueryCp( sizeof(cps), cps, &cp )))
- croak("DosQueryCp() error");
+ croak_with_os2error("DosQueryCp()");
return cp;
}
@@ -776,7 +946,7 @@ out_codepage()
USHORT cp, rc;
if (CheckOSError(VioGetCp( 0, &cp, 0 )))
- croak("VioGetCp() error");
+ croak_with_os2error("VioGetCp()");
return cp;
}
@@ -794,7 +964,7 @@ in_codepage()
USHORT cp, rc;
if (CheckOSError(KbdGetCp( 0, &cp, 0 )))
- croak("KbdGetCp() error");
+ croak_with_os2error("KbdGetCp()");
return cp;
}
@@ -853,6 +1023,9 @@ sidOf(int pid)
#define ulMPFROMSH2CH(s, c1, c2) ((unsigned long)MPFROMSH2CH(s, c1, c2))
#define ulMPFROMLONG(x) ((unsigned long)MPFROMLONG(x))
+#define _MessageBox MessageBox
+#define _MessageBox2 MessageBox2
+
MODULE = OS2::Process PACKAGE = OS2::Process
PROTOTYPES: ENABLE
@@ -904,7 +1077,7 @@ sesmgr_title_set(s)
char *s
SV *
-process_swentry(unsigned long pid = getpid(), unsigned long hwnd = NULLHANDLE);
+process_swentry(unsigned long pid = getpid(), HWND hwnd = NULLHANDLE);
PROTOTYPE: DISABLE
int
@@ -917,27 +1090,27 @@ void
ResetWinError()
int
-WindowText_set(unsigned long hwndFrame, char *title)
+WindowText_set(HWND hwndFrame, char *title)
bool
-FocusWindow_set(unsigned long hwndFocus, unsigned long hwndDesktop = HWND_DESKTOP)
+FocusWindow_set(HWND hwndFocus, HWND hwndDesktop = HWND_DESKTOP)
bool
-ShowWindow(unsigned long hwnd, bool fShow = TRUE)
+ShowWindow(HWND hwnd, bool fShow = TRUE)
bool
-EnableWindow(unsigned long hwnd, bool fEnable = TRUE)
+EnableWindow(HWND hwnd, bool fEnable = TRUE)
bool
-PostMsg(unsigned long hwnd, unsigned long msg, unsigned long mp1 = 0, unsigned long mp2 = 0)
+PostMsg(HWND hwnd, unsigned long msg, unsigned long mp1 = 0, unsigned long mp2 = 0)
C_ARGS: hwnd, msg, (MPARAM)mp1, (MPARAM)mp2
bool
-WindowPos_set(unsigned long hwnd, long x, long y, unsigned long fl = SWP_MOVE, long cx = 0, long cy = 0, unsigned long hwndInsertBehind = HWND_TOP)
+WindowPos_set(HWND hwnd, long x, long y, unsigned long fl = SWP_MOVE, long cx = 0, long cy = 0, HWND hwndInsertBehind = HWND_TOP)
PROTOTYPE: DISABLE
unsigned long
-BeginEnumWindows(unsigned long hwnd)
+BeginEnumWindows(HWND hwnd)
bool
EndEnumWindows(unsigned long henum)
@@ -946,56 +1119,60 @@ unsigned long
GetNextWindow(unsigned long henum)
bool
-IsWindowVisible(unsigned long hwnd)
+IsWindowVisible(HWND hwnd)
bool
-IsWindowEnabled(unsigned long hwnd)
+IsWindowEnabled(HWND hwnd)
bool
-IsWindowShowing(unsigned long hwnd)
+IsWindowShowing(HWND hwnd)
unsigned long
-QueryWindow(unsigned long hwnd, long cmd)
+QueryWindow(HWND hwnd, long cmd)
unsigned long
-IsChild(unsigned long hwnd, unsigned long hwndParent)
+IsChild(HWND hwnd, HWND hwndParent)
unsigned long
-WindowFromId(unsigned long hwndParent, unsigned long id)
+WindowFromId(HWND hwndParent, unsigned long id)
unsigned long
-WindowFromPoint(long x, long y, unsigned long hwnd = HWND_DESKTOP, bool fChildren = TRUE)
+WindowFromPoint(long x, long y, HWND hwnd = HWND_DESKTOP, bool fChildren = TRUE)
PROTOTYPE: DISABLE
unsigned long
-EnumDlgItem(unsigned long hwndDlg, unsigned long code, unsigned long hwnd = NULLHANDLE)
+EnumDlgItem(HWND hwndDlg, unsigned long code, HWND hwnd = NULLHANDLE)
C_ARGS: hwndDlg, hwnd, code
bool
-EnableWindowUpdate(unsigned long hwnd, bool fEnable = TRUE)
+EnableWindowUpdate(HWND hwnd, bool fEnable = TRUE)
bool
-SetWindowBits(unsigned long hwnd, long index, unsigned long flData, unsigned long flMask)
+SetWindowBits(HWND hwnd, long index, unsigned long flData, unsigned long flMask)
bool
-SetWindowPtr(unsigned long hwnd, long index, unsigned long p)
+SetWindowPtr(HWND hwnd, long index, unsigned long p)
C_ARGS: hwnd, index, (PVOID)p
bool
-SetWindowULong(unsigned long hwnd, long index, unsigned long i)
+SetWindowULong(HWND hwnd, long index, unsigned long i)
bool
-SetWindowUShort(unsigned long hwnd, long index, unsigned short i)
+SetWindowUShort(HWND hwnd, long index, unsigned short i)
bool
-IsWindow(unsigned long hwnd, unsigned long hab = Acquire_hab())
+IsWindow(HWND hwnd, HAB hab = Acquire_hab())
C_ARGS: hab, hwnd
BOOL
-ActiveWindow_set(unsigned long hwnd, unsigned long hwndDesktop = HWND_DESKTOP)
+ActiveWindow_set(HWND hwnd, HWND hwndDesktop = HWND_DESKTOP)
CODE:
RETVAL = SetActiveWindow(hwndDesktop, hwnd);
+unsigned long
+LoadPointer(unsigned long idres, unsigned long hmod = 0, HWND hwndDesktop = HWND_DESKTOP)
+ C_ARGS: hwndDesktop, hmod, idres
+
int
out_codepage()
@@ -1039,56 +1216,173 @@ cursor(OUTLIST int stp, OUTLIST int ep, OUTLIST int wp, OUTLIST int ap)
bool
cursor_set(int s, int e, int w = cursor__(0), int a = cursor__(1))
+NO_OUTPUT bool
+_ClipbrdData_set(unsigned long ulData, unsigned long fmt = CF_TEXT, unsigned long rgfFmtInfo = ((fmt == CF_TEXT || fmt == CF_DSPTEXT) ? CFI_POINTER : CFI_HANDLE), HAB hab = perl_hab_GET())
+ PROTOTYPE: DISABLE
+ C_ARGS: hab, ulData, fmt, rgfFmtInfo
+ POSTCALL:
+ if (CheckWinError(RETVAL))
+ croak_with_os2error("_ClipbrdData_set() error");
+
+void
+ClipbrdData_set(SV *text, int convert_nl = 1, unsigned long fmt = CF_TEXT, unsigned long rgfFmtInfo = ((fmt == CF_TEXT || fmt == CF_DSPTEXT) ? CFI_POINTER : CFI_HANDLE), HAB hab = perl_hab_GET())
+ PROTOTYPE: DISABLE
+
+void
+ClipbrdOwner_set(HWND hwnd, HAB hab = perl_hab_GET())
+ C_ARGS: hab, hwnd
+
+void
+ClipbrdViewer_set(HWND hwnd, HAB hab = perl_hab_GET())
+ C_ARGS: hab, hwnd
+
+unsigned long
+EnumClipbrdFmts(unsigned long fmt = 0, HAB hab = perl_hab_GET())
+ C_ARGS: hab, fmt
+
+unsigned long
+AddAtom(char *pszAtomName, HATOMTBL hAtomTbl = QuerySystemAtomTable())
+ C_ARGS: hAtomTbl, pszAtomName
+
+unsigned long
+FindAtom(char *pszAtomName, HATOMTBL hAtomTbl = QuerySystemAtomTable())
+ C_ARGS: hAtomTbl, pszAtomName
+
+unsigned long
+DeleteAtom(char *pszAtomName, HATOMTBL hAtomTbl = QuerySystemAtomTable())
+ C_ARGS: hAtomTbl, pszAtomName
+
+void
+Alarm(unsigned long rgfType = WA_ERROR, HWND hwndDesktop = HWND_DESKTOP)
+ C_ARGS: hwndDesktop, rgfType
+
+void
+FlashWindow(HWND hwndFrame, bool fFlash)
+
MODULE = OS2::Process PACKAGE = OS2::Process PREFIX = myQuery
SV *
-myQueryWindowText(unsigned long hwnd)
+myQueryWindowText(HWND hwnd)
SV *
-myQueryClassName(unsigned long hwnd)
+myQueryClassName(HWND hwnd)
MODULE = OS2::Process PACKAGE = OS2::Process PREFIX = Query
unsigned long
-QueryFocusWindow(unsigned long hwndDesktop = HWND_DESKTOP)
+QueryFocusWindow(HWND hwndDesktop = HWND_DESKTOP)
long
-QueryWindowTextLength(unsigned long hwnd)
+QueryWindowTextLength(HWND hwnd)
SV *
-QueryWindowSWP(unsigned long hwnd)
+QueryWindowSWP(HWND hwnd)
unsigned long
-QueryWindowULong(unsigned long hwnd, long index)
+QueryWindowULong(HWND hwnd, long index)
unsigned short
-QueryWindowUShort(unsigned long hwnd, long index)
+QueryWindowUShort(HWND hwnd, long index)
+
+unsigned long
+QueryActiveWindow(HWND hwnd = HWND_DESKTOP)
+
+unsigned long
+QueryDesktopWindow(HAB hab = Acquire_hab(), unsigned long hdc = NULLHANDLE)
+
+unsigned long
+QueryClipbrdData(unsigned long fmt = CF_TEXT, HAB hab = perl_hab_GET())
+ C_ARGS: hab, fmt
+ PROTOTYPE: DISABLE
+
+unsigned long
+QueryClipbrdViewer(HAB hab = perl_hab_GET())
+
+unsigned long
+QueryClipbrdOwner(HAB hab = perl_hab_GET())
+
+void
+CloseClipbrd(HAB hab = perl_hab_GET())
+
+void
+EmptyClipbrd(HAB hab = perl_hab_GET())
+
+bool
+OpenClipbrd(HAB hab = perl_hab_GET())
+
+unsigned long
+QueryAtomUsage(ATOM atom, HATOMTBL hAtomTbl = QuerySystemAtomTable())
+ C_ARGS: hAtomTbl, atom
+
+unsigned long
+QueryAtomLength(ATOM atom, HATOMTBL hAtomTbl = QuerySystemAtomTable())
+ C_ARGS: hAtomTbl, atom
+
+unsigned long
+QuerySystemAtomTable()
+
+unsigned long
+QuerySysPointer(long lId, bool fCopy = 1, HWND hwndDesktop = HWND_DESKTOP)
+ C_ARGS: hwndDesktop, lId, fCopy
unsigned long
-QueryActiveWindow(unsigned long hwnd = HWND_DESKTOP)
+CreateAtomTable(unsigned long initial = 0, unsigned long buckets = 0)
unsigned long
-QueryDesktopWindow(unsigned long hab = Acquire_hab(), unsigned long hdc = NULLHANDLE)
+DestroyAtomTable(HATOMTBL hAtomTbl)
+
MODULE = OS2::Process PACKAGE = OS2::Process PREFIX = myWinQuery
unsigned long
-myWinQueryWindowPtr(unsigned long hwnd, long index)
+myWinQueryWindowPtr(HWND hwnd, long index)
NO_OUTPUT BOOL
-myWinQueryWindowProcess(unsigned long hwnd, OUTLIST unsigned long pid, OUTLIST unsigned long tid)
+myWinQueryWindowProcess(HWND hwnd, OUTLIST unsigned long pid, OUTLIST unsigned long tid)
PROTOTYPE: $
POSTCALL:
if (CheckWinError(RETVAL))
- croak("WindowProcess() error");
+ croak_with_os2error("WindowProcess() error");
+
+SV *
+myWinQueryActiveDesktopPathname()
+
+void
+myWinQueryClipbrdFmtInfo(OUTLIST unsigned long prgfFmtInfo, unsigned long fmt = CF_TEXT, HAB hab = perl_hab_GET())
+ C_ARGS: hab, fmt, &prgfFmtInfo
+
+SV *
+myWinQueryAtomName(ATOM atom, HATOMTBL hAtomTbl = QuerySystemAtomTable())
MODULE = OS2::Process PACKAGE = OS2::Process PREFIX = myWin
int
-myWinSwitchToProgram(unsigned long hsw)
+myWinSwitchToProgram(HSWITCH hsw = switch_of(NULLHANDLE, getpid()))
PREINIT:
ULONG rc;
+#if 0
+
+unsigned long
+myWinMessageBox(unsigned long pszText, char* pszCaption = "Perl script error", unsigned long flStyle = MB_CANCEL | MB_ICONHAND, HWND hwndParent = HWND_DESKTOP, HWND hwndOwner = HWND_DESKTOP, unsigned long idWindow = 0)
+ C_ARGS: hwndParent, hwndOwner, pszText, pszCaption, idWindow, flStyle
+
+#endif
+
+unsigned long
+_MessageBox(char* pszText, char* pszCaption = "Perl script error", unsigned long flStyle = MB_CANCEL | MB_INFORMATION | MB_MOVEABLE, HWND hwndParent = HWND_DESKTOP, HWND hwndOwner = NULLHANDLE, unsigned long idWindow = 0)
+ C_ARGS: hwndParent, hwndOwner, pszText, pszCaption, idWindow, flStyle
+ POSTCALL:
+ if (RETVAL == MBID_ERROR)
+ RETVAL = 0;
+
+unsigned long
+_MessageBox2(char *pszText, char* pmb2info, char *pszCaption, HWND hwndParent = HWND_DESKTOP, HWND hwndOwner = NULLHANDLE, unsigned long idWindow = 0)
+ C_ARGS: hwndParent, hwndOwner, pszText, pszCaption, idWindow, (PMB2INFO)pmb2info
+ POSTCALL:
+ if (RETVAL == MBID_ERROR)
+ RETVAL = 0;
+
MODULE = OS2::Process PACKAGE = OS2::Process PREFIX = myWinQuery
MODULE = OS2::Process PACKAGE = OS2::Process PREFIX = get
@@ -1109,6 +1403,12 @@ getscrsize(OUTLIST int wp, OUTLIST int hp)
bool
scrsize_set(int w_or_h, int h = -9999)
+void
+get_InvalidateRect(HWND hwnd, char *prcl, bool fIncludeChildren)
+
+void
+get_CreateFrameControls(HWND hwndFrame, char *pfcdata, char* pszTitle)
+
MODULE = OS2::Process PACKAGE = OS2::Process PREFIX = ul
unsigned long
diff --git a/os2/OS2/REXX/DLL/DLL.pm b/os2/OS2/REXX/DLL/DLL.pm
index 09e3e37a08..f6660d6cad 100644
--- a/os2/OS2/REXX/DLL/DLL.pm
+++ b/os2/OS2/REXX/DLL/DLL.pm
@@ -5,38 +5,16 @@ our $VERSION = '1.00';
use Carp;
use XSLoader;
-sub AUTOLOAD {
- $AUTOLOAD =~ /^OS2::DLL::.+::(.+)$/
- or confess("Undefined subroutine &$AUTOLOAD called");
- return undef if $1 eq "DESTROY";
- $_[0]->find($1)
- or confess("Can't find entry '$1' to DLL '$_[0]->{File}': $^E");
- goto &$AUTOLOAD;
-}
-
@libs = split(/;/, $ENV{'PERL5REXX'} || $ENV{'PERLREXX'} || $ENV{'LIBPATH'} || $ENV{'PATH'});
%dlls = ();
# Preloaded methods go here. Autoload methods go after __END__, and are
# processed by the autosplit program.
-# Cannot autoload, the autoloader is used for the REXX functions.
+# Cannot be autoload, the autoloader is used for the REXX functions.
-sub new {
- confess 'Usage: OS2::DLL->new( <file> [<dirs>] )' unless @_ >= 2;
- my ($class, $file) = (shift, shift);
- my $handle;
- $handle = $class->load($file, @_) and return $handle;
- my $path = @_ ? " from '@_'" : '';
- my $err = DynaLoader::dl_error();
- $err =~ s/\s+at\s+\S+\s+line\s+\S+\s*\z//;
- croak "Can't load '$file'$path: $err";
-}
-
-sub load
-{
- confess 'Usage: load OS2::DLL <file> [<dirs>]' unless $#_ >= 1;
- my ($class, $file, @where) = (@_, @libs);
+my $load_with_dirs = sub {
+ my ($class, $file, @where) = (@_);
return $dlls{$file} if $dlls{$file};
my $handle;
foreach (@where) {
@@ -45,41 +23,81 @@ sub load
}
$handle = DynaLoader::dl_load_file($file) unless $handle;
return undef unless $handle;
- my $packs = $INC{'OS2/REXX.pm'} ? 'OS2::DLL OS2::REXX' : 'OS2::DLL';
- eval <<EOE or die "eval package $@";
-package OS2::DLL::$file; \@ISA = qw($packs);
-sub AUTOLOAD {
- \$OS2::DLL::AUTOLOAD = \$AUTOLOAD;
- goto &OS2::DLL::AUTOLOAD;
-}
-1;
-EOE
+ my @packs = $INC{'OS2/REXX.pm'} ? qw(OS2::DLL::dll OS2::REXX) : 'OS2::DLL::dll';
+ my $p = "OS2::DLL::dll::$file";
+ @{"$p\::ISA"} = @packs;
+ *{"$p\::AUTOLOAD"} = \&OS2::DLL::dll::AUTOLOAD;
return $dlls{$file} =
- bless {Handle => $handle, File => $file, Queue => 'SESSION' },
- "OS2::DLL::$file";
+ bless {Handle => $handle, File => $file, Queue => 'SESSION' }, $p;
+};
+
+my $new_dll = sub {
+ my ($dirs, $class, $file) = (shift, shift, shift);
+ my $handle;
+ push @_, @libs if $dirs;
+ $handle = $load_with_dirs->($class, $file, @_)
+ and return $handle;
+ my $path = @_ ? " from '@_'" : '';
+ my $err = DynaLoader::dl_error();
+ $err =~ s/\s+at\s+\S+\s+line\s+\S+\s*\z//;
+ croak "Can't load '$file'$path: $err";
+};
+
+sub new {
+ confess 'Usage: OS2::DLL->new( <file> [<dirs>] )' unless @_ >= 2;
+ $new_dll->(1, @_);
}
-sub find
-{
+sub module {
+ confess 'Usage: OS2::DLL->module( <file> [<dirs>] )' unless @_ >= 2;
+ $new_dll->(0, @_);
+}
+
+sub load {
+ confess 'Usage: load OS2::DLL <file> [<dirs>]' unless $#_ >= 1;
+ $load_with_dirs->(@_, @libs);
+}
+
+package OS2::DLL::dll;
+use Carp;
+@ISA = 'OS2::DLL';
+
+sub AUTOLOAD {
+ $AUTOLOAD =~ /^OS2::DLL::dll::.+::(.+)$/
+ or confess("Undefined subroutine &$AUTOLOAD called");
+ return undef if $1 eq "DESTROY";
+ die "AUTOLOAD loop" if $1 eq "AUTOLOAD";
+ $_[0]->find($1) or confess($@);
+ goto &$AUTOLOAD;
+}
+
+sub wrapper_REXX {
+ confess 'Usage: $dllhandle->wrapper_REXX($func_name)' unless @_ == 2;
my $self = shift;
my $file = $self->{File};
my $handle = $self->{Handle};
my $prefix = exists($self->{Prefix}) ? $self->{Prefix} : "";
my $queue = $self->{Queue};
- foreach (@_) {
- my $name = "OS2::DLL::${file}::$_";
- next if defined(&$name);
- my $addr = DynaLoader::dl_find_symbol($handle, uc $prefix.$_)
- || DynaLoader::dl_find_symbol($handle, $prefix.$_)
- or return 0;
- eval <<EOE or die "eval sub";
-package OS2::DLL::$file;
-sub $_ {
- shift;
- OS2::DLL::_call('$_', $addr, '$queue', \@_);
+ my $name = shift;
+ $prefix = '' if $name =~ /^#\d+/; # loading by ordinal
+ my $addr = (DynaLoader::dl_find_symbol($handle, uc $prefix.$name)
+ || DynaLoader::dl_find_symbol($handle, $prefix.$name));
+ return sub {
+ OS2::DLL::_call($name, $addr, $queue, @_);
+ } if $addr;
+ my $err = DynaLoader::dl_error();
+ $err =~ s/\s+at\s+\S+\s+line\s+\S+\s*\z//;
+ croak "Can't find symbol `$name' in DLL `$file': $err";
}
-1;
-EOE
+
+sub find
+{
+ my $self = shift;
+ my $file = $self->{File};
+ my $p = ref $self;
+ foreach (@_) {
+ my $f = eval {$self->wrapper_REXX($_)} or return 0;
+ ${"${p}::"}{$_} = sub { shift; $f->(@_) };
}
return 1;
}
@@ -102,45 +120,124 @@ See documentation of L<OS2::REXX> module if you need the variable pool.
=head1 SYNOPSIS
use OS2::DLL;
- $emx_dll = OS2::DLL->load('emx');
+ $emx_dll = OS2::DLL->module('emx');
$emx_version = $emx_dll->emx_revision();
+ $func_emx_version = $emx_dll->wrapper_REXX('#128'); # emx_revision
+ $emx_version = $func_emx_version->();
=head1 DESCRIPTION
-=head2 Load REXX DLL
+=head2 Create a DLL handle
- $dll = load OS2::DLL NAME [, WHERE];
+ $dll = OS2::DLL->module( NAME [, WHERE] );
-NAME is DLL name, without path and extension.
+Loads an OS/2 module NAME, looking in directories WHERE (adding the
+extension F<.dll>), if the DLL is not found there, loads in the usual OS/2 way
+(via LIBPATH and other settings). Croaks with a verbose report on failure.
-Directories are searched WHERE first (list of dirs), then environment
-paths PERL5REXX, PERLREXX, PATH or, as last resort, OS/2-ish search
-is performed in default DLL path (without adding paths and extensions).
+The DLL is not unloaded when the return value is destroyed.
-The DLL is not unloaded when the variable dies.
+=head2 Create a DLL handle (looking in some strange locations)
-Returns DLL object reference, or undef on failure (in this case one can
-get the reason via C<DynaLoader::dl_error()>).
+ $dll = OS2::DLL->new( NAME [, WHERE] );
-=head2 Create a REXX DLL handle
+Same as L<C<module>|Create a DLL handle>, but in addition to WHERE, looks
+in environment paths PERL5REXX, PERLREXX, PATH (provided for backward
+compatibility).
- $dll = OS2::DLL->new( NAME [, WHERE] );
+=head2 Loads DLL by name
-Same as L<C<load>|Load REXX DLL>, but croaks with a meaningful message on
-failure.
+ $dll = load OS2::DLL NAME [, WHERE];
+
+Same as L<C<new>|Create a DLL handle (looking in some strange locations)>,
+but returns DLL object reference, or undef on failure (in this case one can
+get the reason via C<DynaLoader::dl_error()>) (provided for backward
+compatibility).
=head2 Check for functions (optional):
BOOL = $dll->find(NAME [, NAME [, ...]]);
-Returns true if all functions are available.
+Returns true if all functions are available. As a side effect, creates
+a REXX wrapper with the specified name in the package constructed by the name
+of the DLL so that the next call to C<$dll->NAME()> will pick up the cached
+method.
+
+=head2 Create a Perl wrapper (optional):
+
+ $func = $dll->wrapper_REXX(NAME);
+
+Returns a reference to a Perl function wrapper for the entry point NAME
+in the DLL. Similar to the OS/2 API, the NAME may be C<"#123"> - in this case
+the ordinal is loaded. Croaks with a meaningful error message if NAME does
+not exists (although the message for the case when the name is an ordinal may
+be confusing).
+
+=head2 Call external function with REXX calling convention:
+
+ $ret_string = $dll->function_name(arguments);
+
+Returns the return string if the REXX return code is 0, else undef.
+Dies with error message if the function is not available. On the first call
+resolves the name in the DLL and caches the Perl wrapper; future calls go
+through the wrapper.
+
+Unless used inside REXX environment (see L<OS2::REXX>), the REXX runtime
+environment (variable pool, queue etc.) is not available to the called
+function.
+
+=head1 Low-level API
+
+=over
+
+=item Call a _System linkage function via a pointer
+
+If a function takes up to 20 ULONGs and returns ULONG:
+
+ $res = call20( $pointer, $arg0, $arg1, ...);
+
+=item Same for packed arguments:
+
+ $res = call20_p( $pointer, pack 'L20', $arg0, $arg1, ...);
+
+=item Same for C<regparm(3)> function:
+
+ $res = call20_rp3( $pointer, $arg0, $arg1, ...);
+
+=item Same for packed arguments and C<regparm(3)> function
+
+ $res = call20_rp3_p( $pointer, pack 'L20', $arg0, $arg1, ...);
+
+=item Same for a function which returns non-0 and sets system-error on error
+
+ call20_Dos( $msg, $pointer, $arg0, $arg1, ...); # die("$msg: $^E") if error
+
+[Good for C<Dos*> API - and rare C<Win*> calls.]
+
+=item Same for a function which returns 0 and sets WinLastError() on error
+
+ $res = call20_Win( $msg, $pointer, $arg0, $arg1, ...);
+ # would die("$msg: $^E") if error
+
+[Good for most of C<Win*> API.]
+
+=item Same for a function which returns 0 and sets WinLastError() on error but
+0 is also a valid return
+
+ $res = call20_Win_0OK( $msg, $pointer, $arg0, $arg1, ...);
+ # would die("$msg: $^E") if error
+
+[Good for some of C<Win*> API.]
+
+=item As previous, but without die()
-=head2 Call external REXX function:
+ $res = call20_Win_0OK_survive( $pointer, $arg0, $arg1, ...);
+ if ($res == 0 and $^E) { # Do error processing here
+ }
- $dll->function(arguments);
+[Good for some of C<Win*> API.]
-Returns the return string if the return code is 0, else undef.
-Dies with error message if the function is not available.
+=back
=head1 ENVIRONMENT
@@ -149,7 +246,7 @@ in C<PERL5REXX>, C<PERLREXX>, C<PATH>.
=head1 AUTHOR
-Extracted by Ilya Zakharevich ilya@math.ohio-state.edu from L<OS2::REXX>
+Extracted by Ilya Zakharevich perl-module-OS2-DLL@ilyaz.org from L<OS2::REXX>
written by Andreas Kaiser ak@ananke.s.bawue.de.
=cut
diff --git a/os2/OS2/REXX/DLL/DLL.xs b/os2/OS2/REXX/DLL/DLL.xs
index c8e7c58007..90b14eaf85 100644
--- a/os2/OS2/REXX/DLL/DLL.xs
+++ b/os2/OS2/REXX/DLL/DLL.xs
@@ -21,12 +21,112 @@ needstrs(int n)
}
}
+typedef ULONG (*fptr_UL_20)(ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG);
+typedef __attribute__((regparm(3))) ULONG (*fptr_UL_20_rp3)(ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG);
+
+static inline unsigned long
+call20_p(unsigned long fp, char* str)
+{
+ ULONG *argv = (ULONG*)str;
+ fptr_UL_20 f = (fptr_UL_20)fp;
+
+ return f(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5], argv[6], argv[7], argv[8], argv[9], argv[10], argv[11], argv[12], argv[13], argv[14], argv[15], argv[16], argv[17], argv[18], argv[19]);
+}
+
+static inline unsigned long
+call20(unsigned long fp, unsigned long arg0, unsigned long arg1, unsigned long arg2, unsigned long arg3, unsigned long arg4, unsigned long arg5, unsigned long arg6, unsigned long arg7, unsigned long arg8, unsigned long arg9, unsigned long arg10, unsigned long arg11, unsigned long arg12, unsigned long arg13, unsigned long arg14, unsigned long arg15, unsigned long arg16, unsigned long arg17, unsigned long arg18, unsigned long arg19)
+{
+ fptr_UL_20 f = (fptr_UL_20)fp;
+
+ return f(arg0, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8, arg9, arg10, arg11, arg12, arg13, arg14, arg15, arg16, arg17, arg18, arg19);
+}
+
+static inline unsigned long
+call20_rp3_p(unsigned long fp, char* str)
+{
+ ULONG *argv = (ULONG*)str;
+ fptr_UL_20_rp3 f = (fptr_UL_20_rp3)fp;
+
+ return f(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5], argv[6], argv[7], argv[8], argv[9], argv[10], argv[11], argv[12], argv[13], argv[14], argv[15], argv[16], argv[17], argv[18], argv[19]);
+}
+
+static inline unsigned long
+call20_rp3(unsigned long fp, unsigned long arg0, unsigned long arg1, unsigned long arg2, unsigned long arg3, unsigned long arg4, unsigned long arg5, unsigned long arg6, unsigned long arg7, unsigned long arg8, unsigned long arg9, unsigned long arg10, unsigned long arg11, unsigned long arg12, unsigned long arg13, unsigned long arg14, unsigned long arg15, unsigned long arg16, unsigned long arg17, unsigned long arg18, unsigned long arg19)
+{
+ fptr_UL_20_rp3 f = (fptr_UL_20_rp3)fp;
+
+ return f(arg0, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8, arg9, arg10, arg11, arg12, arg13, arg14, arg15, arg16, arg17, arg18, arg19);
+}
+
+static inline void
+call20_Dos(char *msg, unsigned long fp, unsigned long arg0, unsigned long arg1, unsigned long arg2, unsigned long arg3, unsigned long arg4, unsigned long arg5, unsigned long arg6, unsigned long arg7, unsigned long arg8, unsigned long arg9, unsigned long arg10, unsigned long arg11, unsigned long arg12, unsigned long arg13, unsigned long arg14, unsigned long arg15, unsigned long arg16, unsigned long arg17, unsigned long arg18, unsigned long arg19)
+{
+ fptr_UL_20 f = (fptr_UL_20)fp;
+ ULONG rc;
+
+ if (CheckOSError(f(arg0, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8, arg9, arg10, arg11, arg12, arg13, arg14, arg15, arg16, arg17, arg18, arg19)))
+ croak_with_os2error(msg);
+}
+
+static inline unsigned long
+call20_Win(char *msg, unsigned long fp, unsigned long arg0, unsigned long arg1, unsigned long arg2, unsigned long arg3, unsigned long arg4, unsigned long arg5, unsigned long arg6, unsigned long arg7, unsigned long arg8, unsigned long arg9, unsigned long arg10, unsigned long arg11, unsigned long arg12, unsigned long arg13, unsigned long arg14, unsigned long arg15, unsigned long arg16, unsigned long arg17, unsigned long arg18, unsigned long arg19)
+{
+ fptr_UL_20 f = (fptr_UL_20)fp;
+
+ if (CheckWinError(f(arg0, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8, arg9, arg10, arg11, arg12, arg13, arg14, arg15, arg16, arg17, arg18, arg19)))
+ croak_with_os2error(msg);
+}
+
+static inline unsigned long
+call20_Win_0OK(char *msg, unsigned long fp, unsigned long arg0, unsigned long arg1, unsigned long arg2, unsigned long arg3, unsigned long arg4, unsigned long arg5, unsigned long arg6, unsigned long arg7, unsigned long arg8, unsigned long arg9, unsigned long arg10, unsigned long arg11, unsigned long arg12, unsigned long arg13, unsigned long arg14, unsigned long arg15, unsigned long arg16, unsigned long arg17, unsigned long arg18, unsigned long arg19)
+{
+ fptr_UL_20 f = (fptr_UL_20)fp;
+
+ ResetWinError();
+ return SaveCroakWinError(f(arg0, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8, arg9, arg10, arg11, arg12, arg13, arg14, arg15, arg16, arg17, arg18, arg19),
+ 1 /* Die on error */, /* No prefix */, msg);
+}
+
+static inline unsigned long
+call20_Win_0OK_survive(unsigned long fp, unsigned long arg0, unsigned long arg1, unsigned long arg2, unsigned long arg3, unsigned long arg4, unsigned long arg5, unsigned long arg6, unsigned long arg7, unsigned long arg8, unsigned long arg9, unsigned long arg10, unsigned long arg11, unsigned long arg12, unsigned long arg13, unsigned long arg14, unsigned long arg15, unsigned long arg16, unsigned long arg17, unsigned long arg18, unsigned long arg19)
+{
+ fptr_UL_20 f = (fptr_UL_20)fp;
+
+ ResetWinError();
+ return SaveCroakWinError(f(arg0, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8, arg9, arg10, arg11, arg12, arg13, arg14, arg15, arg16, arg17, arg18, arg19),
+ 0 /* No die on error */, /* No prefix */, "N/A");
+}
+
MODULE = OS2::DLL PACKAGE = OS2::DLL
BOOT:
needstrs(8);
trace = getenv("PERL_REXX_DEBUG");
+unsigned long
+call20_p(unsigned long fp, char* argv)
+
+unsigned long
+call20(unsigned long fp, unsigned long arg0 = 0, unsigned long arg1 = 0, unsigned long arg2 = 0, unsigned long arg3 = 0, unsigned long arg4 = 0, unsigned long arg5 = 0, unsigned long arg6 = 0, unsigned long arg7 = 0, unsigned long arg8 = 0, unsigned long arg9 = 0, unsigned long arg10 = 0, unsigned long arg11 = 0, unsigned long arg12 = 0, unsigned long arg13 = 0, unsigned long arg14 = 0, unsigned long arg15 = 0, unsigned long arg16 = 0, unsigned long arg17 = 0, unsigned long arg18 = 0, unsigned long arg19 = 0)
+
+void
+call20_Dos(char* msg, unsigned long fp, unsigned long arg0 = 0, unsigned long arg1 = 0, unsigned long arg2 = 0, unsigned long arg3 = 0, unsigned long arg4 = 0, unsigned long arg5 = 0, unsigned long arg6 = 0, unsigned long arg7 = 0, unsigned long arg8 = 0, unsigned long arg9 = 0, unsigned long arg10 = 0, unsigned long arg11 = 0, unsigned long arg12 = 0, unsigned long arg13 = 0, unsigned long arg14 = 0, unsigned long arg15 = 0, unsigned long arg16 = 0, unsigned long arg17 = 0, unsigned long arg18 = 0, unsigned long arg19 = 0)
+
+unsigned long
+call20_Win(char *msg, unsigned long fp, unsigned long arg0 = 0, unsigned long arg1 = 0, unsigned long arg2 = 0, unsigned long arg3 = 0, unsigned long arg4 = 0, unsigned long arg5 = 0, unsigned long arg6 = 0, unsigned long arg7 = 0, unsigned long arg8 = 0, unsigned long arg9 = 0, unsigned long arg10 = 0, unsigned long arg11 = 0, unsigned long arg12 = 0, unsigned long arg13 = 0, unsigned long arg14 = 0, unsigned long arg15 = 0, unsigned long arg16 = 0, unsigned long arg17 = 0, unsigned long arg18 = 0, unsigned long arg19 = 0)
+
+unsigned long
+call20_Win_0OK(char *msg, unsigned long fp, unsigned long arg0 = 0, unsigned long arg1 = 0, unsigned long arg2 = 0, unsigned long arg3 = 0, unsigned long arg4 = 0, unsigned long arg5 = 0, unsigned long arg6 = 0, unsigned long arg7 = 0, unsigned long arg8 = 0, unsigned long arg9 = 0, unsigned long arg10 = 0, unsigned long arg11 = 0, unsigned long arg12 = 0, unsigned long arg13 = 0, unsigned long arg14 = 0, unsigned long arg15 = 0, unsigned long arg16 = 0, unsigned long arg17 = 0, unsigned long arg18 = 0, unsigned long arg19 = 0)
+
+unsigned long
+call20_Win_0OK_survive(unsigned long fp, unsigned long arg0 = 0, unsigned long arg1 = 0, unsigned long arg2 = 0, unsigned long arg3 = 0, unsigned long arg4 = 0, unsigned long arg5 = 0, unsigned long arg6 = 0, unsigned long arg7 = 0, unsigned long arg8 = 0, unsigned long arg9 = 0, unsigned long arg10 = 0, unsigned long arg11 = 0, unsigned long arg12 = 0, unsigned long arg13 = 0, unsigned long arg14 = 0, unsigned long arg15 = 0, unsigned long arg16 = 0, unsigned long arg17 = 0, unsigned long arg18 = 0, unsigned long arg19 = 0)
+
+unsigned long
+call20_rp3_p(unsigned long fp, char* argv)
+
+unsigned long
+call20_rp3(unsigned long fp, unsigned long arg0 = 0, unsigned long arg1 = 0, unsigned long arg2 = 0, unsigned long arg3 = 0, unsigned long arg4 = 0, unsigned long arg5 = 0, unsigned long arg6 = 0, unsigned long arg7 = 0, unsigned long arg8 = 0, unsigned long arg9 = 0, unsigned long arg10 = 0, unsigned long arg11 = 0, unsigned long arg12 = 0, unsigned long arg13 = 0, unsigned long arg14 = 0, unsigned long arg15 = 0, unsigned long arg16 = 0, unsigned long arg17 = 0, unsigned long arg18 = 0, unsigned long arg19 = 0)
+
SV *
_call(name, address, queue="SESSION", ...)
char * name
diff --git a/os2/OS2/REXX/t/rx_emxrv.t b/os2/OS2/REXX/t/rx_emxrv.t
index d51e1b0e32..5df8c32785 100644
--- a/os2/OS2/REXX/t/rx_emxrv.t
+++ b/os2/OS2/REXX/t/rx_emxrv.t
@@ -8,7 +8,7 @@ BEGIN {
}
}
-print "1..5\n";
+print "1..20\n";
require OS2::DLL;
print "ok 1\n";
@@ -22,3 +22,40 @@ print "ok 4\n";
$reason = '';
$emx_version >= 99 and $reason = ' # skipped: version of EMX 100 or more'; # Be safe
print "ok 5$reason\n";
+
+$emx_fullname = OS2::DLLname 0x202, $emx_dll->{Handle}; # Handle ==> fullname
+print "ok 6\n";
+$emx_dll1 = OS2::DLL->module($emx_fullname);
+print "ok 7\n";
+$emx_dll->{Handle} == $emx_dll1->{Handle} or print "not ";
+print "ok 8\n";
+
+$emx_version1 = $emx_dll1->emx_revision();
+print "ok 9\n";
+$emx_version1 eq $emx_version or print "not ";
+print "ok 10\n";
+
+$emx_revision = $emx_dll->wrapper_REXX('emx_revision');
+print "ok 11\n";
+$emx_version2 = $emx_revision->();
+print "ok 12\n";
+$emx_version2 eq $emx_version or print "not ";
+print "ok 13\n";
+
+$emx_revision1 = $emx_dll1->wrapper_REXX('#128');
+print "ok 14\n";
+$emx_version3 = $emx_revision1->();
+print "ok 15\n";
+$emx_version3 eq $emx_version or print "not ";
+print "ok 16\n";
+
+($emx_fullname1 = $emx_fullname) =~ s,/,\\,g;
+$emx_dll2 = OS2::DLL->new($emx_fullname1);
+print "ok 17\n";
+$emx_dll->{Handle} == $emx_dll2->{Handle} or print "not ";
+print "ok 18\n";
+
+$emx_version4 = $emx_dll2->emx_revision();
+print "ok 19\n";
+$emx_version4 eq $emx_version or print "not ";
+print "ok 20\n";
diff --git a/os2/OS2/REXX/t/rx_objcall.t b/os2/OS2/REXX/t/rx_objcall.t
index b1154757d4..0ec67b112d 100644
--- a/os2/OS2/REXX/t/rx_objcall.t
+++ b/os2/OS2/REXX/t/rx_objcall.t
@@ -30,4 +30,9 @@ print "ok 4\n" if $res[0] == $$;
print "# @pid\n";
eval { $rxu->nixda(); };
-print "ok 5\n" if $@ =~ /^Can't find entry 'nixda\'/;
+my $err = $@;
+if ($err) {
+ $err =~ s/\n/\n#\t/g;
+ print "# \$\@ = '$err'\n";
+}
+print "ok 5\n" if $@ =~ /^Can't find symbol `nixda\'/;
diff --git a/os2/OS2/PrfDB/typemap b/os2/OS2/typemap
index eb2722bda5..b6f0e079d1 100644
--- a/os2/OS2/PrfDB/typemap
+++ b/os2/OS2/typemap
@@ -1,14 +1,28 @@
BOOL T_IV
-ULONG T_IV
-HINI T_IV
-HAB T_IV
+ULONG T_UV
+HINI T_UV
+HAB T_UV
+HWND T_UV
+ATOM T_UV
+HATOMTBL T_UV
+HSWITCH T_UV
+ULONG T_UV
+USHORT T_UV
+LONG T_IV
+SHORT T_IV
+
PSZ T_PVNULL
+PCSZ T_PVNULLC
#############################################################################
INPUT
T_PVNULL
$var = ( SvOK($arg) ? ($type)SvPV($arg,PL_na) : NULL )
+T_PVNULLC
+ $var = ( SvOK($arg) ? ($type)SvPV($arg,PL_na) : NULL )
#############################################################################
OUTPUT
T_PVNULL
sv_setpv((SV*)$arg, $var);
+T_PVNULLC
+ NOTIMPLEMENTED
diff --git a/os2/dl_os2.c b/os2/dl_os2.c
index b698451b08..76fa9dc42d 100644
--- a/os2/dl_os2.c
+++ b/os2/dl_os2.c
@@ -4,10 +4,15 @@
#define INCL_BASE
#include <os2.h>
+#include <float.h>
+#include <stdlib.h>
static ULONG retcode;
static char fail[300];
+static ULONG dllHandle;
+static int handle_found;
+static int handle_loaded;
#ifdef PERL_CORE
#include "EXTERN.h"
@@ -19,6 +24,57 @@ char *os2error(int rc);
#endif
+#ifdef DLOPEN_INITTERM
+unsigned long _DLL_InitTerm(unsigned long modHandle, unsigned long flag)
+{
+ switch (flag) {
+ case 0: /* INIT */
+ /* Save handle */
+ dllHandle = modHandle;
+ handle_found = 1;
+ return TRUE;
+
+ case 1: /* TERM */
+ handle_found = 0;
+ dllHandle = (unsigned long)NULLHANDLE;
+ return TRUE;
+ }
+
+ return FALSE;
+}
+
+#endif
+
+HMODULE
+find_myself(void)
+{
+
+ static APIRET APIENTRY (*pDosQueryModFromEIP) (HMODULE * hmod, ULONG * obj, ULONG BufLen, PCHAR Buf,
+ ULONG * Offset, ULONG Address);
+ HMODULE doscalls_h, mod;
+ static int failed;
+ ULONG obj, offset, rc;
+ char buf[260];
+
+ if (failed)
+ return 0;
+ failed = 1;
+ doscalls_h = (HMODULE)dlopen("DOSCALLS",0);
+ if (!doscalls_h)
+ return 0;
+/* {&doscalls_handle, NULL, 360}, */ /* DosQueryModFromEIP */
+ rc = DosQueryProcAddr(doscalls_h, 360, 0, (PFN*)&pDosQueryModFromEIP);
+ if (rc)
+ return 0;
+ rc = pDosQueryModFromEIP(&mod, &obj, sizeof(buf), buf, &offset, (ULONG)dlopen);
+ if (rc)
+ return 0;
+ failed = 0;
+ handle_found = 1;
+ dllHandle = mod;
+ return mod;
+}
+
void *
dlopen(const char *path, int mode)
{
@@ -26,10 +82,36 @@ dlopen(const char *path, int mode)
char tmp[260];
const char *beg, *dot;
ULONG rc;
+ unsigned fpflag = _control87(0,0);
fail[0] = 0;
+ if (!path) { /* Our own handle. */
+ if (handle_found || find_myself()) {
+ char dllname[260];
+
+ if (handle_loaded)
+ return (void*)dllHandle;
+ rc = DosQueryModuleName(dllHandle, sizeof(dllname), dllname);
+ if (rc) {
+ strcpy(fail, "can't find my DLL name by the handle");
+ retcode = rc;
+ return 0;
+ }
+ rc = DosLoadModule(fail, sizeof fail, dllname, &handle);
+ if (rc) {
+ strcpy(fail, "can't load my own DLL");
+ retcode = rc;
+ return 0;
+ }
+ handle_loaded = 1;
+ goto ret;
+ }
+ retcode = ERROR_MOD_NOT_FOUND;
+ strcpy(fail, "can't load from myself: compiled without -DDLOPEN_INITTERM");
+ return 0;
+ }
if ((rc = DosLoadModule(fail, sizeof fail, (char*)path, &handle)) == 0)
- return (void *)handle;
+ goto ret;
retcode = rc;
@@ -49,12 +131,17 @@ dlopen(const char *path, int mode)
memmove(tmp, path, n);
memmove(tmp+n, dot, strlen(dot)+1);
if (DosLoadModule(fail, sizeof fail, tmp, &handle) == 0)
- return (void *)handle;
+ goto ret;
}
+ handle = 0;
- return NULL;
+ ret:
+ _control87(fpflag, MCW_EM); /* Some modules reset FP flags on load */
+ return (void *)handle;
}
+#define ERROR_WRONG_PROCTYPE 0xffffffff
+
void *
dlsym(void *handle, const char *symbol)
{
@@ -67,7 +154,7 @@ dlsym(void *handle, const char *symbol)
rc = DosQueryProcType((HMODULE)handle, 0, symbol, &type);
if (rc == 0 && type == PT_32BIT)
return (void *)addr;
- rc = ERROR_CALL_NOT_IMPLEMENTED;
+ rc = ERROR_WRONG_PROCTYPE;
}
retcode = rc;
return NULL;
@@ -82,12 +169,15 @@ dlerror(void)
if (retcode == 0)
return NULL;
- err = os2error(retcode);
+ if (retcode == ERROR_WRONG_PROCTYPE)
+ err = "Wrong procedure type";
+ else
+ err = os2error(retcode);
len = strlen(err);
if (len > sizeof(buf) - 1)
len = sizeof(buf) - 1;
strncpy(buf, err, len+1);
- if (fail[0] && len < 300)
+ if (fail[0] && len + strlen(fail) < sizeof(buf) - 100)
sprintf(buf + len, ", possible problematic module: '%s'", fail);
retcode = 0;
return buf;
diff --git a/os2/os2.c b/os2/os2.c
index 0490449f0d..bf8891bfc6 100644
--- a/os2/os2.c
+++ b/os2/os2.c
@@ -3,6 +3,8 @@
#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
@@ -30,6 +32,173 @@
#include "EXTERN.h"
#include "perl.h"
+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;
+
+} 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)
+
+const Perl_PFN * const pExtFCN = (Perl_po2()->po2_ExtFCN);
+
+
#if defined(USE_5005THREADS) || defined(USE_ITHREADS)
typedef void (*emx_startroutine)(void *);
@@ -44,7 +213,7 @@ enum pthreads_state {
pthreads_st_norun,
pthreads_st_exited_waited,
};
-const char *pthreads_states[] = {
+const char * const pthreads_states[] = {
"uninit",
"running",
"exited",
@@ -60,10 +229,9 @@ static const char*
pthreads_state_string(enum pthreads_state state)
{
if (state < 0 || state >= sizeof(pthreads_states)/sizeof(*pthreads_states)) {
- static char buf[80];
-
- snprintf(buf, sizeof(buf), "unknown thread state %d", (int)state);
- return buf;
+ snprintf(pthreads_state_buf, sizeof(pthreads_state_buf),
+ "unknown thread state %d", (int)state);
+ return pthreads_state_buf;
}
return pthreads_states[state];
}
@@ -77,6 +245,8 @@ typedef struct {
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)
@@ -304,11 +474,11 @@ os2_cond_wait(perl_cond *c, perl_mutex *m)
int rc;
STRLEN n_a;
if ((rc = DosResetEventSem(*c,&n_a)) && (rc != ERROR_ALREADY_RESET))
- Perl_croak_nocontext("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))
- Perl_croak_nocontext("panic: COND_WAIT: rc=%i", rc);
+ croak_with_os2error("panic: COND_WAIT");
if (rc == ERROR_INTERRUPT)
errno = EINTR;
if (m) MUTEX_LOCK(m);
@@ -318,28 +488,12 @@ os2_cond_wait(perl_cond *c, perl_mutex *m)
static int exe_is_aout(void);
-/*****************************************************************************/
-/* 2.1 would not resolve symbols on demand, and has no ExtLIBPATH. */
-#define C_ARR_LEN(sym) (sizeof(sym)/sizeof(*sym))
-
-struct dll_handle {
- const char *modname;
- HMODULE handle;
-};
-static struct dll_handle doscalls_handle = {"doscalls", 0};
-static struct dll_handle tcp_handle = {"tcp32dll", 0};
-static struct dll_handle pmwin_handle = {"pmwin", 0};
-static struct dll_handle rexx_handle = {"rexx", 0};
-static struct dll_handle rexxapi_handle = {"rexxapi", 0};
-static struct dll_handle sesmgr_handle = {"sesmgr", 0};
-static struct dll_handle pmshapi_handle = {"pmshapi", 0};
-
/* This should match enum entries_ordinals defined in os2ish.h. */
static const struct {
- struct dll_handle *dll;
+ struct dll_handle_t *dll;
const char *entryname;
int entrypoint;
-} loadOrdinals[ORD_NENTRIES] = {
+} loadOrdinals[] = {
{&doscalls_handle, NULL, 874}, /* DosQueryExtLibpath */
{&doscalls_handle, NULL, 873}, /* DosSetExtLibpath */
{&doscalls_handle, NULL, 460}, /* DosVerifyPidTid */
@@ -427,12 +581,46 @@ static const struct {
{&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 */
};
-static PFN ExtFCN[C_ARR_LEN(loadOrdinals)]; /* Labeled by ord ORD_*. */
-const Perl_PFN * const pExtFCN = ExtFCN;
-struct PMWIN_entries_t PMWIN_entries;
-
HMODULE
loadModule(const char *modname, int fail)
{
@@ -444,16 +632,69 @@ loadModule(const char *modname, int fail)
return h;
}
+/* const char* const ptypes[] = { "FS", "DOS", "VIO", "PM", "DETACH" }; */
+
+static int
+my_type()
+{
+ int rc;
+ TIB *tib;
+ PIB *pib;
+
+ if (!(_emx_env & 0x200)) return 1; /* not OS/2. */
+ if (CheckOSError(DosGetInfoBlocks(&tib, &pib)))
+ return -1;
+
+ return (pib->pib_ultype);
+}
+
+static void
+my_type_set(int type)
+{
+ int rc;
+ TIB *tib;
+ PIB *pib;
+
+ if (!(_emx_env & 0x200))
+ Perl_croak_nocontext("Can't set type on DOS"); /* not OS/2. */
+ if (CheckOSError(DosGetInfoBlocks(&tib, &pib)))
+ croak_with_os2error("Error getting info blocks");
+ pib->pib_ultype = type;
+}
+
PFN
loadByOrdinal(enum entries_ordinals ord, int fail)
{
+ if (sizeof(loadOrdinals)/sizeof(loadOrdinals[0]) != ORD_NENTRIES)
+ Perl_croak_nocontext(
+ "Wrong size of loadOrdinals array: expected %d, actual %d",
+ sizeof(loadOrdinals)/sizeof(loadOrdinals[0]), ORD_NENTRIES);
if (ExtFCN[ord] == NULL) {
PFN fcn = (PFN)-1;
APIRET rc;
- if (!loadOrdinals[ord].dll->handle)
+ if (!loadOrdinals[ord].dll->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,
@@ -504,12 +745,11 @@ 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);
-static int pidtid_lookup;
PQTOPLEVEL
get_sysinfo(ULONG pid, ULONG flags)
@@ -616,13 +856,7 @@ getpriority(int which /* ignored */, int pid)
/*****************************************************************************/
/* spawn */
-int emx_runtime_init; /* If 1, we need to manually init it */
-int emx_exception_init; /* If 1, we need to manually set it */
-/* 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)
@@ -690,22 +924,6 @@ enum execf_t {
EXECF_SYNC
};
-/* 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 ULONG
file_type(char *path)
{
@@ -730,8 +948,6 @@ file_type(char *path)
return apptype;
}
-static ULONG os2_mytype;
-
/* Spawn/exec a program, revert to shell if needed. */
/* global PL_Argv[] contains arguments. */
@@ -745,11 +961,11 @@ do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag)
{
int trueflag = flag;
int rc, pass = 1;
- char *tmps;
- char *args[4];
- static char * fargs[4]
+ char *real_name;
+ char const * args[4];
+ static const char * const fargs[4]
= { "/bin/sh", "-c", "\"$@\"", "spawn-via-shell", };
- char **argsp = fargs;
+ const char * const *argsp = fargs;
int nargs = 4;
int force_shell;
int new_stderr = -1, nostderr = 0;
@@ -760,24 +976,26 @@ do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag)
if (flag == P_WAIT)
flag = P_NOWAIT;
+ if (really && !*(real_name = SvPV(really, n_a)))
+ really = Nullsv;
retry:
if (strEQ(PL_Argv[0],"/bin/sh"))
PL_Argv[0] = PL_sh_path;
/* We should check PERL_SH* and PERLLIB_* as well? */
- if (!really || !*(tmps = SvPV(really, n_a)))
- tmps = PL_Argv[0];
- if (tmps[0] != '/' && tmps[0] != '\\'
- && !(tmps[0] && tmps[1] == ':'
- && (tmps[2] == '/' || tmps[2] != '\\'))
+ if (!really || pass >= 2)
+ real_name = PL_Argv[0];
+ if (real_name[0] != '/' && real_name[0] != '\\'
+ && !(real_name[0] && real_name[1] == ':'
+ && (real_name[2] == '/' || real_name[2] != '\\'))
) /* will spawnvp use PATH? */
TAINT_ENV(); /* testing IFS here is overkill, probably */
reread:
force_shell = 0;
if (_emx_env & 0x200) { /* OS/2. */
- int type = file_type(tmps);
+ int type = file_type(real_name);
type_again:
if (type == -1) { /* Not found */
errno = ENOENT;
@@ -792,10 +1010,10 @@ do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag)
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)
@@ -809,11 +1027,11 @@ do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag)
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)
+ 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);
}
@@ -824,7 +1042,7 @@ do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag)
if (os2_mytype != 0) { /* not full screen */
if (flag == P_NOWAIT)
flag = P_SESSION;
- else if ((flag & 7) != P_SESSION)
+ else if ((flag & 7) != P_SESSION && ckWARN(WARN_EXEC))
Perl_warner(aTHX_ packWARN(WARN_EXEC), "Starting Full Screen process with flag=%d, mytype=%d",
flag, os2_mytype);
}
@@ -859,24 +1077,23 @@ do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag)
}
#if 0
- rc = result(aTHX_ 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,tmps,PL_Argv);
+ rc = spawnvp(trueflag,real_name,PL_Argv);
else /* EXECF_SPAWN, EXECF_SPAWN_BYFLAG */
rc = result(aTHX_ trueflag,
- spawnvp(flag,tmps,PL_Argv));
+ 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) {
@@ -912,7 +1129,7 @@ do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag)
scr = SvPV(scrsv, n_a); /* Reload */
if (PerlLIO_stat(scr,&PL_statbuf) >= 0
&& !S_ISDIR(PL_statbuf.st_mode)) { /* Found */
- tmps = scr;
+ real_name = scr;
pass++;
goto reread;
} else { /* Restore */
@@ -922,7 +1139,8 @@ do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag)
}
if (PerlIO_close(file) != 0) { /* Failure */
panic_file:
- Perl_warner(aTHX_ packWARN(WARN_EXEC), "Error reading \"%s\": %s",
+ if (ckWARN(WARN_EXEC))
+ Perl_warner(aTHX_ packWARN(WARN_EXEC), "Error reading \"%s\": %s",
scr, Strerror(errno));
buf = ""; /* Not #! */
goto doshell_args;
@@ -975,7 +1193,7 @@ do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag)
doshell_args:
{
char **a = PL_Argv;
- char *exec_args[2];
+ const char *exec_args[2];
if (force_shell
|| (!buf[0] && file)) { /* File without magic */
@@ -1046,8 +1264,8 @@ do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag)
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;
@@ -1056,6 +1274,20 @@ do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag)
/* 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], '/');
@@ -1072,7 +1304,8 @@ do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag)
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 = -1;
@@ -1215,9 +1448,9 @@ do_spawn3(pTHX_ char *cmd, int execf, int flag)
return rc;
}
-/* Array spawn. */
+/* Array spawn/exec. */
int
-os2_do_aspawn(pTHX_ SV *really, register void **vmark, register void **vsp)
+os2_aspawn4(pTHX_ SV *really, register SV **vmark, register SV **vsp, int execing)
{
register SV **mark = (SV **)vmark;
register SV **sp = (SV **)vsp;
@@ -1245,16 +1478,32 @@ os2_do_aspawn(pTHX_ SV *really, register void **vmark, register void **vsp)
}
*a = Nullch;
- if (flag_set && (a == PL_Argv + 1)) { /* One arg? */
+ 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(aTHX_ 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
os2_do_spawn(pTHX_ char *cmd)
{
@@ -1460,7 +1709,9 @@ os2_stat(const char *name, struct stat *st)
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;
}
@@ -1529,7 +1780,7 @@ sys_alloc(int size) {
/* tmp path */
-char *tmppath = TMPPATH1;
+const char *tmppath = TMPPATH1;
void
settmppath()
@@ -1538,6 +1789,7 @@ 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);
@@ -1562,6 +1814,7 @@ XS(XS_File__Copy_syscopy)
char * dst = (char *)SvPV(ST(1),n_a);
U32 flag;
int RETVAL, rc;
+ dXSTARG;
if (items < 3)
flag = 0;
@@ -1570,8 +1823,7 @@ XS(XS_File__Copy_syscopy)
}
RETVAL = !CheckOSError(DosCopy(src, dst, flag));
- ST(0) = sv_newmortal();
- sv_setiv(ST(0), (IV)RETVAL);
+ XSprePUSH; PUSHi((IV)RETVAL);
}
XSRETURN(1);
}
@@ -1583,7 +1835,6 @@ XS(XS_File__Copy_syscopy)
char *
mod2fname(pTHX_ SV *sv)
{
- static char fname[9];
int pos = 6, len, avlen;
unsigned int sum = 0;
char *s;
@@ -1640,10 +1891,11 @@ XS(XS_DynaLoader_mod2fname)
{
SV * sv = ST(0);
char * RETVAL;
+ dXSTARG;
RETVAL = mod2fname(aTHX_ sv);
- ST(0) = sv_newmortal();
- sv_setpv((SV*)ST(0), RETVAL);
+ sv_setpv(TARG, RETVAL);
+ XSprePUSH; PUSHTARG;
}
XSRETURN(1);
}
@@ -1652,7 +1904,6 @@ char *
os2error(int rc)
{
dTHX;
- static char buf[300];
ULONG len;
char *s;
int number = SvTRUE(get_sv("OS2::nsyserror", TRUE));
@@ -1661,17 +1912,37 @@ os2error(int rc)
if (rc == 0)
return "";
if (number) {
- sprintf(buf, "SYS%04d=%#x: ", rc, rc);
- s = buf + strlen(buf);
+ sprintf(os2error_buf, "SYS%04d=%#x: ", rc, rc);
+ s = os2error_buf + strlen(os2error_buf);
} else
- s = buf;
- if (DosGetMessage(NULL, 0, s, sizeof(buf) - 1 - (s-buf),
+ s = os2error_buf;
+ if (DosGetMessage(NULL, 0, s, sizeof(os2error_buf) - 1 - (s-os2error_buf),
rc, "OSO001.MSG", &len)) {
+ char *name = "";
+
if (!number) {
- sprintf(buf, "SYS%04d=%#x: ", rc, rc);
- s = buf + strlen(buf);
+ sprintf(os2error_buf, "SYS%04d=%#x: ", rc, rc);
+ s = os2error_buf + strlen(os2error_buf);
}
- sprintf(s, "[No description found in OSO001.MSG]");
+ 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')
@@ -1680,12 +1951,12 @@ os2error(int rc)
s[--len] = 0;
if (len && s[len - 1] == '.')
s[--len] = 0;
- if (len >= 10 && number && strnEQ(s, buf, 7)
+ 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 buf;
+ return os2error_buf;
}
void
@@ -1741,12 +2012,17 @@ os2_execname(pTHX)
char *
perllib_mangle(char *s, unsigned int l)
{
- static char *newp, *oldp;
- static int newl, oldl, notfound;
- static char ret[STATIC_FILE_LENGTH+1];
-
if (!newp && !notfound) {
- newp = getenv("PERLLIB_PREFIX");
+ newp = getenv("PERLLIB_" STRINGIFY(PERL_REVISION)
+ STRINGIFY(PERL_VERSION) STRINGIFY(PERL_SUBVERSION)
+ "_PREFIX");
+ if (!newp)
+ newp = getenv("PERLLIB_" STRINGIFY(PERL_REVISION)
+ STRINGIFY(PERL_VERSION) "_PREFIX");
+ if (!newp)
+ newp = getenv("PERLLIB_" STRINGIFY(PERL_REVISION) "_PREFIX");
+ if (!newp)
+ newp = getenv("PERLLIB_PREFIX");
if (newp) {
char *s;
@@ -1761,8 +2037,8 @@ perllib_mangle(char *s, unsigned int l)
if (newl == 0 || oldl == 0) {
Perl_croak_nocontext("Malformed PERLLIB_PREFIX");
}
- strcpy(ret, newp);
- s = ret;
+ strcpy(mangle_ret, newp);
+ s = mangle_ret;
while (*s) {
if (*s == '\\') *s = '/';
s++;
@@ -1783,8 +2059,8 @@ perllib_mangle(char *s, unsigned int l)
if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH) {
Perl_croak_nocontext("Malformed PERLLIB_PREFIX");
}
- strcpy(ret + newl, s + oldl);
- return ret;
+ strcpy(mangle_ret + newl, s + oldl);
+ return mangle_ret;
}
unsigned long
@@ -1793,6 +2069,31 @@ Perl_hab_GET() /* Needed if perl.h cannot be included */
return perl_hab_GET();
}
+static void
+Create_HMQ(int serve, char *message) /* Assumes morphing */
+{
+ unsigned fpflag = _control87(0,0);
+
+ init_PMWIN_entries();
+ /* 64 messages if before OS/2 3.0, ignored otherwise */
+ Perl_hmq = (*PMWIN_entries.CreateMsgQueue)(perl_hab_GET(), 64);
+ if (!Perl_hmq) {
+ dTHX;
+
+ SAVEINT(rmq_cnt); /* Allow catch()ing. */
+ if (rmq_cnt++)
+ _exit(188); /* Panic can try to create a window. */
+ CroakWinError(1, message ? message : "Cannot create a message queue");
+ }
+ if (serve != -1)
+ (*PMWIN_entries.CancelShutdown)(Perl_hmq, !serve);
+ /* We may have loaded some modules */
+ _control87(fpflag, MCW_EM); /* Some modules reset FP flags on (un)load */
+}
+
+#define REGISTERMQ_WILL_SERVE 1
+#define REGISTERMQ_IMEDIATE_UNMORPH 2
+
HMQ
Perl_Register_MQ(int serve)
{
@@ -1802,24 +2103,20 @@ Perl_Register_MQ(int serve)
Perl_hmq_refcnt = 0; /* Be extra safe */
DosGetInfoBlocks(&tib, &pib);
- 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 */
- 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;
- static int cnt;
-
- SAVEINT(cnt); /* Allow catch()ing. */
- if (cnt++)
- _exit(188); /* Panic can try to create a window. */
- Perl_croak_nocontext("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) {
+ 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);
@@ -1827,6 +2124,8 @@ Perl_Register_MQ(int serve)
} 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;
}
@@ -1873,24 +2172,31 @@ Perl_Process_Messages(int force, I32 *cntp)
void
Perl_Deregister_MQ(int serve)
{
- PPIB pib;
- PTIB tib;
-
- if (serve)
+ if (serve & REGISTERMQ_WILL_SERVE)
Perl_hmq_servers--;
+
if (--Perl_hmq_refcnt <= 0) {
+ unsigned fpflag = _control87(0,0);
+
init_PMWIN_entries(); /* To be extra safe */
(*PMWIN_entries.DestroyMsgQueue)(Perl_hmq);
Perl_hmq = 0;
+ /* We may have (un)loaded some modules */
+ _control87(fpflag, MCW_EM); /* Some modules reset FP flags on (un)load */
+ } else if ((serve & REGISTERMQ_WILL_SERVE) && Perl_hmq_servers <= 0)
+ (*PMWIN_entries.CancelShutdown)(Perl_hmq, 1); /* Last server exited */
+ if (!(serve & REGISTERMQ_IMEDIATE_UNMORPH) && (--Perl_morph_refcnt <= 0)) {
/* Try morphing back from a PM application. */
+ PPIB pib;
+ PTIB tib;
+
DosGetInfoBlocks(&tib, &pib);
if (pib->pib_ultype == 3) /* 3 is PM */
pib->pib_ultype = Perl_os2_initial_mode;
else
Perl_warn_nocontext("Unexpected program mode %d when morphing back from PM",
- pib->pib_ultype);
- } else if (serve && Perl_hmq_servers <= 0) /* Last server exited */
- (*PMWIN_entries.CancelShutdown)(Perl_hmq, 1);
+ pib->pib_ultype);
+ }
}
#define sys_is_absolute(path) ( isALPHA((path)[0]) && (path)[1] == ':' \
@@ -1903,8 +2209,6 @@ Perl_Deregister_MQ(int serve)
#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;
@@ -1919,7 +2223,7 @@ XS(XS_OS2_Error)
unsigned long rc;
if (CheckOSError(DosError(a)))
- Perl_croak_nocontext("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);
@@ -1928,8 +2232,6 @@ XS(XS_OS2_Error)
XSRETURN(1);
}
-static signed char DOS_suppression_state = -1;
-
XS(XS_OS2_Errors2Drive)
{
dXSARGS;
@@ -1949,7 +2251,8 @@ XS(XS_OS2_Errors2Drive)
? SPU_ENABLESUPPRESSION
: SPU_DISABLESUPPRESSION),
drive)))
- Perl_croak_nocontext("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);
@@ -1960,7 +2263,356 @@ XS(XS_OS2_Errors2Drive)
XSRETURN(1);
}
-static const char * const si_fields[QSV_MAX] = {
+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);
+}
+
+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",
@@ -1985,7 +2637,13 @@ static const char * const si_fields[QSV_MAX] = {
"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)
@@ -1994,25 +2652,67 @@ XS(XS_OS2_SysInfo)
if (items != 0)
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))))
- Perl_croak_nocontext("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);
}
- XSRETURN(2 * QSV_MAX);
+}
+
+XS(XS_OS2_SysInfoFor)
+{
+ dXSARGS;
+ int count = (items == 2 ? (int)SvIV(ST(1)) : 1);
+
+ if (items < 1 || items > 2)
+ Perl_croak_nocontext("Usage: OS2::SysInfoFor(id[,count])");
+ {
+ /* System Information Data Buffer (10 extra w.r.t. Warp 4.5) */
+ ULONG si[C_ARRAY_LENGTH(si_fields) + 10];
+ APIRET rc = NO_ERROR; /* Return code */
+ int i = 0;
+ int start = (int)SvIV(ST(0));
+
+ if (count > C_ARRAY_LENGTH(si) || count <= 0)
+ Perl_croak(aTHX_ "unexpected count %d for OS2::SysInfoFor()", count);
+ if (CheckOSError(DosQuerySysInfo(start,
+ start + count - 1,
+ (PVOID)si,
+ sizeof(si))))
+ croak_with_os2error("DosQuerySysInfo() failed");
+ EXTEND(SP,count);
+ while (i < count) {
+ ST(i) = sv_newmortal();
+ sv_setiv(ST(i), si[i]);
+ i++;
+ }
+ }
+ XSRETURN(count);
}
XS(XS_OS2_BootDrive)
@@ -2024,17 +2724,36 @@ XS(XS_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))))
- Perl_croak_nocontext("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;
@@ -2043,9 +2762,9 @@ XS(XS_OS2_MorphPM)
{
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);
}
@@ -2071,9 +2790,9 @@ XS(XS_OS2_Serve_Messages)
{
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);
}
@@ -2086,6 +2805,7 @@ XS(XS_OS2_Process_Messages)
{
bool force = SvOK(ST(0));
unsigned long cnt;
+ dXSTARG;
if (items == 2) {
I32 cntr;
@@ -2100,8 +2820,7 @@ XS(XS_OS2_Process_Messages)
} else {
cnt = Perl_Process_Messages(force, NULL);
}
- ST(0) = sv_newmortal();
- sv_setiv(ST(0), cnt);
+ XSprePUSH; PUSHi((IV)cnt);
}
XSRETURN(1);
}
@@ -2113,10 +2832,11 @@ XS(XS_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);
}
@@ -2214,9 +2934,11 @@ XS(XS_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
@@ -2392,6 +3114,7 @@ XS(XS_Cwd_extLibpath)
char to[1024];
U32 rc;
char * RETVAL;
+ dXSTARG;
if (items < 1)
type = 0;
@@ -2403,8 +3126,8 @@ XS(XS_Cwd_extLibpath)
RETVAL = extLibpath(to, type);
if (RETVAL && RETVAL[0] == 1 && RETVAL[1] == 0)
Perl_croak_nocontext("panic Cwd::extLibpath parameter");
- ST(0) = sv_newmortal();
- sv_setpv((SV*)ST(0), RETVAL);
+ sv_setpv(TARG, RETVAL);
+ XSprePUSH; PUSHTARG;
}
XSRETURN(1);
}
@@ -2445,7 +3168,8 @@ 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};
+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)
@@ -2454,14 +3178,19 @@ module_name_at(void *pp, enum module_name_how how)
char buf[MAXPATHLEN];
char *p = buf;
HMODULE mod;
- ULONG obj, offset, rc;
-
- if (!_DosQueryModFromEIP(&mod, &obj, sizeof(buf), buf, &offset, (ULONG)pp))
+ 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_full
+ if ( how != mod_name_shortname
&& CheckOSError(DosQueryModuleName(mod, sizeof(buf), buf)) )
return &PL_sv_undef;
while (*p) {
@@ -2478,6 +3207,10 @@ 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);
@@ -2510,6 +3243,70 @@ XS(XS_OS2_DLLname)
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
@@ -2522,14 +3319,63 @@ XS(XS_OS2__control87)
unsigned new = (unsigned)SvIV(ST(0));
unsigned mask = (unsigned)SvIV(ST(1));
unsigned RETVAL;
+ dXSTARG;
RETVAL = _control87(new, mask);
- ST(0) = sv_newmortal();
- sv_setiv(ST(0), (IV)RETVAL);
+ 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;
@@ -2537,10 +3383,10 @@ XS(XS_OS2_get_control87)
Perl_croak(aTHX_ "Usage: OS2::get_control87()");
{
unsigned RETVAL;
+ dXSTARG;
RETVAL = get_control87();
- ST(0) = sv_newmortal();
- sv_setiv(ST(0), (IV)RETVAL);
+ XSprePUSH; PUSHi((IV)RETVAL);
}
XSRETURN(1);
}
@@ -2555,6 +3401,7 @@ XS(XS_OS2_set_control87)
unsigned new;
unsigned mask;
unsigned RETVAL;
+ dXSTARG;
if (items < 1)
new = MCW_EM;
@@ -2569,8 +3416,29 @@ XS(XS_OS2_set_control87)
}
RETVAL = set_control87(new, mask);
- ST(0) = sv_newmortal();
- sv_setiv(ST(0), (IV)RETVAL);
+ XSprePUSH; PUSHi((IV)RETVAL);
+ }
+ XSRETURN(1);
+}
+
+XS(XS_OS2_incrMaxFHandles) /* DosSetRelMaxFH */
+{
+ dXSARGS;
+ if (items < 0 || items > 1)
+ Perl_croak(aTHX_ "Usage: OS2::incrMaxFHandles(delta = 0)");
+ {
+ LONG delta;
+ ULONG RETVAL, rc;
+ dXSTARG;
+
+ if (items < 1)
+ delta = 0;
+ else
+ delta = (LONG)SvIV(ST(0));
+
+ if (CheckOSError(DosSetRelMaxFH(&delta, &RETVAL)))
+ croak_with_os2error("OS2::incrMaxFHandles(): DosSetRelMaxFH() error");
+ XSprePUSH; PUSHu((UV)RETVAL);
}
XSRETURN(1);
}
@@ -2590,6 +3458,8 @@ Xs_OS2_init(pTHX)
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);
@@ -2608,6 +3478,15 @@ Xs_OS2_init(pTHX)
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::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
@@ -2634,8 +3513,6 @@ Xs_OS2_init(pTHX)
return 0;
}
-OS2_Perl_data_t OS2_Perl_data;
-
extern void _emx_init(void*);
static void jmp_out_of_atexit(void);
@@ -2645,7 +3522,7 @@ static void jmp_out_of_atexit(void);
static void
my_emx_init(void *layout) {
- static volatile void *p = 0; /* Cannot be on stack! */
+ 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 */
@@ -2656,7 +3533,7 @@ my_emx_init(void *layout) {
"call __emx_init\n"
"movl %1, %%esp\n"
"popa\n"
- "popf\n" : : "r" (layout), "m" (p) );
+ "popf\n" : : "r" (layout), "m" (old_esp) );
}
struct layout_table_t {
@@ -2680,7 +3557,7 @@ struct layout_table_t {
static ULONG
my_os_version() {
- static ULONG res; /* Cannot be on stack! */
+ 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 */
@@ -2689,9 +3566,9 @@ my_os_version() {
"call ___os_version\n"
"movl %%eax, %0\n"
"popa\n"
- "popf\n" : "=m" (res) );
+ "popf\n" : "=m" (osv_res) );
- return res;
+ return osv_res;
}
static void
@@ -2703,7 +3580,6 @@ force_init_emx_runtime(EXCEPTIONREGISTRATIONRECORD *preg, ULONG flags)
void *oldstackend, *oldstack;
PPIB pib;
PTIB tib;
- static ULONG os2_dll;
ULONG rc, error = 0, out;
char buf[512];
static struct layout_table_t layout_table;
@@ -2714,7 +3590,7 @@ force_init_emx_runtime(EXCEPTIONREGISTRATIONRECORD *preg, ULONG flags)
} *newstack;
char *s;
- layout_table.os2_dll = (ULONG)&os2_dll;
+ layout_table.os2_dll = (ULONG)&os2_dll_fake;
layout_table.flags = 0x02000002; /* flags: application, OMF */
DosGetInfoBlocks(&tib, &pib);
@@ -2794,9 +3670,6 @@ force_init_emx_runtime(EXCEPTIONREGISTRATIONRECORD *preg, ULONG flags)
exit(56);
}
-jmp_buf at_exit_buf;
-int longjmp_at_exit;
-
static void
jmp_out_of_atexit(void)
{
@@ -2806,8 +3679,6 @@ jmp_out_of_atexit(void)
extern void _CRT_term(void);
-int emx_runtime_secondary;
-
void
Perl_OS2_term(void **p, int exitstatus, int flags)
{
@@ -2847,12 +3718,12 @@ Perl_OS2_term(void **p, int exitstatus, int flags)
extern ULONG __os_version(); /* See system.doc */
-static int emx_wasnt_initialized;
-
void
check_emx_runtime(char **env, EXCEPTIONREGISTRATIONRECORD *preg)
{
- ULONG v_crt, v_emx;
+ ULONG v_crt, v_emx, count = 0, rc, 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
@@ -2861,6 +3732,44 @@ check_emx_runtime(char **env, EXCEPTIONREGISTRATIONRECORD *preg)
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(). */
@@ -2913,6 +3822,9 @@ check_emx_runtime(char **env, EXCEPTIONREGISTRATIONRECORD *preg)
*ep = NULL;
}
_environ = _org_environ = env;
+ emx_init_done = 1;
+ if (hmtx_emx_init)
+ DosReleaseMutexSem(hmtx_emx_init);
}
#define ENTRY_POINT 0x10000
@@ -2973,8 +3885,11 @@ Perl_OS2_init3(char **env, void **preg, int flags)
}
#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 */
/* Some DLLs reset FP flags on load. We may have been linked with them */
_control87(MCW_EM, MCW_EM);
}
@@ -3072,16 +3987,20 @@ my_flock(int handle, int o)
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? */
@@ -3175,9 +4094,6 @@ my_flock(int handle, int o)
return 0;
}
-static int pwent_cnt;
-static int _my_pwent = -1;
-
static int
use_my_pwent(void)
{
@@ -3224,8 +4140,6 @@ my_getpwent (void)
return getpwuid(0);
}
-static int grent_cnt;
-
void
setgrent(void)
{
@@ -3254,7 +4168,6 @@ static const char pw_p[] = "Jf0Wb/BzMFvk7K7lrzK";
static struct passwd *
passw_wrap(struct passwd *p)
{
- static struct passwd pw;
char *s;
if (!p || (p->pw_passwd && *p->pw_passwd)) /* Not a dangerous password */
@@ -3283,6 +4196,21 @@ my_getpwnam (__const__ char *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);
}
@@ -3293,14 +4221,66 @@ int fork_with_resources()
dTHX;
void *ctx = PERL_GET_CONTEXT;
#endif
-
+ unsigned fpflag = _control87(0,0);
int rc = fork();
-#if (defined(USE_5005THREADS) || defined(USE_ITHREADS)) && !defined(USE_SLOW_THREAD_SPECIFIC)
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;
}
+
diff --git a/os2/os2ish.h b/os2/os2ish.h
index c6baad554a..b612683602 100644
--- a/os2/os2ish.h
+++ b/os2/os2ish.h
@@ -297,7 +297,7 @@ void *sys_alloc(int size);
#endif
#define TMPPATH1 "plXXXXXX"
-extern char *tmppath;
+extern const char *tmppath;
PerlIO *my_syspopen(pTHX_ char *cmd, char *mode);
/* Cannot prototype with I32 at this point. */
int my_syspclose(PerlIO *f);
@@ -310,6 +310,28 @@ void my_setpwent (void);
void my_endpwent (void);
char *gcvt_os2(double value, int digits, char *buffer);
+#define MAX_SLEEP (((1<30) / (1000/4))-1) /* 1<32 msec */
+
+static __inline__ unsigned
+my_sleep(unsigned sec)
+{
+ int remain;
+ while (sec > MAX_SLEEP) {
+ sec -= MAX_SLEEP;
+ remain = sleep(MAX_SLEEP);
+ if (remain)
+ return remain + sec;
+ }
+ return sleep(sec);
+}
+
+#define sleep my_sleep
+
+#ifndef INCL_DOS
+unsigned long DosSleep(unsigned long);
+unsigned long DosAllocThreadLocalMemory (unsigned long cb, unsigned long **p);
+#endif
+
struct group *getgrent (void);
void setgrent (void);
void endgrent (void);
@@ -328,6 +350,9 @@ struct passwd *my_getpwnam (__const__ char *);
#define strtoll _strtoll
#define strtoull _strtoull
+#define usleep(usec) ((void)_sleep2(((usec)+500)/1000))
+
+
/*
* fwrite1() should be a routine with the same calling sequence as fwrite(),
* but which outputs all of the bytes requested as a single stream (unlike
@@ -438,6 +463,7 @@ typedef struct OS2_Perl_data {
unsigned long phmq_refcnt;
unsigned long phmq_servers;
unsigned long initial_mode; /* VIO etc. mode we were started in */
+ unsigned long morph_refcnt;
} OS2_Perl_data_t;
extern OS2_Perl_data_t OS2_Perl_data;
@@ -461,6 +487,7 @@ extern OS2_Perl_data_t OS2_Perl_data;
#define Perl_hmq_refcnt (OS2_Perl_data.phmq_refcnt)
#define Perl_hmq_servers (OS2_Perl_data.phmq_servers)
#define Perl_os2_initial_mode (OS2_Perl_data.initial_mode)
+#define Perl_morph_refcnt (OS2_Perl_data.morph_refcnt)
unsigned long Perl_hab_GET();
unsigned long Perl_Register_MQ(int serve);
@@ -613,6 +640,44 @@ enum entries_ordinals {
ORD_WinQueryDesktopWindow,
ORD_WinSetActiveWindow,
ORD_DosQueryModFromEIP,
+ ORD_Dos32QueryHeaderInfo,
+ ORD_DosTmrQueryFreq,
+ ORD_DosTmrQueryTime,
+ ORD_WinQueryActiveDesktopPathname,
+ ORD_WinInvalidateRect,
+ ORD_WinCreateFrameControls,
+ ORD_WinQueryClipbrdFmtInfo,
+ ORD_WinQueryClipbrdOwner,
+ ORD_WinQueryClipbrdViewer,
+ ORD_WinQueryClipbrdData,
+ ORD_WinOpenClipbrd,
+ ORD_WinCloseClipbrd,
+ ORD_WinSetClipbrdData,
+ ORD_WinSetClipbrdOwner,
+ ORD_WinSetClipbrdViewer,
+ ORD_WinEnumClipbrdFmts,
+ ORD_WinEmptyClipbrd,
+ ORD_WinAddAtom,
+ ORD_WinFindAtom,
+ ORD_WinDeleteAtom,
+ ORD_WinQueryAtomUsage,
+ ORD_WinQueryAtomName,
+ ORD_WinQueryAtomLength,
+ ORD_WinQuerySystemAtomTable,
+ ORD_WinCreateAtomTable,
+ ORD_WinDestroyAtomTable,
+ ORD_WinOpenWindowDC,
+ ORD_DevOpenDC,
+ ORD_DevQueryCaps,
+ ORD_DevCloseDC,
+ ORD_WinMessageBox,
+ ORD_WinMessageBox2,
+ ORD_WinQuerySysValue,
+ ORD_WinSetSysValue,
+ ORD_WinAlarm,
+ ORD_WinFlashWindow,
+ ORD_WinLoadPointer,
+ ORD_WinQuerySysPointer,
ORD_NENTRIES
};
@@ -674,6 +739,21 @@ char *perllib_mangle(char *, unsigned int);
#define fork fork_with_resources
+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)
+ return 0;
+ errno = EINTR;
+ return -1;
+ }
+ return select(nfds, readfds, writefds, exceptfds, timeout);
+}
+
+#define select my_select
+
+
typedef int (*Perl_PFN)();
Perl_PFN loadByOrdinal(enum entries_ordinals ord, int fail);
extern const Perl_PFN * const pExtFCN;
@@ -683,9 +763,11 @@ int fork_with_resources();
int setpriority(int which, int pid, int val);
int getpriority(int which /* ignored */, int pid);
+void croak_with_os2error(char *s) __attribute__((noreturn));
+
#ifdef PERL_CORE
int os2_do_spawn(pTHX_ char *cmd);
-int os2_do_aspawn(pTHX_ SV *really, void **vmark, void **vsp);
+int os2_do_aspawn(pTHX_ SV *really, SV **vmark, SV **vsp);
#endif
#ifndef LOG_DAEMON
diff --git a/os2/perlrexx.cmd b/os2/perlrexx.cmd
new file mode 100644
index 0000000000..5a32d85105
--- /dev/null
+++ b/os2/perlrexx.cmd
@@ -0,0 +1,68 @@
+/* Test PERLREXX.DLL */
+/* Example:
+ perlrexx.cmd BEGIN {push @INC, 'lib'} use OS2::REXX; REXX_eval "address cmd\n'copyy'";
+ */
+
+call RxFuncAdd 'SysLoadFuncs', 'RexxUtil', 'SysLoadFuncs'
+call SysLoadFuncs
+
+parse arg args
+retval = runperl(args)
+say 'retval = "'retval'"'
+exit 0
+
+addperl: procedure
+ parse arg perlf
+ pathname='perlrexx'
+ r = RxFuncAdd(perlf, pathname, perlf)
+ say "RxFuncAdd("perlf","pathname") -> "r
+ return
+
+runperl1: procedure
+ parse arg perlarg
+ call addperl('PERL')
+ call addperl('PERLTERM')
+ call addperl('PERLEXIT')
+ call addperl('PERLEVAL')
+ call addperl('PERLLASTERROR')
+ signal on syntax name runperl_error
+/* signal on error name runperl_error
+ signal on failure name runperl_error */
+ say "doing PERLEVAL("perlarg")"
+ tmp = PERLEVAL(perlarg)
+ say "PERLEVAL -> '"tmp"'"
+ signal off syntax
+ call RxFuncDrop 'PERL'
+ call RxFuncDrop 'PERLLASTERROR'
+ call RxFuncDrop 'PERLTERM'
+ call RxFuncDrop 'PERLEVAL'
+ call PERLEXIT
+ call RxFuncDrop 'PERLEXIT'
+ return pathname ': PERLEVAL('perlarg') =' tmp
+
+runperl: procedure
+ parse arg perlarg
+ pathname='perlrexx'
+ r = RxFuncAdd("PerlExportAll", pathname, "PERLEXPORTALL")
+ say "RxFuncAdd("'PerlExportAll'","pathname") -> "r
+ r = PerlExportAll()
+ say "PerlExportAll() -> "r
+ signal on syntax name runperl_error
+/* signal on error name runperl_error
+ signal on failure name runperl_error */
+ say "doing PERLEVAL("perlarg")"
+ tmp = PERLEVAL(perlarg)
+ say "PERLEVAL -> '"tmp"'"
+ address evalperl perlarg
+ say "Did address evalperl "perlarg
+ signal off syntax
+ r = PerlDropAllExit()
+ /* The following line is not reached... Why? */
+ say "PerlDropAllExit() -> "r
+ return pathname ': PERLEVAL('perlarg') =' tmp
+
+
+runperl_error:
+ return pathname ': REXX->Perl interface not available; rc="'rc'", .rs="'.rs'", errstr="'errortext(rc)'", perlerr="'PERLLASTERROR()'"'
+
+/* return pathname ': REXX->Perl interface not available; rc="'rc'", .rs="'.rs'", errstr="'errortext(rc)'", perlerr="???"' */
View Lorry Controller Status