summaryrefslogtreecommitdiff
path: root/os2/OS2
diff options
context:
space:
mode:
authorIlya Zakharevich <ilya@math.berkeley.edu>2006-12-17 16:45:24 -0800
committerRafael Garcia-Suarez <rgarciasuarez@gmail.com>2006-12-18 13:34:00 +0000
commit9d419b5f6925ac8219b490513f2c0e4f2d7c7f74 (patch)
treeade0148247a1332511a5db94e9ff95d8b80c9b4b /os2/OS2
parentdbf3bb275a8c67f06df1e6e24df320e3d78b2d60 (diff)
downloadperl-9d419b5f6925ac8219b490513f2c0e4f2d7c7f74.tar.gz
OS/2-specific fixes, round II
Message-ID: <20061218084524.GA14866@powdermilk.math.berkeley.edu> p4raw-id: //depot/perl@29580
Diffstat (limited to 'os2/OS2')
-rw-r--r--os2/OS2/Process/Process.pm847
-rw-r--r--os2/OS2/Process/Process.xs214
-rw-r--r--os2/OS2/Process/t/os2_atoms.t88
-rw-r--r--os2/OS2/Process/t/os2_clipboard.t211
-rw-r--r--os2/OS2/Process/t/os2_process.t24
-rw-r--r--os2/OS2/REXX/DLL/Changes2
-rw-r--r--os2/OS2/REXX/DLL/DLL.pm7
7 files changed, 1300 insertions, 93 deletions
diff --git a/os2/OS2/Process/Process.pm b/os2/OS2/Process/Process.pm
index c299e88467..51d8700fe7 100644
--- a/os2/OS2/Process/Process.pm
+++ b/os2/OS2/Process/Process.pm
@@ -60,6 +60,9 @@ our @EXPORT = qw(
T_VIRTDRV
T_PROTDLL
T_32BIT
+
+ os2constant
+
ppid
ppidOf
sidOf
@@ -137,16 +140,22 @@ our @EXPORT = qw(
WindowPtr
WindowULong
WindowUShort
+ WindowStyle
SetWindowBits
SetWindowPtr
SetWindowULong
SetWindowUShort
+ WindowBits_set
+ WindowPtr_set
+ WindowULong_set
+ WindowUShort_set
TopLevel
FocusWindow_set_keep_Zorder
ActiveDesktopPathname
InvalidateRect
- CreateFrameControl
+ CreateFrameControls
+
ClipbrdFmtInfo
ClipbrdOwner
ClipbrdViewer
@@ -158,6 +167,8 @@ our @EXPORT = qw(
ClipbrdViewer_set
EnumClipbrdFmts
EmptyClipbrd
+ ClipbrdFmtNames
+ ClipbrdFmtAtoms
AddAtom
FindAtom
DeleteAtom
@@ -171,11 +182,15 @@ our @EXPORT = qw(
_ClipbrdData_set
ClipbrdText
ClipbrdText_set
+ ClipbrdText_2byte
+ ClipbrdTextUCS2le
+ MemoryRegionSize
_MessageBox
MessageBox
_MessageBox2
MessageBox2
+ get_pointer
LoadPointer
SysPointer
Alarm
@@ -183,6 +198,7 @@ our @EXPORT = qw(
get_title
set_title
+ io_term
);
our @EXPORT_OK = qw(
ResetWinError
@@ -216,11 +232,18 @@ sub AUTOLOAD {
goto &$AUTOLOAD;
}
-sub const_import {
+sub os2constant {
require OS2::Process::Const;
my $sym = shift;
my ($err, $val) = OS2::Process::Const::constant($sym);
die $err if $err;
+ $val;
+}
+
+sub const_import {
+ require OS2::Process::Const;
+ my $sym = shift;
+ my $val = os2constant($sym);
my $p = caller(1);
# no strict;
@@ -412,21 +435,78 @@ sub FocusWindow_set_keep_Zorder ($) {
EnableWindowUpdate($t, 1);
}
-sub ClipbrdText (@) {
- my $morph = OS2::localMorphPM->new(0);
- OpenClipbrd();
- my $txt = unpack 'p', pack 'L', ClipbrdData @_;
+sub WindowStyle ($) {
+ WindowULong(shift,-2); # QWL_STYLE
+}
+
+sub OS2::localClipbrd::new {
+ my ($c) = shift;
+ my $morph = [];
+ push @$morph, OS2::localMorphPM->new(0) unless shift;
+ &OpenClipbrd;
+ # print STDERR ">>>>>\n";
+ bless $morph, $c
+}
+sub OS2::localClipbrd::DESTROY {
+ # print STDERR "<<<<<\n";
CloseClipbrd();
- $txt;
}
-sub ClipbrdText_set ($;$) {
+sub OS2::localFlashWindow::new ($$) {
+ my ($c, $w) = (shift, shift);
my $morph = OS2::localMorphPM->new(0);
- OpenClipbrd();
+ FlashWindow($w, 1);
+ # print STDERR ">>>>>\n";
+ bless [$w, $morph], $c
+}
+sub OS2::localFlashWindow::DESTROY {
+ # print STDERR "<<<<<\n";
+ FlashWindow(shift->[0], 0);
+}
+
+# Good for \0-terminated text (not "text/unicode" and other Firefox stuff)
+sub ClipbrdText (@) {
+ my $h = OS2::localClipbrd->new;
+ my $data = ClipbrdData @_;
+ return unless $data;
+ my $lim = MemoryRegionSize($data);
+ $lim = StrLen($data, $lim); # Look for 1-byte 0
+ return unpack "P$lim", pack 'L', $data;
+}
+
+sub ClipbrdText_2byte (@) {
+ my $h = OS2::localClipbrd->new;
+ my $data = ClipbrdData @_;
+ return unless $data;
+ my $lim = MemoryRegionSize($data);
+ $lim = StrLen($data, $lim, 2); # Look for 2-byte 0
+ return unpack "P$lim", pack 'L', $data;
+}
+
+sub ClipbrdTextUCS2le (@) {
+ my $txt = ClipbrdText_2byte @_; # little-endian shorts
+ #require Unicode::String;
+ pack "U*", unpack "v*", $txt;
+}
+
+sub ClipbrdText_set ($;@) {
+ my $h = OS2::localClipbrd->new;
EmptyClipbrd(); # It may contain other types
my ($txt, $no_convert_nl) = (shift, shift);
ClipbrdData_set($txt, !$no_convert_nl, @_);
- CloseClipbrd();
+}
+
+sub ClipbrdFmtAtoms {
+ my $h = OS2::localClipbrd->new('nomorph');
+ my $fmt = 0;
+ my @formats;
+ push @formats, $fmt while eval {$fmt = EnumClipbrdFmts $fmt};
+ die $@ if $@ and $^E == 0x1001 and $fmt = 0; # Croaks on empty list?
+ @formats;
+}
+
+sub ClipbrdFmtNames {
+ map AtomName($_), ClipbrdFmtAtoms(@_);
}
sub MessageBox ($;$$$$$) {
@@ -467,7 +547,7 @@ sub process_MB2_INFO ($;$$$) {
my $buttons = shift;
die "Buttons array should consist of pairs" if @$buttons % 2;
- push @_, 0 unless @_; # Icon id (pointer)
+ push @_, 0 unless @_; # Icon id; non-0 ignored without MB_CUSTOMICON
# Box flags (MB_MOVABLE and MB_INFORMATION or MB_CUSTOMICON)
push @_, ($_[0] ? 0x4080 : 0x4030) unless @_ > 1;
push @_, 0 unless @_ > 2; # Notify window
@@ -492,20 +572,63 @@ sub process_MB2_INFO ($;$$$) {
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
+ push @_ , [[Dismiss => 0x1000], # Name, retval (style BS_PUSHBUTTON|BS_DEFAULT)
+ #0, # e.g., 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;
+ push @_ , ($0 eq '-e' ? "Perl one-liner" : $0). "'s message" if @_ == 2;
$_[1] = &process_MB2_INFO(@{$_[1]}) if ref($_[1]) eq 'ARRAY';
&_MessageBox2;
}
+my %mbH_default = (
+ text => 'Something happened',
+ title => ($0 eq '-e' ? "Perl one-liner" : $0). "'s message",
+ parent => 1, # HWND_DESKTOP
+ owner => 0,
+ helpID => 0,
+ buttons => ['Dismiss' => 0x1000],
+ default_button => 1,
+# icon => 0x30, # MB_INFORMATION
+# iconID => 0, # XXX???
+ flags => 0, # XXX???
+ notifyWindow => 0, # XXX???
+);
+
+sub MessageBoxH {
+ die "MessageBoxH: even number of arguments expected" if @_ % 2;
+ my %a = (%mbH_default, @_);
+ die "MessageBoxH: even number of elts of button array expected"
+ if @{$a{buttons}} % 2;
+ if (defined $a{iconID}) {
+ $a{flags} |= 0x80; # MB_CUSTOMICON
+ } else {
+ $a{icon} = 0x30 unless defined $a{icon};
+ $a{iconID} = 0;
+ $a{flags} |= $a{icon};
+ }
+ # Mark default_button as MessageBox2() expects it:
+ $a{buttons}[2*$a{default_button}] = [$a{buttons}[2*$a{default_button}]];
+
+ my $use_2 = 'ARRAY' eq ref $a{buttons};
+ return
+ MessageBox2 $a{text}, [@a{qw(buttons iconID flags notifyWindow)}],
+ $a{parent}, $a{owner}, $a{helpID}
+ if $use_2;
+ die "MessageBoxH: unexpected format of argument 'buttons'";
+}
+
# backward compatibility
*set_title = \&Title_set;
*get_title = \&Title;
+# New (logical) names
+*WindowBits_set = \&SetWindowBits;
+*WindowPtr_set = \&SetWindowPtr;
+*WindowULong_set = \&SetWindowULong;
+*WindowUShort_set = \&SetWindowUShort;
+
# adapter; display; cbMemory; Configuration; VDHVersion; Flags; HWBufferSize;
# FullSaveSize; PartSaveSize; EMAdaptersOFF; EMDisplaysOFF;
sub vioConfig (;$$) {
@@ -573,6 +696,138 @@ sub kbdhStatus_set {
_kbdStatus_set($o,$h);
}
+#sub DeleteAtom { !WinDeleteAtom(@_) }
+sub DeleteAtom { !_DeleteAtom(@_) }
+sub DestroyAtomTable { !_DestroyAtomTable(@_) }
+
+# XXXX This is a wrong order: we start keyreader, then screenwriter; so it is
+# the writer who gets signals.
+
+# XXXX Do we ever get a message "screenwriter killed"??? If reader HUPs us...
+# Large buffer works at least for read from pipes; should we binmode???
+sub __term_mirror_screen { # Read from fd=$in and write to the console
+ local $SIG{TERM} = $SIG{HUP} = $SIG{BREAK} = $SIG{INT} = # die() can stop END
+ sub { my $s = shift; warn "screenwriter killed ($s)...\n";};
+ my $in = shift;
+ open IN, "<&=$in" or die "open <&=$in: $!";
+ # Attempt to redirect to STDERR/OUT is not very useful, but try this anyway...
+ open OUT, '>', '/dev/con' or open OUT, '>&STDERR' or open OUT, '>&STDOUT'
+ and select OUT or die "Can't open /dev/con or STDERR/STDOUT for write";
+ $| = 1; local $SIG{TERM} = sub { die "screenwriter exits...\n"};
+ binmode IN; binmode OUT;
+ eval { print $_ while sysread IN, $_, 1<<16; }; # print to OUT...
+ warn $@ if $@;
+ warn "Screenwriter can't read any more ($!, $^E), terminating...\n";
+}
+
+# Does not automatically ends when the parent exits if related => 0
+# copy from fd=$in to screen ; same for $out; or $in may be a named pipe
+sub __term_mirror {
+ my $pid;
+ ### If related => 1, we get TERM when our parent exits...
+ local $SIG{TERM} = sub { my $s = shift;
+ die "keyreader exits in a few secs ($s)...\n" };
+ my ($in, $out) = (shift, shift);
+ if (defined $out and length $out) { # Allow '' for ease of @ARGV
+ open OUT, ">&=$out" or die "Cannot open &=$out for write: $!";
+ fcntl(OUT, 4, 1); # F_SETFD, NOINHERIT
+ open IN, "<&=$in" or die "Cannot open &=$in for read/ioctl: $!";
+ fcntl(IN, 4, 0); # F_SETFD, INHERIT
+ } else {
+ warn "Unexpected i/o pipe name: `$in'" unless $in =~ m,^[\\/]pipe[\\/],i;
+ OS2::pipe $in, 'wait';
+ open OUT, '+<', $in or die "Can't open `$in' for r/w: $!";
+ fcntl(OUT, 4, 0); # F_SETFD, INHERIT
+ $in = fileno OUT;
+ undef $out;
+ }
+ my %opt = @_;
+ Title_set $opt{title} if exists $opt{title};
+ &scrsize_set(split /,/, $opt{scrsize}) if exists $opt{scrsize};
+
+ my @i = map +('-I', $_), @INC; # Propagate @INC
+
+ # Careful unless PERL_SIGNALS=unsafe: SIGCHLD does not work...
+ $SIG{CHLD} = sub {wait; die "Keyreader follows screenwriter...\n"}
+ unless defined $out;
+
+ $pid = system 1, $^X, @i, '-MOS2::Process',
+ '-we', 'END {sleep 2} OS2::Process::__term_mirror_screen shift', $in;
+ close IN if defined $out;
+ $pid > 0 or die "Cannot start a grandkid";
+
+ open STDIN, '</dev/con' or warn "reopen stdin: $!";
+ select OUT; $| = 1; binmode OUT; # need binmode: sysread() may be bin
+ $SIG{PIPE} = sub { die "writing to a closed pipe" };
+ $SIG{HUP} = $SIG{BREAK} = $SIG{INT} = $SIG{TERM};
+ # Workaround: EMX v61 won't return pid on SESSION|UNRELATED after fork()...
+ syswrite OUT, pack 'L', $$ or die "syswrite failed: $!" if $opt{writepid};
+ # Turn Nodelay on kbd. Pipe is automatically nodelay...
+ if ($opt{read_by_key}) {
+ if (eval {require Term::ReadKey; 1}) {
+ Term::ReadKey::ReadMode(4);
+ } else { warn "can't load Term::ReadKey; input by lines..." }
+ }
+ print while sysread STDIN, $_, 1<<($opt{smallbuffer} ? 0 : 16); # to OUT
+}
+
+my $c = 0;
+sub io_term { # arguments as hash: read_by_key/title/scrsize/related/writepid
+ # read_by_key disables echo too...
+ local $\ = '';
+ my ($sysf, $in1, $out1, $in2, $out2, $f1, $f2, $fd) = 4; # P_SESSION
+ my %opt = @_;
+
+ if ($opt{related}) {
+ pipe $in1, $out1 or die "pipe(): $!";
+ pipe $in2, $out2 or do { close($in1), close($out1), die "pipe(): $!" };
+ $f1 = fileno $in1; $f2 = fileno $out2;
+ fcntl($in2, 4, 1); fcntl($out1, 4, 1); # F_SETFD, NOINHERIT
+ fcntl($in1, 4, 0); fcntl($out2, 4, 0); # F_SETFD, INHERIT
+ } else {
+ $f1 = "/pipe/perlmodule/OS2/Process/$$-" . $c++;
+ $out1 = OS2::pipe $f1, 'rw' or die "OS2::pipe(): $^E";
+ #open $out1, "+<&=$fd" or die "dup($fd): $!, $^E";
+ fcntl($out1, 4, 1); # F_SETFD, NOINHERIT
+ #$in2 = $out1;
+ $f2 = '';
+ $sysf |= 0x40000; # P_UNRELATED
+ $opt{writepid} = 1, unless exists $opt{writepid};
+ }
+
+ # system P_SESSION will fail if there is another process
+ # in the same session with a "related" asynchronous child session.
+ my @i = map +('-I', $_), @INC; # Propagate @INC
+ my $krun = <<'EOS';
+ END {sleep($sleep || 5)}
+ use OS2::Process; $sleep = 1;
+ OS2::Process::__term_mirror(@ARGV);
+EOS
+ my $kpid;
+ if ($opt{related}) {
+ $kpid = system $sysf, $^X, @i, '-we', $krun, $f1, $f2, %opt;
+ } else {
+ local $ENV{PERL_SIGNALS} = 'unsafe';
+ $kpid = system $sysf, $^X, @i, '-we', $krun, $f1, $f2, %opt;
+ }
+ close $in1 or warn if defined $in1;
+ close $out2 or warn if defined $out2;
+ # EMX BUG with $kpid == 0 after fork()
+ do { close($in2), ($out1 != $in2 and close($out1)),
+ die "system $sysf, $^X: kid=$kpid, \$!=`$!', \$^E=`$^E'" }
+ unless $kpid > 0 or $kpid == 0 and $opt{writepid};
+ # Can't read or write until the kid opens the pipes
+ OS2::pipeCntl $out1, 'connect', 'wait' unless length $f2;
+ # Without duping: write after read (via termio) on the same fd dups input
+ open $in2, '<&', $out1 or die "dup($out1): $^E" unless $opt{related};
+ if ($opt{writepid}) {
+ my $c = length pack 'L', 0;
+ my $c1 = sysread $in2, (my $pid), $c;
+ $c1 == $c or die "unexpected length read: $c1 vs $c";
+ $kpid = unpack 'L', $pid;
+ }
+ return ($in2, $out1, $kpid);
+}
# Autoload methods go after __END__, and are processed by the autosplit program.
@@ -1059,6 +1314,28 @@ name returned is in the form "#nnnnn", where "nnnnn" is a group
of up to five digits that corresponds to the value of the WC_* class name
constant.
+=item WindowStyle($hwnd)
+
+Returns the "window style" flags for window handle $hwnd.
+
+=item WindowULong($hwnd, $id), WindowPtr($hwnd, $id), WindowUShort($hwnd, $id)
+
+Return data associated to window handle $hwnd. $id should be one of
+C<QWL_*>, C<QWP_PFNWP>, C<QWS_*> constants, or a byte offset referencing
+a region (of length 4, 4, 2 correspondingly) fully inside C<0..cbWindowData-1>.
+Here C<cbWindowData> is the count of extra user-specified bytes reserved
+for the given class of windows.
+
+=item WindowULong_set($hwnd, $id, $value), WindowPtr_set, WindowUShort_set
+
+Similar to WindowULong(), WindowPtr(), WindowUShort(), but for assigning the
+value $value.
+
+=item WindowBits_set($hwnd, $id, $value, $mask)
+
+Similar to WindowULong_set(), but will change only the bits which are
+set in $mask.
+
=item FocusWindow()
returns the handle of the focus window. Optional argument for specifying
@@ -1304,72 +1581,512 @@ This function is normally not needed. Not exported by default.
gets the path of the directory which corresponds to Desktop.
+=item InvalidateRect
+
+=item CreateFrameControls
+
+=back
+
+=head2 Control of the PM clipboard
+
+=over
+
=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>).
+of the data in the clipboard (defaults to C<CF_TEXT>). May croak with error
+C<PMERR_INVALID_HWND> if no data of given $fmt is present.
Note that the usual convention is to have clipboard data with
-C<"\r\n"> as line separators.
+C<"\r\n"> as line separators. This function will only work with clipboard
+data types which are delimited by C<"\0"> byte (not included in the result).
-=item ClipbrdText_set($txt)
+=item ClipbrdText_2byte
-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>).
+Same as ClipbrdText(), but will only work with clipboard
+data types which are collection of C C<shorts> delimited by C<0> short
+(not included in the result).
-=item InvalidateRect
+=item ClipbrdTextUCS2le
+
+Same as ClipbrdText_2byte(), but will assume that the shorts represent
+an Unicode string in I<UCS-2le> format (little-endian 2-byte representation
+of Unicode), and will provide the result in Perl internal C<utf8> format
+(one short of input represents one Perl character).
+
+Note that Firefox etc. export their selection in unicode types of this format.
+
+=item ClipbrdText_set($txt, [$no_convert_nl, [$fmt, [$fmtinfo, [$hab] ] ] ] )
+
+sets the text content of the clipboard after removing old contents. Unless the
+optional argument $no_convert_nl is TRUE, will convert newlines to C<"\r\n">. Another optional
+argument $fmt is the format of the data in the clipboard (should be an
+atom, defaults to C<CF_TEXT>). Other arguments are as for C<ClipbrdData_set>.
+Croaks on failure.
+
+=item ClipbrdFmtInfo( [$fmt, [ $hab ] ])
-=item CreateFrameControl
+returns the $fmtInfo flags set by the application which filled the
+format $fmt of the clipboard. $fmt defaults to C<CF_TEXT>.
-=item ClipbrdFmtInfo
+=item ClipbrdOwner( [ $hab ] )
-=item ClipbrdOwner
+Returns window handle of the current clipboard owner.
-=item ClipbrdViewer
+=item ClipbrdViewer( [ $hab ] )
-=item ClipbrdData
+Returns window handle of the current clipboard viewer.
-=item OpenClipbrd
+=item ClipbrdData( [$fmt, [ $hab ] ])
-=item CloseClipbrd
+Returns a handle to clipboard data of the given format as an integer.
+Format defaults to C<CF_TEXT> (in this case the handle is a memory address).
-=item ClipbrdData_set
+Clipboard should be opened before calling this function. May croak with error
+C<PMERR_INVALID_HWND> if no data of given $fmt is present.
-=item ClipbrdOwner_set
+The result should not be used after clipboard is closed. Hence a return handle
+of type C<CLI_POINTER> may need to be converted to a string and stored for
+future usage. Use MemoryRegionSize() to get a high estimate on the length
+of region addressed by this pointer; the actual length inside this region
+should be obtained by knowing particular format of data. E.g., it may be
+0-byte terminated for string types, or 0-short terminated for wide-char string
+types.
-=item ClipbrdViewer_set
+=item OpenClipbrd( [ $hab ] )
-=item EnumClipbrdFmts
+claim read access to the clipboard. May need a message queue to operate.
+May block until other processes finish dealing with clipboard.
-=item EmptyClipbrd
+=item CloseClipbrd( [ $hab ] )
-=item AddAtom
+Allow other processes access to clipboard.
+Clipboard should be opened before calling this function.
-=item FindAtom
+=item ClipbrdData_set($data, [$convert_nl, [$fmt, [$fmtInfo, [ $hab] ] ] ] )
-=item DeleteAtom
+Sets the clipboard data of format given by atom $fmt. Format defaults to
+CF_TEXT.
-=item AtomUsage
+$fmtInfo should declare what type of handle $data is; it should be either
+C<CFI_POINTER>, or C<CFI_HANDLE> (possibly qualified by C<CFI_OWNERFREE>
+and C<CFI_OWNERDRAW> flags). It defaults to C<CFI_HANDLE> for $fmt being
+standard bitmap, metafile, and palette (undocumented???) formats;
+otherwise defaults to C<CFI_POINTER>. If format is C<CFI_POINTER>, $data
+should contain the string to copy to clipboard; otherwise it should be an
+integer handle.
-=item AtomName
+If $convert_nl is TRUE (the default), C<"\n"> in $data are converted to
+C<"\r\n"> pairs if $fmt is C<CFI_POINTER> (as is the convention for text
+format of the clipboard) unless they are already in such a pair.
-=item AtomLength
+=item _ClipbrdData_set($data, [$fmt, [$fmtInfo, [ $hab] ] ] )
-=item SystemAtomTable
+Sets the clipboard data of format given by atom $fmt. Format defaults to
+CF_TEXT. $data should be an address (in givable unnamed shared memory which
+should not be accessed or manipulated after this call) or a handle in a form
+of an integer.
-=item CreateAtomTable
+$fmtInfo has the same semantic as for ClipbrdData_set().
-=item DestroyAtomTable
+=item ClipbrdOwner_set( $hwnd, [ $hab ] )
-Low-level methods to access clipboard and the atom table(s).
+Sets window handle of the current clipboard owner (window which gets messages
+when content of clipboard is retrieved).
+
+=item ClipbrdViewer_set( $hwnd, [ $hab ] )
+
+Sets window handle of the current clipboard owner (window which gets messages
+when content of clipboard is changed).
+
+=item ClipbrdFmtNames()
+
+Returns list of names of formats currently available in the clipboard.
+
+=item ClipbrdFmtAtoms()
+
+Returns list of atoms of formats currently available in the clipboard.
+
+=item EnumClipbrdFmts($fmt [, $hab])
+
+Low-level access to the list of formats currently available in the clipboard.
+Returns the atom for the format of clipboard after $fmt. If $fmt is 0, returns
+the first format of clipboard. Returns 0 if $fmt is the last format. Example:
+
+ {
+ my $h = OS2::localClipbrd->new('nomorph');
+ my $fmt = 0;
+ push @formats, AtomName $fmt
+ while $fmt = EnumClipbrdFmts $fmt;
+ }
+
+Clipboard should be opened before calling this function. May croak if
+no format is present.
+
+=item EmptyClipbrd( [ $hab ] )
+
+Remove all the data handles in the clipboard. croak()s on failure.
+Clipboard should be opened before calling this function.
+
+Recommended before assigning a value to clipboard to remove extraneous
+formats of data from clipboard.
+
+=item ($size, $flags) = MemoryRegionSize($addr, [$size_lim, [ $interrupt ]])
+
+$addr should be a memory address (encoded as integer). This call finds
+the largest continuous region of memory belonging to the same memory object
+as $addr, and having the same memory flags as $addr. $flags is the value of
+the memory flag of $addr (see docs of DosQueryMem(3) for details). If
+optional argumetn $size_lim is given, the search is restricted to the region
+this many bytes long (after $addr).
+
+($addr and $size are rounded so that all the memory pages containing
+the region are inspected.) Optional argument $interrupt (defaults to 1)
+specifies whether region scan should be interruptable by signals.
=back
-=head1 OS2::localMorphPM class
+Use class C<OS2::localClipbrd> to ensure that clipboard is closed even if
+the code in the block made a non-local exit.
+
+See L<"OS2::localMorphPM and OS2::localClipbrd classes">.
+
+=head2 Control of the PM atom tables
+
+Low-level methods to access the atom table(s). $atomtable defaults to
+the SystemAtomTable().
+
+=over
-This class morphs the process to PM for the duration of the given scope.
+=item AddAtom($name, [$atomtable])
+
+Returns the atom; increments the use count unless $name is a name of an
+integer atom.
+
+=item FindAtom($name, [$atomtable])
+
+Returns the atom if it exists, 0 otherwise (actually, croaks).
+
+=item DeleteAtom($name, [$atomtable])
+
+Decrements the use count unless $name is a name of an integer atom.
+When count goes to 0, association of the name to an integer is removed.
+(Version with prepended underscore returns 0 on success.)
+
+=item AtomName($atom, [$atomtable])
+
+Returns the name of the atom. Integer atoms have names of format C<"#ddddd">
+of variable length up to 7 chars.
+
+=item AtomLength($atom, [$atomtable])
+
+Returns the length of the name of the atom. Return of 0 means that no
+such atom exists (but usually croaks in such a case).
+
+Integer atoms always return length 6.
+
+=item AtomUsage($name, [$atomtable])
+
+Returns the usage count of the atom.
+
+=item SystemAtomTable()
+
+Returns central atom table accessible to any process.
+
+=item CreateAtomTable( [ $initial, [ $buckets ] ] )
+
+Returns new per-process atom table. See docs for WinCreateAtomTable(3).
+
+=item DestroyAtomTable($atomtable)
+
+Dispose of the table. (Version with prepended underscore returns 0 on success.)
+
+
+=back
+
+=head2 Alerting the user
+
+=over
+
+=item Alarm([$type])
+
+Audible alarm of type $type (defaults to C<WA_ERROR=2>). Other useful
+values are C<WA_WARNING=0>, C<WA_NOTE=1>. (What is C<WA_CDEFALARMS=3>???)
+
+The duration and frequency of the alarms can be changed by the
+OS2::SysValues_set(). The alarm frequency is defined to be in the range 0x0025
+through 0x7FFF. The alarm is not generated if system value SV_ALARM is set
+to FALSE. The alarms are dependent on the device capability.
+
+=item FlashWindow($hwnd, $doFlash)
+
+Starts/stops (depending on $doFlash being TRUE/FALSE) flashing the window
+$hwnd's borders and titlebar. First 5 flashes are accompanied by alarm beeps.
+
+Example (for VIO applications):
+
+ { my $morph = OS2::localMorphPM->new(0);
+ print STDERR "Press ENTER!\n";
+ FlashWindow(process_hwnd, 1);
+ <>;
+ FlashWindow(process_hwnd, 0);
+ }
+
+Since flashing window persists even when application ends, it is very
+important to protect the switching off flashing from non-local exits. Use
+the class C<OS2::localFlashWindow> for this. Creating the object of this
+class starts flashing the window until the object is destroyed. The above
+example becomes:
+
+ print STDERR "Press ENTER!\n";
+ { my $flash = OS2::localFlashWindow->new( process_hwnd );
+ <>;
+ }
+
+B<Notes from IBM docs:> Flashing a window brings the user's attention to a
+window that is not the active window, where some important message or dialog
+must be seen by the user.
+
+Note: It should be used only for important messages, for example, where some
+component of the system is failing and requires immediate attention to avoid
+damage.
+
+=item MessageBox($text, [ $title, [$flags, ...] ])
+
+Shows a simple messagebox with (optional) icon, message $text, and one or
+more buttons to dismiss the box. Returns the indicator of which action was
+taken by the user. If optional argument $title is not given,
+the title is constructed from the application name. The optional argument
+$flags describes the appearance of the box; the default is to have B<Cancel>
+button, I<INFO>-style icon, and a border for moving. Flags should be
+a combination of
+
+ Buttons on the box: or Button Group
+ MB_OK OK
+ MB_OKCANCEL both OK and CANCEL
+ MB_CANCEL CANCEL
+ MB_ENTER ENTER
+ MB_ENTERCANCEL both ENTER and CANCEL
+ MB_RETRYCANCEL both RETRY and CANCEL
+ MB_ABORTRETRYIGNORE ABORT, RETRY, and IGNORE
+ MB_YESNO both YES and NO
+ MB_YESNOCANCEL YES, NO, and CANCEL
+
+ Color or Icon
+ MB_ICONHAND a small red circle with a red line across it.
+ MB_ERROR a small red circle with a red line across it.
+ MB_ICONASTERISK an information (i) icon.
+ MB_INFORMATION an information (i) icon.
+ MB_ICONEXCLAMATION an exclamation point (!) icon.
+ MB_WARNING an exclamation point (!) icon.
+ MB_ICONQUESTION a question mark (?) icon.
+ MB_QUERY a question mark (?) icon.
+ MB_NOICON No icon.
+
+ Default action (i.e., focussed button; default is MB_DEFBUTTON1)
+ MB_DEFBUTTON1 The first button is the default selection.
+ MB_DEFBUTTON2 The second button is the default selection.
+ MB_DEFBUTTON3 The third button is the default selection.
+
+ Modality indicator
+ MB_APPLMODAL Message box is application modal (default).
+ MB_SYSTEMMODAL Message box is system modal.
+
+ Mobility indicator
+ MB_MOVEABLE Message box is moveable.
+
+With C<MB_MOVEABLE> the message box is displayed with a title bar and a
+system menu, which shows only the Move, Close, and Task Manager choices,
+which can be selected either by use of the pointing device or by
+accelerator keys. If the user selects Close, the message box is removed
+and the usResponse is set to C<MBID_CANCEL>, whether or not a cancel button
+existed within the message box.
+
+C<Esc> key dismisses the dialogue only if C<CANCEL> button is present; the
+return value is C<MBID_CANCEL>.
+
+With C<MB_APPLMODAL> the owner of the dialogue is disabled; therefore, do not
+specify the owner as the parent if this option is used.
+
+Additionally, the following flag is possible, but probably not very useful:
+
+ Help button
+ MB_HELP a HELP button appears, which sends a WM_HELP
+ message is sent to the window procedure of the
+ message box.
+
+Other optional arguments: $parent window, $owner_window, $helpID (used with
+C<WM_HELP> message if C<MB_HELP> style is given).
+
+The return value is one of
+
+ MBID_ENTER ENTER was selected
+ MBID_OK OK was selected
+ MBID_CANCEL CANCEL was selected
+ MBID_ABORT ABORT was selected
+ MBID_RETRY RETRY was selected
+ MBID_IGNORE IGNORE was selected
+ MBID_YES YES was selected
+ MBID_NO NO was selected
+
+ 0 Function not successful; an error occurred.
+
+B<BUGS???> keyboard transversal by pressing C<TAB> key does not work.
+Do not appear in window list, so may be hard to find if covered by other
+windows.
+
+=item _MessageBox($text, [ $title, [$flags, ...] ])
+
+Similar to MessageBox(), but the default $title does not depend on the name
+of the script.
+
+=item MessageBox2($text, [ $buttons_Icon, [$title, ...] ])
+
+Similar to MessageBox(), but allows more flexible choice of button texts
+and the icon. $buttons_Icon is a reference to an array with information about
+buttons and the icon to use; the semantic of this array is the same as
+for argument list of process_MB2_INFO(). The default value will show
+one button B<Dismiss> which will return C<0x1000>.
+
+Other optional arguments are the same as for MessageBox().
+
+B<NOTE.> Remark about C<MBID_CANCEL> in presence of C<MB_MOVABLE> is
+equally applicable to MessageBox() and MessageBox2().
+
+Example:
+
+ print MessageBox2
+ 'Foo prints 100, Bar 101, Baz 102',
+ [['~Foo' => 100, 'B~ar' => 101, ['Ba~z'] => 102]],
+ 'Choose a number to print';
+
+will show a messagebox with
+
+=over 20
+
+=item Title
+
+B<Choose a number to print>,
+
+=item Text
+
+B<Foo prints 100, Bar 101, Baz 102>
+
+=item Icon
+
+INFORMATION ICON
+
+=item Buttons
+
+B<Foo>, B<Bar>, B<Baz>
+
+=item Default button
+
+B<Baz>
+
+=item accelerator keys
+
+B<F>, B<a>, and B<z>
+
+=item return values
+
+100, 101, and 102 correspondingly,
+
+=back
+
+Using
+
+ print MessageBox2
+ 'Foo prints 100, Bar 101, Baz 102',
+ [['~Foo' => 100, 'B~ar' => 101, ['Ba~z'] => 102], 'SP#22'],
+ 'Choose a number to print';
+
+will show the 22nd system icon as the dialog icon (small folder icon).
+
+=item _MessageBox2($text, $buttons_Icon_struct, [$title, ...])
+
+low-level workhorse to implement MessageBox2(). Differs by the dafault
+$title, and that $buttons_Icon_struct is required, and is a string with
+low-level C struct.
+
+=item process_MB2_INFO($buttons, [$iconID, [$flags, [$notifyWindow]]])
+
+low-level workhorse to implement MessageBox2(); calculates the second
+argument of _MessageBox2(). $buttons is a reference
+to array of button descriptions. $iconID is either an ID of icon for
+the message box, or a string of the form C<"SP#number">; in the latter case
+the number's system icon is chosen; this field is ignored unless
+$flags contains C<MB_CUSTOMICON> flag. $flags has the same meaning as mobility,
+modality, and icon flags for MessageBox() with addition of extra flags
+
+ MB_CUSTOMICON Use a custom icon specified in hIcon.
+ MB_NONMODAL Message box is nonmodal
+
+$flags defaults to C<MB_INFORMATION> or C<MB_CUSTOMICON> (depending on whether
+$iconID is non-0), combined with MB_MOVABLE.
+
+Each button's description takes two elements of the description array,
+appearance description, and the return value of MessageBox2() if this
+button is selected. The appearance description is either an array reference
+of the form C<[$button_Text, $button_Style]>, or the same without
+$button_Style (then style is C<BS_DEFAULT>, making this button the default)
+or just $button_Text (with "normal" style). E.g., the list
+
+ Foo => 100, Bar => 101, [Baz] => 102
+
+will show three buttons B<Foo>, B<Bar>, B<Baz> with B<Baz> being the default
+button; pressing buttons return 100, 101, or 102 correspondingly.
+
+In particular, exactly one button should have C<BS_DEFAULT> style (e.g.,
+given as C<[$button_Name]>); otherwise the message box will not have keyboard
+focus! (The only exception is the case of one button; then C<[$button_Name]>
+can be replaced (for convenience) with plain C<$button_Name>.)
+
+If text of the button contains character C<~>, the following character becomes
+the keyboard accelerator for this button. One can also get the handle
+of system icons directly, so C<'SP#22'> can be replaced by
+C<OS2::Process::get_pointer(22)>; see also C<SPTR_*> constants.
+
+B<NOTE> With C<MB_NONMODAL> the program continues after displaying the
+nonmodal message box. The message box remains visible until the owner window
+destroys it. Two notification messages, WM_MSGBOXINIT and WM_MSGBOXDISMISS,
+are used to support this non-modality.
+
+=item LoadPointer($id, [$module, [$hwnd]])
+
+Loads a handle for the pointer $id from the resources of the module
+$module on desktop $hwnd. If $module is 0 (default), loads from the main
+executable; otherwise from a DLL with the handle $module.
+
+The pointer is owned by the process, and is destroyed by
+DestroyPointer() call, or when the process terminates.
+
+=item SysPointer($id, [$copy, [$hwnd]])
+
+Gets a handle for (a copy of) the system pointer $id (the value should
+be one of C<SPTR_*> constants). A copy is made if $copy is TRUE (the
+default). $hwnd defaults to C<HWND_DESKTOP>.
+
+=item get_pointer($id, [$copy, [$hwnd]])
+
+Gets (and caches) a copy of the system pointer.
+
+=back
+
+=head2 Constants used by OS/2 APIs
+
+Function C<os2constant($name)> returns the value of the constant; to
+decrease the memory usage of this package, only the constants used by
+APIs called by Perl functions in this package are made available.
+
+For direct access, see also the L<"EXPORTS"> section; the latter way
+may also provide some performance advantages, since the value of the
+constant is cached.
+
+=head1 OS2::localMorphPM, OS2::localFlashWindow, and OS2::localClipbrd classes
+
+The class C<OS2::localMorphPM> morphs the process to PM for the duration of
+the given scope.
{
my $h = OS2::localMorphPM->new(0);
@@ -1379,6 +2096,23 @@ This class morphs the process to PM for the duration of the given scope.
The argument has the same meaning as one to OS2::MorphPM(). Calls can
nest with internal ones being NOPs.
+Likewise, C<OS2::localClipbrd> class opens the clipboard for the duration
+of the current scope; if TRUE optional argument is given, it would not
+morph the application into PM:
+
+ {
+ my $handle = OS2::localClipbrd->new(1); # Do not morph into PM
+ # Do something with clipboard here...
+ }
+
+C<OS2::localFlashWindow> behaves similarly; see
+L<"FlashWindow($hwnd,$doFlash)">.
+
+=head1 EXAMPLES
+
+The test suite for this module contains an almost comprehensive collection
+of examples of using the API of this module.
+
=head1 TODO
Add tests for:
@@ -1397,7 +2131,6 @@ Add tests for:
QueryWindow
EnumDlgItem
WindowPtr
- WindowULong
WindowUShort
SetWindowBits
SetWindowPtr
@@ -1408,12 +2141,18 @@ Add tests for:
scrsize
scrsize_set
-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
+Document: InvalidateRect,
+CreateFrameControls, kbdChar, kbdhChar,
+kbdStatus, _kbdStatus_set, kbdhStatus, kbdhStatus_set,
+vioConfig, viohConfig, vioMode, viohMode, viohMode_set, _vioMode_set,
+_vioState, _vioState_set, vioFont, vioFont_set
+
+Test: SetWindowULong/Short/Ptr, SetWindowBits. InvalidateRect,
+CreateFrameControls, ClipbrdOwner_set, ClipbrdViewer_set, _ClipbrdData_set,
+Alarm, FlashWindow, _MessageBox, MessageBox, _MessageBox2, MessageBox2,
+LoadPointer, SysPointer, kbdChar, kbdhChar, kbdStatus, _kbdStatus_set,
+kbdhStatus, kbdhStatus_set, vioConfig, viohConfig, vioMode, viohMode,
+viohMode_set, _vioMode_set, _vioState, _vioState_set, vioFont, vioFont_set
Implement SOMETHINGFROMMR.
diff --git a/os2/OS2/Process/Process.xs b/os2/OS2/Process/Process.xs
index cda4847c83..05befa02cc 100644
--- a/os2/OS2/Process/Process.xs
+++ b/os2/OS2/Process/Process.xs
@@ -315,8 +315,6 @@ DeclWinFunc_CACHE(BOOL, CreateFrameControls,
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));
@@ -324,10 +322,6 @@ 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),
@@ -338,7 +332,6 @@ DeclWinFunc_CACHE(ULONG, QueryAtomName,
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,
@@ -353,6 +346,13 @@ DeclWinFunc_CACHE(HPOINTER, QuerySysPointer,
DeclWinFunc_CACHE(BOOL, Alarm, (HWND hwndDesktop, ULONG rgfType), (hwndDesktop, rgfType));
DeclWinFunc_CACHE(BOOL, FlashWindow, (HWND hwndFrame, BOOL fFlash), (hwndFrame, fFlash));
+#if 0 /* Need to have the entry points described in the parent */
+DeclWinFunc_CACHE(BOOL, QueryClassInfo, (HAB hab, char* pszClassName, PCLASSINFO pClassInfo), (hab, pszClassName, pClassInfo));
+
+#define _QueryClassInfo(hab, pszClassName, pClassInfo) \
+ QueryClassInfo(hab, pszClassName, (PCLASSINFO)pClassInfo)
+
+#endif
/* These functions do not croak on error */
DeclWinFunc_CACHE_survive(BOOL, SetClipbrdData,
@@ -378,6 +378,16 @@ DeclWinFunc_CACHE_resetError(HWND, GetNextWindow, (HENUM henum), (henum))
DeclWinFunc_CACHE_resetError(BOOL, IsWindowEnabled, (HWND hwnd), (hwnd))
DeclWinFunc_CACHE_resetError(BOOL, IsWindowVisible, (HWND hwnd), (hwnd))
DeclWinFunc_CACHE_resetError(BOOL, IsWindowShowing, (HWND hwnd), (hwnd))
+DeclWinFunc_CACHE_resetError(ATOM, FindAtom, (HATOMTBL hAtomTbl, PCSZ pszAtomName),
+ (hAtomTbl, pszAtomName));
+DeclWinFunc_CACHE_resetError(ATOM, DeleteAtom, (HATOMTBL hAtomTbl, ATOM atom),
+ (hAtomTbl, atom));
+DeclWinFunc_CACHE_resetError(HATOMTBL, DestroyAtomTable, (HATOMTBL hAtomTbl), (hAtomTbl));
+DeclWinFunc_CACHE_resetError(HWND, QueryClipbrdViewer, (HAB hab), (hab));
+DeclWinFunc_CACHE_resetError(HWND, QueryClipbrdOwner, (HAB hab), (hab));
+
+#define _DeleteAtom DeleteAtom
+#define _DestroyAtomTable DestroyAtomTable
/* No die()ing on error */
DeclWinFunc_CACHE_survive(BOOL, IsWindow, (HAB hab, HWND hwnd), (hab, hwnd))
@@ -521,15 +531,22 @@ myWinQueryActiveDesktopPathname()
SV *
myWinQueryAtomName(ATOM atom, HATOMTBL hAtomTbl)
{
- ULONG len = QueryAtomLength(hAtomTbl, atom);
+ ULONG len = QueryAtomLength(hAtomTbl, atom);
+
+ if (len) { /* Probably always so... */
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;
+ len = QueryAtomName(hAtomTbl, atom, SvPV(sv, n_a), len + 1);
+ if (len) { /* Probably always so... */
+ SvCUR_set(sv, len);
+ *SvEND(sv) = 0;
+ return sv;
+ }
+ SvREFCNT_dec(sv);
+ }
+ return &PL_sv_undef;
}
#define myWinQueryClipbrdFmtInfo QueryClipbrdFmtInfo
@@ -539,26 +556,28 @@ 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;
+ char *buf;
+ char *pByte = 0, *s, c;
+ ULONG nls = 0, rc, handle;
- if (convert_nl) {
+ if (rgfFmtInfo & CFI_POINTER) {
+ s = buf = SvPV_force(sv, len);
+ 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,
+ 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)
+ if (!nls)
memcpy(pByte, buf, len + 1);
- else {
+ else {
char *t = pByte, *e = buf + len;
while (buf < e) {
@@ -566,14 +585,56 @@ ClipbrdData_set(SV *sv, int convert_nl, unsigned long fmt, unsigned long rgfFmtI
if (c == '\n' && (t == pByte + 1 || t[-2] != '\r'))
t[-1] = '\r', *t++ = '\n';
}
+ }
+ handle = (ULONG)pByte;
+ } else {
+ handle = (ULONG)SvUV(sv);
}
- if (!SetClipbrdData(hab, (ULONG)pByte, fmt, rgfFmtInfo)) {
- DosFreeMem((PPVOID)&pByte);
+ if (!SetClipbrdData(hab, handle, fmt, rgfFmtInfo)) {
+ if (fmt & CFI_POINTER)
+ DosFreeMem((PPVOID)&pByte);
croak_with_os2error("ClipbrdData_set: WinSetClipbrdData error");
}
}
+ULONG
+QueryMemoryRegionSize(ULONG addr, ULONG *flagp, ULONG len, I32 interrupt)
+{
+ ULONG l, f; /* Modifiable copy */
+ ULONG rc;
+
+ do {
+ l = len;
+ rc = DosQueryMem((void *)addr, &l, &f);
+ } while ( interrupt ? 0 : rc == ERROR_INTERRUPT );
+
+ /* We assume this is not about addr */
+/*
+ if (rc == ERROR_INVALID_ADDRESS)
+ return 0xFFFFFFFF;
+*/
+ os2cp_croak(rc,"QueryMemoryRegionSize");
+ if (flagp)
+ *flagp = f;
+ return l;
+}
+
+static ULONG
+default_fmtInfo(ULONG fmt)
+{
+ switch (fmt) {
+ case CF_PALETTE: /* Actually, fmtInfo not documented for palette... */
+ case CF_BITMAP:
+ case CF_METAFILE:
+ case CF_DSPBITMAP:
+ case CF_DSPMETAFILE:
+ return CFI_HANDLE;
+ default:
+ return CFI_POINTER;
+ }
+}
+
#if 0
ULONG
@@ -1295,6 +1356,55 @@ sidOf(int pid)
return sid;
}
+STRLEN
+StrLen(ULONG addr, ULONG lim, I32 unitsize)
+{
+ switch (unitsize) {
+ case 1:
+ {
+ char *s = (char *)addr;
+ char *s1 = s, *e = (char *)(addr + lim);
+
+ while (s < e && *s)
+ s++;
+ return s - s1;
+ }
+ break;
+ case 2:
+ {
+ short *s = (short *)addr;
+ short *s1 = s, *e = (short *)(addr + lim);
+
+ while (s < e && *s)
+ s++;
+ return (char*)s - (char*)s1;
+ }
+ break;
+ case 4:
+ {
+ int *s = (int *)addr;
+ int *s1 = s, *e = (int *)(addr + lim);
+
+ while (s < e && *s)
+ s++;
+ return (char*)s - (char*)s1;
+ }
+ break;
+ case 8:
+ {
+ long long *s = (long long *)addr;
+ long long *s1 = s, *e = (long long *)(addr + lim);
+
+ while (s < e && *s)
+ s++;
+ return (char*)s - (char*)s1;
+ }
+ break;
+ default:
+ croak("StrLen: unknown unitsize %d", (int)unitsize);
+ }
+}
+
#define ulMPFROMSHORT(i) ((unsigned long)MPFROMSHORT(i))
#define ulMPVOID() ((unsigned long)MPVOID)
#define ulMPFROMCHAR(i) ((unsigned long)MPFROMCHAR(i))
@@ -1367,6 +1477,8 @@ swentries_list()
void
ResetWinError()
+ POSTCALL:
+ XSRETURN_YES;
int
WindowText_set(HWND hwndFrame, char *title)
@@ -1503,6 +1615,8 @@ _kbdStatus(int handle = 0)
void
_kbdStatus_set(SV *sv, int handle = 0)
+ POSTCALL:
+ XSRETURN_YES;
SV*
_vioConfig(int which = 0, int handle = 0)
@@ -1512,38 +1626,51 @@ _vioMode()
void
_vioMode_set(SV *buffer)
+ POSTCALL:
+ XSRETURN_YES;
SV*
_vioState(int what, int first = -1, int count = -1)
void
_vioState_set(SV *buffer)
+ POSTCALL:
+ XSRETURN_YES;
SV*
vioFont( int type = 0, OUTLIST int w, OUTLIST int h)
void
vioFont_set(SV *buffer, int cellwidth, int cellheight, int type = 0)
+ POSTCALL:
+ XSRETURN_YES;
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())
+_ClipbrdData_set(unsigned long ulData, unsigned long fmt = CF_TEXT, unsigned long rgfFmtInfo = default_fmtInfo(fmt), HAB hab = perl_hab_GET())
PROTOTYPE: DISABLE
C_ARGS: hab, ulData, fmt, rgfFmtInfo
POSTCALL:
if (CheckWinError(RETVAL))
croak_with_os2error("_ClipbrdData_set() error");
+ XSRETURN_YES;
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())
+ClipbrdData_set(SV *text, int convert_nl = 1, unsigned long fmt = CF_TEXT, unsigned long rgfFmtInfo = default_fmtInfo(fmt), HAB hab = perl_hab_GET())
PROTOTYPE: DISABLE
+ POSTCALL:
+ XSRETURN_YES;
void
ClipbrdOwner_set(HWND hwnd, HAB hab = perl_hab_GET())
C_ARGS: hab, hwnd
+ POSTCALL:
+ XSRETURN_YES;
void
ClipbrdViewer_set(HWND hwnd, HAB hab = perl_hab_GET())
C_ARGS: hab, hwnd
+ POSTCALL:
+ XSRETURN_YES;
unsigned long
EnumClipbrdFmts(unsigned long fmt = 0, HAB hab = perl_hab_GET())
@@ -1558,15 +1685,31 @@ FindAtom(char *pszAtomName, HATOMTBL hAtomTbl = QuerySystemAtomTable())
C_ARGS: hAtomTbl, pszAtomName
unsigned long
-DeleteAtom(char *pszAtomName, HATOMTBL hAtomTbl = QuerySystemAtomTable())
- C_ARGS: hAtomTbl, pszAtomName
+_DeleteAtom(ATOM atom, HATOMTBL hAtomTbl = QuerySystemAtomTable())
+ PROTOTYPE: DISABLE
+ C_ARGS: hAtomTbl, atom
+
+#if 0
+
+unsigned long
+WinDeleteAtom(ATOM atom, HATOMTBL hAtomTbl = QuerySystemAtomTable())
+ C_ARGS: hAtomTbl, atom
+
+#endif
void
Alarm(unsigned long rgfType = WA_ERROR, HWND hwndDesktop = HWND_DESKTOP)
C_ARGS: hwndDesktop, rgfType
+ POSTCALL:
+ XSRETURN_YES;
void
FlashWindow(HWND hwndFrame, bool fFlash)
+ POSTCALL:
+ XSRETURN_YES;
+
+STRLEN
+StrLen(ULONG addr, ULONG lim, I32 unitsize = 1)
MODULE = OS2::Process PACKAGE = OS2::Process PREFIX = myQuery
@@ -1604,6 +1747,9 @@ QueryClipbrdData(unsigned long fmt = CF_TEXT, HAB hab = perl_hab_GET())
C_ARGS: hab, fmt
PROTOTYPE: DISABLE
+ULONG
+QueryMemoryRegionSize(ULONG addr, OUTLIST ULONG flagp, ULONG len = 0xFFFFFFFF - addr, I32 interrupt = 1)
+
unsigned long
QueryClipbrdViewer(HAB hab = perl_hab_GET())
@@ -1612,9 +1758,13 @@ QueryClipbrdOwner(HAB hab = perl_hab_GET())
void
CloseClipbrd(HAB hab = perl_hab_GET())
+ POSTCALL:
+ XSRETURN_YES;
void
EmptyClipbrd(HAB hab = perl_hab_GET())
+ POSTCALL:
+ XSRETURN_YES;
bool
OpenClipbrd(HAB hab = perl_hab_GET())
@@ -1626,6 +1776,9 @@ QueryAtomUsage(ATOM atom, HATOMTBL hAtomTbl = QuerySystemAtomTable())
unsigned long
QueryAtomLength(ATOM atom, HATOMTBL hAtomTbl = QuerySystemAtomTable())
C_ARGS: hAtomTbl, atom
+ POSTCALL:
+ if (!RETVAL)
+ XSRETURN_EMPTY;
unsigned long
QuerySystemAtomTable()
@@ -1638,7 +1791,8 @@ unsigned long
CreateAtomTable(unsigned long initial = 0, unsigned long buckets = 0)
unsigned long
-DestroyAtomTable(HATOMTBL hAtomTbl)
+_DestroyAtomTable(HATOMTBL hAtomTbl)
+ PROTOTYPE: DISABLE
MODULE = OS2::Process PACKAGE = OS2::Process PREFIX = myWinQuery
@@ -1673,20 +1827,20 @@ myWinSwitchToProgram(HSWITCH hsw = switch_of(NULLHANDLE, getpid()))
#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)
+myWinMessageBox(unsigned long pszText, char* pszCaption = "Perl script message", 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)
+_MessageBox(char* pszText, char* pszCaption = "Perl script message", 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)
+_MessageBox2(char *pszText, char* pmb2info, char *pszCaption = "Perl script message", 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)
diff --git a/os2/OS2/Process/t/os2_atoms.t b/os2/OS2/Process/t/os2_atoms.t
new file mode 100644
index 0000000000..5d9603f2c9
--- /dev/null
+++ b/os2/OS2/Process/t/os2_atoms.t
@@ -0,0 +1,88 @@
+#! /usr/bin/perl -w
+
+use strict;
+use Test::More tests => 48;
+BEGIN {use_ok 'OS2::Process'}
+
+ok(SystemAtomTable(), 'SystemAtomTable succeeds');
+my $tbl = CreateAtomTable;
+
+ok($tbl, 'CreateAtomTable succeeds');
+
+is(AtomLength(133, $tbl), 6, 'AtomLength of unknown atom is 6');
+is(AtomLength(1, $tbl), 6, 'AtomLength of unknown atom is 6');
+ok(!defined eval {AtomLength(100000, $tbl); 1}, 'AtomLength of invalid atom croaks');
+# diag($@);
+
+is(AtomUsage(134, $tbl), 65535, 'AtomUsage of unknown atom is 65535');
+is(AtomUsage(1, $tbl), 65535, 'AtomUsage of unknown atom is 65535');
+ok(!defined eval {AtomUsage(100000, $tbl); 1}, 'AtomUsage of invalid atom croaks');
+# diag($@);
+
+is(AtomName(134, $tbl), '#134', 'AtomName of unknown atom is #number');
+is(AtomName(2, $tbl), '#2', 'AtomName of unknown atom is #number');
+ok(!defined eval {AtomName(100000, $tbl); 1}, 'AtomName of invalid atom croaks');
+# diag($@);
+
+is(FindAtom('#134', $tbl), 134, 'Name of unknown atom per #number');
+is(FindAtom('#2', $tbl), 2, 'Name of unknown atom per #number');
+ok(!defined eval {FindAtom('#90000', $tbl); 1}, 'Finding invalid numeric atom croaks');
+# diag($@);
+ok(!defined eval {FindAtom('2#', $tbl); 1}, 'Finding invalid atom croaks');
+# diag($@);
+ok(!defined eval {FindAtom('texxt/unnknnown', $tbl); 1}, 'Finding invalid atom croaks');
+# diag($@);
+
+is(DeleteAtom(125000, $tbl), '', 'Deleting invalid atom returns FALSE');
+is(DeleteAtom(10000, $tbl), 1, 'Deleting unknown atom returns 1');
+ok(!defined eval {DeleteAtom(0, $tbl); 1}, 'Deleting zero atom croaks');
+# diag($@);
+
+is(AddAtom('#134', $tbl), 134, 'Add unknown atom per #number');
+is(AddAtom('#2', $tbl), 2, 'Add unknown atom per #number');
+ok(!defined eval {AddAtom('#80000', $tbl); 1}, 'Add invalid numeric atom croaks');
+# diag($@);
+
+my $a1 = AddAtom("perltest//pp$$", $tbl);
+ok($a1, 'Add unknown atom per string');
+my $a2 = AddAtom("perltest//p$$", $tbl);
+ok($a2, 'Add another unknown atom per string');
+is(AddAtom("perltest//p$$", $tbl), $a2, 'Add same unknown atom per string');
+isnt($a1, $a2, 'Different strings result in different atoms');
+ok($a1 > 0, 'Atom positive');
+ok($a2 > 0, 'Another atom positive');
+ok($a1 < 0x10000, 'Atom small');
+ok($a2 < 0x10000, 'Another atom small');
+
+is(AtomLength($a1, $tbl), length "perltest//pp$$", 'AtomLength of known atom');
+is(AtomLength($a2, $tbl), length "perltest//p$$", 'AtomLength of another known atom');
+
+is(AtomUsage($a1, $tbl), 1, 'AtomUsage of known atom');
+is(AtomUsage($a2, $tbl), 2, 'AtomUsage of another known atom');
+
+is(AtomName($a1, $tbl), "perltest//pp$$", 'AtomName of known atom');
+is(AtomName($a2, $tbl), "perltest//p$$", 'AtomName of another known atom');
+
+is(FindAtom("perltest//pp$$", $tbl), $a1, 'Name of known atom');
+is(FindAtom("perltest//p$$", $tbl), $a2, 'Name of known atom');
+
+#$^E = 0;
+ok(DeleteAtom($a1, $tbl), 'DeleteAtom of known atom');
+#diag("err=$^E");
+#$^E = 0;
+ok(DeleteAtom($a2, $tbl), 'DeleteAtom of another known atom');
+#diag("err=$^E");
+
+ok(!defined eval {AtomUsage($a1, $tbl); 1}, 'AtomUsage of deleted known atom croaks');
+# diag($@);
+is(AtomUsage($a2, $tbl), 1, 'AtomUsage of another known atom');
+
+ok(!defined eval {AtomName($a1, $tbl); 1}, 'AtomName of deleted known atom croaks');
+# diag($@);
+is(AtomName($a2, $tbl), "perltest//p$$", 'AtomName of undeleted another known atom');
+
+ok(!defined eval {FindAtom("perltest//pp$$", $tbl); 1}, 'Finding known deleted atom croaks');
+# diag($@);
+is(FindAtom("perltest//p$$", $tbl), $a2, 'Finding known undeleted atom');
+
+ok(DestroyAtomTable($tbl), 'DestroyAtomTable succeeds');
diff --git a/os2/OS2/Process/t/os2_clipboard.t b/os2/OS2/Process/t/os2_clipboard.t
new file mode 100644
index 0000000000..398a5fee7d
--- /dev/null
+++ b/os2/OS2/Process/t/os2_clipboard.t
@@ -0,0 +1,211 @@
+#! /usr/bin/perl -w
+
+use strict;
+use Test::More tests => 87;
+BEGIN {use_ok 'OS2::Process', qw(:DEFAULT CFI_POINTER CF_TEXT)}
+
+# Initialize
+my $raw = "Just a random\nselection";
+(my $cr = $raw) =~ s/\n/\r\n/g;
+ok(ClipbrdText_set($raw), 'ClipbrdText_set');
+
+my ($v, $p, @f);
+is(ClipbrdText, $cr, "ClipbrdText it back");
+is(ClipbrdOwner, 0, "ClipbrdOwner is not defined");
+$v = ClipbrdViewer;
+ok((!$v || IsWindow $v), "ClipbrdViewer is not defined or a valid window");
+
+{
+ my $h = OS2::localClipbrd->new;
+ $p = ClipbrdData;
+
+ @f = MemoryRegionSize($p, 0x4000); # 4 pages, 16K, limit
+ is(scalar @f, 2, 'MemoryRegionSize(16K) returns 2 values');
+ # diag(sprintf '%#x, %#x, %#x, %#x', @f, $f[0]+$p, $p);
+ is($f[0], 4096, 'MemoryRegionSize claims 1 page is available');
+ ok($f[1] & 0x1, 'MemoryRegionSize claims page readable');# PAG_READ=1 0x12013
+
+ my @f1 = MemoryRegionSize($p, 0x100000); # 16 blocks, 1M, limit
+ is(scalar @f1, 2, 'MemoryRegionSize(1M) returns 2 values');
+ is($f1[0], $f[0], 'MemoryRegionSize returns same length');
+ is($f1[1], $f[1], 'MemoryRegionSize returns same flags');
+
+ @f1 = MemoryRegionSize($p);
+ is(scalar @f1, 2, 'MemoryRegionSize(no-limit) returns 2 values');
+ is($f1[0], $f[0], 'MemoryRegionSize returns same length');
+ is($f1[1], $f[1], 'MemoryRegionSize returns same flags');
+}
+
+ok($p, 'ClipbrdData');
+
+is(ClipbrdFmtInfo, CFI_POINTER, 'ClipbrdFmtInfo is CFI_POINTER');
+
+# CF_TEXT is 1
+ok(!defined eval {ClipbrdText(1+CF_TEXT); 1}, "ClipbrdText(not CF_TEXT) croaks");
+like($@, qr/\bPMERR_INVALID_HWND\b/, 'with expected (lousy) error message');
+
+@f = ClipbrdFmtAtoms;
+is(scalar @f, 1, "Only one format available");
+is($f[0], CF_TEXT, "format is CF_TEXT");
+
+@f = ClipbrdFmtNames;
+is(scalar @f, 1, "Only one format available");
+is($f[0], '#1', "format is CF_TEXT='#1'");
+
+{
+ my $h = OS2::localClipbrd->new;
+ ok(EmptyClipbrd, 'EmptyClipbrd');
+}
+
+@f = ClipbrdFmtNames;
+is(scalar @f, 0, "No format available");
+
+undef $p; undef $v;
+eval {
+ my $h = OS2::localClipbrd->new;
+ $p = ClipbrdData;
+ $v = 1;
+};
+
+ok(! defined $p, 'ClipbrdData croaked');
+like($@, qr/\bPMERR_INVALID_HWND\b/, 'with expected (lousy) error message');
+
+ok(! defined eval {ClipbrdText}, "ClipbrdText croaks");
+like($@, qr/\bPMERR_INVALID_HWND\b/, 'with expected (lousy) error message');
+
+# CF_TEXT is 1
+ok(!defined eval {ClipbrdText(1+CF_TEXT); 1}, "ClipbrdText(not CF_TEXT) croaks");
+like($@, qr/\bPMERR_INVALID_HWND\b/, 'with expected (lousy) error message');
+
+is(ClipbrdOwner, 0, "ClipbrdOwner is not defined");
+
+$v = ClipbrdViewer;
+ok((!$v || IsWindow $v), "ClipbrdViewer is not defined or a valid window");
+
+is(ClipbrdFmtInfo, 0, 'ClipbrdFmtInfo is 0');
+
+@f = ClipbrdFmtAtoms;
+is(scalar @f, 0, "No formats available");
+
+{
+ my $h = OS2::localClipbrd->new;
+ ok(EmptyClipbrd, 'EmptyClipbrd when clipboard is empty succeeds');
+}
+
+ok(ClipbrdText_set($raw, 1), 'ClipbrdText_set() raw');
+is(ClipbrdText, $raw, "ClipbrdText it back");
+
+{
+ my $h = OS2::localClipbrd->new;
+ ok(EmptyClipbrd, 'EmptyClipbrd again');
+}
+
+my $ar = AddAtom 'perltest/unknown_raw';
+ok($ar, 'Atom added');
+my $ar1 = AddAtom 'perltest/unknown_raw1';
+ok($ar1, 'Atom added');
+my $a = AddAtom 'perltest/unknown';
+ok($a, 'Atom added');
+my $a1 = AddAtom 'perltest/unknown1';
+ok($a1, 'Atom added');
+
+{
+ my $h = OS2::localClipbrd->new;
+ ok(ClipbrdData_set($raw), 'ClipbrdData_set()');
+ ok(ClipbrdData_set($raw, 0, $ar1), 'ClipbrdData_set(perltest/unknown_raw1)');
+ ok(ClipbrdData_set($cr, 0, $ar), 'ClipbrdData_set(perltest/unknown_raw)');
+ ok(ClipbrdData_set($raw, 1, $a1), 'ClipbrdData_set(perltest/unknown1)');
+ ok(ClipbrdData_set($cr, 1, $a), 'ClipbrdData_set(perltest/unknown)');
+ # Results should be the same, except ($raw, 0) one...
+}
+
+is(ClipbrdText, $cr, "ClipbrdText CF_TEXT back");
+is(ClipbrdText($ar1), $raw, "ClipbrdText perltest/unknown_raw1 back");
+is(ClipbrdText($ar), $cr, "ClipbrdText perltest/unknown_raw back");
+is(ClipbrdText($a1), $cr, "ClipbrdText perltest/unknown1 back");
+is(ClipbrdText($a), $cr, "ClipbrdText perltest/unknown back");
+
+is(ClipbrdFmtInfo, CFI_POINTER, 'ClipbrdFmtInfo is CFI_POINTER');
+is(ClipbrdFmtInfo($ar1), CFI_POINTER, 'ClipbrdFmtInfo is CFI_POINTER');
+is(ClipbrdFmtInfo($ar), CFI_POINTER, 'ClipbrdFmtInfo is CFI_POINTER');
+is(ClipbrdFmtInfo($a1), CFI_POINTER, 'ClipbrdFmtInfo is CFI_POINTER');
+is(ClipbrdFmtInfo($a), CFI_POINTER, 'ClipbrdFmtInfo is CFI_POINTER');
+
+# CF_TEXT is 1
+ok(!defined eval {ClipbrdText(1+CF_TEXT); 1}, "ClipbrdText(1+CF_TEXT) croaks");
+like($@, qr/\bPMERR_INVALID_HWND\b/, 'with expected (lousy) error message');
+
+my $names = join ',', sort '#1', qw(perltest/unknown perltest/unknown1
+ perltest/unknown_raw perltest/unknown_raw1);
+@f = ClipbrdFmtAtoms;
+is(scalar @f, 5, "5 formats available");
+is((join ',', sort map AtomName($_), @f), $names, "formats are $names");
+
+@f = ClipbrdFmtNames;
+is(scalar @f, 5, "Only one format available");
+is((join ',', sort @f), $names, "formats are $names");
+
+{
+ my $h = OS2::localClipbrd->new;
+ ok(EmptyClipbrd, 'EmptyClipbrd');
+}
+
+@f = ClipbrdFmtNames;
+is(scalar @f, 0, "No formats available");
+
+{
+ my $h = OS2::localClipbrd->new;
+ ok(ClipbrdText_set($cr, 1, $ar), 'ClipbrdText_set(perltest/unknown_raw)');
+};
+
+#diag(join ' ', ClipbrdFmtNames);
+
+is(ClipbrdText($ar), $cr, "ClipbrdText perltest/unknown_raw back");
+is(ClipbrdFmtInfo($ar), CFI_POINTER, 'ClipbrdFmtInfo is CFI_POINTER');
+
+ok(!defined eval {ClipbrdText(CF_TEXT); 1}, "ClipbrdText(CF_TEXT) croaks");
+like($@, qr/\bPMERR_INVALID_HWND\b/, 'with expected (lousy) error message');
+# CF_TEXT is 1
+ok(!defined eval {ClipbrdText(1+CF_TEXT); 1}, "ClipbrdText(1+CF_TEXT) croaks");
+like($@, qr/\bPMERR_INVALID_HWND\b/, 'with expected (lousy) error message');
+
+@f = ClipbrdFmtNames;
+is(scalar @f, 1, "1 format available");
+is($f[0], 'perltest/unknown_raw', "format is perltest/unknown_raw");
+
+@f = ClipbrdFmtAtoms;
+is(scalar @f, 1, "1 format available");
+is($f[0], $ar, "format is perltest/unknown_raw");
+
+{
+ my $h = OS2::localClipbrd->new;
+ ok(EmptyClipbrd, 'EmptyClipbrd');
+}
+
+undef $p; undef $v;
+eval {
+ my $h = OS2::localClipbrd->new;
+ $p = ClipbrdData;
+ $v = 1;
+};
+
+ok(! defined $p, 'ClipbrdData croaked');
+like($@, qr/\bPMERR_INVALID_HWND\b/, 'with expected (lousy) error message');
+
+ok(! defined eval {ClipbrdText}, "ClipbrdText croaks");
+like($@, qr/\bPMERR_INVALID_HWND\b/, 'with expected (lousy) error message');
+
+# CF_TEXT is 1
+ok(!defined eval {ClipbrdText(1+CF_TEXT); 1}, "ClipbrdText(not CF_TEXT) croaks");
+like($@, qr/\bPMERR_INVALID_HWND\b/, 'with expected (lousy) error message');
+
+is(ClipbrdOwner, 0, "ClipbrdOwner is not defined");
+
+$v = ClipbrdViewer;
+ok((!$v || IsWindow $v), "ClipbrdViewer is not defined or a valid window");
+
+is(ClipbrdFmtInfo, 0, 'ClipbrdFmtInfo is 0');
+
+@f = ClipbrdFmtAtoms;
+is(scalar @f, 0, "No formats available");
+
diff --git a/os2/OS2/Process/t/os2_process.t b/os2/OS2/Process/t/os2_process.t
index 123525dd4d..18d8fe2a11 100644
--- a/os2/OS2/Process/t/os2_process.t
+++ b/os2/OS2/Process/t/os2_process.t
@@ -24,7 +24,7 @@ BEGIN { # Remap I/O to the parent's window
}
use strict;
-use Test::More tests => 232;
+use Test::More tests => 235;
use OS2::Process;
sub SWP_flags ($) {
@@ -218,18 +218,28 @@ is($fhwnd, $ahwnd, 'the focus window = the active window');
ok hWindowPos_set({behind => 3}, $k_hwnd), # HWND_TOP
'put kid to the front';
-is((hWindowPos $k_hwnd)->{behind}, 3, 'kis is at front');
+# After Alt-Tab a WS_TOPMOST, WS_DISABLED window of class 'AltTabWindow' exists
+my $top = (hWindowPos $k_hwnd)->{behind};
+ok(($top == 3 or WindowStyle($top) & 0x200000), # HWND_TOP, WS_TOPMOST
+ 'kid is at front');
+# is((hWindowPos $k_hwnd)->{behind}, 3, 'kid is at front');
-my ($enum_handle, $first_zorder);
+my ($enum_handle, $first_zorder, $first_non_TOPMOST);
{ my $force_PM = OS2::localMorphPM->new(0);
ok $force_PM, 'morphed to PM locally again';
$enum_handle = BeginEnumWindows 1; # HWND_DESKTOP
ok $enum_handle, 'start enumeration';
- $first_zorder = GetNextWindow $enum_handle;
+ $first_non_TOPMOST = $first_zorder = GetNextWindow $enum_handle;
ok $first_zorder, 'GetNextWindow works';
+ my $f = WindowStyle $first_non_TOPMOST;
+ ok $f, 'WindowStyle works';
+ $f = WindowStyle($first_non_TOPMOST = GetNextWindow $enum_handle)
+ while $f & 0x200000; # WS_TOPMOST
+ ok($first_non_TOPMOST, 'There is non-TOPMOST window');
+ ok(!(WindowStyle($first_non_TOPMOST) & 0x200000), 'Indeed non-TOPMOST');
ok EndEnumWindows($enum_handle), 'end enumeration';
}
-is ($first_zorder, $k_hwnd, 'kid is the first in z-order enumeration');
+is ($first_non_TOPMOST, $k_hwnd, 'kid is the first in z-order enumeration');
ok hWindowPos_set({behind => 4}, $k_hwnd), # HWND_BOTTOM
'put kid to the back';
@@ -262,7 +272,9 @@ is $list[-2], $k_hwnd, 'kid is the last but one in ChildWindows';
ok hWindowPos_set({behind => 3}, $k_hwnd), # HWND_TOP
'put kid to the front again';
-is((hWindowPos $k_hwnd)->{behind}, 3, 'kis is at front again');
+$top = (hWindowPos $k_hwnd)->{behind};
+ok(($top == 3 or WindowStyle($top) & 0x200000), # WS_TOPMOST
+ 'kid is at front again');
sleep 5 if $interactive_wait;
ok IsWindow($k_hwnd), 'IsWindow works';
diff --git a/os2/OS2/REXX/DLL/Changes b/os2/OS2/REXX/DLL/Changes
index e2c656dd90..07c41da30a 100644
--- a/os2/OS2/REXX/DLL/Changes
+++ b/os2/OS2/REXX/DLL/Changes
@@ -2,3 +2,5 @@
Split out of OS2::REXX
0.02:
New methods libPath_find(), has_f32(), handle() and fullname().
+1.03:
+ New flag 0x8 for "return all" for libPath_find
diff --git a/os2/OS2/REXX/DLL/DLL.pm b/os2/OS2/REXX/DLL/DLL.pm
index 5d8a24ea7b..2a2486e863 100644
--- a/os2/OS2/REXX/DLL/DLL.pm
+++ b/os2/OS2/REXX/DLL/DLL.pm
@@ -1,6 +1,6 @@
package OS2::DLL;
-our $VERSION = '1.02';
+our $VERSION = '1.03';
use Carp;
use XSLoader;
@@ -64,10 +64,11 @@ sub libPath_find {
push @path, split /;/, OS2::extLibpath if $flags & 0x1; # BEGIN
push @path, split /;/, OS2::libPath if $flags & 0x2;
push @path, split /;/, OS2::extLibpath(1) if $flags & 0x4; # END
- s,(?![/\\])$,/, for @path;
- s,\\,/,g for @path;
+ s,(?![/\\])$,/, for @path;
+ s,\\,/,g for @path;
$name .= ".dll" unless $name =~ /\.[^\\\/]*$/;
$_ .= $name for @path;
+ return grep -f $_, @path if $flags & 0x8;
-f $_ and return $_ for @path;
return;
}