summaryrefslogtreecommitdiff
path: root/os2/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/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/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
8 files changed, 945 insertions, 138 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