From: Ilya Zakharevich Date: Mon, 18 Dec 2006 00:45:24 +0000 (-0800) Subject: OS/2-specific fixes, round II X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=9d419b5f6925ac8219b490513f2c0e4f2d7c7f74;hp=dbf3bb275a8c67f06df1e6e24df320e3d78b2d60;p=p5sagit%2Fp5-mst-13.2.git OS/2-specific fixes, round II Message-ID: <20061218084524.GA14866@powdermilk.math.berkeley.edu> p4raw-id: //depot/perl@29580 --- diff --git a/MANIFEST b/MANIFEST index 36d440c..c976d90 100644 --- a/MANIFEST +++ b/MANIFEST @@ -2862,6 +2862,7 @@ os2/dl_os2.c Addon for dl_open os2/Makefile.SHs Shared library generation for OS/2 os2/os2add.sym Overriding symbols to export os2/os2_base.t Additional tests for builtin methods +os2/os2_pipe.t Tests for pipe creation logic os2/os2.c Additional code for OS/2 os2/OS2/ExtAttr/Changes EA access module os2/OS2/ExtAttr/ExtAttr.pm EA access module @@ -2885,6 +2886,8 @@ os2/OS2/Process/Process.xs system() constants in a module os2/OS2/Process/t/os2_process_kid.t Tests os2/OS2/Process/t/os2_process.t Tests os2/OS2/Process/t/os2_process_text.t Tests +os2/OS2/Process/t/os2_atoms.t Test for OS2::Process +os2/OS2/Process/t/os2_clipboard.t Test for OS2::Process os2/OS2/REXX/Changes DLL access module os2/OS2/REXX/DLL/Changes DLL access module os2/OS2/REXX/DLL/DLL.pm DLL access module diff --git a/emacs/ptags b/emacs/ptags index 8039153..c017e66 100755 --- a/emacs/ptags +++ b/emacs/ptags @@ -36,7 +36,7 @@ case "$1" in echo "Building TAGS with relative paths" esac -emacs=`(which emacs || which xemacs) 2>/dev/null` +emacs=`(which emacs || which xemacs || echo emacs) 2>/dev/null` [ -x "$emacs" ] || { echo "can't find emacs or xemacs in PATH"; exit 1; } # Insure proper order (.h after .c, .xs before .c in subdirs): diff --git a/ext/DynaLoader/XSLoader_pm.PL b/ext/DynaLoader/XSLoader_pm.PL index 2f8b3e8..8bd39e4 100644 --- a/ext/DynaLoader/XSLoader_pm.PL +++ b/ext/DynaLoader/XSLoader_pm.PL @@ -62,6 +62,13 @@ print OUT <<'EOT' if defined &DynaLoader::mod2fname; EOT +print OUT <<'EOT' if $^O eq 'os2'; + + # os2 static build can dynaload, but cannot dynaload Perl modules... + die 'Dynaloaded Perl modules are not available in this build of Perl' if $OS2::is_static; + +EOT + print OUT <<'EOT'; my $modpname = join('/',@modparts); my $modlibname = (caller())[1]; diff --git a/lib/ExtUtils/MM_Unix.pm b/lib/ExtUtils/MM_Unix.pm index d5f93a5..da0d57d 100644 --- a/lib/ExtUtils/MM_Unix.pm +++ b/lib/ExtUtils/MM_Unix.pm @@ -2538,7 +2538,7 @@ doc_inst_perl: MAP_LIBPERL "$(MAP_LIBPERL)" \ >> }.$self->catfile('$(DESTINSTALLARCHLIB)','perllocal.pod').q{ -}; +} if -f 'Makefile.PL'; push @m, q{ inst_perl: pure_inst_perl doc_inst_perl @@ -3415,6 +3415,7 @@ sub test { } # note: 'test.pl' name is also hardcoded in init_dirscan() my(@m); + my $subdirs_test = ($self->{DIR} && @{$self->{DIR}} ? 'subdirs-test' : ''); push(@m," TEST_VERBOSE=0 TEST_TYPE=test_\$(LINKTYPE) @@ -3424,17 +3425,17 @@ TESTDB_SW = -d testdb :: testdb_\$(LINKTYPE) -test :: \$(TEST_TYPE) +test :: \$(TEST_TYPE) $subdirs_test "); foreach my $dir (@{ $self->{DIR} }) { my $test = $self->oneliner(sprintf <<'CODE', $dir); chdir '%s'; -system '$(MAKE) test $(PASTHRU)' +system '$(MAKE) $(USEMAKEFILE) $(FIRST_MAKEFILE) test $(PASTHRU)' if -f '$(FIRST_MAKEFILE)'; CODE - push(@m, "\t\$(NOECHO) $test\n"); + push(@m, "\nsubdirs-test ::\n\t\$(NOECHO) $test\n"); } push(@m, "\t\$(NOECHO) \$(ECHO) 'No tests defined for \$(NAME) extension.'\n") diff --git a/os2/Makefile.SHs b/os2/Makefile.SHs index 4b2a00d..f7ee823 100644 --- a/os2/Makefile.SHs +++ b/os2/Makefile.SHs @@ -219,6 +219,10 @@ $(AOUT_DYNALOADER_OBJ) : $(DYNALOADER_OBJ) $(DYNALOADER_OBJ) : $(DYNALOADER) @sh -c true +# Quick hack to construct directories necessary for /*/% stuff: + +$(aout_static_ext) : $(static_ext) $(dynamic_ext) + $(AOUT_LIBPERL) : $(aout_obj) perl$(AOUT_OBJ_EXT) rm -f $@ $(AOUT_AR) rcu $@ perl$(AOUT_OBJ_EXT) $(aout_obj) diff --git a/os2/OS2/Process/Process.pm b/os2/OS2/Process/Process.pm index c299e88..51d8700 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, ' 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, C, C constants, or a byte offset referencing +a region (of length 4, 4, 2 correspondingly) fully inside C<0..cbWindowData-1>. +Here C 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). +of the data in the clipboard (defaults to C). May croak with error +C 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). +Same as ClipbrdText(), but will only work with clipboard +data types which are collection of C C 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 format (little-endian 2-byte representation +of Unicode), and will provide the result in Perl internal C 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). Other arguments are as for C. +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. -=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 (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 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 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, or C (possibly qualified by C +and C flags). It defaults to C for $fmt being +standard bitmap, metafile, and palette (undocumented???) formats; +otherwise defaults to C. If format is C, $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 (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 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). Other useful +values are C, C. (What is C???) + +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 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 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 +button, I-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 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, whether or not a cancel button +existed within the message box. + +C key dismisses the dialogue only if C button is present; the +return value is C. + +With C 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 message if C 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 keyboard transversal by pressing C 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 which will return C<0x1000>. + +Other optional arguments are the same as for MessageBox(). + +B Remark about C in presence of C 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, + +=item Text + +B + +=item Icon + +INFORMATION ICON + +=item Buttons + +B, B, B + +=item Default button + +B + +=item accelerator keys + +B, B, and B + +=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 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 or C (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, 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, B, B with B being the default +button; pressing buttons return 100, 101, or 102 correspondingly. + +In particular, exactly one button should have C 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; see also C constants. + +B With C 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 constants). A copy is made if $copy is TRUE (the +default). $hwnd defaults to C. + +=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 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 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 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 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 cda4847..05befa0 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 0000000..5d9603f --- /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 0000000..398a5fe --- /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 123525d..18d8fe2 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 e2c656d..07c41da 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 5d8a24e..2a2486e 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; } diff --git a/os2/os2.c b/os2/os2.c index 38e47dd..ff1c7bb 100644 --- a/os2/os2.c +++ b/os2/os2.c @@ -490,7 +490,7 @@ os2_cond_wait(perl_cond *c, perl_mutex *m) int rc; STRLEN n_a; if ((rc = DosResetEventSem(*c,&n_a)) && (rc != ERROR_ALREADY_RESET)) - Perl_rc = rc, croak_with_os2error("panic: COND_WAIT-reset"); + Perl_rc = CheckOSError(rc), croak_with_os2error("panic: COND_WAIT-reset"); if (m) MUTEX_UNLOCK(m); if (CheckOSError(DosWaitEventSem(*c,SEM_INDEFINITE_WAIT)) && (rc != ERROR_INTERRUPT)) @@ -1469,42 +1469,47 @@ do_spawn3(pTHX_ char *cmd, int execf, int flag) return rc; } +#define ASPAWN_WAIT 0 +#define ASPAWN_EXEC 1 +#define ASPAWN_NOWAIT 2 + /* Array spawn/exec. */ int -os2_aspawn4(pTHX_ SV *really, register SV **vmark, register SV **vsp, int execing) +os2_aspawn_4(pTHX_ SV *really, register SV **args, I32 cnt, int execing) { - register SV **mark = (SV **)vmark; - register SV **sp = (SV **)vsp; + register SV **argp = (SV **)args; + register SV **last = argp + cnt; register char **a; int rc; int flag = P_WAIT, flag_set = 0; STRLEN n_a; - if (sp > mark) { - Newx(PL_Argv, sp - mark + 3, char*); + if (cnt) { + Newx(PL_Argv, cnt + 3, char*); /* 3 extra to expand #! */ a = PL_Argv; - if (mark < sp && SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) { - ++mark; - flag = SvIVx(*mark); - flag_set = 1; - - } + if (cnt > 1 && SvNIOKp(*argp) && !SvPOKp(*argp)) { + flag = SvIVx(*argp); + flag_set = 1; + } else + --argp; - while (++mark <= sp) { - if (*mark) - *a++ = SvPVx(*mark, n_a); + while (++argp < last) { + if (*argp) + *a++ = SvPVx(*argp, n_a); else *a++ = ""; } *a = Nullch; if ( flag_set && (a == PL_Argv + 1) - && !really && !execing ) { /* One arg? */ + && !really && execing == ASPAWN_WAIT ) { /* One arg? */ rc = do_spawn3(aTHX_ a[-1], EXECF_SPAWN_BYFLAG, flag); - } else - rc = do_spawn_ve(aTHX_ really, flag, - (execing ? EXECF_EXEC : EXECF_SPAWN), NULL, 0); + } else { + const int execf[3] = {EXECF_SPAWN, EXECF_EXEC, EXECF_SPAWN_NOWAIT}; + + rc = do_spawn_ve(aTHX_ really, flag, execf[execing], NULL, 0); + } } else rc = -1; do_execfree(); @@ -1515,14 +1520,14 @@ os2_aspawn4(pTHX_ SV *really, register SV **vmark, register SV **vsp, int execin int os2_do_aspawn(pTHX_ SV *really, register SV **vmark, register SV **vsp) { - return os2_aspawn4(aTHX_ really, vmark, vsp, 0); + return os2_aspawn_4(aTHX_ really, vmark + 1, vsp - vmark, ASPAWN_WAIT); } /* Array exec. */ bool Perl_do_aexec(pTHX_ SV* really, SV** vmark, SV** vsp) { - return os2_aspawn4(aTHX_ really, vmark, vsp, 1); + return os2_aspawn_4(aTHX_ really, vmark + 1, vsp - vmark, ASPAWN_EXEC); } int @@ -1551,7 +1556,7 @@ os2exec(pTHX_ char *cmd) } PerlIO * -my_syspopen(pTHX_ char *cmd, char *mode) +my_syspopen4(pTHX_ char *cmd, char *mode, I32 cnt, SV** args) { #ifndef USE_POPEN int p[2]; @@ -1599,7 +1604,10 @@ my_syspopen(pTHX_ char *cmd, char *mode) fcntl(p[this], F_SETFD, FD_CLOEXEC); if (newfd != -1) fcntl(newfd, F_SETFD, FD_CLOEXEC); - pid = do_spawn_nowait(aTHX_ cmd); + if (cnt) { /* Args: "Real cmd", before first arg, the last, execing */ + pid = os2_aspawn_4(aTHX_ Nullsv, args, cnt, ASPAWN_NOWAIT); + } else + pid = do_spawn_nowait(aTHX_ cmd); if (newfd == -1) close(*mode == 'r'); /* It was closed initially */ else if (newfd != (*mode == 'r')) { /* Probably this check is not needed */ @@ -1630,6 +1638,9 @@ my_syspopen(pTHX_ char *cmd, char *mode) PerlIO *res; SV *sv; + if (cnt) + Perl_croak(aTHX_ "List form of piped open not implemented"); + # ifdef TRYSHELL res = popen(cmd, mode); # else @@ -1648,6 +1659,12 @@ my_syspopen(pTHX_ char *cmd, char *mode) } +PerlIO * +my_syspopen(pTHX_ char *cmd, char *mode) +{ + return my_syspopen4(aTHX_ cmd, mode, 0, NULL); +} + /******************************************************************/ #ifndef HAS_FORK @@ -1868,7 +1885,7 @@ XS(XS_OS2_replaceModule) if (!replaceModule(target, source, backup)) croak_with_os2error("replaceModule() error"); } - XSRETURN_EMPTY; + XSRETURN_YES; } /* APIRET APIENTRY DosPerfSysCall(ULONG ulCommand, ULONG ulParm1, @@ -1955,6 +1972,7 @@ XS(XS_OS2_perfSysCall) RETVAL = perfSysCall(ulCommand, ulParm1, ulParm2, ulParm3); if (!RETVAL) croak_with_os2error("perfSysCall() error"); + XSprePUSH; if (total) { int i,j; @@ -1962,6 +1980,7 @@ XS(XS_OS2_perfSysCall) PUSHn(u[0][0]); /* Total ticks on the first processor */ XSRETURN(1); } + EXTEND(SP, 4*total); for (i=0; i < total; i++) for (j=0; j < 4; j++) PUSHs(sv_2mortal(newSVnv(u[i][j]))); @@ -2087,6 +2106,21 @@ os2error(int rc) case PMERR_NOT_IN_A_PM_SESSION: name = "PMERR_NOT_IN_A_PM_SESSION"; break; + case PMERR_INVALID_ATOM: + name = "PMERR_INVALID_ATOM"; + break; + case PMERR_INVALID_HATOMTBL: + name = "PMERR_INVALID_HATOMTMB"; + break; + case PMERR_INVALID_INTEGER_ATOM: + name = "PMERR_INVALID_INTEGER_ATOM"; + break; + case PMERR_INVALID_ATOM_NAME: + name = "PMERR_INVALID_ATOM_NAME"; + break; + case PMERR_ATOM_NAME_NOT_FOUND: + name = "PMERR_ATOM_NAME_NOT_FOUND"; + break; } sprintf(s, "%s%s[No description found in OSO001.MSG]", name, (*name ? "=" : "")); @@ -2699,7 +2733,7 @@ XS(XS_OS2_ms_sleep) /* for testing only... */ ms = SvUV(ST(0)); lim = items > 1 ? SvUV(ST(1)) : ms + 1; async_mssleep(ms, lim); - XSRETURN_EMPTY; + XSRETURN_YES; } ULONG (*pDosTmrQueryFreq) (PULONG); @@ -2866,20 +2900,35 @@ XS(XS_OS2_DevCap) - CAPS_FAMILY + 1, si))) rc1 = Perl_rc; + else { + EXTEND(SP,2*(CAPS_DEVICE_POLYSET_POINTS - CAPS_FAMILY + 1)); + while (i < CAPS_DEVICE_POLYSET_POINTS - CAPS_FAMILY + 1) { + ST(j) = sv_newmortal(); + sv_setpv(ST(j++), dc_fields[i]); + ST(j) = sv_newmortal(); + sv_setiv(ST(j++), si[i]); + i++; + } + i = CAPS_DEVICE_POLYSET_POINTS + 1; + while (i < CAPS_DEVICE_POLYSET_POINTS + 11) { /* Just in case... */ + LONG l; + + if (CheckWinError(pDevQueryCaps(hScreenDC, i, 1, &l))) + break; + EXTEND(SP, j + 2); + ST(j) = sv_newmortal(); + sv_setiv(ST(j++), i); + ST(j) = sv_newmortal(); + sv_setiv(ST(j++), l); + i++; + } + } if (!items && CheckWinError(pDevCloseDC(hScreenDC))) Perl_warn_nocontext("DevCloseDC() failed: %s", os2error(Perl_rc)); if (rc1) Perl_rc = rc1, croak_with_os2error("DevQueryCaps() failed"); - EXTEND(SP,2*(CAPS_DEVICE_POLYSET_POINTS - CAPS_FAMILY + 1)); - while (i < CAPS_DEVICE_POLYSET_POINTS - CAPS_FAMILY + 1) { - ST(j) = sv_newmortal(); - sv_setpv(ST(j++), dc_fields[i]); - ST(j) = sv_newmortal(); - sv_setiv(ST(j++), si[i]); - i++; - } + XSRETURN(j); } - XSRETURN(2 * (CAPS_DEVICE_POLYSET_POINTS - CAPS_FAMILY + 1)); } LONG (*pWinQuerySysValue) (HWND hwndDesktop, LONG iSysValue); @@ -3077,7 +3126,7 @@ XS(XS_OS2_SysValues_set) if (CheckWinError(pWinSetSysValue(hwnd, which, val))) croak_with_os2error("SysValues_set()"); } - XSRETURN_EMPTY; + XSRETURN_YES; } #define QSV_MAX_WARP3 QSV_MAX_COMP_LENGTH @@ -3132,7 +3181,7 @@ XS(XS_OS2_SysInfo) (PVOID)si, sizeof(si)))) croak_with_os2error("DosQuerySysInfo() failed"); - while (last++ <= C_ARRAY_LENGTH(si)) { + while (++last <= C_ARRAY_LENGTH(si)) { if (CheckOSError(DosQuerySysInfo(last, last, /* One entry only */ (PVOID)(si+last-1), sizeof(*si)))) { @@ -3141,13 +3190,16 @@ XS(XS_OS2_SysInfo) break; } } - last--; + last--; /* Count of successfully processed offsets */ EXTEND(SP,2*last); while (i < last) { ST(j) = sv_newmortal(); - sv_setpv(ST(j++), si_fields[i]); + if (i < C_ARRAY_LENGTH(si_fields)) + sv_setpv(ST(j++), si_fields[i]); + else + sv_setiv(ST(j++), i + 1); ST(j) = sv_newmortal(); - sv_setiv(ST(j++), si[i]); + sv_setuv(ST(j++), si[i]); i++; } XSRETURN(2 * last); @@ -3219,7 +3271,7 @@ XS(XS_OS2_Beep) if (CheckOSError(DosBeep(freq, ms))) croak_with_os2error("SysValues_set()"); } - XSRETURN_EMPTY; + XSRETURN_YES; } @@ -3919,7 +3971,7 @@ XS(XS_OS2_mytype_set) else Perl_croak(aTHX_ "Usage: OS2::mytype_set(type)"); my_type_set(type); - XSRETURN_EMPTY; + XSRETURN_YES; } @@ -3990,6 +4042,459 @@ XS(XS_OS2_incrMaxFHandles) /* DosSetRelMaxFH */ XSRETURN(1); } +/* wait>0: force wait, wait<0: force nowait; + if restore, save/restore flags; otherwise flags are in oflags. + + Returns 1 if connected, 0 if not (due to nowait); croaks on error. */ +static ULONG +connectNPipe(ULONG hpipe, int wait, ULONG restore, ULONG oflags) +{ + ULONG ret = ERROR_INTERRUPT, rc, flags; + + if (restore && wait) + os2cp_croak(DosQueryNPHState(hpipe, &oflags), "DosQueryNPHState()"); + /* DosSetNPHState fails if more bits than NP_NOWAIT|NP_READMODE_MESSAGE */ + oflags &= (NP_NOWAIT | NP_READMODE_MESSAGE); + flags = (oflags & ~NP_NOWAIT) | (wait > 0 ? NP_WAIT : NP_NOWAIT); + /* We know (o)flags unless wait == 0 && restore */ + if (wait && (flags != oflags)) + os2cp_croak(DosSetNPHState(hpipe, flags), "DosSetNPHState()"); + while (ret == ERROR_INTERRUPT) + ret = DosConnectNPipe(hpipe); + (void)CheckOSError(ret); + if (restore && wait && (flags != oflags)) + os2cp_croak(DosSetNPHState(hpipe, oflags), "DosSetNPHState() back"); + /* We know flags unless wait == 0 && restore */ + if ( ((wait || restore) ? (flags & NP_NOWAIT) : 1) + && (ret == ERROR_PIPE_NOT_CONNECTED) ) + return 0; /* normal return value */ + if (ret == NO_ERROR) + return 1; + croak_with_os2error("DosConnectNPipe()"); +} + +/* With a lot of manual editing: +NO_OUTPUT ULONG +DosCreateNPipe(PCSZ pszName, OUTLIST HPIPE hpipe, ULONG ulOpenMode, int connect = 1, int count = 1, ULONG ulInbufLength = 8192, ULONG ulOutbufLength = ulInbufLength, ULONG ulPipeMode = count | NP_NOWAIT | NP_TYPE_BYTE | NP_READMODE_BYTE, ULONG ulTimeout = 0) + PREINIT: + ULONG rc; + C_ARGS: + pszName, &hpipe, ulOpenMode, ulPipeMode, ulInbufLength, ulOutbufLength, ulTimeout + POSTCALL: + if (CheckOSError(RETVAL)) + croak_with_os2error("OS2::mkpipe() error"); +*/ +XS(XS_OS2_pipe); /* prototype to pass -Wmissing-prototypes */ +XS(XS_OS2_pipe) +{ + dXSARGS; + if (items < 2 || items > 8) + Perl_croak(aTHX_ "Usage: OS2::pipe(pszName, ulOpenMode, connect= 1, count= 1, ulInbufLength= 8192, ulOutbufLength= ulInbufLength, ulPipeMode= count | NP_NOWAIT | NP_TYPE_BYTE | NP_READMODE_BYTE, ulTimeout= 0)"); + { + ULONG RETVAL; + PCSZ pszName = ( SvOK(ST(0)) ? (PCSZ)SvPV(ST(0),PL_na) : NULL ); + HPIPE hpipe; + SV *OpenMode = ST(1); + ULONG ulOpenMode; + int connect = 0, count, message_r = 0, message = 0, b = 0; + ULONG ulInbufLength, ulOutbufLength, ulPipeMode, ulTimeout, rc; + STRLEN len; + char *s, buf[10], *s1, *perltype = Nullch; + PerlIO *perlio; + double timeout; + + if (!pszName || !*pszName) + Perl_croak(aTHX_ "OS2::pipe(): empty pipe name"); + s = SvPV(OpenMode, len); + if (len == 4 && strEQ(s, "wait")) { /* DosWaitNPipe() */ + ULONG ms = 0xFFFFFFFF, ret = ERROR_INTERRUPT; /* Indefinite */ + + if (items == 3) { + timeout = (double)SvNV(ST(2)); + ms = timeout * 1000; + if (timeout < 0) + ms = 0xFFFFFFFF; /* Indefinite */ + else if (timeout && !ms) + ms = 1; + } else if (items > 3) + Perl_croak(aTHX_ "OS2::pipe(): too many arguments for wait-for-connect: %ld", (long)items); + + while (ret == ERROR_INTERRUPT) + ret = DosWaitNPipe(pszName, ms); /* XXXX Update ms? */ + os2cp_croak(ret, "DosWaitNPipe()"); + XSRETURN_YES; + } + if (len == 4 && strEQ(s, "call")) { /* DosCallNPipe() */ + ULONG ms = 0xFFFFFFFF, got; /* Indefinite */ + STRLEN l; + char *s; + char buf[8192]; + STRLEN ll = sizeof(buf); + char *b = buf; + + if (items < 3 || items > 5) + Perl_croak(aTHX_ "usage: OS2::pipe(pszName, 'call', write [, timeout= 0xFFFFFFFF, buffsize = 8192])"); + s = SvPV(ST(2), l); + if (items >= 4) { + timeout = (double)SvNV(ST(3)); + ms = timeout * 1000; + if (timeout < 0) + ms = 0xFFFFFFFF; /* Indefinite */ + else if (timeout && !ms) + ms = 1; + } + if (items >= 5) { + STRLEN lll = SvUV(ST(4)); + SV *sv = NEWSV(914, lll); + + sv_2mortal(sv); + ll = lll; + b = SvPVX(sv); + } + + os2cp_croak(DosCallNPipe(pszName, s, l, b, ll, &got, ms), + "DosCallNPipe()"); + XSRETURN_PVN(b, got); + } + s1 = buf; + if (len && len <= 3 && !(*s >= '0' && *s <= '9')) { + int r, w, R, W; + + r = strchr(s, 'r') != 0; + w = strchr(s, 'w') != 0; + R = strchr(s, 'R') != 0; + W = strchr(s, 'W') != 0; + b = strchr(s, 'b') != 0; + if (r + w + R + W + b != len || (r && R) || (w && W)) + Perl_croak(aTHX_ "OS2::pipe(): unknown OpenMode argument: `%s'", s); + if ((r || R) && (w || W)) + ulOpenMode = NP_INHERIT | NP_NOWRITEBEHIND | NP_ACCESS_DUPLEX; + else if (r || R) + ulOpenMode = NP_INHERIT | NP_NOWRITEBEHIND | NP_ACCESS_INBOUND; + else + ulOpenMode = NP_INHERIT | NP_NOWRITEBEHIND | NP_ACCESS_OUTBOUND; + if (R) + message = message_r = 1; + if (W) + message = 1; + else if (w && R) + Perl_croak(aTHX_ "OS2::pipe(): can't have message read mode for non-message pipes"); + } else + ulOpenMode = (ULONG)SvUV(OpenMode); /* ST(1) */ + + if ( (ulOpenMode & 0x3) == NP_ACCESS_DUPLEX + || (ulOpenMode & 0x3) == NP_ACCESS_INBOUND ) + *s1++ = 'r'; + if ( (ulOpenMode & 0x3) == NP_ACCESS_DUPLEX ) + *s1++ = '+'; + if ( (ulOpenMode & 0x3) == NP_ACCESS_OUTBOUND ) + *s1++ = 'w'; + if (b) + *s1++ = 'b'; + *s1 = 0; + if ( (ulOpenMode & 0x3) == NP_ACCESS_DUPLEX ) + perltype = "+<&"; + else if ( (ulOpenMode & 0x3) == NP_ACCESS_OUTBOUND ) + perltype = ">&"; + else + perltype = "<&"; + + if (items < 3) + connect = -1; /* no wait */ + else if (SvTRUE(ST(2))) { + s = SvPV(ST(2), len); + if (len == 6 && strEQ(s, "nowait")) + connect = -1; /* no wait */ + else if (len == 4 && strEQ(s, "wait")) + connect = 1; /* wait */ + else + Perl_croak(aTHX_ "OS2::pipe(): unknown connect argument: `%s'", s); + } + + if (items < 4) + count = 1; + else + count = (int)SvIV(ST(3)); + + if (items < 5) + ulInbufLength = 8192; + else + ulInbufLength = (ULONG)SvUV(ST(4)); + + if (items < 6) + ulOutbufLength = ulInbufLength; + else + ulOutbufLength = (ULONG)SvUV(ST(5)); + + if (count < -1 || count == 0 || count >= 255) + Perl_croak(aTHX_ "OS2::pipe(): count should be -1 or between 1 and 254: %ld", (long)count); + if (count < 0 ) + count = 255; /* Unlimited */ + + ulPipeMode = count; + if (items < 7) + ulPipeMode |= (NP_WAIT + | (message ? NP_TYPE_MESSAGE : NP_TYPE_BYTE) + | (message_r ? NP_READMODE_MESSAGE : NP_READMODE_BYTE)); + else + ulPipeMode |= (ULONG)SvUV(ST(6)); + + if (items < 8) + timeout = 0; + else + timeout = (double)SvNV(ST(7)); + ulTimeout = timeout * 1000; + if (timeout < 0) + ulTimeout = 0xFFFFFFFF; /* Indefinite */ + else if (timeout && !ulTimeout) + ulTimeout = 1; + + RETVAL = DosCreateNPipe(pszName, &hpipe, ulOpenMode, ulPipeMode, ulInbufLength, ulOutbufLength, ulTimeout); + if (CheckOSError(RETVAL)) + croak_with_os2error("OS2::pipe(): DosCreateNPipe() error"); + + if (connect) + connectNPipe(hpipe, connect, 1, 0); /* XXXX wait, retval */ + hpipe = __imphandle(hpipe); + + perlio = PerlIO_fdopen(hpipe, buf); + ST(0) = sv_newmortal(); + { + GV *gv = newGVgen("OS2::pipe"); + if ( do_open(gv, perltype, strlen(perltype), FALSE, 0, 0, perlio) ) + sv_setsv(ST(0), sv_bless(newRV((SV*)gv), gv_stashpv("IO::Handle",1))); + else + ST(0) = &PL_sv_undef; + } + } + XSRETURN(1); +} + +XS(XS_OS2_pipeCntl); /* prototype to pass -Wmissing-prototypes */ +XS(XS_OS2_pipeCntl) +{ + dXSARGS; + if (items < 2 || items > 3) + Perl_croak(aTHX_ "Usage: OS2::pipeCntl(pipe, op [, wait])"); + { + ULONG rc; + PerlIO *perlio = IoIFP(sv_2io(ST(0))); + IV fn = PerlIO_fileno(perlio); + HPIPE hpipe = (HPIPE)fn; + STRLEN len; + char *s = SvPV(ST(1), len); + int wait = 0, disconnect = 0, connect = 0, message = -1, query = 0; + int peek = 0, state = 0, info = 0; + + if (fn < 0) + Perl_croak(aTHX_ "OS2::pipeCntl(): not a pipe"); + if (items == 3) + wait = (SvTRUE(ST(2)) ? 1 : -1); + + switch (len) { + case 4: + if (strEQ(s, "byte")) + message = 0; + else if (strEQ(s, "peek")) + peek = 1; + else if (strEQ(s, "info")) + info = 1; + else + goto unknown; + break; + case 5: + if (strEQ(s, "reset")) + disconnect = connect = 1; + else if (strEQ(s, "state")) + query = 1; + else + goto unknown; + break; + case 7: + if (strEQ(s, "connect")) + connect = 1; + else if (strEQ(s, "message")) + message = 1; + else + goto unknown; + break; + case 9: + if (!strEQ(s, "readstate")) + goto unknown; + state = 1; + break; + case 10: + if (!strEQ(s, "disconnect")) + goto unknown; + disconnect = 1; + break; + default: + unknown: + Perl_croak(aTHX_ "OS2::pipeCntl(): unknown argument: `%s'", s); + break; + } + + if (items == 3 && !connect) + Perl_croak(aTHX_ "OS2::pipeCntl(): no wait argument for `%s'", s); + + XSprePUSH; /* Do not need arguments any more */ + if (disconnect) { + os2cp_croak(DosDisConnectNPipe(hpipe), "OS2::pipeCntl(): DosDisConnectNPipe()"); + PerlIO_clearerr(perlio); + } + if (connect) { + if (!connectNPipe(hpipe, wait , 1, 0)) + XSRETURN_IV(-1); + } + if (query) { + ULONG flags; + + os2cp_croak(DosQueryNPHState(hpipe, &flags), "DosQueryNPHState()"); + XSRETURN_UV(flags); + } + if (peek || state || info) { + ULONG BytesRead, PipeState; + AVAILDATA BytesAvail; + + os2cp_croak( DosPeekNPipe(hpipe, NULL, 0, &BytesRead, &BytesAvail, + &PipeState), "DosPeekNPipe() for state"); + if (state) { + EXTEND(SP, 3); + PUSHs(newSVuv(PipeState)); + /* Bytes (available/in-message) */ + PUSHs(newSViv(BytesAvail.cbpipe)); + PUSHs(newSViv(BytesAvail.cbmessage)); + XSRETURN(3); + } else if (info) { + /* L S S C C C/Z* + ID of the (remote) computer + buffers (out/in) + instances (max/actual) + */ + struct pipe_info_t { + ULONG id; /* char id[4]; */ + PIPEINFO pInfo; + char buf[512]; + } b; + int size; + + os2cp_croak( DosQueryNPipeInfo(hpipe, 1, &b.pInfo, sizeof(b) - STRUCT_OFFSET(struct pipe_info_t, pInfo)), + "DosQueryNPipeInfo(1)"); + os2cp_croak( DosQueryNPipeInfo(hpipe, 2, &b.id, sizeof(b.id)), + "DosQueryNPipeInfo(2)"); + size = b.pInfo.cbName; + /* Trailing 0 is included in cbName - undocumented; so + one should always extract with Z* */ + if (size) /* name length 254 or less */ + size--; + else + size = strlen(b.pInfo.szName); + EXTEND(SP, 6); + PUSHs(newSVpvn(b.pInfo.szName, size)); + PUSHs(newSVuv(b.id)); + PUSHs(newSViv(b.pInfo.cbOut)); + PUSHs(newSViv(b.pInfo.cbIn)); + PUSHs(newSViv(b.pInfo.cbMaxInst)); + PUSHs(newSViv(b.pInfo.cbCurInst)); + XSRETURN(6); + } else if (BytesAvail.cbpipe == 0) { + XSRETURN_NO; + } else { + SV *tmp = NEWSV(914, BytesAvail.cbpipe); + char *s = SvPVX(tmp); + + sv_2mortal(tmp); + os2cp_croak( DosPeekNPipe(hpipe, s, BytesAvail.cbpipe, &BytesRead, + &BytesAvail, &PipeState), "DosPeekNPipe()"); + SvCUR_set(tmp, BytesRead); + *SvEND(tmp) = 0; + SvPOK_on(tmp); + XSprePUSH; PUSHs(tmp); + XSRETURN(1); + } + } + if (message > -1) { + ULONG oflags, flags; + + os2cp_croak(DosQueryNPHState(hpipe, &oflags), "DosQueryNPHState()"); + /* DosSetNPHState fails if more bits than NP_NOWAIT|NP_READMODE_MESSAGE */ + oflags &= (NP_NOWAIT | NP_READMODE_MESSAGE); + flags = (oflags & NP_NOWAIT) + | (message ? NP_READMODE_MESSAGE : NP_READMODE_BYTE); + if (flags != oflags) + os2cp_croak(DosSetNPHState(hpipe, flags), "DosSetNPHState()"); + } + } + XSRETURN_YES; +} + +/* +NO_OUTPUT ULONG +DosOpen(PCSZ pszFileName, OUTLIST HFILE hFile, OUTLIST ULONG ulAction, ULONG ulOpenFlags, ULONG ulOpenMode = OPEN_ACTION_OPEN_IF_EXISTS | OPEN_ACTION_FAIL_IF_NEW, ULONG ulAttribute = FILE_NORMAL, ULONG ulFileSize = 0, PEAOP2 pEABuf = NULL); + PREINIT: + ULONG rc; + C_ARGS: + pszFileName, &hFile, &ulAction, ulFileSize, ulAttribute, ulOpenFlags, ulOpenMode, pEABuf + POSTCALL: + if (CheckOSError(RETVAL)) + croak_with_os2error("OS2::open() error"); +*/ +XS(XS_OS2_open); /* prototype to pass -Wmissing-prototypes */ +XS(XS_OS2_open) +{ + dXSARGS; + if (items < 2 || items > 6) + Perl_croak(aTHX_ "Usage: OS2::open(pszFileName, ulOpenMode, ulOpenFlags= OPEN_ACTION_OPEN_IF_EXISTS | OPEN_ACTION_FAIL_IF_NEW, ulAttribute= FILE_NORMAL, ulFileSize= 0, pEABuf= NULL)"); + { +#line 39 "pipe.xs" + ULONG rc; +#line 113 "pipe.c" + ULONG RETVAL; + PCSZ pszFileName = ( SvOK(ST(0)) ? (PCSZ)SvPV(ST(0),PL_na) : NULL ); + HFILE hFile; + ULONG ulAction; + ULONG ulOpenMode = (ULONG)SvUV(ST(1)); + ULONG ulOpenFlags; + ULONG ulAttribute; + ULONG ulFileSize; + PEAOP2 pEABuf; + + if (items < 3) + ulOpenFlags = OPEN_ACTION_OPEN_IF_EXISTS | OPEN_ACTION_FAIL_IF_NEW; + else { + ulOpenFlags = (ULONG)SvUV(ST(2)); + } + + if (items < 4) + ulAttribute = FILE_NORMAL; + else { + ulAttribute = (ULONG)SvUV(ST(3)); + } + + if (items < 5) + ulFileSize = 0; + else { + ulFileSize = (ULONG)SvUV(ST(4)); + } + + if (items < 6) + pEABuf = NULL; + else { + pEABuf = (PEAOP2)SvUV(ST(5)); + } + + RETVAL = DosOpen(pszFileName, &hFile, &ulAction, ulFileSize, ulAttribute, ulOpenFlags, ulOpenMode, pEABuf); + if (CheckOSError(RETVAL)) + croak_with_os2error("OS2::open() error"); + XSprePUSH; EXTEND(SP,2); + PUSHs(sv_newmortal()); + sv_setuv(ST(0), (UV)hFile); + PUSHs(sv_newmortal()); + sv_setuv(ST(1), (UV)ulAction); + } + XSRETURN(2); +} + int Xs_OS2_init(pTHX) { @@ -4041,6 +4546,9 @@ Xs_OS2_init(pTHX) newXSproto("OS2::SysValues", XS_OS2_SysValues, file, ";$$"); newXSproto("OS2::SysValues_set", XS_OS2_SysValues_set, file, "$$;$"); newXSproto("OS2::Beep", XS_OS2_Beep, file, ";$$"); + newXSproto("OS2::pipe", XS_OS2_pipe, file, "$$;$$$$$$"); + newXSproto("OS2::pipeCntl", XS_OS2_pipeCntl, file, "$$;$"); + newXSproto("OS2::open", XS_OS2_open, file, "$$;$$$$"); gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV); GvMULTI_on(gv); #ifdef PERL_IS_AOUT diff --git a/os2/os2_pipe.t b/os2/os2_pipe.t new file mode 100644 index 0000000..208d376 --- /dev/null +++ b/os2/os2_pipe.t @@ -0,0 +1,201 @@ +#!/usr/bin/perl -w +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +use Test::More tests => 80; +use strict; +use IO::Handle; +use Fcntl; + +my $pname = "/pipe/perl_pipe_test$$"; + +ok !eval {OS2::pipe $pname, 'wait'}, 'wait for non-existing pipe fails'; +is 0 + $^E, 3, 'correct error code'; +ok my $server_pipe = OS2::pipe($pname, 'rw'), 'create pipe, no connect'; +ok((my $fd = fileno $server_pipe) >= 0, 'has a fileno'); +is +(OS2::pipeCntl($server_pipe, 'readstate'))[0], 2, 'is listening'; +is OS2::pipeCntl($server_pipe, 'state') & 0xFF, 1, 'max count=1'; + +ok 0 > OS2::pipeCntl($server_pipe, 'connect', !'wait'), 'connect nowait'; + +ok open(my $fh, '+<', $pname), 'open client end'; +#ok sysopen($fh, $pname, O_RDWR), 'sysopen client end' . $^E; +#my ($fd1, $action) = OS2::open $pname, 0x2042 or warn $^E; # ERROR,SHARE,RDWR +is +(OS2::pipeCntl($server_pipe, 'readstate'))[0], 3, 'is connected'; +ok 0 < OS2::pipeCntl($server_pipe, 'connect', !'wait'), 'connect nowait'; +ok OS2::pipeCntl($server_pipe, 'connect', 'wait'), 'connect wait'; +is $server_pipe->autoflush, 0, 'autoflush server'; # Returns the old value +is $fh->autoflush, 0, 'autoflush'; # Returns the old value +ok syswrite($server_pipe, "some string\n"), 'server write'; +is scalar <$fh>, "some string\n", 'client read'; +ok syswrite($fh, "another string\n"), 'client write'; + +is OS2::pipeCntl($server_pipe, 'peek'), "another string\n", 'peeking is fine'; +my ($st, $bytesAvail, $bytesInMess) = OS2::pipeCntl($server_pipe, 'readstate'); +my ($name, $remoteID, $outBuffer, $inBuffer, $maxInstance, $countInstance) + = OS2::pipeCntl($server_pipe, 'info'); +is $bytesAvail, length("another string\n"), 'count bytes'; +is $remoteID, 0, 'not remote'; +is $maxInstance, 1, 'max count is 1'; +is $countInstance, 1, 'count is 1'; +#is $len, length($pname) + 1, 'length of name is 1 more than the actual'; +(my $tmp = $pname) =~ s,/,\\,g; +is lc $name, lc $tmp, 'name is correct (up to case)'; + +# If do print() instead of syswrite(), this gets "some string\n" instead!!! +is scalar <$server_pipe>, "another string\n", 'server read'; + +ok !open(my $fh1, '+<', $pname), 'open client end fails'; + +# No new child present, return -1 +ok 0 > OS2::pipeCntl($server_pipe, 'reset', !'wait'), 'server reset, no wait'; +ok eof($fh), 'client EOF'; +ok(($fh->clearerr, 1), 'client clear EOF'); # XXXX Returns void + +$!=0; $^E = 0; +ok close $fh, 'close client'; +#diag $!; +#diag $^E; +is fileno $fh, undef, 'was actually closed...'; + +ok open($fh, '+<', $pname), 'open client end'; + +is $fh->autoflush, 1, 'autoflush'; # Returns the old value +ok syswrite($server_pipe, "some string\n"), 'server write'; +is scalar <$fh>, "some string\n", 'client read'; +ok syswrite($fh, "another string\n"), 'client write'; + +# If do print() instead of syswrite(), this gets "some string\n" instead!!! +is scalar <$server_pipe>, "another string\n", 'server read'; + +ok syswrite($server_pipe, "some string\n"), 'server write'; +ok syswrite($fh, "another string\n"), 'client write'; +is scalar <$fh>, "some string\n", 'client read'; + +# If do print() instead of syswrite(), this gets "some string\n" instead!!! +is scalar <$server_pipe>, "another string\n", 'server read'; + +ok syswrite($server_pipe, "some string\n"), 'server write'; +ok syswrite($fh, "another string\n"), 'client write'; + +ok((sysread $fh, my $in, 2000), 'client sysread'); +is $in, "some string\n", 'client sysread correct'; + +# If do print() instead of syswrite(), this gets "some string\n" instead!!! +ok((sysread $server_pipe, $in, 2000), 'server sysread'); +is $in, "another string\n", 'server sysread correct'; + +ok !open($fh1, '+<', $pname), 'open client end fails'; + +# XXXX Not needed??? +#ok(($fh->clearerr, 1), 'client clear EOF'); # XXXX Returns void + +ok close $fh, 'close client'; +ok eof $server_pipe, 'server EOF'; # Creates an error condition + +my $pid = system 4|0x40000, $^X, '-wle', <<'EOS', $pname; # SESSION|INDEPENDENT + my $success; + END {sleep($success ? 1 : 10);} + my $mess = ''; + $SIG{TERM} = sub {die "kid1 error: Got SIGTERM\nmess=`$mess'"}; + my $pn = shift; + my $fh; + eval { + $mess .= "Pipe open fails\n" unless open $fh, '+<', $pn; + my $t = time; ### TIMESTAMP0 + warn "kid1: Wait for pipe...\n"; + $mess .= "Pipe became available\n" if OS2::pipe $pn, 'wait'; + my $t1 = time() - $t; ### TIMESTAMP1 + $mess .= "Unexpected delay $t1\n" unless $t1 >= 1 and $t1 <= 3; + warn "kid1: sleep 4...\n"; + sleep 4; + $mess .= "Pipe open\n" if open $fh, '+<', $pn; + binmode $fh; + 1; ### TIMESTAMP2 + } or warn $@; + warn "kid1: pipe opened...\n"; + select $fh; $| = 1; + my $c = syswrite $fh, $mess or warn "print: $!"; + warn "kid1: Wrote $c bytes\n"; + warn $mess; + close $fh or die "kid1 error: close: $!"; + $success = 1; +EOS + +ok $pid > 0, 'kid pid'; + +### TIMESTAMP0 +sleep 2; +my $t = time; +### TIMESTAMP1 +# New child present; will clear error condition... +ok 0 < OS2::pipeCntl($server_pipe, 'reset', 'wait'), 'server reset, wait'; +### TIMESTAMP2 +my $t1 = time() - $t; +ok $t1 <= 6 && $t1 >= 2, 'correct delay'; + +sleep 2; + +ok binmode($server_pipe), 'binmode'; +ok !eof $server_pipe, 'server: no EOF'; +my @in = <$server_pipe>; +my @exp = ( "Pipe open fails\n", "Pipe became available\n", "Pipe open\n"); + +is "@in", "@exp", 'expected data'; + +# Can't switch to message mode if created in byte mode... +ok close $server_pipe, 'server close'; +ok $server_pipe = OS2::pipe($pname, 'RW'), 'create pipe in message mode'; +ok OS2::pipeCntl($server_pipe, 'byte'), 'can switch to byte mode'; +ok OS2::pipeCntl($server_pipe, 'message'), 'can switch to message mode'; + +$pid = system 4|0x40000, $^X, '-wle', <<'EOS', $pname, $$; # SESSION|INDEPENDENT + END {sleep 2} + my ($name, $ppid) = (shift, shift); + $name =~ s,/,\\,g; + $name = uc $name; + warn "kid2: OS2::pipe $name, 'call', ...\n"; + my $got = OS2::pipe $name, 'call', "Is your pid $ppid?\n"; + my $ok = $got eq 'Yes'; + warn "kid2: got `$got'\n"; + OS2::pipe $name, 'call', $ok ? "fine\n" : "bad\n"; +EOS + +ok $pid, 'kid started'; +sleep 2; # XXX How to syncronize with kid??? +$in = scalar <$server_pipe>; +my $ok1 = ($in || '') eq "Is your pid $$?\n"; +is $in, "Is your pid $$?\n", 'call in'; +ok syswrite($server_pipe, $ok1 ? 'Yes' : 'No' ), 'server write'; + +ok 0 < OS2::pipeCntl($server_pipe, 'reset', 'wait'), 'server reset, wait'; +$in = scalar <$server_pipe>; +is $in, "fine\n", 'call in'; +ok syswrite($server_pipe, 'ending' ), 'server write'; + +ok close $server_pipe, 'server close'; + +ok $server_pipe = OS2::pipe($pname, 'W'), 'create pipe in message write mode'; +ok !eval {OS2::pipeCntl($server_pipe, 'readstate'); 1}, 'readstate fails, as expected'; +ok close $server_pipe, 'server close'; + +ok $server_pipe = OS2::pipe($pname, 'w'), 'create pipe in byte write mode'; +ok !eval {OS2::pipeCntl($server_pipe, 'readstate'); 1}, 'readstate fails, as expected'; +ok close $server_pipe, 'server close'; + +ok $server_pipe = OS2::pipe($pname, 'r'), 'create pipe in byte read mode'; +is +(OS2::pipeCntl($server_pipe, 'readstate'))[0], 2, 'is listening'; +ok close $server_pipe, 'server close'; + +ok $server_pipe = OS2::pipe($pname, 'r', 0), 'create-no-connect pipe in byte read mode'; +is +(OS2::pipeCntl($server_pipe, 'readstate'))[0], 1, 'is disconnected'; +ok close $server_pipe, 'server close'; + +ok $server_pipe = OS2::pipe($pname, 'R'), 'create pipe in message read mode'; +is +(OS2::pipeCntl($server_pipe, 'readstate'))[0], 2, 'is listening'; +ok close $server_pipe, 'server close'; + +#is waitpid($pid, 0), $pid, 'kid ended'; +#is $?, 0, 'kid exitcode'; diff --git a/os2/os2ish.h b/os2/os2ish.h index b27a631..a4b972f 100644 --- a/os2/os2ish.h +++ b/os2/os2ish.h @@ -312,7 +312,10 @@ void *sys_alloc(int size); #define TMPPATH1 "plXXXXXX" extern const char *tmppath; PerlIO *my_syspopen(pTHX_ char *cmd, char *mode); -/* Cannot prototype with I32 at this point. */ +#ifdef PERL_CORE +/* Cannot prototype with I32, SV at this point (used in x2p too). */ +PerlIO *my_syspopen4(pTHX_ char *cmd, char *mode, I32 cnt, SV** args); +#endif int my_syspclose(PerlIO *f); FILE *my_tmpfile (void); char *my_tmpnam (char *); diff --git a/perl.c b/perl.c index de3b277..4ad77af 100644 --- a/perl.c +++ b/perl.c @@ -1547,11 +1547,7 @@ setuid perl scripts securely.\n"); } /* Can we grab env area too to be used as the area for $0? */ if (s && PL_origenviron) { - if ((PL_origenviron[0] == s + 1 -#ifdef OS2 - || (PL_origenviron[0] == s + 9 && (s += 8)) -#endif - ) + if ((PL_origenviron[0] == s + 1) || (aligned && (PL_origenviron[0] > s && @@ -1559,7 +1555,7 @@ setuid perl scripts securely.\n"); INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask))) ) { -#ifndef OS2 +#ifndef OS2 /* ENVIRON is read by the kernel too. */ s = PL_origenviron[0]; while (*s) s++; #endif diff --git a/util.c b/util.c index c5f69ae..fb77773 100644 --- a/util.c +++ b/util.c @@ -2267,8 +2267,12 @@ Perl_my_popen_list(pTHX_ char *mode, int n, SV **args) PerlLIO_close(pp[0]); return PerlIO_fdopen(p[This], mode); #else +# ifdef OS2 /* Same, without fork()ing and all extra overhead... */ + return my_syspopen4(aTHX_ Nullch, mode, n, args); +# else Perl_croak(aTHX_ "List form of piped open not implemented"); return (PerlIO *) NULL; +# endif #endif }