From 354c724e8ab74f150e14800acc80d505949161f5 Mon Sep 17 00:00:00 2001 From: Nicholas Clark Date: Fri, 4 Sep 2009 11:04:30 +0100 Subject: OS/2 hadn't been updated to cope with the ext/ restructuring. I don't have OS/2, so I can't test this, but the code in Configure will assume flat directories, because ext/File-Glob is present, and hence not search recursively and not find the OS/2 extensions if they are copied into ext/OS2/* I believe that without this change OS/2 will not have been building since the change to flattened ext. This change may not be sufficient to get OS/2 building again, but it is in the right direction. --- os2/OS2/ExtAttr/Changes | 7 - os2/OS2/ExtAttr/ExtAttr.pm | 175 --- os2/OS2/ExtAttr/ExtAttr.xs | 197 --- os2/OS2/ExtAttr/MANIFEST | 8 - os2/OS2/ExtAttr/Makefile.PL | 11 - os2/OS2/ExtAttr/myea.h | 2 - os2/OS2/ExtAttr/t/os2_ea.t | 85 -- os2/OS2/ExtAttr/typemap | 4 - os2/OS2/OS2-ExtAttr/Changes | 7 + os2/OS2/OS2-ExtAttr/ExtAttr.pm | 175 +++ os2/OS2/OS2-ExtAttr/ExtAttr.xs | 197 +++ os2/OS2/OS2-ExtAttr/MANIFEST | 8 + os2/OS2/OS2-ExtAttr/Makefile.PL | 11 + os2/OS2/OS2-ExtAttr/myea.h | 2 + os2/OS2/OS2-ExtAttr/t/os2_ea.t | 85 ++ os2/OS2/OS2-ExtAttr/typemap | 4 + os2/OS2/OS2-PrfDB/Changes | 6 + os2/OS2/OS2-PrfDB/MANIFEST | 7 + os2/OS2/OS2-PrfDB/Makefile.PL | 11 + os2/OS2/OS2-PrfDB/PrfDB.pm | 312 ++++ os2/OS2/OS2-PrfDB/PrfDB.xs | 173 +++ os2/OS2/OS2-PrfDB/t/os2_prfdb.t | 190 +++ os2/OS2/OS2-Process/MANIFEST | 7 + os2/OS2/OS2-Process/Makefile.PL | 44 + os2/OS2/OS2-Process/Process.pm | 2372 ++++++++++++++++++++++++++++++ os2/OS2/OS2-Process/Process.xs | 1896 ++++++++++++++++++++++++ os2/OS2/OS2-Process/t/os2_atoms.t | 88 ++ os2/OS2/OS2-Process/t/os2_clipboard.t | 211 +++ os2/OS2/OS2-Process/t/os2_process.t | 529 +++++++ os2/OS2/OS2-Process/t/os2_process_kid.t | 64 + os2/OS2/OS2-Process/t/os2_process_text.t | 52 + os2/OS2/OS2-REXX/Changes | 7 + os2/OS2/OS2-REXX/DLL/Changes | 6 + os2/OS2/OS2-REXX/DLL/DLL.pm | 308 ++++ os2/OS2/OS2-REXX/DLL/DLL.xs | 172 +++ os2/OS2/OS2-REXX/DLL/MANIFEST | 5 + os2/OS2/OS2-REXX/DLL/Makefile.PL | 9 + os2/OS2/OS2-REXX/MANIFEST | 14 + os2/OS2/OS2-REXX/Makefile.PL | 9 + os2/OS2/OS2-REXX/REXX.pm | 483 ++++++ os2/OS2/OS2-REXX/REXX.xs | 566 +++++++ os2/OS2/OS2-REXX/t/rx_cmprt.t | 54 + os2/OS2/OS2-REXX/t/rx_dllld.t | 36 + os2/OS2/OS2-REXX/t/rx_emxrv.t | 61 + os2/OS2/OS2-REXX/t/rx_objcall.t | 38 + os2/OS2/OS2-REXX/t/rx_sql.test | 97 ++ os2/OS2/OS2-REXX/t/rx_tiesql.test | 86 ++ os2/OS2/OS2-REXX/t/rx_tievar.t | 89 ++ os2/OS2/OS2-REXX/t/rx_tieydb.t | 33 + os2/OS2/OS2-REXX/t/rx_varset.t | 39 + os2/OS2/OS2-REXX/t/rx_vrexx.t | 63 + os2/OS2/OS2-typemap | 28 + os2/OS2/PrfDB/Changes | 6 - os2/OS2/PrfDB/MANIFEST | 7 - os2/OS2/PrfDB/Makefile.PL | 11 - os2/OS2/PrfDB/PrfDB.pm | 312 ---- os2/OS2/PrfDB/PrfDB.xs | 173 --- os2/OS2/PrfDB/t/os2_prfdb.t | 190 --- os2/OS2/Process/MANIFEST | 7 - os2/OS2/Process/Makefile.PL | 44 - os2/OS2/Process/Process.pm | 2372 ------------------------------ os2/OS2/Process/Process.xs | 1896 ------------------------ os2/OS2/Process/t/os2_atoms.t | 88 -- os2/OS2/Process/t/os2_clipboard.t | 211 --- os2/OS2/Process/t/os2_process.t | 529 ------- os2/OS2/Process/t/os2_process_kid.t | 64 - os2/OS2/Process/t/os2_process_text.t | 52 - os2/OS2/REXX/Changes | 7 - os2/OS2/REXX/DLL/Changes | 6 - os2/OS2/REXX/DLL/DLL.pm | 308 ---- os2/OS2/REXX/DLL/DLL.xs | 172 --- os2/OS2/REXX/DLL/MANIFEST | 5 - os2/OS2/REXX/DLL/Makefile.PL | 9 - os2/OS2/REXX/MANIFEST | 14 - os2/OS2/REXX/Makefile.PL | 9 - os2/OS2/REXX/REXX.pm | 483 ------ os2/OS2/REXX/REXX.xs | 566 ------- os2/OS2/REXX/t/rx_cmprt.t | 54 - os2/OS2/REXX/t/rx_dllld.t | 36 - os2/OS2/REXX/t/rx_emxrv.t | 61 - os2/OS2/REXX/t/rx_objcall.t | 38 - os2/OS2/REXX/t/rx_sql.test | 97 -- os2/OS2/REXX/t/rx_tiesql.test | 86 -- os2/OS2/REXX/t/rx_tievar.t | 89 -- os2/OS2/REXX/t/rx_tieydb.t | 33 - os2/OS2/REXX/t/rx_varset.t | 39 - os2/OS2/REXX/t/rx_vrexx.t | 63 - os2/OS2/typemap | 28 - 88 files changed, 8654 insertions(+), 8654 deletions(-) delete mode 100644 os2/OS2/ExtAttr/Changes delete mode 100644 os2/OS2/ExtAttr/ExtAttr.pm delete mode 100644 os2/OS2/ExtAttr/ExtAttr.xs delete mode 100644 os2/OS2/ExtAttr/MANIFEST delete mode 100644 os2/OS2/ExtAttr/Makefile.PL delete mode 100644 os2/OS2/ExtAttr/myea.h delete mode 100644 os2/OS2/ExtAttr/t/os2_ea.t delete mode 100644 os2/OS2/ExtAttr/typemap create mode 100644 os2/OS2/OS2-ExtAttr/Changes create mode 100644 os2/OS2/OS2-ExtAttr/ExtAttr.pm create mode 100644 os2/OS2/OS2-ExtAttr/ExtAttr.xs create mode 100644 os2/OS2/OS2-ExtAttr/MANIFEST create mode 100644 os2/OS2/OS2-ExtAttr/Makefile.PL create mode 100644 os2/OS2/OS2-ExtAttr/myea.h create mode 100644 os2/OS2/OS2-ExtAttr/t/os2_ea.t create mode 100644 os2/OS2/OS2-ExtAttr/typemap create mode 100644 os2/OS2/OS2-PrfDB/Changes create mode 100644 os2/OS2/OS2-PrfDB/MANIFEST create mode 100644 os2/OS2/OS2-PrfDB/Makefile.PL create mode 100644 os2/OS2/OS2-PrfDB/PrfDB.pm create mode 100644 os2/OS2/OS2-PrfDB/PrfDB.xs create mode 100644 os2/OS2/OS2-PrfDB/t/os2_prfdb.t create mode 100644 os2/OS2/OS2-Process/MANIFEST create mode 100644 os2/OS2/OS2-Process/Makefile.PL create mode 100644 os2/OS2/OS2-Process/Process.pm create mode 100644 os2/OS2/OS2-Process/Process.xs create mode 100644 os2/OS2/OS2-Process/t/os2_atoms.t create mode 100644 os2/OS2/OS2-Process/t/os2_clipboard.t create mode 100644 os2/OS2/OS2-Process/t/os2_process.t create mode 100644 os2/OS2/OS2-Process/t/os2_process_kid.t create mode 100644 os2/OS2/OS2-Process/t/os2_process_text.t create mode 100644 os2/OS2/OS2-REXX/Changes create mode 100644 os2/OS2/OS2-REXX/DLL/Changes create mode 100644 os2/OS2/OS2-REXX/DLL/DLL.pm create mode 100644 os2/OS2/OS2-REXX/DLL/DLL.xs create mode 100644 os2/OS2/OS2-REXX/DLL/MANIFEST create mode 100644 os2/OS2/OS2-REXX/DLL/Makefile.PL create mode 100644 os2/OS2/OS2-REXX/MANIFEST create mode 100644 os2/OS2/OS2-REXX/Makefile.PL create mode 100644 os2/OS2/OS2-REXX/REXX.pm create mode 100644 os2/OS2/OS2-REXX/REXX.xs create mode 100644 os2/OS2/OS2-REXX/t/rx_cmprt.t create mode 100644 os2/OS2/OS2-REXX/t/rx_dllld.t create mode 100644 os2/OS2/OS2-REXX/t/rx_emxrv.t create mode 100644 os2/OS2/OS2-REXX/t/rx_objcall.t create mode 100644 os2/OS2/OS2-REXX/t/rx_sql.test create mode 100644 os2/OS2/OS2-REXX/t/rx_tiesql.test create mode 100644 os2/OS2/OS2-REXX/t/rx_tievar.t create mode 100644 os2/OS2/OS2-REXX/t/rx_tieydb.t create mode 100644 os2/OS2/OS2-REXX/t/rx_varset.t create mode 100644 os2/OS2/OS2-REXX/t/rx_vrexx.t create mode 100644 os2/OS2/OS2-typemap delete mode 100644 os2/OS2/PrfDB/Changes delete mode 100644 os2/OS2/PrfDB/MANIFEST delete mode 100644 os2/OS2/PrfDB/Makefile.PL delete mode 100644 os2/OS2/PrfDB/PrfDB.pm delete mode 100644 os2/OS2/PrfDB/PrfDB.xs delete mode 100644 os2/OS2/PrfDB/t/os2_prfdb.t delete mode 100644 os2/OS2/Process/MANIFEST delete mode 100644 os2/OS2/Process/Makefile.PL delete mode 100644 os2/OS2/Process/Process.pm delete mode 100644 os2/OS2/Process/Process.xs delete mode 100644 os2/OS2/Process/t/os2_atoms.t delete mode 100644 os2/OS2/Process/t/os2_clipboard.t delete mode 100644 os2/OS2/Process/t/os2_process.t delete mode 100644 os2/OS2/Process/t/os2_process_kid.t delete mode 100644 os2/OS2/Process/t/os2_process_text.t delete mode 100644 os2/OS2/REXX/Changes delete mode 100644 os2/OS2/REXX/DLL/Changes delete mode 100644 os2/OS2/REXX/DLL/DLL.pm delete mode 100644 os2/OS2/REXX/DLL/DLL.xs delete mode 100644 os2/OS2/REXX/DLL/MANIFEST delete mode 100644 os2/OS2/REXX/DLL/Makefile.PL delete mode 100644 os2/OS2/REXX/MANIFEST delete mode 100644 os2/OS2/REXX/Makefile.PL delete mode 100644 os2/OS2/REXX/REXX.pm delete mode 100644 os2/OS2/REXX/REXX.xs delete mode 100644 os2/OS2/REXX/t/rx_cmprt.t delete mode 100644 os2/OS2/REXX/t/rx_dllld.t delete mode 100644 os2/OS2/REXX/t/rx_emxrv.t delete mode 100644 os2/OS2/REXX/t/rx_objcall.t delete mode 100644 os2/OS2/REXX/t/rx_sql.test delete mode 100644 os2/OS2/REXX/t/rx_tiesql.test delete mode 100644 os2/OS2/REXX/t/rx_tievar.t delete mode 100644 os2/OS2/REXX/t/rx_tieydb.t delete mode 100644 os2/OS2/REXX/t/rx_varset.t delete mode 100644 os2/OS2/REXX/t/rx_vrexx.t delete mode 100644 os2/OS2/typemap (limited to 'os2/OS2') diff --git a/os2/OS2/ExtAttr/Changes b/os2/OS2/ExtAttr/Changes deleted file mode 100644 index 92b51826cc..0000000000 --- a/os2/OS2/ExtAttr/Changes +++ /dev/null @@ -1,7 +0,0 @@ -Revision history for Perl extension OS2::ExtAttr. - -0.01 Sun Apr 21 11:07:04 1996 - - original version; created by h2xs 1.16 - -0.02 Update to XSLoader and 'our'. - Remove Exporter. diff --git a/os2/OS2/ExtAttr/ExtAttr.pm b/os2/OS2/ExtAttr/ExtAttr.pm deleted file mode 100644 index c49f1d4de5..0000000000 --- a/os2/OS2/ExtAttr/ExtAttr.pm +++ /dev/null @@ -1,175 +0,0 @@ -package OS2::ExtAttr; - -use strict; -use XSLoader; - -our $VERSION = '0.02'; -XSLoader::load 'OS2::ExtAttr', $VERSION; - -# Preloaded methods go here. - -# Format of the array: -# 0 ead, 1 file name, 2 file handle. 3 length, 4 position, 5 need to write. - -sub TIEHASH { - my $class = shift; - my $ea = _create() || die "Cannot create EA: $!"; - my $file = shift; - my ($name, $handle); - if (ref $file eq 'GLOB' or ref \$file eq 'GLOB') { - die "File handle is not opened" unless $handle = fileno $file; - _read($ea, undef, $handle, 0); - } else { - $name = $file; - _read($ea, $name, 0, 0); - } - bless [$ea, $name, $handle, 0, 0, 0], $class; -} - -sub DESTROY { - my $eas = shift; - # 0 means: discard eas which are not in $eas->[0]. - _write( $eas->[0], $eas->[1], $eas->[2], 0) and die "Cannot write EA: $!" - if $eas->[5]; - _destroy( $eas->[0] ); -} - -sub FIRSTKEY { - my $eas = shift; - $eas->[3] = _count($eas->[0]); - $eas->[4] = 1; - return undef if $eas->[4] > $eas->[3]; - return _get_name($eas->[0], $eas->[4]); -} - -sub NEXTKEY { - my $eas = shift; - $eas->[4]++; - return undef if $eas->[4] > $eas->[3]; - return _get_name($eas->[0], $eas->[4]); -} - -sub FETCH { - my $eas = shift; - my $index = _find($eas->[0], shift); - return undef if $index <= 0; - return value($eas->[0], $index); -} - -sub EXISTS { - my $eas = shift; - return _find($eas->[0], shift) > 0; -} - -sub STORE { - my $eas = shift; - $eas->[5] = 1; - add($eas->[0], shift, shift) > 0 or die "Error setting EA: $!"; -} - -sub DELETE { - my $eas = shift; - my $index = _find($eas->[0], shift); - return undef if $index <= 0; - my $value = value($eas->[0], $index); - _delete($eas->[0], $index) and die "Error deleting EA: $!"; - $eas->[5] = 1; - return $value; -} - -sub CLEAR { - my $eas = shift; - _clear($eas->[0]); - $eas->[5] = 1; -} - -# Here are additional methods: - -*new = \&TIEHASH; - -sub copy { - my $eas = shift; - my $file = shift; - my ($name, $handle); - if (ref $file eq 'GLOB' or ref \$file eq 'GLOB') { - die "File handle is not opened" unless $handle = fileno $file; - _write($eas->[0], undef, $handle, 0) or die "Cannot write EA: $!"; - } else { - $name = $file; - _write($eas->[0], $name, 0, 0) or die "Cannot write EA: $!"; - } -} - -sub update { - my $eas = shift; - # 0 means: discard eas which are not in $eas->[0]. - _write( $eas->[0], $eas->[1], $eas->[2], 0) and die "Cannot write EA: $!"; -} - -# Autoload methods go after =cut, and are processed by the autosplit program. - -1; -__END__ -# Below is the stub of documentation for your module. You better edit it! - -=head1 NAME - -OS2::ExtAttr - Perl access to extended attributes. - -=head1 SYNOPSIS - - use OS2::ExtAttr; - tie %ea, 'OS2::ExtAttr', 'my.file'; - print $ea{eaname}; - $ea{myfield} = 'value'; - - untie %ea; - -=head1 DESCRIPTION - -The package provides low-level and high-level interface to Extended -Attributes under OS/2. - -=head2 High-level interface: C - -The only argument of tie() is a file name, or an open file handle. - -Note that all the changes of the tied hash happen in core, to -propagate it to disk the tied hash should be untie()ed or should go -out of scope. Alternatively, one may use the low-level C -method on the corresponding object. Example: - - tied(%hash)->update; - -Note also that setting/getting EA flag is not supported by the -high-level interface, one should use the low-level interface -instead. To use it on a tied hash one needs undocumented way to find -C give the tied hash. - -=head2 Low-level interface - -Two low-level methods are supported by the objects: copy() and -update(). The copy() takes one argument: the name of a file to copy -the attributes to, or an opened file handle. update() takes no -arguments, and is discussed above. - -Three convenience functions are provided: - - value($eas, $key) - add($eas, $key, $value [, $flag]) - replace($eas, $key, $value [, $flag]) - -The default value for C is 0. - -In addition, all the C<_ea_*> and C<_ead_*> functions defined in EMX -library are supported, with leading C<_ea/_ead> stripped. - -=head1 AUTHOR - -Ilya Zakharevich, ilya@math.ohio-state.edu - -=head1 SEE ALSO - -perl(1). - -=cut diff --git a/os2/OS2/ExtAttr/ExtAttr.xs b/os2/OS2/ExtAttr/ExtAttr.xs deleted file mode 100644 index 1f4e203cec..0000000000 --- a/os2/OS2/ExtAttr/ExtAttr.xs +++ /dev/null @@ -1,197 +0,0 @@ -#ifdef __cplusplus -extern "C" { -#endif -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" -#ifdef __cplusplus -} -#endif - -#include "myea.h" - -SV * -my_eadvalue(pTHX_ _ead ead, int index) -{ - SV *sv; - int size = _ead_value_size(ead, index); - const char *p; - - if (size == -1) { - Perl_die(aTHX_ "Error getting size of EA: %s", strerror(errno)); - } - p = _ead_get_value(ead, index); - return newSVpv(p, size); -} - -#define my_eadreplace(ead, index, sv, flag) \ - _ead_replace((ead), (index), flag, SvPVX(sv), SvCUR(sv)) - -#define my_eadadd(ead, name, sv, flag) \ - _ead_add((ead), (name), flag, SvPVX(sv), SvCUR(sv)) - - -MODULE = OS2::ExtAttr PACKAGE = OS2::ExtAttr PREFIX = my_ead - -SV * -my_eadvalue(ead, index) - _ead ead - int index - CODE: - RETVAL = my_eadvalue(aTHX_ ead, index); - OUTPUT: - RETVAL - -int -my_eadreplace(ead, index, sv, flag = 0) - _ead ead - int index - SV * sv - int flag - -int -my_eadadd(ead, name, sv, flag = 0) - _ead ead - char * name - SV * sv - int flag - -MODULE = OS2::ExtAttr PACKAGE = OS2::ExtAttr PREFIX = _ea - - -void -_ea_free(ptr) - struct _ea * ptr - -int -_ea_get(dst, path, handle, name) - struct _ea * dst - char * path - int handle - char * name - -int -_ea_put(src, path, handle, name) - struct _ea * src - char * path - int handle - char * name - -int -_ea_remove(path, handle, name) - char * path - int handle - char * name - -MODULE = OS2::ExtAttr PACKAGE = OS2::ExtAttr PREFIX = _ead - -int -_ead_add(ead, name, flags, value, size) - _ead ead - char * name - int flags - void * value - int size - -void -_ead_clear(ead) - _ead ead - -int -_ead_copy(dst_ead, src_ead, src_index) - _ead dst_ead - _ead src_ead - int src_index - -int -_ead_count(ead) - _ead ead - -_ead -_ead_create() - -int -_ead_delete(ead, index) - _ead ead - int index - -void -_ead_destroy(ead) - _ead ead - -int -_ead_fea2list_size(ead) - _ead ead - -void * -_ead_fea2list_to_fealist(src) - void * src - -void * -_ead_fealist_to_fea2list(src) - void * src - -int -_ead_find(ead, name) - _ead ead - char * name - -const void * -_ead_get_fea2list(ead) - _ead ead - -int -_ead_get_flags(ead, index) - _ead ead - int index - -const char * -_ead_get_name(ead, index) - _ead ead - int index - -const void * -_ead_get_value(ead, index) - _ead ead - int index - -int -_ead_name_len(ead, index) - _ead ead - int index - -int -_ead_read(ead, path, handle, flags) - _ead ead - char * path - int handle - int flags - -int -_ead_replace(ead, index, flags, value, size) - _ead ead - int index - int flags - void * value - int size - -void -_ead_sort(ead) - _ead ead - -int -_ead_use_fea2list(ead, src) - _ead ead - void * src - -int -_ead_value_size(ead, index) - _ead ead - int index - -int -_ead_write(ead, path, handle, flags) - _ead ead - char * path - int handle - int flags diff --git a/os2/OS2/ExtAttr/MANIFEST b/os2/OS2/ExtAttr/MANIFEST deleted file mode 100644 index b1a8e80e77..0000000000 --- a/os2/OS2/ExtAttr/MANIFEST +++ /dev/null @@ -1,8 +0,0 @@ -Changes -ExtAttr.pm -ExtAttr.xs -MANIFEST -Makefile.PL -myea.h -t/os2_ea.t -typemap diff --git a/os2/OS2/ExtAttr/Makefile.PL b/os2/OS2/ExtAttr/Makefile.PL deleted file mode 100644 index 0b8837f153..0000000000 --- a/os2/OS2/ExtAttr/Makefile.PL +++ /dev/null @@ -1,11 +0,0 @@ -use ExtUtils::MakeMaker; -# See lib/ExtUtils/MakeMaker.pm for details of how to influence -# the contents of the Makefile that is written. -WriteMakefile( - 'NAME' => 'OS2::ExtAttr', - 'VERSION_FROM' => 'ExtAttr.pm', # finds $VERSION - MAN3PODS => {}, # Pods will be built by installman. - 'LIBS' => [''], # e.g., '-lm' - 'DEFINE' => '', # e.g., '-DHAVE_SOMETHING' - 'INC' => '', # e.g., '-I/usr/include/other' -); diff --git a/os2/OS2/ExtAttr/myea.h b/os2/OS2/ExtAttr/myea.h deleted file mode 100644 index ec4dc81f99..0000000000 --- a/os2/OS2/ExtAttr/myea.h +++ /dev/null @@ -1,2 +0,0 @@ -#include -#include diff --git a/os2/OS2/ExtAttr/t/os2_ea.t b/os2/OS2/ExtAttr/t/os2_ea.t deleted file mode 100644 index 947e2f1916..0000000000 --- a/os2/OS2/ExtAttr/t/os2_ea.t +++ /dev/null @@ -1,85 +0,0 @@ -BEGIN { - chdir 't' if -d 't/lib'; - @INC = '../lib' if -d 'lib'; - require Config; import Config; - if (-d 'lib' and $Config{'extensions'} !~ /\bOS2(::|\/)REXX\b/) { - print "1..0\n"; - exit 0; - } -} - -# Before `make install' is performed this script should be runnable with -# `make test'. After `make install' it should work as `perl test.pl' - -######################### We start with some black magic to print on failure. - -# Change 1..1 below to 1..last_test_to_print . -# (It may become useful if the test is moved to ./t subdirectory.) - -BEGIN { $| = 1; print "1..21\n"; } -END {print "not ok 1\n" unless $loaded;} -use OS2::ExtAttr; -$loaded = 1; -print "ok 1\n"; - -######################### End of black magic. - -# Insert your test code below (better if it prints "ok 13" -# (correspondingly "not ok 13") depending on the success of chunk 13 -# of the test code): - -unlink 't.out' if -f 't.out'; -system 'cmd', '/c', 'echo OK > t.out'; - -{ - my %a; - tie %a, 'OS2::ExtAttr', 't.out'; - print "ok 2\n"; - - keys %a == 0 ? print "ok 3\n" : print "not ok 3\n"; -# Standard Extended Attributes (SEAs) have a dot (.) as a prefix. -# This identifies the extended attribute as a SEA. The leading dot is reserved, -# so applications should not define extended attributes that start with a dot. -# Also, extended attributes -# that start with the characters $, @, &, or + are reserved for system use. - $a{'X--Y'} = '---'; # '++', -++', '!++', 'X++Y' fail on JFS - print "ok 4\n"; - $a{'AAA'} = 'xyz'; # Name is going to be uppercased??? - print "ok 5\n"; -} - -{ - my %a; - tie %a, 'OS2::ExtAttr', 't.out'; - print "ok 6\n"; - - my $c = keys %a; - $c == 2 ? print "ok 7\n" : print "not ok 7\n# c=$c\n"; - my @b = sort keys %a; - "@b" eq 'AAA X--Y' ? print "ok 8\n" : print "not ok 8\n# keys=`@b'\n"; - $a{'X--Y'} eq '---' ? print "ok 9\n" : print "not ok 9\n";; - $a{'AAA'} eq 'xyz' ? print "ok 10\n" : print "not ok 10\n# aaa->`$a{AAA}'\n"; - $c = delete $a{'X--Y'}; - $c eq '---' ? print "ok 11\n" : print "not ok 11\n# deleted->`$c'\n";; -} - -print "ok 12\n"; - -{ - my %a; - tie %a, 'OS2::ExtAttr', 't.out'; - print "ok 13\n"; - - keys %a == 1 ? print "ok 14\n" : print "not ok 14\n"; - my @b = sort keys %a; - "@b" eq 'AAA' ? print "ok 15\n" : print "not ok 15\n"; - $a{'AAA'} eq 'xyz' ? print "ok 16\n" : print "not ok 16\n";; - ! exists $a{'+'} ? print "ok 17\n" : print "not ok 17\n";; - ! defined $a{'+'} ? print "ok 18\n" : print "not ok 18\n# ->`$a{'X--Y'}'\n";; - ! exists $a{'X--Y'} ? print "ok 19\n" : print "not ok 19\n";; - ! defined $a{'X--Y'} ? print "ok 20\n" : print "not ok 20\n# ->`$a{'X--Y'}'\n";; -} - -print "ok 21\n"; -unlink 't.out'; - diff --git a/os2/OS2/ExtAttr/typemap b/os2/OS2/ExtAttr/typemap deleted file mode 100644 index c2f5cda2ed..0000000000 --- a/os2/OS2/ExtAttr/typemap +++ /dev/null @@ -1,4 +0,0 @@ -struct _ea * T_PTR -_ead T_PTR -const void * T_PTR -const char * T_PV diff --git a/os2/OS2/OS2-ExtAttr/Changes b/os2/OS2/OS2-ExtAttr/Changes new file mode 100644 index 0000000000..92b51826cc --- /dev/null +++ b/os2/OS2/OS2-ExtAttr/Changes @@ -0,0 +1,7 @@ +Revision history for Perl extension OS2::ExtAttr. + +0.01 Sun Apr 21 11:07:04 1996 + - original version; created by h2xs 1.16 + +0.02 Update to XSLoader and 'our'. + Remove Exporter. diff --git a/os2/OS2/OS2-ExtAttr/ExtAttr.pm b/os2/OS2/OS2-ExtAttr/ExtAttr.pm new file mode 100644 index 0000000000..c49f1d4de5 --- /dev/null +++ b/os2/OS2/OS2-ExtAttr/ExtAttr.pm @@ -0,0 +1,175 @@ +package OS2::ExtAttr; + +use strict; +use XSLoader; + +our $VERSION = '0.02'; +XSLoader::load 'OS2::ExtAttr', $VERSION; + +# Preloaded methods go here. + +# Format of the array: +# 0 ead, 1 file name, 2 file handle. 3 length, 4 position, 5 need to write. + +sub TIEHASH { + my $class = shift; + my $ea = _create() || die "Cannot create EA: $!"; + my $file = shift; + my ($name, $handle); + if (ref $file eq 'GLOB' or ref \$file eq 'GLOB') { + die "File handle is not opened" unless $handle = fileno $file; + _read($ea, undef, $handle, 0); + } else { + $name = $file; + _read($ea, $name, 0, 0); + } + bless [$ea, $name, $handle, 0, 0, 0], $class; +} + +sub DESTROY { + my $eas = shift; + # 0 means: discard eas which are not in $eas->[0]. + _write( $eas->[0], $eas->[1], $eas->[2], 0) and die "Cannot write EA: $!" + if $eas->[5]; + _destroy( $eas->[0] ); +} + +sub FIRSTKEY { + my $eas = shift; + $eas->[3] = _count($eas->[0]); + $eas->[4] = 1; + return undef if $eas->[4] > $eas->[3]; + return _get_name($eas->[0], $eas->[4]); +} + +sub NEXTKEY { + my $eas = shift; + $eas->[4]++; + return undef if $eas->[4] > $eas->[3]; + return _get_name($eas->[0], $eas->[4]); +} + +sub FETCH { + my $eas = shift; + my $index = _find($eas->[0], shift); + return undef if $index <= 0; + return value($eas->[0], $index); +} + +sub EXISTS { + my $eas = shift; + return _find($eas->[0], shift) > 0; +} + +sub STORE { + my $eas = shift; + $eas->[5] = 1; + add($eas->[0], shift, shift) > 0 or die "Error setting EA: $!"; +} + +sub DELETE { + my $eas = shift; + my $index = _find($eas->[0], shift); + return undef if $index <= 0; + my $value = value($eas->[0], $index); + _delete($eas->[0], $index) and die "Error deleting EA: $!"; + $eas->[5] = 1; + return $value; +} + +sub CLEAR { + my $eas = shift; + _clear($eas->[0]); + $eas->[5] = 1; +} + +# Here are additional methods: + +*new = \&TIEHASH; + +sub copy { + my $eas = shift; + my $file = shift; + my ($name, $handle); + if (ref $file eq 'GLOB' or ref \$file eq 'GLOB') { + die "File handle is not opened" unless $handle = fileno $file; + _write($eas->[0], undef, $handle, 0) or die "Cannot write EA: $!"; + } else { + $name = $file; + _write($eas->[0], $name, 0, 0) or die "Cannot write EA: $!"; + } +} + +sub update { + my $eas = shift; + # 0 means: discard eas which are not in $eas->[0]. + _write( $eas->[0], $eas->[1], $eas->[2], 0) and die "Cannot write EA: $!"; +} + +# Autoload methods go after =cut, and are processed by the autosplit program. + +1; +__END__ +# Below is the stub of documentation for your module. You better edit it! + +=head1 NAME + +OS2::ExtAttr - Perl access to extended attributes. + +=head1 SYNOPSIS + + use OS2::ExtAttr; + tie %ea, 'OS2::ExtAttr', 'my.file'; + print $ea{eaname}; + $ea{myfield} = 'value'; + + untie %ea; + +=head1 DESCRIPTION + +The package provides low-level and high-level interface to Extended +Attributes under OS/2. + +=head2 High-level interface: C + +The only argument of tie() is a file name, or an open file handle. + +Note that all the changes of the tied hash happen in core, to +propagate it to disk the tied hash should be untie()ed or should go +out of scope. Alternatively, one may use the low-level C +method on the corresponding object. Example: + + tied(%hash)->update; + +Note also that setting/getting EA flag is not supported by the +high-level interface, one should use the low-level interface +instead. To use it on a tied hash one needs undocumented way to find +C give the tied hash. + +=head2 Low-level interface + +Two low-level methods are supported by the objects: copy() and +update(). The copy() takes one argument: the name of a file to copy +the attributes to, or an opened file handle. update() takes no +arguments, and is discussed above. + +Three convenience functions are provided: + + value($eas, $key) + add($eas, $key, $value [, $flag]) + replace($eas, $key, $value [, $flag]) + +The default value for C is 0. + +In addition, all the C<_ea_*> and C<_ead_*> functions defined in EMX +library are supported, with leading C<_ea/_ead> stripped. + +=head1 AUTHOR + +Ilya Zakharevich, ilya@math.ohio-state.edu + +=head1 SEE ALSO + +perl(1). + +=cut diff --git a/os2/OS2/OS2-ExtAttr/ExtAttr.xs b/os2/OS2/OS2-ExtAttr/ExtAttr.xs new file mode 100644 index 0000000000..1f4e203cec --- /dev/null +++ b/os2/OS2/OS2-ExtAttr/ExtAttr.xs @@ -0,0 +1,197 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" +#ifdef __cplusplus +} +#endif + +#include "myea.h" + +SV * +my_eadvalue(pTHX_ _ead ead, int index) +{ + SV *sv; + int size = _ead_value_size(ead, index); + const char *p; + + if (size == -1) { + Perl_die(aTHX_ "Error getting size of EA: %s", strerror(errno)); + } + p = _ead_get_value(ead, index); + return newSVpv(p, size); +} + +#define my_eadreplace(ead, index, sv, flag) \ + _ead_replace((ead), (index), flag, SvPVX(sv), SvCUR(sv)) + +#define my_eadadd(ead, name, sv, flag) \ + _ead_add((ead), (name), flag, SvPVX(sv), SvCUR(sv)) + + +MODULE = OS2::ExtAttr PACKAGE = OS2::ExtAttr PREFIX = my_ead + +SV * +my_eadvalue(ead, index) + _ead ead + int index + CODE: + RETVAL = my_eadvalue(aTHX_ ead, index); + OUTPUT: + RETVAL + +int +my_eadreplace(ead, index, sv, flag = 0) + _ead ead + int index + SV * sv + int flag + +int +my_eadadd(ead, name, sv, flag = 0) + _ead ead + char * name + SV * sv + int flag + +MODULE = OS2::ExtAttr PACKAGE = OS2::ExtAttr PREFIX = _ea + + +void +_ea_free(ptr) + struct _ea * ptr + +int +_ea_get(dst, path, handle, name) + struct _ea * dst + char * path + int handle + char * name + +int +_ea_put(src, path, handle, name) + struct _ea * src + char * path + int handle + char * name + +int +_ea_remove(path, handle, name) + char * path + int handle + char * name + +MODULE = OS2::ExtAttr PACKAGE = OS2::ExtAttr PREFIX = _ead + +int +_ead_add(ead, name, flags, value, size) + _ead ead + char * name + int flags + void * value + int size + +void +_ead_clear(ead) + _ead ead + +int +_ead_copy(dst_ead, src_ead, src_index) + _ead dst_ead + _ead src_ead + int src_index + +int +_ead_count(ead) + _ead ead + +_ead +_ead_create() + +int +_ead_delete(ead, index) + _ead ead + int index + +void +_ead_destroy(ead) + _ead ead + +int +_ead_fea2list_size(ead) + _ead ead + +void * +_ead_fea2list_to_fealist(src) + void * src + +void * +_ead_fealist_to_fea2list(src) + void * src + +int +_ead_find(ead, name) + _ead ead + char * name + +const void * +_ead_get_fea2list(ead) + _ead ead + +int +_ead_get_flags(ead, index) + _ead ead + int index + +const char * +_ead_get_name(ead, index) + _ead ead + int index + +const void * +_ead_get_value(ead, index) + _ead ead + int index + +int +_ead_name_len(ead, index) + _ead ead + int index + +int +_ead_read(ead, path, handle, flags) + _ead ead + char * path + int handle + int flags + +int +_ead_replace(ead, index, flags, value, size) + _ead ead + int index + int flags + void * value + int size + +void +_ead_sort(ead) + _ead ead + +int +_ead_use_fea2list(ead, src) + _ead ead + void * src + +int +_ead_value_size(ead, index) + _ead ead + int index + +int +_ead_write(ead, path, handle, flags) + _ead ead + char * path + int handle + int flags diff --git a/os2/OS2/OS2-ExtAttr/MANIFEST b/os2/OS2/OS2-ExtAttr/MANIFEST new file mode 100644 index 0000000000..b1a8e80e77 --- /dev/null +++ b/os2/OS2/OS2-ExtAttr/MANIFEST @@ -0,0 +1,8 @@ +Changes +ExtAttr.pm +ExtAttr.xs +MANIFEST +Makefile.PL +myea.h +t/os2_ea.t +typemap diff --git a/os2/OS2/OS2-ExtAttr/Makefile.PL b/os2/OS2/OS2-ExtAttr/Makefile.PL new file mode 100644 index 0000000000..0b8837f153 --- /dev/null +++ b/os2/OS2/OS2-ExtAttr/Makefile.PL @@ -0,0 +1,11 @@ +use ExtUtils::MakeMaker; +# See lib/ExtUtils/MakeMaker.pm for details of how to influence +# the contents of the Makefile that is written. +WriteMakefile( + 'NAME' => 'OS2::ExtAttr', + 'VERSION_FROM' => 'ExtAttr.pm', # finds $VERSION + MAN3PODS => {}, # Pods will be built by installman. + 'LIBS' => [''], # e.g., '-lm' + 'DEFINE' => '', # e.g., '-DHAVE_SOMETHING' + 'INC' => '', # e.g., '-I/usr/include/other' +); diff --git a/os2/OS2/OS2-ExtAttr/myea.h b/os2/OS2/OS2-ExtAttr/myea.h new file mode 100644 index 0000000000..ec4dc81f99 --- /dev/null +++ b/os2/OS2/OS2-ExtAttr/myea.h @@ -0,0 +1,2 @@ +#include +#include diff --git a/os2/OS2/OS2-ExtAttr/t/os2_ea.t b/os2/OS2/OS2-ExtAttr/t/os2_ea.t new file mode 100644 index 0000000000..947e2f1916 --- /dev/null +++ b/os2/OS2/OS2-ExtAttr/t/os2_ea.t @@ -0,0 +1,85 @@ +BEGIN { + chdir 't' if -d 't/lib'; + @INC = '../lib' if -d 'lib'; + require Config; import Config; + if (-d 'lib' and $Config{'extensions'} !~ /\bOS2(::|\/)REXX\b/) { + print "1..0\n"; + exit 0; + } +} + +# Before `make install' is performed this script should be runnable with +# `make test'. After `make install' it should work as `perl test.pl' + +######################### We start with some black magic to print on failure. + +# Change 1..1 below to 1..last_test_to_print . +# (It may become useful if the test is moved to ./t subdirectory.) + +BEGIN { $| = 1; print "1..21\n"; } +END {print "not ok 1\n" unless $loaded;} +use OS2::ExtAttr; +$loaded = 1; +print "ok 1\n"; + +######################### End of black magic. + +# Insert your test code below (better if it prints "ok 13" +# (correspondingly "not ok 13") depending on the success of chunk 13 +# of the test code): + +unlink 't.out' if -f 't.out'; +system 'cmd', '/c', 'echo OK > t.out'; + +{ + my %a; + tie %a, 'OS2::ExtAttr', 't.out'; + print "ok 2\n"; + + keys %a == 0 ? print "ok 3\n" : print "not ok 3\n"; +# Standard Extended Attributes (SEAs) have a dot (.) as a prefix. +# This identifies the extended attribute as a SEA. The leading dot is reserved, +# so applications should not define extended attributes that start with a dot. +# Also, extended attributes +# that start with the characters $, @, &, or + are reserved for system use. + $a{'X--Y'} = '---'; # '++', -++', '!++', 'X++Y' fail on JFS + print "ok 4\n"; + $a{'AAA'} = 'xyz'; # Name is going to be uppercased??? + print "ok 5\n"; +} + +{ + my %a; + tie %a, 'OS2::ExtAttr', 't.out'; + print "ok 6\n"; + + my $c = keys %a; + $c == 2 ? print "ok 7\n" : print "not ok 7\n# c=$c\n"; + my @b = sort keys %a; + "@b" eq 'AAA X--Y' ? print "ok 8\n" : print "not ok 8\n# keys=`@b'\n"; + $a{'X--Y'} eq '---' ? print "ok 9\n" : print "not ok 9\n";; + $a{'AAA'} eq 'xyz' ? print "ok 10\n" : print "not ok 10\n# aaa->`$a{AAA}'\n"; + $c = delete $a{'X--Y'}; + $c eq '---' ? print "ok 11\n" : print "not ok 11\n# deleted->`$c'\n";; +} + +print "ok 12\n"; + +{ + my %a; + tie %a, 'OS2::ExtAttr', 't.out'; + print "ok 13\n"; + + keys %a == 1 ? print "ok 14\n" : print "not ok 14\n"; + my @b = sort keys %a; + "@b" eq 'AAA' ? print "ok 15\n" : print "not ok 15\n"; + $a{'AAA'} eq 'xyz' ? print "ok 16\n" : print "not ok 16\n";; + ! exists $a{'+'} ? print "ok 17\n" : print "not ok 17\n";; + ! defined $a{'+'} ? print "ok 18\n" : print "not ok 18\n# ->`$a{'X--Y'}'\n";; + ! exists $a{'X--Y'} ? print "ok 19\n" : print "not ok 19\n";; + ! defined $a{'X--Y'} ? print "ok 20\n" : print "not ok 20\n# ->`$a{'X--Y'}'\n";; +} + +print "ok 21\n"; +unlink 't.out'; + diff --git a/os2/OS2/OS2-ExtAttr/typemap b/os2/OS2/OS2-ExtAttr/typemap new file mode 100644 index 0000000000..c2f5cda2ed --- /dev/null +++ b/os2/OS2/OS2-ExtAttr/typemap @@ -0,0 +1,4 @@ +struct _ea * T_PTR +_ead T_PTR +const void * T_PTR +const char * T_PV diff --git a/os2/OS2/OS2-PrfDB/Changes b/os2/OS2/OS2-PrfDB/Changes new file mode 100644 index 0000000000..49ac8c1a43 --- /dev/null +++ b/os2/OS2/OS2-PrfDB/Changes @@ -0,0 +1,6 @@ +Revision history for Perl extension OS2::PrfDB. + +0.01 Tue Mar 26 19:35:27 1996 + - original version; created by h2xs 1.16 +0.02: Field do-not-close added to OS2::Prf::Hini. +0.03: Update to XSLoader and 'our'. diff --git a/os2/OS2/OS2-PrfDB/MANIFEST b/os2/OS2/OS2-PrfDB/MANIFEST new file mode 100644 index 0000000000..fb96b03c5d --- /dev/null +++ b/os2/OS2/OS2-PrfDB/MANIFEST @@ -0,0 +1,7 @@ +Changes +MANIFEST +Makefile.PL +PrfDB.pm +PrfDB.xs +t/os2_prfdb.t +typemap diff --git a/os2/OS2/OS2-PrfDB/Makefile.PL b/os2/OS2/OS2-PrfDB/Makefile.PL new file mode 100644 index 0000000000..2d4a6a7ae5 --- /dev/null +++ b/os2/OS2/OS2-PrfDB/Makefile.PL @@ -0,0 +1,11 @@ +use ExtUtils::MakeMaker; +# See lib/ExtUtils/MakeMaker.pm for details of how to influence +# the contents of the Makefile that is written. +WriteMakefile( + 'NAME' => 'OS2::PrfDB', + 'VERSION_FROM' => 'PrfDB.pm', # finds $VERSION + MAN3PODS => {}, # Pods will be built by installman. + 'LIBS' => [''], # e.g., '-lm' + 'DEFINE' => '', # e.g., '-DHAVE_SOMETHING' + 'INC' => '', # e.g., '-I/usr/include/other' +); diff --git a/os2/OS2/OS2-PrfDB/PrfDB.pm b/os2/OS2/OS2-PrfDB/PrfDB.pm new file mode 100644 index 0000000000..a1bdc33a1c --- /dev/null +++ b/os2/OS2/OS2-PrfDB/PrfDB.pm @@ -0,0 +1,312 @@ +package OS2::PrfDB; + +use strict; + +require Exporter; +use XSLoader; +use Tie::Hash; + +our $debug; +our @ISA = qw(Exporter Tie::Hash); +# Items to export into callers namespace by default. Note: do not export +# names by default without a very good reason. Use EXPORT_OK instead. +# Do not simply export all your public functions/methods/constants. +our @EXPORT = qw( + AnyIni UserIni SystemIni + ); +our $VERSION = '0.04'; + +XSLoader::load 'OS2::PrfDB', $VERSION; + +# Preloaded methods go here. + +sub AnyIni { + new_from_int OS2::PrfDB::Hini OS2::Prf::System(0), + 'Anyone of two "systemish" databases', 1; +} + +sub UserIni { + new_from_int OS2::PrfDB::Hini OS2::Prf::System(1), 'User settings database', 1; +} + +sub SystemIni { + new_from_int OS2::PrfDB::Hini OS2::Prf::System(2),'System settings database',1; +} + +# Internal structure 0 => HINI, 1 => array of entries, 2 => iterator. + +sub TIEHASH { + die "Usage: tie %arr, OS2::PrfDB, filename\n" unless @_ == 2; + my ($obj, $file) = @_; + my $hini = ref $file eq 'OS2::PrfDB::Hini' ? $file + : new OS2::PrfDB::Hini $file; + die "Error opening profile database `$file': $!" unless $hini; + # print "tiehash `@_', hini $hini\n" if $debug; + bless [$hini, undef, undef]; +} + +sub STORE { + my ($self, $key, $val) = @_; + die unless @_ == 3; + die unless ref $val eq 'HASH'; + my %sub; + tie %sub, 'OS2::PrfDB::Sub', $self->[0], $key; + %sub = %$val; +} + +sub FETCH { + my ($self, $key) = @_; + die unless @_ == 2; + my %sub; + tie %sub, 'OS2::PrfDB::Sub', $self->[0], $key; + \%sub; +} + +sub DELETE { + my ($self, $key) = @_; + die unless @_ == 2; + my %sub; + tie %sub, 'OS2::PrfDB::Sub', $self->[0], $key; + %sub = (); +} + +# CLEAR ???? - deletion of the whole + +sub EXISTS { + my ($self, $key) = @_; + die unless @_ == 2; + return OS2::Prf::GetLength($self->[0]->[0], $key, undef) >= 0; +} + +sub FIRSTKEY { + my $self = shift; + my $keys = OS2::Prf::Get($self->[0]->[0], undef, undef); + return undef unless defined $keys; + chop($keys); + $self->[1] = [split /\0/, $keys]; + # print "firstkey1 $self, `$self->[3]->[0], $self->[3]->[1]'\n" if $debug; + $self->[2] = 0; + return $self->[1]->[0]; + # OS2::Prf::Get($self->[0]->[0], $self->[2], $self->[3]->[0])); +} + +sub NEXTKEY { + # print "nextkey `@_'\n" if $debug; + my $self = shift; + return undef unless $self->[2]++ < $#{$self->[1]}; + my $key = $self->[1]->[$self->[2]]; + return $key; #, OS2::Prf::Get($self->[0]->[0], $self->[2], $key)); +} + +package OS2::PrfDB::Hini; + +sub new { + die "Usage: new OS2::PrfDB::Hini filename\n" unless @_ == 2; + shift; + my $file = shift; + my $hini = OS2::Prf::Open($file); + die "Error opening profile database `$file': $!" unless $hini; + bless [$hini, $file]; +} + +# Takes HINI and file name: + +sub new_from_int { shift; bless [@_] } + +# Internal structure 0 => HINI, 1 => filename, 2 => do-not-close. + +sub DESTROY { + my $self = shift; + my $hini = $self->[0]; + unless ($self->[2]) { + OS2::Prf::Close($hini) or die "Error closing profile `$self->[1]': $!"; + } +} + +package OS2::PrfDB::Sub; +use Tie::Hash; + +our $debug; +our @ISA = qw{Tie::Hash}; + +# Internal structure 0 => HINI, 1 => array of entries, 2 => iterator, +# 3 => appname. + +sub TIEHASH { + die "Usage: tie %arr, OS2::PrfDB::Sub, filename, appname\n" unless @_ == 3; + my ($obj, $file, $app) = @_; + my $hini = ref $file eq 'OS2::PrfDB::Hini' ? $file + : new OS2::PrfDB::Hini $file; + die "Error opening profile database `$file': $!" unless $hini; + # print "tiehash `@_', hini $hini\n" if $debug; + bless [$hini, undef, undef, $app]; +} + +sub STORE { + my ($self, $key, $val) = @_; + die unless @_ == 3; + OS2::Prf::Set($self->[0]->[0], $self->[3], $key, $val); +} + +sub FETCH { + my ($self, $key) = @_; + die unless @_ == 2; + OS2::Prf::Get($self->[0]->[0], $self->[3], $key); +} + +sub DELETE { + my ($self, $key) = @_; + die unless @_ == 2; + OS2::Prf::Set($self->[0]->[0], $self->[3], $key, undef); +} + +# CLEAR ???? - deletion of the whole + +sub EXISTS { + my ($self, $key) = @_; + die unless @_ == 2; + return OS2::Prf::GetLength($self->[0]->[0], $self->[3], $key) >= 0; +} + +sub FIRSTKEY { + my $self = shift; + my $keys = OS2::Prf::Get($self->[0]->[0], $self->[3], undef); + return undef unless defined $keys; + chop($keys); + $self->[1] = [split /\0/, $keys]; + # print "firstkey1 $self, `$self->[3]->[0], $self->[3]->[1]'\n" if $debug; + $self->[2] = 0; + return $self->[1]->[0]; + # OS2::Prf::Get($self->[0]->[0], $self->[2], $self->[3]->[0])); +} + +sub NEXTKEY { + # print "nextkey `@_'\n" if $debug; + my $self = shift; + return undef unless $self->[2]++ < $#{$self->[1]}; + my $key = $self->[1]->[$self->[2]]; + return $key; #, OS2::Prf::Get($self->[0]->[0], $self->[2], $key)); +} + +# Autoload methods go after =cut, and are processed by the autosplit program. + +1; +__END__ +# Below is the stub of documentation for your module. You better edit it! + +=head1 NAME + +OS2::PrfDB - Perl extension for access to OS/2 setting database. + +=head1 SYNOPSIS + + use OS2::PrfDB; + tie %settings, OS2::PrfDB, 'my.ini'; + tie %subsettings, OS2::PrfDB::Sub, 'my.ini', 'mykey'; + + print "$settings{firstkey}{subkey}\n"; + print "$subsettings{subkey}\n"; + + tie %system, OS2::PrfDB, SystemIni; + $system{myapp}{mykey} = "myvalue"; + + +=head1 DESCRIPTION + +The extension provides both high-level and low-level access to .ini +files. + +=head2 High level access + +High-level access is the tie-hash access via two packages: +C and C. First one supports one argument, +the name of the file to open, the second one the name of the file to +open and so called I, or the primary key of the +database. + + tie %settings, OS2::PrfDB, 'my.ini'; + tie %subsettings, OS2::PrfDB::Sub, 'my.ini', 'mykey'; + +One may substitute a handle for already opened ini-file instead of the +file name (obtained via low-level access functions). In particular, 3 +functions SystemIni(), UserIni(), and AnyIni() provide handles to the +"systemish" databases. AniIni will read from both, and write into User +database. + +=head2 Low-level access + +Low-level access functions reside in the package C. They are + +=over 14 + +=item C + +Opens the database, returns an I. + +=item C + +Closes the database given an I. + +=item C + +Retrieves data from the database given 2-part-key C C. +If C is C, return the "\0" delimited list of Cs, +terminated by \0. If C is C, returns the list of +possible Cs in the same form. + +=item C + +Same as above, but returns the length of the value. + +=item C + +Sets the value. If the C is not defined, removes the C. If +the C is not defined, removes the C. + +=item C + +Return an I associated with the system database. If +C is 1, it is I database, if 2, I database, if +0, handle for "both" of them: the handle works for read from any one, +and for write into I one. + +=item C + +returns a reference to a list of two strings, giving names of the +I and I databases. + +=item C + +B<(Not tested.)> Sets the profile name of the I database. The +application should have a message queue to use this function! + +=back + +=head2 Integer handles + +To convert a name or an integer handle into an object acceptable as +argument to tie() interface, one may use the following functions from +the package C: + +=over 14 + +=item C + +=item C + +=back + +=head2 Exports + +SystemIni(), UserIni(), and AnyIni(). + +=head1 AUTHOR + +Ilya Zakharevich, ilya@math.ohio-state.edu + +=head1 SEE ALSO + +perl(1). + +=cut + diff --git a/os2/OS2/OS2-PrfDB/PrfDB.xs b/os2/OS2/OS2-PrfDB/PrfDB.xs new file mode 100644 index 0000000000..bc4661a5d6 --- /dev/null +++ b/os2/OS2/OS2-PrfDB/PrfDB.xs @@ -0,0 +1,173 @@ +#define INCL_WINSHELLDATA /* Or use INCL_WIN, INCL_PM, */ + +#ifdef __cplusplus +extern "C" { +#endif +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" +#include +#ifdef __cplusplus +} +#endif + +#define Prf_Open(pszFileName) SaveWinError(pPrfOpenProfile(Perl_hab, (pszFileName))) +#define Prf_Close(hini) (!CheckWinError(pPrfCloseProfile(hini))) + +BOOL (*pPrfCloseProfile) (HINI hini); +HINI (*pPrfOpenProfile) (HAB hab, PCSZ pszFileName); +BOOL (*pPrfQueryProfile) (HAB hab, PPRFPROFILE pPrfProfile); +BOOL (*pPrfQueryProfileData) (HINI hini, PCSZ pszApp, PCSZ pszKey, PVOID pBuffer, + PULONG pulBufferLength); +/* +LONG (*pPrfQueryProfileInt) (HINI hini, PCSZ pszApp, PCSZ pszKey, LONG sDefault); + */ +BOOL (*pPrfQueryProfileSize) (HINI hini, PCSZ pszApp, PCSZ pszKey, + PULONG pulReqLen); +/* +ULONG (*pPrfQueryProfileString) (HINI hini, PCSZ pszApp, PCSZ pszKey, + PCSZ pszDefault, PVOID pBuffer, ULONG ulBufferLength); + */ +BOOL (*pPrfReset) (HAB hab, __const__ PRFPROFILE *pPrfProfile); +BOOL (*pPrfWriteProfileData) (HINI hini, PCSZ pszApp, PCSZ pszKey, + CPVOID pData, ULONG ulDataLength); +/* +BOOL (*pPrfWriteProfileString) (HINI hini, PCSZ pszApp, PCSZ pszKey, + PCSZ pszData); + */ + +SV * +Prf_Get(pTHX_ HINI hini, PSZ app, PSZ key) { + ULONG len; + BOOL rc; + SV *sv; + + if (CheckWinError(pPrfQueryProfileSize(hini, app, key, &len))) return &PL_sv_undef; + sv = newSVpv("", 0); + SvGROW(sv, len + 1); + if (CheckWinError(pPrfQueryProfileData(hini, app, key, SvPVX(sv), &len)) + || (len == 0 && (app == NULL || key == NULL))) { /* Somewhy needed. */ + SvREFCNT_dec(sv); + return &PL_sv_undef; + } + SvCUR_set(sv, len); + *SvEND(sv) = 0; + return sv; +} + +I32 +Prf_GetLength(HINI hini, PSZ app, PSZ key) { + U32 len; + + if (CheckWinError(pPrfQueryProfileSize(hini, app, key, &len))) return -1; + return len; +} + +#define Prf_Set(hini, app, key, s, l) \ + (!(CheckWinError(pPrfWriteProfileData(hini, app, key, s, l)))) + +#define Prf_System(key) \ + ( (key) ? ( (key) == 1 ? HINI_USERPROFILE \ + : ( (key) == 2 ? HINI_SYSTEMPROFILE \ + : (die("Wrong profile id %i", key), 0) )) \ + : HINI_PROFILE) + +SV* +Prf_Profiles(pTHX) +{ + AV *av = newAV(); + SV *rv; + char user[257]; + char system[257]; + PRFPROFILE info = { 257, user, 257, system}; + + if (CheckWinError(pPrfQueryProfile(Perl_hab, &info))) return &PL_sv_undef; + if (info.cchUserName > 257 || info.cchSysName > 257) + die("Panic: Profile names too long"); + av_push(av, newSVpv(user, info.cchUserName - 1)); + av_push(av, newSVpv(system, info.cchSysName - 1)); + rv = newRV((SV*)av); + SvREFCNT_dec(av); + return rv; +} + +BOOL +Prf_SetUser(pTHX_ SV *sv) +{ + char user[257]; + char system[257]; + PRFPROFILE info = { 257, user, 257, system}; + + if (!SvPOK(sv)) die("User profile name not defined"); + if (SvCUR(sv) > 256) die("User profile name too long"); + if (CheckWinError(pPrfQueryProfile(Perl_hab, &info))) return 0; + if (info.cchSysName > 257) + die("Panic: System profile name too long"); + info.cchUserName = SvCUR(sv) + 1; + info.pszUserName = SvPVX(sv); + return !CheckWinError(pPrfReset(Perl_hab, &info)); +} + +MODULE = OS2::PrfDB PACKAGE = OS2::Prf PREFIX = Prf_ + +HINI +Prf_Open(pszFileName) + PSZ pszFileName; + +BOOL +Prf_Close(hini) + HINI hini; + +SV * +Prf_Get(hini, app, key) + HINI hini; + PSZ app; + PSZ key; +CODE: + RETVAL = Prf_Get(aTHX_ hini, app, key); +OUTPUT: + RETVAL + +int +Prf_Set(hini, app, key, s, l = (SvPOK(ST(3)) ? SvCUR(ST(3)): -1)) + HINI hini; + PSZ app; + PSZ key; + PSZ s; + ULONG l; + +I32 +Prf_GetLength(hini, app, key) + HINI hini; + PSZ app; + PSZ key; + +HINI +Prf_System(key) + int key; + +SV* +Prf_Profiles() +CODE: + RETVAL = Prf_Profiles(aTHX); +OUTPUT: + RETVAL + +BOOL +Prf_SetUser(sv) + SV *sv +CODE: + RETVAL = Prf_SetUser(aTHX_ sv); +OUTPUT: + RETVAL + +BOOT: + Acquire_hab(); + AssignFuncPByORD(pPrfQueryProfileSize, ORD_PRF32QUERYPROFILESIZE); + AssignFuncPByORD(pPrfOpenProfile, ORD_PRF32OPENPROFILE); + AssignFuncPByORD(pPrfCloseProfile, ORD_PRF32CLOSEPROFILE); + AssignFuncPByORD(pPrfQueryProfile, ORD_PRF32QUERYPROFILE); + AssignFuncPByORD(pPrfReset, ORD_PRF32RESET); + AssignFuncPByORD(pPrfQueryProfileData, ORD_PRF32QUERYPROFILEDATA); + AssignFuncPByORD(pPrfWriteProfileData, ORD_PRF32WRITEPROFILEDATA); + diff --git a/os2/OS2/OS2-PrfDB/t/os2_prfdb.t b/os2/OS2/OS2-PrfDB/t/os2_prfdb.t new file mode 100644 index 0000000000..b9f7d90ae2 --- /dev/null +++ b/os2/OS2/OS2-PrfDB/t/os2_prfdb.t @@ -0,0 +1,190 @@ +BEGIN { + chdir 't' if -d 't/lib'; + @INC = '../lib' if -d 'lib'; + require Config; import Config; + if (-d 'lib' and $Config{'extensions'} !~ /\bOS2(::|\/)PrfDB\b/) { + print "1..0\n"; + exit 0; + } +} + +# Before `make install' is performed this script should be runnable with +# `make test'. After `make install' it should work as `perl test.pl' + +######################### We start with some black magic to print on failure. + +# Change 1..1 below to 1..last_test_to_print . +# (It may become useful if the test is moved to ./t subdirectory.) + +BEGIN { $| = 1; print "1..48\n"; } +END {print "not ok 1\n" unless $loaded;} +use OS2::PrfDB; +$loaded = 1; +use strict; + +print "ok 1\n"; + +######################### End of black magic. + +# Insert your test code below (better if it prints "ok 13" +# (correspondingly "not ok 13") depending on the success of chunk 13 +# of the test code): + +my $inifile = "my.ini"; + +unlink $inifile if -w $inifile; + +my $ini = OS2::Prf::Open($inifile); +print( ($ini ? "": "not "), "ok 2\n# HINI=`$ini'\n"); + +print( (OS2::Prf::GetLength($ini,'aaa', 'bbb') != -1) ? + "not ok 3\n# err: `$^E'\n" : "ok 3\n"); + + +print( OS2::Prf::Set($ini,'aaa', 'bbb','xyz') ? "ok 4\n" : + "not ok 4\n# err: `$^E'\n"); + +my $len = OS2::Prf::GetLength($ini,'aaa', 'bbb'); +print( $len == 3 ? "ok 5\n" : "not ok 5# len: `$len' err: `$^E'\n"); + +my $val = OS2::Prf::Get($ini,'aaa', 'bbb'); +print( $val eq 'xyz' ? "ok 6\n" : "not ok 6# val: `$val' err: `$^E'\n"); + +$val = OS2::Prf::Get($ini,'aaa', undef); +print( $val eq "bbb\0" ? "ok 7\n" : "not ok 7# val: `$val' err: `$^E'\n"); + +$val = OS2::Prf::Get($ini, undef, undef); +print( $val eq "aaa\0" ? "ok 8\n" : "not ok 8# val: `$val' err: `$^E'\n"); + +my $res = OS2::Prf::Set($ini,'aaa', 'bbb',undef); +print( $res ? "ok 9\n" : "not ok 9# err: `$^E'\n"); + +$val = OS2::Prf::Get($ini, undef, undef); +print( (! defined $val) ? "ok 10\n" : "not ok 10# val: `$val' err: `$^E'\n"); + +$val = OS2::Prf::Get($ini,'aaa', undef); +print( (! defined $val) ? "ok 11\n" : "not ok 11# val: `$val' err: `$^E'\n"); + +print((OS2::Prf::Close($ini) ? "" : "not ") . "ok 12\n"); + +my $files = OS2::Prf::Profiles(); +print( (defined $files) ? "ok 13\n" : "not ok 13# err: `$^E'\n"); +print( (@$files == 2) ? "ok 14\n" : "not ok 14# `@$files' err: `$^E'\n"); +print "# `@$files'\n"; + +$ini = OS2::Prf::Open($inifile); +print( ($ini ? "": "not "), "ok 15\n# HINI=`$ini'\n"); + + +print( OS2::Prf::Set($ini,'aaa', 'ccc','xyz') ? "ok 16\n" : + "not ok 16\n# err: `$^E'\n"); + +print( OS2::Prf::Set($ini,'aaa', 'ddd','123') ? "ok 17\n" : + "not ok 17\n# err: `$^E'\n"); + +print( OS2::Prf::Set($ini,'bbb', 'xxx','abc') ? "ok 18\n" : + "not ok 18\n# err: `$^E'\n"); + +print( OS2::Prf::Set($ini,'bbb', 'yyy','456') ? "ok 19\n" : + "not ok 19\n# err: `$^E'\n"); + +OS2::Prf::Close($ini); + +my %hash1; + +tie %hash1, 'OS2::PrfDB::Sub', $inifile, 'aaa'; +$OS2::PrfDB::Sub::debug = 1; +print "ok 20\n"; + +my @a1 = keys %hash1; +print (@a1 == 2 ? "ok 21\n" : "not ok 21\n# `@a1'\n"); + +my @a2 = sort @a1; +print ("@a2" eq "ccc ddd" ? "ok 22\n" : "not ok 22\n# `@a2'\n"); + +$val = $hash1{ccc}; +print ($val eq "xyz" ? "ok 23\n" : "not ok 23\n# `$val'\n"); + +$val = $hash1{ddd}; +print ($val eq "123" ? "ok 24\n" : "not ok 24\n# `$val'\n"); + +print (exists $hash1{ccc} ? "ok 25\n" : "not ok 25\n# `$val'\n"); + +print (!exists $hash1{hhh} ? "ok 26\n" : "not ok 26\n# `$val'\n"); + +$hash1{hhh} = 12; +print (exists $hash1{hhh} ? "ok 27\n" : "not ok 27\n# `$val'\n"); + +$val = $hash1{hhh}; +print ($val eq "12" ? "ok 28\n" : "not ok 28\n# `$val'\n"); + +delete $hash1{ccc}; + +untie %hash1; +print "ok 29\n"; + +tie %hash1, 'OS2::PrfDB::Sub', $inifile, 'aaa'; +print "ok 30\n"; + +@a1 = keys %hash1; +print (@a1 == 2 ? "ok 31\n" : "not ok 31\n# `@a1'\n"); + +@a2 = sort @a1; +print ("@a2" eq "ddd hhh" ? "ok 32\n" : "not ok 32\n# `@a2'\n"); + +print (exists $hash1{hhh} ? "ok 33\n" : "not ok 33\n# `$val'\n"); + +$val = $hash1{hhh}; +print ($val eq "12" ? "ok 34\n" : "not ok 34\n# `$val'\n"); + +%hash1 = (); +print "ok 35\n"; + +%hash1 = ( hhh => 12, ddd => 5); + +untie %hash1; + +my %hash; + +tie %hash, 'OS2::PrfDB', $inifile; +print "ok 36\n"; + +@a1 = keys %hash; +print (@a1 == 2 ? "ok 37\n" : "not ok 37\n# `@a1'\n"); + +@a2 = sort @a1; +print ("@a2" eq "aaa bbb" ? "ok 38\n" : "not ok 38\n# `@a2'\n"); + +print (exists $hash{aaa} ? "ok 39\n" : "not ok 39\n# `$val'\n"); + +$val = $hash{aaa}; +print (ref $val eq "HASH" ? "ok 40\n" : "not ok 40\n# `$val'\n"); + +%hash1 = %$val; +print "ok 41\n"; + +@a1 = keys %hash1; +print (@a1 == 2 ? "ok 42\n" : "not ok 31\n# `@a1'\n"); + +@a2 = sort @a1; +print ("@a2" eq "ddd hhh" ? "ok 43\n" : "not ok 43\n# `@a2'\n"); + +print (exists $hash1{hhh} ? "ok 44\n" : "not ok 44\n# `$val'\n"); + +$val = $hash1{hhh}; +print ($val eq "12" ? "ok 45\n" : "not ok 45\n# `$val'\n"); + +$hash{nnn}{mmm} = 67; +print "ok 46\n"; + +untie %hash; + +my %hash2; + +tie %hash2, 'OS2::PrfDB', $inifile; +print "ok 47\n"; + +print ($hash2{nnn}->{mmm} eq "67" ? "ok 48\n" : "not ok 48\n# `$val'\n"); + +untie %hash2; +unlink $inifile; diff --git a/os2/OS2/OS2-Process/MANIFEST b/os2/OS2/OS2-Process/MANIFEST new file mode 100644 index 0000000000..125e55fd50 --- /dev/null +++ b/os2/OS2/OS2-Process/MANIFEST @@ -0,0 +1,7 @@ +MANIFEST +Makefile.PL +Process.pm +Process.xs +t/os2_process.t +t/os2_process_kid.t +t/os2_process_text.t diff --git a/os2/OS2/OS2-Process/Makefile.PL b/os2/OS2/OS2-Process/Makefile.PL new file mode 100644 index 0000000000..c24af0c1ed --- /dev/null +++ b/os2/OS2/OS2-Process/Makefile.PL @@ -0,0 +1,44 @@ +use ExtUtils::MakeMaker; + +create_constants(); # Make a module + +# See lib/ExtUtils/MakeMaker.pm for details of how to influence +# the contents of the Makefile that is written. +WriteMakefile( + 'NAME' => 'OS2::Process', + VERSION_FROM=> 'Process.pm', + MAN3PODS => {}, # Pods will be built by installman. + 'LIBS' => [''], # e.g., '-lm' + 'DEFINE' => '', # e.g., '-DHAVE_SOMETHING' + 'INC' => '', # e.g., '-I/usr/include/other' + IMPORTS => { _16_DosSmSetTitle => 'sesmgr.DOSSMSETTITLE', + # _16_Win16SetTitle => 'pmshapi.93', + }, +); + +sub create_constants { + return if -d 'Process_constants'; + my $src_dir; + my @try = qw(.. ../.. ../../.. ../../../..); + for (@try) { + $src_dir = $_, last if -d "$_/utils" and -r "$_/utils/h2xs"; + } + warn("Can't find \$PERL_SRC/utils/h2xs in @try, falling back to no constants"), + return unless defined $src_dir; + # Can't name it *::Constants, otherwise constants.xs would overwrite it... + # This produces warnings from PSZ-conversion on WS_* constants. + system $^X, "-I$src_dir/lib", "$src_dir/utils/h2xs", '-fn', 'OS2::Process::Const', + '--skip-exporter', '--skip-autoloader', # too large memory overhead + '--skip-strict', '--skip-warnings', # likewise + '--skip-ppport', # will not work without dynaloading. + # Most useful for OS2::Process: + '-M^(HWND|WM|SC|SWP|WC|PROG|QW|EDI|WS|QWS|QWP|QWL|FF|FI|LS|FS|FCF|BS|MS|TBM|CF|CFI|FID|MB|MBID|CF|CFI|SPTR)_', + '-F', '-DINCL_NLS -DINCL_BASE -DINCL_PM', # Define more symbols + 'os2emx.h' # EMX version of OS/2 API + and warn("Can't build module with contants, falling back to no constants"), + return; + rename 'OS2/Process/Const', 'Process_constants' + or warn("Error renaming module, falling back to no constants: $!"), + return; + return 1; +} diff --git a/os2/OS2/OS2-Process/Process.pm b/os2/OS2/OS2-Process/Process.pm new file mode 100644 index 0000000000..70583617b1 --- /dev/null +++ b/os2/OS2/OS2-Process/Process.pm @@ -0,0 +1,2372 @@ +package OS2::localMorphPM; +# use strict; + +sub new { + my ($c,$f) = @_; + OS2::MorphPM($f); + # print STDERR ">>>>>\n"; + bless [$f], $c +} +sub DESTROY { + # print STDERR "<<<<<\n"; + OS2::UnMorphPM(shift->[0]) +} + +package OS2::Process; + +BEGIN { + require Exporter; + require XSLoader; + #require AutoLoader; + + our @ISA = qw(Exporter); + our $VERSION = "1.03"; + XSLoader::load('OS2::Process', $VERSION); +} + +# Items to export into callers namespace by default. Note: do not export +# names by default without a very good reason. Use EXPORT_OK instead. +# Do not simply export all your public functions/methods/constants. +our @EXPORT = qw( + P_BACKGROUND + P_DEBUG + P_DEFAULT + P_DETACH + P_FOREGROUND + P_FULLSCREEN + P_MAXIMIZE + P_MINIMIZE + P_NOCLOSE + P_NOSESSION + P_NOWAIT + P_OVERLAY + P_PM + P_QUOTE + P_SESSION + P_TILDE + P_UNRELATED + P_WAIT + P_WINDOWED + my_type + file_type + T_NOTSPEC + T_NOTWINDOWCOMPAT + T_WINDOWCOMPAT + T_WINDOWAPI + T_BOUND + T_DLL + T_DOS + T_PHYSDRV + T_VIRTDRV + T_PROTDLL + T_32BIT + + os2constant + + ppid + ppidOf + sidOf + scrsize + scrsize_set + kbdChar + kbdhChar + kbdStatus + _kbdStatus_set + kbdhStatus + kbdhStatus_set + vioConfig + viohConfig + vioMode + viohMode + viohMode_set + _vioMode_set + _vioState + _vioState_set + vioFont + vioFont_set + process_entry + process_entries + process_hentry + process_hentries + change_entry + change_entryh + process_hwnd + Title_set + Title + winTitle_set + winTitle + swTitle_set + bothTitle_set + WindowText + WindowText_set + WindowPos + WindowPos_set + hWindowPos + hWindowPos_set + WindowProcess + SwitchToProgram + DesktopWindow + ActiveWindow + ActiveWindow_set + ClassName + FocusWindow + FocusWindow_set + ShowWindow + PostMsg + BeginEnumWindows + EndEnumWindows + GetNextWindow + IsWindow + ChildWindows + out_codepage + out_codepage_set + process_codepage_set + in_codepage + in_codepage_set + cursor + cursor_set + screen + screen_set + process_codepages + QueryWindow + WindowFromId + WindowFromPoint + EnumDlgItem + EnableWindow + EnableWindowUpdate + IsWindowEnabled + IsWindowVisible + IsWindowShowing + WindowPtr + WindowULong + WindowUShort + WindowStyle + SetWindowBits + SetWindowPtr + SetWindowULong + SetWindowUShort + WindowBits_set + WindowPtr_set + WindowULong_set + WindowUShort_set + TopLevel + FocusWindow_set_keep_Zorder + + ActiveDesktopPathname + InvalidateRect + CreateFrameControls + + ClipbrdFmtInfo + ClipbrdOwner + ClipbrdViewer + ClipbrdData + OpenClipbrd + CloseClipbrd + ClipbrdData_set + ClipbrdOwner_set + ClipbrdViewer_set + EnumClipbrdFmts + EmptyClipbrd + ClipbrdFmtNames + ClipbrdFmtAtoms + AddAtom + FindAtom + DeleteAtom + AtomUsage + AtomName + AtomLength + SystemAtomTable + CreateAtomTable + DestroyAtomTable + + _ClipbrdData_set + ClipbrdText + ClipbrdText_set + ClipbrdText_2byte + ClipbrdTextUCS2le + MemoryRegionSize + + _MessageBox + MessageBox + _MessageBox2 + MessageBox2 + get_pointer + LoadPointer + SysPointer + Alarm + FlashWindow + + get_title + set_title + io_term +); +our @EXPORT_OK = qw( + ResetWinError + MPFROMSHORT + MPVOID + MPFROMCHAR + MPFROM2SHORT + MPFROMSH2CH + MPFROMLONG +); + +our $AUTOLOAD; + +sub AUTOLOAD { + # This AUTOLOAD is used to 'autoload' constants from the constant() + # XS function. If a constant is not found then control is passed + # to the AUTOLOAD in AutoLoader. + + (my $constname = $AUTOLOAD) =~ s/.*:://; + my $val = constant($constname, @_ ? $_[0] : 0); + if ($! != 0) { + if ($! =~ /Invalid/ || $!{EINVAL}) { + die "Unsupported function $AUTOLOAD" + } else { + my ($pack,$file,$line) = caller; + die "Your vendor has not defined OS2::Process macro $constname, used at $file line $line. +"; + } + } + eval "sub $AUTOLOAD { $val }"; + goto &$AUTOLOAD; +} + +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; + + *{"$p\::$sym"} = sub () { $val }; + (); # needed by import() +} + +sub import { + my $class = shift; + my $ini = @_; + @_ = ($class, + map { + /^(HWND|WM|SC|SWP|WC|PROG|QW|EDI|WS|QWS|QWP|QWL|FF|FI|LS|FS|FCF|BS|MS|TBM|CF|CFI|FID|MB|MBID|CF|CFI|SPTR)_/ ? const_import($_) : $_ + } @_); + goto &Exporter::import if @_ > 1 or $ini == 0; +} + +# Preloaded methods go here. + +sub Title () { (process_entry())[0] } + +# *Title_set = \&sesmgr_title_set; + +sub swTitle_set_sw { + my ($title, @sw) = @_; + $sw[0] = $title; + change_entry(@sw); +} + +sub swTitle_set ($) { + my (@sw) = process_entry(); + swTitle_set_sw(shift, @sw); +} + +sub winTitle_set_sw { + my ($title, @sw) = @_; + my $h = OS2::localMorphPM->new(0); + WindowText_set $sw[1], $title; +} + +sub winTitle_set ($) { + my (@sw) = process_entry(); + winTitle_set_sw(shift, @sw); +} + +sub winTitle () { + my (@sw) = process_entry(); + my $h = OS2::localMorphPM->new(0); + WindowText $sw[1]; +} + +sub bothTitle_set ($) { + my (@sw) = process_entry(); + my $t = shift; + winTitle_set_sw($t, @sw); + swTitle_set_sw($t, @sw); +} + +sub Title_set ($) { + my $t = shift; + return 1 if sesmgr_title_set($t); + return 0 unless $^E == 372; + my (@sw) = process_entry(); + winTitle_set_sw($t, @sw); + swTitle_set_sw($t, @sw); +} + +sub process_entry { swentry_expand(process_swentry(@_)) } + +our @hentry_fields = qw( title owner_hwnd icon_hwnd + owner_phandle owner_pid owner_sid + visible nonswitchable jumpable ptype sw_entry ); + +sub swentry_hexpand ($) { + my %h; + @h{@hentry_fields} = swentry_expand(shift); + \%h; +} + +sub process_hentry { swentry_hexpand(process_swentry(@_)) } +sub process_hwnd { process_hentry()->{owner_hwnd} } + +my $swentry_size = swentry_size(); + +sub sw_entries () { + my $s = swentries_list(); + my ($c, $s1) = unpack 'La*', $s; + die "Unconsistent size in swentries_list()" unless 4+$c*$swentry_size == length $s; + my (@l, $e); + push @l, $e while $e = substr $s1, 0, $swentry_size, ''; + @l; +} + +sub process_entries () { + map [swentry_expand($_)], sw_entries; +} + +sub process_hentries () { + map swentry_hexpand($_), sw_entries; +} + +sub change_entry { + change_swentry(create_swentry(@_)); +} + +sub create_swentryh ($) { + my $h = shift; + create_swentry(@$h{@hentry_fields}); +} + +sub change_entryh ($) { + change_swentry(create_swentryh(shift)); +} + +# Massage entries into the same order as WindowPos_set: +sub WindowPos ($) { + my ($fl, $h, $w, $y, $x, $behind, $hwnd, @rest) + = unpack 'L l4 L4', WindowSWP(shift); + ($x, $y, $fl, $w, $h, $behind, @rest); +} + +# Put them into a hash +sub hWindowPos ($) { + my %h; + @h{ qw(flags height width y x behind hwnd reserved1 reserved2) } + = unpack 'L l4 L4', WindowSWP(shift); + \%h; +} + +my @SWP_keys = ( [qw(width height)], # SWP_SIZE=1 + [qw(x y)], # SWP_MOVE=2 + [qw(behind)] ); # SWP_ZORDER=3 +my %SWP_def; +@SWP_def{ map @$_, @SWP_keys } = (0) x 20; + +# Get them from a hash +sub hWindowPos_set ($$) { + my $hash = shift; + my $hwnd = (@_ ? shift : $hash->{hwnd} ); + my $flags; + if (exists $hash->{flags}) { + $flags = $hash->{flags}; + } else { # Set flags according to existing keys in $hash + $flags = 0; + for my $bit (0..2) { + exists $hash->{$_} and $flags |= (1<<$bit) for @{$SWP_keys[$bit]}; + } + } + for my $bit (0..2) { # Check for required keys + next unless $flags & (1<<$bit); + exists $hash->{$_} + or die sprintf "key $_ required for flags=%#x", $flags + for @{$SWP_keys[$bit]}; + } + my %h = (%SWP_def, flags => $flags, %$hash); # Avoid warnings + my ($x, $y, $fl, $w, $h, $behind) = @h{ qw(x y flags width height behind) }; + WindowPos_set($hwnd, $x, $y, $fl, $w, $h, $behind); +} + +sub ChildWindows (;$) { + my $hm = OS2::localMorphPM->new(0); + my @kids; + my $h = BeginEnumWindows(@_ ? shift : 1); # HWND_DESKTOP + my $w; + push @kids, $w while $w = GetNextWindow $h; + EndEnumWindows $h; + @kids; +} + +sub TopLevel ($) { + my $d = DesktopWindow; + my $w = shift; + while (1) { + my $p = QueryWindow $w, 5; # QW_PARENT; + return $w if not $p or $p == $d; + $w = $p; + } +} + +sub FocusWindow_set_keep_Zorder ($) { + my $w = shift; + my $t = TopLevel $w; + my $b = hWindowPos($t)->{behind}; # we are behind this + EnableWindowUpdate($t, 0); + FocusWindow_set($w); +# sleep 1; # Make flicker stronger when present + hWindowPos_set {behind => $b}, $t; + EnableWindowUpdate($t, 1); +} + +sub 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(); +} + +sub OS2::localFlashWindow::new ($$) { + my ($c, $w) = (shift, shift); + my $morph = OS2::localMorphPM->new(0); + 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, @_); +} + +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 ($;$$$$$) { + my $morph = OS2::localMorphPM->new(0); + die "MessageBox needs text" unless @_; + push @_ , ($0 eq '-e' ? "Perl one-liner's message" : "$0 message") if @_ == 1; + &_MessageBox; +} + +my %pointers; + +sub get_pointer ($;$$) { + my $id = $_[0]; + return $pointers{$id} if exists $pointers{$id}; + $pointers{$id} = &SysPointer; +} + +# $button needs to be of the form 'String', ['String'] or ['String', flag]. +# If ['String'], it is assumed the default button; same for 'String' if $only +# is set. +sub process_MB2 ($$;$) { + die "process_MB2() needs 2 arguments, got '@_'" unless @_ == 2 or @_ == 3; + my ($button, $ret, $only) = @_; + # default is BS_PUSHBUTTON, add BS_DEFAULT if $only is set + $button = [$button, $only ? 0x400 : 0] unless ref $button eq 'ARRAY'; + push @$button, 0x400 if @$button == 1; # BS_PUSHBUTTON|BS_DEFAULT + die "Button needs to be of the form 'String', ['String'] or ['String', flag]" + unless @$button == 2; + pack "Z71 x L l", $button->[0], $ret, $button->[1]; # name, retval, flag +} + +# If one button, make it the default one even if it is of 'String' => val form. +# If icon is of the form 'SP#', load this via SysPointer. +sub process_MB2_INFO ($;$$$) { + my $l = 0; + my $out; + die "process_MB2_INFO() needs 1..4 arguments" unless @_ and @_ < 5; + my $buttons = shift; + die "Buttons array should consist of pairs" if @$buttons % 2; + + push @_, 0 unless @_; # Icon id; 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 + + my ($icon, $style, $notify) = (shift, shift, shift); + $icon = get_pointer $1 if $icon =~ /^SP#(\d+)\z/; + $out = pack "L L L L", # icon, #buttons, style, notify, buttons + $icon, @$buttons/2, $style, $notify; + $out .= join '', + map process_MB2($buttons->[2*$_], $buttons->[2*$_+1], @$buttons == 2), + 0..@$buttons/2-1; + pack('L', length(pack 'L', 0) + length $out) . $out; +} + +# MessageBox2 'Try this', OS2::Process::process_MB2_INFO([['Dismiss', 0] => 0x1000], OS2::Process::get_pointer(22),0x4080,0), 'me', 1, 0, 0 +# or the shortcut +# MessageBox2 'Try this', [[['Dismiss', 0] => 0x1000], 'SP#22'], 'me' +# 0x80 means MB_CUSTOMICON (does not focus?!). This focuses: +# MessageBox2 'Try this', [[['Dismiss',0x400] => 0x1000], 0, 0x4030,0] +# 0x400 means BS_DEFAULT. This is the same as the shortcut +# MessageBox2 'Try this', [[Dismiss => 0x1000]] +sub MessageBox2 ($;$$$$$) { + my $morph = OS2::localMorphPM->new(0); + die "MessageBox needs text" unless @_; + push @_ , [[Dismiss => 0x1000], # Name, retval (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" : $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 (;$$) { + my $data = &_vioConfig; + my @out = unpack 'x[S]SSLSSSLLLSS', $data; + # If present, offset points to S/S (with only the first work making sense) + my (@adaptersEMU, @displayEMU); + @displaysEMU = unpack("x[$out[10]]S/S", $data), pop @out if @out > 10; + @adaptersEMU = unpack("x[$out[ 9]]S/S", $data), pop @out if @out > 9; + $out[9] = $adaptersEMU[0] if @adaptersEMU; + $out[10] = $displaysEMU[0] if @displaysEMU; + @out; +} + +my @vioConfig = qw(adapter display cbMemory Configuration VDHVersion Flags + HWBufferSize FullSaveSize PartSaveSize EMAdapters EMDisplays); + +sub viohConfig (;$$) { + my %h; + @h{@vioConfig} = &vioConfig; + %h; +} + +# fbType; color; col; row; hres; vres; fmt_ID; attrib; buf_addr; buf_length; +# full_length; partial_length; ext_data_addr; +sub vioMode() {unpack 'x[S]CCSSSSCCLLLLL', _vioMode} + +my @vioMode = qw( fbType color col row hres vres fmt_ID attrib buf_addr + buf_length full_length partial_length ext_data_addr); + +sub viohMode() { + my %h; + @h{@vioMode} = vioMode; + %h; +} + +sub viohMode_set { + my %h = (viohMode, @_); + my $o = pack 'x[S]CCSSSSCCLLLLL', @h{@vioMode}; + $o = pack 'SCCSSSSCCLLLLL', length $o, @h{@vioMode}; + _vioMode_set($o); +} + +sub kbdChar (;$$) {unpack 'CCCCSL', &_kbdChar} + +my @kbdChar = qw(ascii scancode status nlsstate shifts time); +sub kbdhChar (;$$) { + my %h; + @h{@kbdChar} = &kbdChar; + %h +} + +sub kbdStatus (;$) {unpack 'x[S]SSSS', &_kbdStatus} +my @kbdStatus = qw(state turnChar intCharFlags shifts); +sub kbdhStatus (;$) { + my %h; + @h{@kbdStatus} = &kbdStatus; + %h +} +sub kbdhStatus_set { + my $h = (@_ % 2 ? shift @_ : 0); + my %h = (kbdhStatus($h), @_); + my $o = pack 'x[S]SSSS', @h{@kbdStatus}; + $o = pack 'SSSSS', length $o, @h{@kbdStatus}; + _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. + +1; +__END__ + +=head1 NAME + +OS2::Process - exports constants for system() call, and process control on OS2. + +=head1 SYNOPSIS + + use OS2::Process; + $pid = system(P_PM | P_BACKGROUND, "epm.exe"); + +=head1 DESCRIPTION + +=head2 Optional argument to system() + +the builtin function system() under OS/2 allows an optional first +argument which denotes the mode of the process. Note that this argument is +recognized only if it is strictly numerical. + +You can use either one of the process modes: + + P_WAIT (0) = wait until child terminates (default) + P_NOWAIT = do not wait until child terminates + P_SESSION = new session + P_DETACH = detached + P_PM = PM program + +and optionally add PM and session option bits: + + P_DEFAULT (0) = default + P_MINIMIZE = minimized + P_MAXIMIZE = maximized + P_FULLSCREEN = fullscreen (session only) + P_WINDOWED = windowed (session only) + + P_FOREGROUND = foreground (if running in foreground) + P_BACKGROUND = background + + P_NOCLOSE = don't close window on exit (session only) + + P_QUOTE = quote all arguments + P_TILDE = MKS argument passing convention + P_UNRELATED = do not kill child when father terminates + +=head2 Access to process properties + +On OS/2 processes have the usual I semantic; +additionally, there is a hierarchy of sessions with their own +I tree. A session is either a FS session, or a windowed +pseudo-session created by PM. A session is a "unit of user +interaction", a change to in/out settings in one of them does not +affect other sessions. + +=over + +=item my_type() + +returns the type of the current process (one of +"FS", "DOS", "VIO", "PM", "DETACH" and "UNKNOWN"), or C on error. + +=item C + +returns the type of the executable file C, or +dies on error. The bits 0-2 of the result contain one of the values + +=over + +=item C (0) + +Application type is not specified in the executable header. + +=item C (1) + +Application type is not-window-compatible. + +=item C (2) + +Application type is window-compatible. + +=item C (3) + +Application type is window-API. + +=back + +The remaining bits should be masked with the following values to +determine the type of the executable: + +=over + +=item C (8) + +Set to 1 if the executable file has been "bound" (by the BIND command) +as a Family API application. Bits 0, 1, and 2 still apply. + +=item C (0x10) + +Set to 1 if the executable file is a dynamic link library (DLL) +module. Bits 0, 1, 2, 3, and 5 will be set to 0. + +=item C (0x20) + +Set to 1 if the executable file is in PC/DOS format. Bits 0, 1, 2, 3, +and 4 will be set to 0. + +=item C (0x40) + +Set to 1 if the executable file is a physical device driver. + +=item C (0x80) + +Set to 1 if the executable file is a virtual device driver. + +=item C (0x100) + +Set to 1 if the executable file is a protected-memory dynamic link +library module. + +=item C (0x4000) + +Set to 1 for 32-bit executable files. + +=back + +file_type() may croak with one of the strings C<"Invalid EXE +signature"> or C<"EXE marked invalid"> to indicate typical error +conditions. If given non-absolute path, will look on C, will +add extension F<.exe> if no extension is present (add extension F<.> +to suppress). + +=item C<@list = process_codepages()> + +the first element is the currently active codepage, up to 2 additional +entries specify the system's "prepared codepages": the codepages the +user can switch to. The active codepage of a process is one of the +prepared codepages of the system (if present). + +=item C + +sets the currently active codepage. [Affects printer output, in/out +codepages of sessions started by this process, and the default +codepage for drawing in PM; is inherited by kids. Does not affect the +out- and in-codepages of the session.] + +=item ppid() + +returns the PID of the parent process. + +=item C + +returns the PID of the parent process of $pid. -1 on error. + +=item C + +returns the session id of the process id $pid. -1 on error. + +=back + +=head2 Control of VIO sessions + +VIO applications are applications running in a text-mode session. + +=over + +=item out_codepage() + +gets code page used for screen output (glyphs). -1 means that a user font +was loaded. + +=item C + +sets code page used for screen output (glyphs). -1 switches to a preloaded +user font. -2 switches off the preloaded user font. + +=item in_codepage() + +gets code page used for keyboard input. 0 means that a hardware codepage +is used. + +=item C + +sets code page used for keyboard input. + +=item C<($w, $h) = scrsize()> + +width and height of the given console window in character cells. + +=item C + +set height (and optionally width) of the given console window in +character cells. Use 0 size to keep the old size. + +=item C<($s, $e, $w, $a) = cursor()> + +gets start/end lines of the blinking cursor in the charcell, its width +(1 on text modes) and attribute (-1 for hidden, in text modes other +values mean visible, in graphic modes color). + +=item C + +sets start/end lines of the blinking cursor in the charcell. Negative +values mean percents of the character cell height. + +=item screen() + +gets a buffer with characters and attributes of the screen. + +=item C + +restores the screen given the result of screen(). E.g., if the file +C<$file> contains the screen contents, then + + open IN, $file or die; + binmode IN; + read IN, $in, -s IN; + $s = screen; + $in .= qq(\0) x (length($s) - length $in); + substr($in, length $s) = ''; + screen_set $in; + +will restore the screen content even if the height of the window +changed (if the width changed, more manipulation is needed). + +=back + +=head2 Control of the process list + +With the exception of Title_set(), all these calls require that PM is +running, they would not work under alternative Session Managers. + +=over + +=item process_entry() + +returns a list of the following data: + +=over + +=item + +Title of the process (in the C list); + +=item + +window handle of switch entry of the process (in the C list); + +=item + +window handle of the icon of the process; + +=item + +process handle of the owner of the entry in C list; + +=item + +process id of the owner of the entry in C list; + +=item + +session id of the owner of the entry in C list; + +=item + +whether visible in C list; + +=item + +whether item cannot be switched to (note that it is not actually +grayed in the C list)); + +=item + +whether participates in jump sequence; + +=item + +program type. Possible values are: + + PROG_DEFAULT 0 + PROG_FULLSCREEN 1 + PROG_WINDOWABLEVIO 2 + PROG_PM 3 + PROG_VDM 4 + PROG_WINDOWEDVDM 7 + +Although there are several other program types for WIN-OS/2 programs, +these do not show up in this field. Instead, the PROG_VDM or +PROG_WINDOWEDVDM program types are used. For instance, for +PROG_31_STDSEAMLESSVDM, PROG_WINDOWEDVDM is used. This is because all +the WIN-OS/2 programs run in DOS sessions. For example, if a program +is a windowed WIN-OS/2 program, it runs in a PROG_WINDOWEDVDM +session. Likewise, if it's a full-screen WIN-OS/2 program, it runs in +a PROG_VDM session. + +=item + +switch-entry handle. + +=back + +Optional arguments: the pid and the window-handle of the application running +in the OS/2 session to query. + +=item process_hentry() + +similar to process_entry(), but returns a hash reference, the keys being + + title owner_hwnd icon_hwnd owner_phandle owner_pid owner_sid + visible nonswitchable jumpable ptype sw_entry + +(a copy of the list of keys is in @hentry_fields). + +=item process_entries() + +similar to process_entry(), but returns a list of array reference for all +the elements in the switch list (one controlling C window). + +=item process_hentries() + +similar to process_hentry(), but returns a list of hash reference for all +the elements in the switch list (one controlling C window). + +=item change_entry() + +changes a process entry, arguments are the same as process_entry() returns. + +=item change_entryh() + +Similar to change_entry(), but takes a hash reference as an argument. + +=item process_hwnd() + +returns the C of the process entry (for VIO windowed processes +this is the frame window of the session). + +=item Title() + +returns the text of the task switch menu entry of the current session. +(There is no way to get this info in non-standard Session Managers. This +implementation is a shortcut via process_entry().) + +=item C + +tries two different interfaces. The Session Manager one does not work +with some windows (if the title is set from the start). +This is a limitation of OS/2, in such a case $^E is set to 372 (type + + help 372 + +for a funny - and wrong - explanation ;-). In such cases a +direct-manipulation of low-level entries is used (same as bothTitle_set()). +Keep in mind that some versions of OS/2 leak memory with such a manipulation. + +=item winTitle() + +returns text of the titlebar of the current process' window. + +=item C + +sets text of the titlebar of the current process' window. The change does not +affect the text of the switch entry of the current window. + +=item C + +sets text of the task switch menu entry of the current process' window. [There +is no API to query this title.] Does it via SwitchEntry interface, +not Session manager interface. The change does not affect the text of the +titlebar of the current window. + +=item C + +sets text of the titlebar and task switch menu of the current process' window +via direct manipulation of the windows' texts. + +=item C + +switch to session given by a switch list handle (defaults to the entry of our process). + +Use of this function causes another window (and its related windows) +of a PM session to appear on the front of the screen, or a switch to +another session in the case of a non-PM program. In either case, +the keyboard (and mouse for the non-PM case) input is directed to +the new program. + +=back + +=head2 Control of the PM windows + +Some of these API's require sending a message to the specified window. +In such a case the process needs to be a PM process, or to be morphed +to a PM process via OS2::MorphPM(). + +For a temporary morphing to PM use L. + +Keep in mind that PM windows are engaged in 2 "orthogonal" window +trees, as well as in the z-order list. + +One tree is given by the I relationship. This +relationship affects drawing (child is drawn relative to its parent +(lower-left corner), and the drawing is clipped by the parent's +boundary; parent may request that I drawing is clipped to be +confined to the outsize of the childs and/or siblings' windows); +hiding; minimizing/restoring; and destroying windows. + +Another tree (not necessarily connected?) is given by I +relationship. Ownership relationship assumes cooperation of the +engaged windows via passing messages on "important events"; e.g., +scrollbars send information messages when the "bar" is moved, menus +send messages when an item is selected; frames +move/hide/unhide/minimize/restore/change-z-order-of owned frames when +the owner is moved/etc., and destroy the owned frames (even when these +frames are not descendants) when the owner is destroyed; etc. [An +important restriction on ownership is that owner should be created by +the same thread as the owned thread, so they engage in the same +message queue.] + +Windows may be in many different state: Focused (take keyboard events) or not, +Activated (=Frame windows in the I tree between the root and +the window with the focus; usually indicate such "active state" by titlebar +highlights, and take mouse events) or not, Enabled/Disabled (this influences +the ability to update the graphic, and may change appearance, as for +enabled/disabled buttons), Visible/Hidden, Minimized/Maximized/Restored, Modal +or not, etc. + +The APIs below all die() on error with the message being $^E. + +=over + +=item C + +gets "a text content" of a window. Requires (morphing to) PM. + +=item C + +sets "a text content" of a window. Requires (morphing to) PM. + +=item C<($x, $y, $flags, $width, $height, $behind, @rest) = WindowPos($hwnd)> + +gets window position info as 8 integers (of C), in the order suitable +for WindowPos_set(). @rest is marked as "reserved" in PM docs. $flags +is a combination of C constants. + +=item C<$hash = hWindowPos($hwnd)> + +gets window position info as a hash reference; the keys are C. + +Example: + + exit unless $hash->{flags} & SWP_MAXIMIZE; # Maximized + +=item C + +Set state of the window: position, size, zorder, show/hide, activation, +minimize/maximize/restore etc. Which of these operations to perform +is governed by $flags. + +=item C + +Same as C, but takes the position from keys C of the hash referenced by $hash. If $hwnd is explicitly +specified, it overrides C<$hash->{hwnd}>. If $hash->{flags} is not specified, +it is calculated basing on the existing keys of $hash. Requires (morphing to) PM. + +Example: + + hWindowPos_set {flags => SWP_MAXIMIZE}, $hwnd; # Maximize + +=item C<($pid, $tid) = WindowProcess($hwnd)> + +gets I and I of the process associated to the window. + +=item C + +returns the class name of the window. + +If this window is of any of the preregistered WC_* classes the class +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 +the desktop to use. + +=item C + +set the focus window by handle. Optional argument for specifying the desktop +to use. E.g, the first entry in program_entries() is the C list. +To show an application, use either one of + + WinShowWindow( $hwnd, 1 ); + FocusWindow_set( $hwnd ); + SwitchToProgram($switch_handle); + +(Which work with alternative focus-to-front policies?) Requires +(morphing to) PM. + +Switching focus to currently-unfocused window moves the window to the +front in Z-order; use FocusWindow_set_keep_Zorder() to avoid this. + +=item C + +same as FocusWindow_set(), but preserves the Z-order of windows. + +=item C + +gets the active subwindow's handle for $parentHwnd or desktop. +Returns FALSE if none. + +=item C + +sets the active subwindow's handle for $parentHwnd or desktop. Requires (morphing to) PM. + +=item C + +Set visible/hidden flag of the window. Default: $show is TRUE. + +=item C + +Set window visibility state flag for the window for subsequent drawing. +No actual drawing is done at this moment. Use C +when redrawing is needed. While update is disabled, changes to the "window +state" do not change the appearance of the window. Default: $update is TRUE. + +(What is manipulated is the bit C of the window style.) + +=item C + +Set the window enabled state. Default: $enable is TRUE. + +Results in C message sent to the window. Typically, this +would change the appearence of the window. If at the moment of disabling +focus is in the window (or a descendant), focus is lost (no focus anywhere). +If focus is needed, it can be reassigned explicitly later. + +=item IsWindowEnabled(), IsWindowVisible(), IsWindowShowing() + +these functions take $hwnd as an argument. IsWindowEnabled() queries +the state changed by EnableWindow(), IsWindowVisible() the state changed +by ShowWindow(), IsWindowShowing() is true if there is a part of the window +visible on the screen. + +=item C + +post message to a window. The meaning of $mp1, $mp2 is specific for each +message id $msg, they default to 0. E.g., + + use OS2::Process qw(:DEFAULT WM_SYSCOMMAND WM_CONTEXTMENU + WM_SAVEAPPLICATION WM_QUIT WM_CLOSE + SC_MAXIMIZE SC_RESTORE); + $hwnd = process_hentry()->{owner_hwnd}; + # Emulate choosing `Restore' from the window menu: + PostMsg $hwnd, WM_SYSCOMMAND, MPFROMSHORT(SC_RESTORE); # Not immediate + + # Emulate `Show-Contextmenu' (Double-Click-2), two ways: + PostMsg ActiveWindow, WM_CONTEXTMENU; + PostMsg FocusWindow, WM_CONTEXTMENU; + + /* Emulate `Close' */ + PostMsg ActiveWindow, WM_CLOSE; + + /* Same but with some "warnings" to the application */ + $hwnd = ActiveWindow; + PostMsg $hwnd, WM_SAVEAPPLICATION; + PostMsg $hwnd, WM_CLOSE; + PostMsg $hwnd, WM_QUIT; + +In fact, MPFROMSHORT() may be omitted above. + +For messages to other processes, messages which take/return a pointer are +not supported. + +=item C + +The functions MPFROMSHORT(), MPVOID(), MPFROMCHAR(), MPFROM2SHORT(), +MPFROMSH2CH(), MPFROMLONG() can be used the same way as from C. Use them +to construct parameters $m1, $m2 to PostMsg(). + +These functions are not exported by default. + +=item C<$eh = BeginEnumWindows($hwnd)> + +starts enumerating immediate child windows of $hwnd in z-order. The +enumeration reflects the state at the moment of BeginEnumWindows() calls; +use IsWindow() to be sure. All the functions in this group require (morphing to) PM. + +=item C<$kid_hwnd = GetNextWindow($eh)> + +gets the next kid in the list. Gets 0 on error or when the list ends. + +=item C + +End enumeration and release the list. + +=item C<@list = ChildWindows([$hwnd])> + +returns the list of child windows at the moment of the call. Same remark +as for enumeration interface applies. Defaults to HWND_DESKTOP. +Example of usage: + + sub l { + my ($o,$h) = @_; + printf ' ' x $o . "%#x\n", $h; + l($o+2,$_) for ChildWindows $h; + } + l 0, $HWND_DESKTOP + +=item C + +true if the window handle is still valid. + +=item C + +gets the handle of a related window. $type should be one of C constants. + +=item C + +return TRUE if $hwnd is a descendant of $parent. + +=item C + +return a window handle of a child of $hwnd with the given $id. + + hwndSysMenu = WinWindowFromID(hwndDlg, FID_SYSMENU); + WinSendMsg(hwndSysMenu, MM_SETITEMATTR, + MPFROM2SHORT(SC_CLOSE, TRUE), + MPFROM2SHORT(MIA_DISABLED, MIA_DISABLED)); + +=item C + +gets a handle of a child of $hwndParent at C<($x,$y)>. If $descedantsToo +(defaulting to 1) then children of children may be returned too. May return +$hwndParent (defaults to desktop) if no suitable children are found, +or 0 if the point is outside the parent. + +$x and $y are relative to $hwndParent. + +=item C + +gets a dialog item window handle for an item of type $type of $dlgHwnd +relative to $relativeHwnd, which is descendant of $dlgHwnd. +$relativeHwnd may be specified if $type is EDI_FIRSTTABITEM or +EDI_LASTTABITEM. + +The return is always an immediate child of hwndDlg, even if hwnd is +not an immediate child window. $type may be + +=over + +=item EDI_FIRSTGROUPITEM + +First item in the same group. + +=item EDI_FIRSTTABITEM + +First item in dialog with style WS_TABSTOP. hwnd is ignored. + +=item EDI_LASTGROUPITEM + +Last item in the same group. + +=item EDI_LASTTABITEM + +Last item in dialog with style WS_TABSTOP. hwnd is ignored. + +=item EDI_NEXTGROUPITEM + +Next item in the same group. Wraps around to beginning of group when +the end of the group is reached. + +=item EDI_NEXTTABITEM + +Next item with style WS_TABSTOP. Wraps around to beginning of dialog +item list when end is reached. + +=item EDI_PREVGROUPITEM + +Previous item in the same group. Wraps around to end of group when the +start of the group is reached. For information on the WS_GROUP style, +see Window Styles. + +=item EDI_PREVTABITEM + +Previous item with style WS_TABSTOP. Wraps around to end of dialog +item list when beginning is reached. + +=back + +=item DesktopWindow() + +gets the actual window handle of the PM desktop; most APIs accept the +pseudo-handle C instead. Keep in mind that the WPS +desktop (one with WindowText() being C<"Desktop">) is a different beast?! + +=item TopLevel($hwnd) + +gets the toplevel window of $hwnd. + +=item ResetWinError() + +Resets $^E. One may need to call it before the C-class APIs which may +return 0 during normal operation. In such a case one should check both +for return value being zero and $^E being non-zero. The following APIs +do ResetWinError() themselves, thus do not need an explicit one: + + WindowPtr + WindowULong + WindowUShort + WindowTextLength + ActiveWindow + PostMsg + +This function is normally not needed. Not exported by default. + +=back + +=head2 Control of the PM data + +=over + +=item ActiveDesktopPathname() + +gets the path of the directory which corresponds to Desktop. + +=item 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). 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. This function will only work with clipboard +data types which are delimited by C<"\0"> byte (not included in the result). + +=item ClipbrdText_2byte + +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 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 ] ]) + +returns the $fmtInfo flags set by the application which filled the +format $fmt of the clipboard. $fmt defaults to C. + +=item ClipbrdOwner( [ $hab ] ) + +Returns window handle of the current clipboard owner. + +=item ClipbrdViewer( [ $hab ] ) + +Returns window handle of the current clipboard viewer. + +=item ClipbrdData( [$fmt, [ $hab ] ]) + +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). + +Clipboard should be opened before calling this function. May croak with error +C if no data of given $fmt is present. + +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 OpenClipbrd( [ $hab ] ) + +claim read access to the clipboard. May need a message queue to operate. +May block until other processes finish dealing with clipboard. + +=item CloseClipbrd( [ $hab ] ) + +Allow other processes access to clipboard. +Clipboard should be opened before calling this function. + +=item ClipbrdData_set($data, [$convert_nl, [$fmt, [$fmtInfo, [ $hab] ] ] ] ) + +Sets the clipboard data of format given by atom $fmt. Format defaults to +CF_TEXT. + +$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. + +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 _ClipbrdData_set($data, [$fmt, [$fmtInfo, [ $hab] ] ] ) + +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. + +$fmtInfo has the same semantic as for ClipbrdData_set(). + +=item ClipbrdOwner_set( $hwnd, [ $hab ] ) + +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 + +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 + +=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); + # Do something + } + +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: + + SwitchToProgram + ClassName + out_codepage + out_codepage_set + in_codepage + in_codepage_set + cursor + cursor_set + screen + screen_set + process_codepages + QueryWindow + EnumDlgItem + WindowPtr + WindowUShort + SetWindowBits + SetWindowPtr + SetWindowULong + SetWindowUShort + my_type + file_type + scrsize + scrsize_set + +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. + + + >But I wish to change the default button if the user enters some + >text into an entryfield. I can detect the entry ok, but can't + >seem to get the button to change to default. + > + >No matter what message I send it, it's being ignored. + + You need to get the style of the buttons using WinQueryWindowULong/QWL_STYLE, + set and reset the BS_DEFAULT bits as appropriate and then use + WinSetWindowULong/QWL_STYLE to set the button style. + Something like this: + hwnd1 = WinWindowFromID (hwnd, id1); + hwnd2 = WinWindowFromID (hwnd, id2); + style1 = WinQueryWindowULong (hwnd1, QWL_STYLE); + style2 = WinQueryWindowULong (hwnd2, QWL_STYLE); + style1 |= style2 & BS_DEFAULT; + style2 &= ~BS_DEFAULT; + WinSetWindowULong (hwnd1, QWL_STYLE, style1); + WinSetWindowULong (hwnd2, QWL_STYLE, style2); + + > How to do query and change a frame creation flags for existing window? + + Set the style bits that correspond to the FCF_* flag for the frame + window and then send a WM_UPDATEFRAME message with the appropriate FCF_* + flag in mp1. + + ULONG ulFrameStyle; + ulFrameStyle = WinQueryWindowULong( WinQueryWindow(hwnd, QW_PARENT), + QWL_STYLE ); + ulFrameStyle = (ulFrameStyle & ~FS_SIZEBORDER) | FS_BORDER; + WinSetWindowULong( WinQueryWindow(hwnd, QW_PARENT), + QWL_STYLE, + ulFrameStyle ); + WinSendMsg( WinQueryWindow(hwnd, QW_PARENT), + WM_UPDATEFRAME, + MPFROMP(FCF_SIZEBORDER), + MPVOID ); + + If the FCF_* flags you want to change does not have a corresponding FS_* + style (i.e. the FCF_* flag corresponds to the presence/lack of a frame + control rather than a property of the frame itself) then you create or + destroy the appropriate control window using the correct FID_* window + identifier and then send the WM_UPDATEFRAME message with the appropriate + FCF_* flag in mp1. + + /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -* + | SetFrameBorder() | + | Changes a frame window's border to the requested type. | + | | + | Parameters on entry: | + | hwndFrame -> Frame window whose border is to be changed. | + | ulBorderStyle -> Type of border to change to. | + | | + | Returns: | + | BOOL -> Success indicator. | + | | + * - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -*/ + BOOL SetFrameBorder( HWND hwndFrame, ULONG ulBorderType ) { + ULONG ulFrameStyle; + BOOL fSuccess = TRUE; + + ulFrameStyle = WinQueryWindowULong( hwndFrame, QWL_STYLE ); + + switch ( ulBorderType ) { + case FS_SIZEBORDER : + ulFrameStyle = (ulFrameStyle & ~(FS_DLGBORDER | FS_BORDER)) + | FS_SIZEBORDER; + break; + + case FS_DLGBORDER : + ulFrameStyle = (ulFrameStyle & ~(FS_SIZEBORDER | FS_BORDER)) + | FS_DLGBORDER; + break; + + case FS_BORDER : + ulFrameStyle = (ulFrameStyle & ~(FS_SIZEBORDER | FS_DLGBORDER)) + | FS_BORDER; + break; + + default : + fSuccess = FALSE; + break; + } // end switch + + if ( fSuccess ) { + fSuccess = WinSetWindowULong( hwndFrame, QWL_STYLE, ulFrameStyle ); + + if ( fSuccess ) { + fSuccess = (BOOL)WinSendMsg( hwndFrame, WM_UPDATEFRAME, 0, 0 ); + if ( fSuccess ) + fSuccess = WinInvalidateRect( hwndFrame, NULL, TRUE ); + } + } + + return ( fSuccess ); + + } // End SetFrameBorder() + + hwndMenu=WinLoadMenu(hwndParent,NULL,WND_IMAGE); + WinSetWindowUShort(hwndMenu,QWS_ID,FID_MENU); + ulStyle=WinQueryWindowULong(hwndMenu,QWL_STYLE); + WinSetWindowULong(hwndMenu,QWL_STYLE,ulStyle|MS_ACTIONBAR); + WinSendMsg(hwndParent,WM_UPDATEFRAME,MPFROMSHORT(FCF_MENU),0L); + + OS/2-windows have another "parent" called the *owner*, + which must be set separately - to get a close relationship: + + WinSetOwner (hwndFrameChild, hwndFrameMain); + + Now your child should move with your main window! + And always stays on top of it.... + + To avoid this, for example for dialogwindows, you can + also "disconnect" this relationship with: + + WinSetWindowBits (hwndFrameChild, QWL_STYLE + , FS_NOMOVEWITHOWNER + , FS_NOMOVEWITHOWNER); + + Adding a button icon later: + + /* switch the button style to BS_MINIICON */ + WinSetWindowBits(hwndBtn, QWL_STYLE, BS_MINIICON, BS_MINIICON) ; + + /* set up button control data */ + BTNCDATA bcd; + bcd.cb = sizeof(BTNCDATA); + bcd.hImage = WinLoadPointer(HWND_DESKTOP, dllHandle, ID_ICON_BUTTON1) ; + bcd.fsCheckState = bcd.fsHiliteState = 0 ; + + + WNDPARAMS wp; + wp.fsStatus = WPM_CTLDATA; + wp.pCtlData = &bcd; + + /* add the icon on the button */ + WinSendMsg(hwndBtn, WM_SETWINDOWPARAMS, (MPARAM)&wp, NULL); + + MO> Can anyone tell what OS/2 expects of an application to be properly + MO> minimized to the desktop? + case WM MINMAXFRAME : + { + BOOL fShow = ! (((PSWP) mp1)->fl & SWP MINIMIZE); + HENUM henum; + + HWND hwndChild; + + WinEnableWindowUpdate ( hwnd, FALSE ); + + for (henum=WinBeginEnumWindows(hwnd); + (hwndChild = WinGetNextWindow (henum)) != 0; ) + WinShowWindow ( hwndChild, fShow ); + + WinEndEnumWindows ( henum ); + WinEnableWindowUpdate ( hwnd, TRUE ); + } + break; + +Why C gives C<< behind => HWND_TOP >>? + +=head1 $^E + +the majority of the APIs of this module set $^E on failure (no matter +whether they die() on failure or not). By the semantic of PM API +which returns something other than a boolean, it is impossible to +distinguish failure from a "normal" 0-return. In such cases C<$^E == +0> indicates an absence of error. + +=head1 EXPORTS + +In addition to symbols described above, the following constants (available +also via module C) are exportable. Note that these +symbols live in package C, they are not available +by full name through C! + + HWND_* Standard (abstract) window handles + WM_* Message ids + SC_* WM_SYSCOMMAND flavor + SWP_* Size/move etc flag + WC_* Standard window classes + PROG_* Program category (PM, VIO etc) + QW_* Query-Window flag + EDI_* Enumerate-Dialog-Item code + WS_* Window Style flag + QWS_* Query-window-UShort offsets + QWP_* Query-window-pointer offsets + QWL_* Query-window-ULong offsets + FF_* Frame-window state flags + FI_* Frame-window information flags + LS_* List box styles + FS_* Frame style + FCF_* Frame creation flags + BS_* Button style + MS_* Menu style + TBM_* Title bar messages? + CF_* Clipboard formats + CFI_* Clipboard storage type + FID_* ids of subwindows of frames + +=head1 BUGS + +whether a given API dies or returns FALSE/empty-list on error may be +confusing. This may change in the future. + +=head1 AUTHOR + +Andreas Kaiser , +Ilya Zakharevich . + +=head1 SEE ALSO + +C() system calls, L and L modules. + +=cut diff --git a/os2/OS2/OS2-Process/Process.xs b/os2/OS2/OS2-Process/Process.xs new file mode 100644 index 0000000000..05befa02cc --- /dev/null +++ b/os2/OS2/OS2-Process/Process.xs @@ -0,0 +1,1896 @@ +#include +#define INCL_DOS +#define INCL_DOSERRORS +#define INCL_DOSNLS +#define INCL_WINSWITCHLIST +#define INCL_WINWINDOWMGR +#define INCL_WININPUT +#define INCL_VIO +#define INCL_KBD +#define INCL_WINCLIPBOARD +#define INCL_WINATOM +#include + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +static unsigned long +constant(char *name, int arg) +{ + errno = 0; + if (name[0] == 'P' && name[1] == '_') { + if (strEQ(name, "P_BACKGROUND")) +#ifdef P_BACKGROUND + return P_BACKGROUND; +#else + goto not_there; +#endif + if (strEQ(name, "P_DEBUG")) +#ifdef P_DEBUG + return P_DEBUG; +#else + goto not_there; +#endif + if (strEQ(name, "P_DEFAULT")) +#ifdef P_DEFAULT + return P_DEFAULT; +#else + goto not_there; +#endif + if (strEQ(name, "P_DETACH")) +#ifdef P_DETACH + return P_DETACH; +#else + goto not_there; +#endif + if (strEQ(name, "P_FOREGROUND")) +#ifdef P_FOREGROUND + return P_FOREGROUND; +#else + goto not_there; +#endif + if (strEQ(name, "P_FULLSCREEN")) +#ifdef P_FULLSCREEN + return P_FULLSCREEN; +#else + goto not_there; +#endif + if (strEQ(name, "P_MAXIMIZE")) +#ifdef P_MAXIMIZE + return P_MAXIMIZE; +#else + goto not_there; +#endif + if (strEQ(name, "P_MINIMIZE")) +#ifdef P_MINIMIZE + return P_MINIMIZE; +#else + goto not_there; +#endif + if (strEQ(name, "P_NOCLOSE")) +#ifdef P_NOCLOSE + return P_NOCLOSE; +#else + goto not_there; +#endif + if (strEQ(name, "P_NOSESSION")) +#ifdef P_NOSESSION + return P_NOSESSION; +#else + goto not_there; +#endif + if (strEQ(name, "P_NOWAIT")) +#ifdef P_NOWAIT + return P_NOWAIT; +#else + goto not_there; +#endif + if (strEQ(name, "P_OVERLAY")) +#ifdef P_OVERLAY + return P_OVERLAY; +#else + goto not_there; +#endif + if (strEQ(name, "P_PM")) +#ifdef P_PM + return P_PM; +#else + goto not_there; +#endif + if (strEQ(name, "P_QUOTE")) +#ifdef P_QUOTE + return P_QUOTE; +#else + goto not_there; +#endif + if (strEQ(name, "P_SESSION")) +#ifdef P_SESSION + return P_SESSION; +#else + goto not_there; +#endif + if (strEQ(name, "P_TILDE")) +#ifdef P_TILDE + return P_TILDE; +#else + goto not_there; +#endif + if (strEQ(name, "P_UNRELATED")) +#ifdef P_UNRELATED + return P_UNRELATED; +#else + goto not_there; +#endif + if (strEQ(name, "P_WAIT")) +#ifdef P_WAIT + return P_WAIT; +#else + goto not_there; +#endif + if (strEQ(name, "P_WINDOWED")) +#ifdef P_WINDOWED + return P_WINDOWED; +#else + goto not_there; +#endif + } else if (name[0] == 'T' && name[1] == '_') { + if (strEQ(name, "FAPPTYP_NOTSPEC")) +#ifdef FAPPTYP_NOTSPEC + return FAPPTYP_NOTSPEC; +#else + goto not_there; +#endif + if (strEQ(name, "T_NOTWINDOWCOMPAT")) +#ifdef FAPPTYP_NOTWINDOWCOMPAT + return FAPPTYP_NOTWINDOWCOMPAT; +#else + goto not_there; +#endif + if (strEQ(name, "T_WINDOWCOMPAT")) +#ifdef FAPPTYP_WINDOWCOMPAT + return FAPPTYP_WINDOWCOMPAT; +#else + goto not_there; +#endif + if (strEQ(name, "T_WINDOWAPI")) +#ifdef FAPPTYP_WINDOWAPI + return FAPPTYP_WINDOWAPI; +#else + goto not_there; +#endif + if (strEQ(name, "T_BOUND")) +#ifdef FAPPTYP_BOUND + return FAPPTYP_BOUND; +#else + goto not_there; +#endif + if (strEQ(name, "T_DLL")) +#ifdef FAPPTYP_DLL + return FAPPTYP_DLL; +#else + goto not_there; +#endif + if (strEQ(name, "T_DOS")) +#ifdef FAPPTYP_DOS + return FAPPTYP_DOS; +#else + goto not_there; +#endif + if (strEQ(name, "T_PHYSDRV")) +#ifdef FAPPTYP_PHYSDRV + return FAPPTYP_PHYSDRV; +#else + goto not_there; +#endif + if (strEQ(name, "T_VIRTDRV")) +#ifdef FAPPTYP_VIRTDRV + return FAPPTYP_VIRTDRV; +#else + goto not_there; +#endif + if (strEQ(name, "T_PROTDLL")) +#ifdef FAPPTYP_PROTDLL + return FAPPTYP_PROTDLL; +#else + goto not_there; +#endif + if (strEQ(name, "T_32BIT")) +#ifdef FAPPTYP_32BIT + return FAPPTYP_32BIT; +#else + goto not_there; +#endif + } + + errno = EINVAL; + return 0; + +not_there: + errno = ENOENT; + return 0; +} + +const char* const ptypes[] = { "FS", "DOS", "VIO", "PM", "DETACH" }; + +static char * +my_type() +{ + int rc; + TIB *tib; + PIB *pib; + + if (!(_emx_env & 0x200)) return (char*)ptypes[1]; /* not OS/2. */ + if (CheckOSError(DosGetInfoBlocks(&tib, &pib))) + return NULL; + + return (pib->pib_ultype <= 4 ? (char*)ptypes[pib->pib_ultype] : "UNKNOWN"); +} + +static ULONG +file_type(char *path) +{ + int rc; + ULONG apptype; + + if (!(_emx_env & 0x200)) + croak("file_type not implemented on DOS"); /* not OS/2. */ + if (CheckOSError(DosQueryAppType(path, &apptype))) { +#if 0 + if (rc == ERROR_INVALID_EXE_SIGNATURE) + croak("Invalid EXE signature"); + else if (rc == ERROR_EXE_MARKED_INVALID) { + croak("EXE marked invalid"); + } +#endif + croak_with_os2error("DosQueryAppType"); + } + + return apptype; +} + +/* These use different type of wrapper. Good to check wrappers. ;-) */ +/* XXXX This assumes DOS type return type, without SEVERITY?! */ +DeclFuncByORD(HSWITCH, myWinQuerySwitchHandle, ORD_WinQuerySwitchHandle, + (HWND hwnd, PID pid), (hwnd, pid)) +DeclFuncByORD(ULONG, myWinQuerySwitchEntry, ORD_WinQuerySwitchEntry, + (HSWITCH hsw, PSWCNTRL pswctl), (hsw, pswctl)) +DeclFuncByORD(ULONG, myWinSetWindowText, ORD_WinSetWindowText, + (HWND hwnd, char* text), (hwnd, text)) +DeclFuncByORD(BOOL, myWinQueryWindowProcess, ORD_WinQueryWindowProcess, + (HWND hwnd, PPID ppid, PTID ptid), (hwnd, ppid, ptid)) +DeclFuncByORD(ULONG, XmyWinSwitchToProgram, ORD_WinSwitchToProgram, + (HSWITCH hsw), (hsw)) +#define myWinSwitchToProgram(hsw) (!CheckOSError(XmyWinSwitchToProgram(hsw))) + + +/* These function croak if the return value is 0. */ +DeclWinFunc_CACHE(HWND, QueryWindow, (HWND hwnd, LONG cmd), (hwnd, cmd)) +DeclWinFunc_CACHE(BOOL, QueryWindowPos, (HWND hwnd, PSWP pswp), + (hwnd, pswp)) +DeclWinFunc_CACHE(LONG, QueryWindowText, + (HWND hwnd, LONG cchBufferMax, PCH pchBuffer), + (hwnd, cchBufferMax, pchBuffer)) +DeclWinFunc_CACHE(LONG, QueryClassName, (HWND hwnd, LONG cchMax, PCH pch), + (hwnd, cchMax, pch)) +DeclWinFunc_CACHE(HWND, QueryFocus, (HWND hwndDesktop), (hwndDesktop)) +DeclWinFunc_CACHE(BOOL, SetFocus, (HWND hwndDesktop, HWND hwndFocus), + (hwndDesktop, hwndFocus)) +DeclWinFunc_CACHE(BOOL, ShowWindow, (HWND hwnd, BOOL fShow), (hwnd, fShow)) +DeclWinFunc_CACHE(BOOL, EnableWindow, (HWND hwnd, BOOL fEnable), + (hwnd, fEnable)) +DeclWinFunc_CACHE(BOOL, SetWindowPos, + (HWND hwnd, HWND hwndInsertBehind, LONG x, LONG y, + LONG cx, LONG cy, ULONG fl), + (hwnd, hwndInsertBehind, x, y, cx, cy, fl)) +DeclWinFunc_CACHE(HENUM, BeginEnumWindows, (HWND hwnd), (hwnd)) +DeclWinFunc_CACHE(BOOL, EndEnumWindows, (HENUM henum), (henum)) +DeclWinFunc_CACHE(BOOL, EnableWindowUpdate, (HWND hwnd, BOOL fEnable), + (hwnd, fEnable)) +DeclWinFunc_CACHE(BOOL, SetWindowBits, + (HWND hwnd, LONG index, ULONG flData, ULONG flMask), + (hwnd, index, flData, flMask)) +DeclWinFunc_CACHE(BOOL, SetWindowPtr, (HWND hwnd, LONG index, PVOID p), + (hwnd, index, p)) +DeclWinFunc_CACHE(BOOL, SetWindowULong, (HWND hwnd, LONG index, ULONG ul), + (hwnd, index, ul)) +DeclWinFunc_CACHE(BOOL, SetWindowUShort, (HWND hwnd, LONG index, USHORT us), + (hwnd, index, us)) +DeclWinFunc_CACHE(HWND, IsChild, (HWND hwnd, HWND hwndParent), + (hwnd, hwndParent)) +DeclWinFunc_CACHE(HWND, WindowFromId, (HWND hwnd, ULONG id), (hwnd, id)) +DeclWinFunc_CACHE(HWND, EnumDlgItem, (HWND hwndDlg, HWND hwnd, ULONG code), + (hwndDlg, hwnd, code)) +DeclWinFunc_CACHE(HWND, QueryDesktopWindow, (HAB hab, HDC hdc), (hab, hdc)); +DeclWinFunc_CACHE(BOOL, SetActiveWindow, (HWND hwndDesktop, HWND hwnd), + (hwndDesktop, hwnd)); +DeclWinFunc_CACHE(BOOL, QueryActiveDesktopPathname, (PSZ pszPathName, ULONG ulSize), + (pszPathName, ulSize)); +DeclWinFunc_CACHE(BOOL, InvalidateRect, + (HWND hwnd, /*RECTL*/ char *prcl, BOOL fIncludeChildren), + (hwnd, prcl, fIncludeChildren)); +DeclWinFunc_CACHE(BOOL, CreateFrameControls, + (HWND hwndFrame, /*PFRAMECDATA*/ char* pfcdata, PCSZ pszTitle), + (hwndFrame, pfcdata, pszTitle)); +DeclWinFunc_CACHE(BOOL, OpenClipbrd, (HAB hab), (hab)); +DeclWinFunc_CACHE(BOOL, EmptyClipbrd, (HAB hab), (hab)); +DeclWinFunc_CACHE(BOOL, CloseClipbrd, (HAB hab), (hab)); +DeclWinFunc_CACHE(BOOL, QueryClipbrdFmtInfo, (HAB hab, ULONG fmt, PULONG prgfFmtInfo), (hab, fmt, prgfFmtInfo)); +DeclWinFunc_CACHE(ULONG, QueryClipbrdData, (HAB hab, ULONG fmt), (hab, fmt)); +DeclWinFunc_CACHE(HWND, SetClipbrdViewer, (HAB hab, HWND hwnd), (hab, hwnd)); +DeclWinFunc_CACHE(HWND, SetClipbrdOwner, (HAB hab, HWND hwnd), (hab, hwnd)); +DeclWinFunc_CACHE(ULONG, EnumClipbrdFmts, (HAB hab, ULONG fmt), (hab, fmt)); +DeclWinFunc_CACHE(ATOM, AddAtom, (HATOMTBL hAtomTbl, PCSZ pszAtomName), + (hAtomTbl, pszAtomName)); +DeclWinFunc_CACHE(ULONG, QueryAtomUsage, (HATOMTBL hAtomTbl, ATOM atom), + (hAtomTbl, atom)); +DeclWinFunc_CACHE(ULONG, QueryAtomLength, (HATOMTBL hAtomTbl, ATOM atom), + (hAtomTbl, atom)); +DeclWinFunc_CACHE(ULONG, QueryAtomName, + (HATOMTBL hAtomTbl, ATOM atom, PSZ pchBuffer, ULONG cchBufferMax), + (hAtomTbl, atom, pchBuffer, cchBufferMax)); +DeclWinFunc_CACHE(HATOMTBL, QuerySystemAtomTable, (VOID), ()); +DeclWinFunc_CACHE(HATOMTBL, CreateAtomTable, (ULONG initial, ULONG buckets), + (initial, buckets)); +DeclWinFunc_CACHE(ULONG, MessageBox, (HWND hwndParent, HWND hwndOwner, PCSZ pszText, PCSZ pszCaption, ULONG idWindow, ULONG flStyle), (hwndParent, hwndOwner, pszText, pszCaption, idWindow, flStyle)); +DeclWinFunc_CACHE(ULONG, MessageBox2, + (HWND hwndParent, HWND hwndOwner, PCSZ pszText, + PCSZ pszCaption, ULONG idWindow, PMB2INFO pmb2info), + (hwndParent, hwndOwner, pszText, pszCaption, idWindow, pmb2info)); +DeclWinFunc_CACHE(HPOINTER, LoadPointer, + (HWND hwndDesktop, HMODULE hmod, ULONG idres), + (hwndDesktop, hmod, idres)); +DeclWinFunc_CACHE(HPOINTER, QuerySysPointer, + (HWND hwndDesktop, LONG lId, BOOL fCopy), + (hwndDesktop, lId, fCopy)); +DeclWinFunc_CACHE(BOOL, Alarm, (HWND hwndDesktop, ULONG rgfType), (hwndDesktop, rgfType)); +DeclWinFunc_CACHE(BOOL, FlashWindow, (HWND hwndFrame, BOOL fFlash), (hwndFrame, fFlash)); + +#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, + (HAB hab, ULONG ulData, ULONG fmt, ULONG rgfFmtInfo), + (hab, ulData, fmt, rgfFmtInfo)); + +#define get_InvalidateRect InvalidateRect +#define get_CreateFrameControls CreateFrameControls + +/* These functions may return 0 on success; check $^E/Perl_rc on res==0: */ +DeclWinFunc_CACHE_resetError(PVOID, QueryWindowPtr, (HWND hwnd, LONG index), + (hwnd, index)) +DeclWinFunc_CACHE_resetError(ULONG, QueryWindowULong, (HWND hwnd, LONG index), + (hwnd, index)) +DeclWinFunc_CACHE_resetError(SHORT, QueryWindowUShort, (HWND hwnd, LONG index), + (hwnd, index)) +DeclWinFunc_CACHE_resetError(LONG, QueryWindowTextLength, (HWND hwnd), (hwnd)) +DeclWinFunc_CACHE_resetError(HWND, QueryActiveWindow, (HWND hwnd), (hwnd)) +DeclWinFunc_CACHE_resetError(BOOL, PostMsg, + (HWND hwnd, ULONG msg, MPARAM mp1, MPARAM mp2), + (hwnd, msg, mp1, mp2)) +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)) + +/* These functions are called frow complicated wrappers: */ +ULONG (*pWinQuerySwitchList) (HAB hab, PSWBLOCK pswblk, ULONG usDataLength); +ULONG (*pWinChangeSwitchEntry) (HSWITCH hsw, __const__ SWCNTRL *pswctl); +HWND (*pWinWindowFromPoint)(HWND hwnd, __const__ POINTL *pptl, BOOL fChildren); + + +/* These functions have different names/signatures than what is + declared above */ +#define QueryFocusWindow QueryFocus +#define FocusWindow_set(hwndFocus, hwndDesktop) SetFocus(hwndDesktop, hwndFocus) +#define WindowPos_set(hwnd, x, y, fl, cx, cy, hwndInsertBehind) \ + SetWindowPos(hwnd, hwndInsertBehind, x, y, cx, cy, fl) +#define myWinQueryWindowPtr(hwnd, i) ((ULONG)QueryWindowPtr(hwnd, i)) +#define _ClipbrdData_set SetClipbrdData +#define ClipbrdOwner_set SetClipbrdOwner +#define ClipbrdViewer_set SetClipbrdViewer + +int +WindowText_set(HWND hwnd, char* text) +{ + return !CheckWinError(myWinSetWindowText(hwnd, text)); +} + +SV * +myQueryWindowText(HWND hwnd) +{ + LONG l = QueryWindowTextLength(hwnd), len; + SV *sv; + STRLEN n_a; + + if (l == 0) { + if (Perl_rc) /* Last error */ + return &PL_sv_undef; + return &PL_sv_no; + } + sv = newSVpvn("", 0); + SvGROW(sv, l + 1); + len = QueryWindowText(hwnd, l + 1, SvPV_force(sv, n_a)); + if (len != l) { + Safefree(sv); + croak("WinQueryWindowText() uncompatible with WinQueryWindowTextLength()"); + } + SvCUR_set(sv, l); + return sv; +} + +SWP +QueryWindowSWP_(HWND hwnd) +{ + SWP swp; + + if (!QueryWindowPos(hwnd, &swp)) + croak("WinQueryWindowPos() error"); + return swp; +} + +SV * +QueryWindowSWP(HWND hwnd) +{ + SWP swp = QueryWindowSWP_(hwnd); + + return newSVpvn((char*)&swp, sizeof(swp)); +} + +SV * +myQueryClassName(HWND hwnd) +{ + SV *sv = newSVpvn("",0); + STRLEN l = 46, len = 0, n_a; + + while (l + 1 >= len) { + if (len) + len = 2*len + 10; /* Grow quick */ + else + len = l + 2; + SvGROW(sv, len); + l = QueryClassName(hwnd, len, SvPV_force(sv, n_a)); + } + SvCUR_set(sv, l); + return sv; +} + +HWND +WindowFromPoint(long x, long y, HWND hwnd, BOOL fChildren) +{ + POINTL ppl; + + ppl.x = x; ppl.y = y; + if (!pWinWindowFromPoint) + AssignFuncPByORD(pWinWindowFromPoint, ORD_WinWindowFromPoint); + return SaveWinError(pWinWindowFromPoint(hwnd, &ppl, fChildren)); +} + +static HSWITCH +switch_of(HWND hwnd, PID pid) +{ + HSWITCH hSwitch; + + if (!(_emx_env & 0x200)) + croak("switch_entry not implemented on DOS"); /* not OS/2. */ + if (CheckWinError(hSwitch = + myWinQuerySwitchHandle(hwnd, pid))) + croak_with_os2error("WinQuerySwitchHandle"); + return hSwitch; +} + + +static void +fill_swentry(SWENTRY *swentryp, HWND hwnd, PID pid) +{ + int rc; + HSWITCH hSwitch = switch_of(hwnd, pid); + + swentryp->hswitch = hSwitch; + if (CheckOSError(myWinQuerySwitchEntry(hSwitch, &swentryp->swctl))) + croak_with_os2error("WinQuerySwitchEntry"); +} + +static void +fill_swentry_default(SWENTRY *swentryp) +{ + fill_swentry(swentryp, NULLHANDLE, getpid()); +} + +static SV* +myWinQueryActiveDesktopPathname() +{ + SV *buf = newSVpv("",0); + STRLEN n_a; + + SvGROW(buf, MAXPATHLEN); + QueryActiveDesktopPathname(SvPV(buf,n_a), MAXPATHLEN); + SvCUR_set(buf, strlen(SvPV(buf, n_a))); + return buf; +} + +SV * +myWinQueryAtomName(ATOM atom, HATOMTBL hAtomTbl) +{ + ULONG len = QueryAtomLength(hAtomTbl, atom); + + if (len) { /* Probably always so... */ + SV *sv = newSVpvn("",0); + STRLEN n_a; + + SvGROW(sv, len + 1); + 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 + +/* Put data into shared memory, then call SetClipbrdData */ +void +ClipbrdData_set(SV *sv, int convert_nl, unsigned long fmt, unsigned long rgfFmtInfo, HAB hab) +{ + STRLEN len; + char *buf; + char *pByte = 0, *s, c; + ULONG nls = 0, rc, handle; + + 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, + PAG_WRITE | PAG_COMMIT | OBJ_GIVEABLE | OBJ_GETTABLE))) + croak_with_os2error("ClipbrdData_set: DosAllocSharedMem error"); + + if (!nls) + memcpy(pByte, buf, len + 1); + else { + char *t = pByte, *e = buf + len; + + while (buf < e) { + c = *t++ = *buf++; + if (c == '\n' && (t == pByte + 1 || t[-2] != '\r')) + t[-1] = '\r', *t++ = '\n'; + } + } + handle = (ULONG)pByte; + } else { + handle = (ULONG)SvUV(sv); + } + + 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 +myWinMessageBox(HWND hwndParent, HWND hwndOwner, PCSZ pszText, PCSZ pszCaption, ULONG idWindow, ULONG flStyle) +{ + ULONG rc = MessageBox(hwndParent, hwndOwner, pszText, pszCaption, + idWindow, flStyle); + + if (rc == MBID_ERROR) + rc = 0; + if (CheckWinError(rc)) + croak_with_os2error("MessageBox"); + return rc; +} + +ULONG +myWinMessageBox2(HWND hwndParent, HWND hwndOwner, PCSZ pszText, + PCSZ pszCaption, ULONG idWindow, PMB2INFO pmb2info) +{ + ULONG rc = MessageBox2(hwndParent, hwndOwner, pszText, pszCaption, idWindow, pmb2info); + + if (rc == MBID_ERROR) + rc = 0; + if (CheckWinError(rc)) + croak_with_os2error("MessageBox2"); + return rc; +} +#endif + +/* static ULONG (* APIENTRY16 pDosSmSetTitle)(ULONG, PSZ); */ +ULONG _THUNK_FUNCTION(DosSmSetTitle)(ULONG, PSZ); + +#if 0 /* Does not work. */ +static ULONG (*pDosSmSetTitle)(ULONG, PSZ); + +static void +sesmgr_title_set(char *s) +{ + SWENTRY swentry; + static HMODULE hdosc = 0; + BYTE buf[20]; + long rc; + + fill_swentry_default(&swentry); + if (!pDosSmSetTitle || !hdosc) { + if (CheckOSError(DosLoadModule(buf, sizeof buf, "sesmgr", &hdosc))) + croak("Cannot load SESMGR: no `%s'", buf); + if (CheckOSError(DosQueryProcAddr(hdosc, 0, "DOSSMSETTITLE", + (PFN*)&pDosSmSetTitle))) + croak("Cannot load SESMGR.DOSSMSETTITLE, err=%ld", rc); + } +/* (pDosSmSetTitle)(swcntrl.idSession,s); */ + rc = ((USHORT) + (_THUNK_PROLOG (2+4); + _THUNK_SHORT (swcntrl.idSession); + _THUNK_FLAT (s); + _THUNK_CALLI (*pDosSmSetTitle))); + if (CheckOSError(rc)) + warn("*DOSSMSETTITLE: err=%ld, ses=%ld, addr=%x, *paddr=%x", + rc, swcntrl.idSession, &_THUNK_FUNCTION(DosSmSetTitle), + pDosSmSetTitle); +} + +#else /* !0 */ + +static bool +sesmgr_title_set(char *s) +{ + SWENTRY swentry; + long rc; + + fill_swentry_default(&swentry); + rc = ((USHORT) + (_THUNK_PROLOG (2+4); + _THUNK_SHORT (swentry.swctl.idSession); + _THUNK_FLAT (s); + _THUNK_CALL (DosSmSetTitle))); +#if 0 + if (CheckOSError(rc)) + warn("DOSSMSETTITLE: err=%ld, ses=%ld, addr=%x", + rc, swcntrl.idSession, _THUNK_FUNCTION(DosSmSetTitle)); +#endif + return !CheckOSError(rc); +} +#endif /* !0 */ + +#if 0 /* Does not work. */ +USHORT _THUNK_FUNCTION(Win16SetTitle) (); + +static void +set_title2(char *s) +{ + long rc; + + rc = ((USHORT) + (_THUNK_PROLOG (4); + _THUNK_FLAT (s); + _THUNK_CALL (Win16SetTitle))); + if (CheckWinError(rc)) + warn("Win16SetTitle: err=%ld", rc); +} +#endif + +SV * +process_swentry(unsigned long pid, HWND hwnd) +{ + SWENTRY swentry; + + if (!(_emx_env & 0x200)) + croak("process_swentry not implemented on DOS"); /* not OS/2. */ + fill_swentry(&swentry, hwnd, pid); + return newSVpvn((char*)&swentry, sizeof(swentry)); +} + +SV * +swentries_list() +{ + int num, n = 0; + STRLEN n_a; + PSWBLOCK pswblk; + SV *sv = newSVpvn("",0); + + if (!(_emx_env & 0x200)) + croak("swentries_list not implemented on DOS"); /* not OS/2. */ + if (!pWinQuerySwitchList) + AssignFuncPByORD(pWinQuerySwitchList, ORD_WinQuerySwitchList); + num = pWinQuerySwitchList(0, NULL, 0); /* HAB is not required */ + if (!num) + croak("(Unknown) error during WinQuerySwitchList()"); + /* Allow one extra entry to allow overflow detection (may happen + if the list has been changed). */ + while (num > n) { + if (n == 0) + n = num + 1; + else + n = 2*num + 10; /* Enlarge quickly */ + SvGROW(sv, sizeof(ULONG) + sizeof(SWENTRY) * n + 1); + pswblk = (PSWBLOCK) SvPV_force(sv, n_a); + num = pWinQuerySwitchList(0, pswblk, SvLEN(sv)); + } + SvCUR_set(sv, sizeof(ULONG) + sizeof(SWENTRY) * num); + *SvEND(sv) = 0; + return sv; +} + +SWENTRY +swentry( char *title, HWND sw_hwnd, HWND icon_hwnd, HPROGRAM owner_phandle, + PID owner_pid, ULONG owner_sid, ULONG visible, ULONG nonswitchable, + ULONG jumpable, ULONG ptype, HSWITCH sw_entry) +{ + SWENTRY e; + + strncpy(e.swctl.szSwtitle, title, MAXNAMEL); + e.swctl.szSwtitle[60] = 0; + e.swctl.hwnd = sw_hwnd; + e.swctl.hwndIcon = icon_hwnd; + e.swctl.hprog = owner_phandle; + e.swctl.idProcess = owner_pid; + e.swctl.idSession = owner_sid; + e.swctl.uchVisibility = ((visible ? SWL_VISIBLE : SWL_INVISIBLE) + | (nonswitchable ? SWL_GRAYED : 0)); + e.swctl.fbJump = (jumpable ? SWL_JUMPABLE : 0); + e.swctl.bProgType = ptype; + e.hswitch = sw_entry; + return e; +} + +SV * +create_swentry( char *title, HWND owner_hwnd, HWND icon_hwnd, HPROGRAM owner_phandle, + PID owner_pid, ULONG owner_sid, ULONG visible, ULONG nonswitchable, + ULONG jumpable, ULONG ptype, HSWITCH sw_entry) +{ + SWENTRY e = swentry(title, owner_hwnd, icon_hwnd, owner_phandle, owner_pid, + owner_sid, visible, nonswitchable, jumpable, ptype, + sw_entry); + + return newSVpvn((char*)&e, sizeof(e)); +} + +int +change_swentrysw(SWENTRY *sw) +{ + ULONG rc; /* For CheckOSError */ + + if (!(_emx_env & 0x200)) + croak("change_entry() not implemented on DOS"); /* not OS/2. */ + if (!pWinChangeSwitchEntry) + AssignFuncPByORD(pWinChangeSwitchEntry, ORD_WinChangeSwitchEntry); + return !CheckOSError(pWinChangeSwitchEntry(sw->hswitch, &sw->swctl)); +} + +int +change_swentry(SV *sv) +{ + STRLEN l; + PSWENTRY pswentry = (PSWENTRY)SvPV(sv, l); + + if (l != sizeof(SWENTRY)) + croak("Wrong structure size %ld!=%ld in change_swentry()", (long)l, (long)sizeof(SWENTRY)); + return change_swentrysw(pswentry); +} + + +#define swentry_size() (sizeof(SWENTRY)) + +void +getscrsize(int *wp, int *hp) +{ + int i[2]; + + _scrsize(i); + *wp = i[0]; + *hp = i[1]; +} + +/* Force vio to not cross 64K-boundary: */ +#define VIO_FROM_VIOB \ + vio = viob; \ + if (!_THUNK_PTR_STRUCT_OK(vio)) \ + vio++ + +bool +scrsize_set(int w, int h) +{ + VIOMODEINFO viob[2], *vio; + ULONG rc; + + VIO_FROM_VIOB; + + if (h == -9999) + h = w, w = 0; + vio->cb = sizeof(*vio); + if (CheckOSError(VioGetMode( vio, 0 ))) + return 0; + + if( w > 0 ) + vio->col = (USHORT)w; + + if( h > 0 ) + vio->row = (USHORT)h; + + vio->cb = 8; + if (CheckOSError(VioSetMode( vio, 0 ))) + return 0; + return 1; +} + +void +cursor(int *sp, int *ep, int *wp, int *ap) +{ + VIOCURSORINFO viob[2], *vio; + ULONG rc; + + VIO_FROM_VIOB; + + if (CheckOSError(VioGetCurType( vio, 0 ))) + croak_with_os2error("VioGetCurType() error"); + + *sp = vio->yStart; + *ep = vio->cEnd; + *wp = vio->cx; + *ep = vio->attr; +} + +bool +cursor__(int is_a) +{ + int s,e,w,a; + + cursor(&s, &e, &w, &a); + if (is_a) + return a; + else + return w; +} + +bool +cursor_set(int s, int e, int w, int a) +{ + VIOCURSORINFO viob[2], *vio; + ULONG rc; + + VIO_FROM_VIOB; + + vio->yStart = s; + vio->cEnd = e; + vio->cx = w; + vio->attr = a; + return !CheckOSError(VioSetCurType( vio, 0 )); +} + +static int +bufsize(void) +{ +#if 1 + VIOMODEINFO viob[2], *vio; + ULONG rc; + + VIO_FROM_VIOB; + + vio->cb = sizeof(*vio); + if (CheckOSError(VioGetMode( vio, 0 ))) + croak_with_os2error("Can't get size of buffer for screen"); +#if 0 /* buf=323552247, full=1118455, partial=0 */ + croak("Lengths: buf=%d, full=%d, partial=%d",vio->buf_length,vio->full_length,vio->partial_length); + return newSVpvn((char*)vio->buf_addr, vio->full_length); +#endif + return vio->col * vio->row * 2; /* How to get bytes/cell? 2 or 4? */ +#else /* 0 */ + int i[2]; + + _scrsize(i); + return i[0]*i[1]*2; +#endif /* 0 */ +} + +SV* +_kbdChar(unsigned int nowait, int handle) +{ + KBDKEYINFO viob[2], *vio; + ULONG rc; + + VIO_FROM_VIOB; + + if (nowait > 2) + croak("unexpected nowait"); + if (CheckOSError(nowait == 2 + ? KbdPeek( vio, handle ) + : KbdCharIn( vio, nowait == 1, handle ))) + croak_with_os2error("Can't _kbdChar"); + return newSVpvn((char*)vio, sizeof(*vio)); +} + +SV* +_kbdStatus(int handle) +{ + KBDINFO viob[2], *vio; + ULONG rc; + + VIO_FROM_VIOB; + + vio->cb = sizeof(*vio); + if (CheckOSError(KbdGetStatus( vio, handle ))) + croak_with_os2error("Can't _kbdStatus"); + return newSVpvn((char*)vio, sizeof(*vio)); +} + +void +_kbdStatus_set(SV* sv, int handle) +{ + KBDINFO viob[2], *vio; + ULONG rc; + STRLEN l; + char *s = SvPV(sv, l); + + VIO_FROM_VIOB; + + if (l != sizeof(*vio)) + croak("unexpected datasize"); + Copy((KBDINFO*)s, vio, 1, KBDINFO); + if (vio->cb != sizeof(*vio)) + croak("unexpected datasize"); + if (CheckOSError(KbdSetStatus( vio, handle ))) + croak_with_os2error("Can't kbdStatus_set()"); +} + +SV* +_vioConfig(int which, int handle) +{ + struct {VIOCONFIGINFO i; short a[20];} viob[2], *vio; + ULONG rc; + + VIO_FROM_VIOB; + + vio->i.cb = 2; + if (CheckOSError(VioGetConfig( which, &vio->i, handle ))) + croak_with_os2error("Can't get VIO config size"); + if (vio->i.cb > sizeof(*vio)) + vio->i.cb = sizeof(*vio); + if (CheckOSError(VioGetConfig( which, &vio->i, handle ))) + croak_with_os2error("Can't get VIO config"); + return newSVpvn((char*)vio, vio->i.cb); +} + +SV* +_vioMode(void) +{ + VIOMODEINFO viob[2], *vio; + ULONG rc; + + VIO_FROM_VIOB; + + vio->cb = sizeof(*vio); + if (CheckOSError(VioGetMode( vio, 0 ))) + croak_with_os2error("Can't get VIO mode"); + return newSVpvn((char*)vio, sizeof(*vio)); +} + +void +_vioMode_set(SV* sv) +{ + VIOMODEINFO viob[2], *vio; + ULONG rc; + STRLEN l; + char *s = SvPV(sv, l); + + VIO_FROM_VIOB; + + Copy((VIOMODEINFO*)s, vio, 1, VIOMODEINFO); + if (vio->cb != sizeof(*vio) || l != vio->cb) + croak("unexpected datasize"); + if (CheckOSError(VioSetMode( vio, 0 ))) + croak_with_os2error("Can't set VIO mode"); +} + +SV* +vioFont(int type, int *w, int *h) /* 0 for actual RAM font, 1 for ROM font */ +{ + VIOFONTINFO viob[2], *vio; + ULONG rc; + UCHAR b[1<<17]; + UCHAR *buf = b; + SV *sv; + + VIO_FROM_VIOB; + + /* Should not cross 64K boundaries too: */ + if (((ULONG)buf) & 0xFFFF) + buf += 0x10000 - (((ULONG)buf) & 0xFFFF); + + vio->cb = sizeof(*vio); + vio->type = type; /* BIOS or the loaded font. */ + vio->cbData = 0xFFFF; /* How large is my buffer? */ + vio->pbData = _emx_32to16(buf); /* Wants an 16:16 pointer */ + if (CheckOSError(VioGetFont( vio, 0 ))) + croak_with_os2error("Can't get VIO font"); + *w = vio->cxCell; + *h = vio->cyCell; + return newSVpvn(buf,vio->cbData); +} + +void +vioFont_set(SV *sv, int cellwidth, int cellheight, int type) +{ + VIOFONTINFO viob[2], *vio; + ULONG rc; + UCHAR b[1<<17]; + UCHAR *buf = b; + STRLEN l; + char *s = SvPV(sv, l); + + VIO_FROM_VIOB; + + /* Should not cross 64K boundaries too: */ + if (((ULONG)buf) & 0xFFFF) + buf += 0x10000 - (((ULONG)buf) & 0xFFFF); + + if (l > 0xFFFF) + croak("length overflow of VIO font"); + if (l != (cellwidth + 7)/8 * cellheight * 256) + warn("unexpected length of VIO font"); + vio->cb = sizeof(*vio); + vio->type = type; /* BIOS or the loaded font. */ + vio->cbData = l; /* How large is my buffer? */ + vio->pbData = _emx_32to16(buf); /* Wants an 16:16 pointer */ + vio->cxCell = cellwidth; + vio->cyCell = cellheight; + Copy(s, buf, l, char); + + if (CheckOSError(VioSetFont( vio, 0 ))) + croak_with_os2error("Can't set VIO font"); +} + +/* + uses use32,os2def,os2base,crt,defs; + var Plt :Plt256; + const Pal :VioPalState=(Cb:sizeof(VioPalState);rType:0;iFirst:0; + Acolor:($FF,$FF,$FF,$FF,$FF,$FF,$FF,$FF,$FF,$FF,$FF,$FF,$FF,$FF,$FF,$FF)); + CReg:VioColorReg=(Cb:sizeof(VioColorReg);rType:3;FirstColorReg:0; + NumColorRegs:256; ColorRegAddr:@Plt); + var ii:Pointer; + begin + VioGetState(Pal,0); + Pal.Acolor[09]:=$0F; + Pal.Acolor[10]:=$A; + Pal.Acolor[13]:=$2F; + VioSetState(Pal,0); // ce smena EGA registrov + asm + lea eax,Plt + call DosFlatToSel + mov ii,eax + end; + CReg.ColorRegAddr:=ii; + VioGetState(CReg,0); + Plt[10,0]:=$00; + Plt[10,1]:=$32; + Plt[10,2]:=$2A; + VioSetState(CReg,0); // a ce - VGA registrov + end. +*/ + +typedef union { + VIOPALSTATE pal; + struct { VIOPALSTATE pal; USHORT a[15]; } pal_padded; + VIOOVERSCAN overscan; + VIOINTENSITY intensity; + VIOCOLORREG colorreg; + struct { VIOCOLORREG reg; char rgb[3*256]; } colorreg_padded; + VIOSETULINELOC lineloc; + VIOSETTARGET target; +} my_VIOSTATE; + +int +vio_state_size(int what) +{ + static const char sizes[] = { + sizeof(VIOPALSTATE), + sizeof(VIOOVERSCAN), + sizeof(VIOINTENSITY), + sizeof(VIOCOLORREG), + 6, /* Random number: Reserved entry */ + sizeof(VIOSETULINELOC), + sizeof(VIOSETTARGET) + }; + if (what < 0 || what >= sizeof(sizes)) + croak("Unexpected VIO state type"); + return sizes[what]; +} + +SV* +_vioState(int what, int first, int count) +{ + my_VIOSTATE viob[2], *vio; + ULONG rc, size = vio_state_size(what); + + VIO_FROM_VIOB; + + vio->pal.cb = size; + vio->pal.type = what; + if (what == 0) { + vio->pal.iFirst = first; + if (first < 0 || first >= 16) + croak("unexpected palette start value"); + if (count < 0 || count > 16) + croak("unexpected palette count"); + vio->pal.cb = (size += (count - 1) * sizeof(short)); + } else if (what == 3) { + /* Wants an 16:16 pointer */ + if (count < 0 || count > 256) + croak("unexpected palette count"); + vio->colorreg.colorregaddr = (PCH)_emx_32to16(vio->colorreg_padded.rgb); + vio->colorreg.numcolorregs = count; /* 256 is max */ + vio->colorreg.firstcolorreg = first; + size += 3 * count; + } + if (CheckOSError(VioGetState( (void*)vio, 0 ))) + croak_with_os2error("Can't get VIO state"); + return newSVpvn((char*)vio, size); +} + +void +_vioState_set(SV *sv) +{ + my_VIOSTATE viob[2], *ovio = (my_VIOSTATE*)SvPV_nolen(sv), *vio = ovio; + int what = ovio->pal.type, cb = ovio->pal.cb; + ULONG rc, size = vio_state_size(what); + STRLEN l; + char *s = SvPV(sv, l); + + VIO_FROM_VIOB; + + switch (what) { + case 0: + if ( cb < size || cb > size + 15*sizeof(SHORT) || l != cb) + croak("unexpected datasize"); + size = l; + break; + case 3: + if (l != cb + 3 * ovio->colorreg.numcolorregs || cb != size) + croak("unexpected datasize"); + size = l; + break; + default: + if (l != cb || l != size ) + croak("unexpected datasize"); + break; + } + Copy(s, (char*)vio, size, char); + if (what == 3) /* We expect colors put after VIOCOLORREG */ + vio->colorreg.colorregaddr = (PCH)_emx_32to16(vio->colorreg_padded.rgb); + + if (CheckOSError(VioSetState( (void*)vio, 0 ))) + croak_with_os2error("Can't set VIO state"); +} + +SV * +screen(void) +{ + ULONG rc; + USHORT bufl = bufsize(); + char b[(1<<16) * 3]; /* This/3 is enough for 16-bit calls, we need + 2x overhead due to 2 vs 4 issue, and extra + 64K due to alignment logic */ + char *buf = b; + + if (((ULONG)buf) & 0xFFFF) + buf += 0x10000 - (((ULONG)buf) & 0xFFFF); + if ((sizeof(b) - (buf - b)) < 2*bufl) + croak("panic: VIO buffer allocation"); + if (CheckOSError(VioReadCellStr( buf, &bufl, 0, 0, 0 ))) + return &PL_sv_undef; + return newSVpvn(buf,bufl); +} + +bool +screen_set(SV *sv) +{ + ULONG rc; + STRLEN l = SvCUR(sv), bufl = bufsize(); + char b[(1<<16) * 2]; /* This/2 is enough for 16-bit calls, we need + extra 64K due to alignment logic */ + char *buf = b; + + if (((ULONG)buf) & 0xFFFF) + buf += 0x10000 - (((ULONG)buf) & 0xFFFF); + if (!SvPOK(sv) || ((l != bufl) && (l != 2*bufl))) + croak("Wrong size %d of saved screen data", SvCUR(sv)); + if ((sizeof(b) - (buf - b)) < l) + croak("panic: VIO buffer allocation"); + Copy(SvPV(sv,l), buf, bufl, char); + if (CheckOSError(VioWrtCellStr( buf, bufl, 0, 0, 0 ))) + return 0; + return 1; +} + +int +process_codepages() +{ + ULONG cps[4], cp, rc; + + if (CheckOSError(DosQueryCp( sizeof(cps), cps, &cp ))) + croak_with_os2error("DosQueryCp()"); + return cp; +} + +int +out_codepage() +{ + USHORT cp, rc; + + if (CheckOSError(VioGetCp( 0, &cp, 0 ))) + croak_with_os2error("VioGetCp()"); + return cp; +} + +bool +out_codepage_set(int cp) +{ + USHORT rc; + + return !(CheckOSError(VioSetCp( 0, cp, 0 ))); +} + +int +in_codepage() +{ + USHORT cp, rc; + + if (CheckOSError(KbdGetCp( 0, &cp, 0 ))) + croak_with_os2error("KbdGetCp()"); + return cp; +} + +bool +in_codepage_set(int cp) +{ + USHORT rc; + + return !(CheckOSError(KbdSetCp( 0, cp, 0 ))); +} + +bool +process_codepage_set(int cp) +{ + USHORT rc; + + return !(CheckOSError(DosSetProcessCp( cp ))); +} + +int +ppidOf(int pid) +{ + PQTOPLEVEL psi; + int ppid; + + if (!pid) + return -1; + psi = get_sysinfo(pid, QSS_PROCESS); + if (!psi) + return -1; + ppid = psi->procdata->ppid; + Safefree(psi); + return ppid; +} + +int +sidOf(int pid) +{ + PQTOPLEVEL psi; + int sid; + + if (!pid) + return -1; + psi = get_sysinfo(pid, QSS_PROCESS); + if (!psi) + return -1; + sid = psi->procdata->sessid; + Safefree(psi); + 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)) +#define ulMPFROM2SHORT(x1,x2) ((unsigned long)MPFROM2SHORT(x1,x2)) +#define ulMPFROMSH2CH(s, c1, c2) ((unsigned long)MPFROMSH2CH(s, c1, c2)) +#define ulMPFROMLONG(x) ((unsigned long)MPFROMLONG(x)) + +#define _MessageBox MessageBox +#define _MessageBox2 MessageBox2 + +MODULE = OS2::Process PACKAGE = OS2::Process + +PROTOTYPES: ENABLE + +unsigned long +constant(name,arg) + char * name + int arg + +char * +my_type() + +U32 +file_type(path) + char *path + +SV * +swentry_expand( SV *sv ) + PPCODE: + { + STRLEN l; + PSWENTRY pswentry = (PSWENTRY)SvPV(sv, l); + + if (l != sizeof(SWENTRY)) + croak("Wrong structure size %ld!=%ld in swentry_expand()", (long)l, (long)sizeof(SWENTRY)); + EXTEND(sp,11); + PUSHs(sv_2mortal(newSVpv(pswentry->swctl.szSwtitle, 0))); + PUSHs(sv_2mortal(newSVnv(pswentry->swctl.hwnd))); + PUSHs(sv_2mortal(newSVnv(pswentry->swctl.hwndIcon))); + PUSHs(sv_2mortal(newSViv(pswentry->swctl.hprog))); + PUSHs(sv_2mortal(newSViv(pswentry->swctl.idProcess))); + PUSHs(sv_2mortal(newSViv(pswentry->swctl.idSession))); + PUSHs(sv_2mortal(newSViv(pswentry->swctl.uchVisibility & SWL_VISIBLE))); + PUSHs(sv_2mortal(newSViv(pswentry->swctl.uchVisibility & SWL_GRAYED))); + PUSHs(sv_2mortal(newSViv(pswentry->swctl.fbJump == SWL_JUMPABLE))); + PUSHs(sv_2mortal(newSViv(pswentry->swctl.bProgType))); + PUSHs(sv_2mortal(newSViv(pswentry->hswitch))); + } + +SV * +create_swentry( char *title, unsigned long sw_hwnd, unsigned long icon_hwnd, unsigned long owner_phandle, unsigned long owner_pid, unsigned long owner_sid, unsigned long visible, unsigned long switchable, unsigned long jumpable, unsigned long ptype, unsigned long sw_entry) +PROTOTYPE: DISABLE + +int +change_swentry( SV *sv ) + +bool +sesmgr_title_set(s) + char *s + +SV * +process_swentry(unsigned long pid = getpid(), HWND hwnd = NULLHANDLE); + PROTOTYPE: DISABLE + +int +swentry_size() + +SV * +swentries_list() + +void +ResetWinError() + POSTCALL: + XSRETURN_YES; + +int +WindowText_set(HWND hwndFrame, char *title) + +bool +FocusWindow_set(HWND hwndFocus, HWND hwndDesktop = HWND_DESKTOP) + +bool +ShowWindow(HWND hwnd, bool fShow = TRUE) + +bool +EnableWindow(HWND hwnd, bool fEnable = TRUE) + +bool +PostMsg(HWND hwnd, unsigned long msg, unsigned long mp1 = 0, unsigned long mp2 = 0) + C_ARGS: hwnd, msg, (MPARAM)mp1, (MPARAM)mp2 + +bool +WindowPos_set(HWND hwnd, long x, long y, unsigned long fl = SWP_MOVE, long cx = 0, long cy = 0, HWND hwndInsertBehind = HWND_TOP) + PROTOTYPE: DISABLE + +unsigned long +BeginEnumWindows(HWND hwnd) + +bool +EndEnumWindows(unsigned long henum) + +unsigned long +GetNextWindow(unsigned long henum) + +bool +IsWindowVisible(HWND hwnd) + +bool +IsWindowEnabled(HWND hwnd) + +bool +IsWindowShowing(HWND hwnd) + +unsigned long +QueryWindow(HWND hwnd, long cmd) + +unsigned long +IsChild(HWND hwnd, HWND hwndParent) + +unsigned long +WindowFromId(HWND hwndParent, unsigned long id) + +unsigned long +WindowFromPoint(long x, long y, HWND hwnd = HWND_DESKTOP, bool fChildren = TRUE) +PROTOTYPE: DISABLE + +unsigned long +EnumDlgItem(HWND hwndDlg, unsigned long code, HWND hwnd = NULLHANDLE) + C_ARGS: hwndDlg, hwnd, code + +bool +EnableWindowUpdate(HWND hwnd, bool fEnable = TRUE) + +bool +SetWindowBits(HWND hwnd, long index, unsigned long flData, unsigned long flMask) + +bool +SetWindowPtr(HWND hwnd, long index, unsigned long p) + C_ARGS: hwnd, index, (PVOID)p + +bool +SetWindowULong(HWND hwnd, long index, unsigned long i) + +bool +SetWindowUShort(HWND hwnd, long index, unsigned short i) + +bool +IsWindow(HWND hwnd, HAB hab = Acquire_hab()) + C_ARGS: hab, hwnd + +BOOL +ActiveWindow_set(HWND hwnd, HWND hwndDesktop = HWND_DESKTOP) + CODE: + RETVAL = SetActiveWindow(hwndDesktop, hwnd); + +unsigned long +LoadPointer(unsigned long idres, unsigned long hmod = 0, HWND hwndDesktop = HWND_DESKTOP) + C_ARGS: hwndDesktop, hmod, idres + +int +out_codepage() + +bool +out_codepage_set(int cp) + +int +in_codepage() + +bool +in_codepage_set(int cp) + +SV * +screen() + +bool +screen_set(SV *sv) + +SV * +process_codepages() + PPCODE: + { + ULONG cps[4], c, i = 0, rc; + + if (CheckOSError(DosQueryCp( sizeof(cps), cps, &c ))) + c = 0; + c /= sizeof(ULONG); + if (c >= 3) + EXTEND(sp, c); + while (i < c) + PUSHs(sv_2mortal(newSViv(cps[i++]))); + } + +bool +process_codepage_set(int cp) + +void +cursor(OUTLIST int stp, OUTLIST int ep, OUTLIST int wp, OUTLIST int ap) + PROTOTYPE: + +bool +cursor_set(int s, int e, int w = cursor__(0), int a = cursor__(1)) + +SV* +_kbdChar(int nowait = 0, int handle = 0) + +SV* +_kbdStatus(int handle = 0) + +void +_kbdStatus_set(SV *sv, int handle = 0) + POSTCALL: + XSRETURN_YES; + +SV* +_vioConfig(int which = 0, int handle = 0) + +SV* +_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 = 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 = 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()) + C_ARGS: hab, fmt + +unsigned long +AddAtom(char *pszAtomName, HATOMTBL hAtomTbl = QuerySystemAtomTable()) + C_ARGS: hAtomTbl, pszAtomName + +unsigned long +FindAtom(char *pszAtomName, HATOMTBL hAtomTbl = QuerySystemAtomTable()) + C_ARGS: hAtomTbl, pszAtomName + +unsigned long +_DeleteAtom(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 + +SV * +myQueryWindowText(HWND hwnd) + +SV * +myQueryClassName(HWND hwnd) + +MODULE = OS2::Process PACKAGE = OS2::Process PREFIX = Query + +unsigned long +QueryFocusWindow(HWND hwndDesktop = HWND_DESKTOP) + +long +QueryWindowTextLength(HWND hwnd) + +SV * +QueryWindowSWP(HWND hwnd) + +unsigned long +QueryWindowULong(HWND hwnd, long index) + +unsigned short +QueryWindowUShort(HWND hwnd, long index) + +unsigned long +QueryActiveWindow(HWND hwnd = HWND_DESKTOP) + +unsigned long +QueryDesktopWindow(HAB hab = Acquire_hab(), unsigned long hdc = NULLHANDLE) + +unsigned long +QueryClipbrdData(unsigned long fmt = CF_TEXT, HAB hab = perl_hab_GET()) + C_ARGS: hab, fmt + PROTOTYPE: DISABLE + +ULONG +QueryMemoryRegionSize(ULONG addr, OUTLIST ULONG flagp, ULONG len = 0xFFFFFFFF - addr, I32 interrupt = 1) + +unsigned long +QueryClipbrdViewer(HAB hab = perl_hab_GET()) + +unsigned long +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()) + +unsigned long +QueryAtomUsage(ATOM atom, HATOMTBL hAtomTbl = QuerySystemAtomTable()) + C_ARGS: hAtomTbl, atom + +unsigned long +QueryAtomLength(ATOM atom, HATOMTBL hAtomTbl = QuerySystemAtomTable()) + C_ARGS: hAtomTbl, atom + POSTCALL: + if (!RETVAL) + XSRETURN_EMPTY; + +unsigned long +QuerySystemAtomTable() + +unsigned long +QuerySysPointer(long lId, bool fCopy = 1, HWND hwndDesktop = HWND_DESKTOP) + C_ARGS: hwndDesktop, lId, fCopy + +unsigned long +CreateAtomTable(unsigned long initial = 0, unsigned long buckets = 0) + +unsigned long +_DestroyAtomTable(HATOMTBL hAtomTbl) + PROTOTYPE: DISABLE + + +MODULE = OS2::Process PACKAGE = OS2::Process PREFIX = myWinQuery + +unsigned long +myWinQueryWindowPtr(HWND hwnd, long index) + +NO_OUTPUT BOOL +myWinQueryWindowProcess(HWND hwnd, OUTLIST unsigned long pid, OUTLIST unsigned long tid) + PROTOTYPE: $ + POSTCALL: + if (CheckWinError(RETVAL)) + croak_with_os2error("WindowProcess() error"); + +SV * +myWinQueryActiveDesktopPathname() + +void +myWinQueryClipbrdFmtInfo(OUTLIST unsigned long prgfFmtInfo, unsigned long fmt = CF_TEXT, HAB hab = perl_hab_GET()) + C_ARGS: hab, fmt, &prgfFmtInfo + +SV * +myWinQueryAtomName(ATOM atom, HATOMTBL hAtomTbl = QuerySystemAtomTable()) + +MODULE = OS2::Process PACKAGE = OS2::Process PREFIX = myWin + +int +myWinSwitchToProgram(HSWITCH hsw = switch_of(NULLHANDLE, getpid())) + PREINIT: + ULONG rc; + +#if 0 + +unsigned long +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 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 = "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) + RETVAL = 0; + +MODULE = OS2::Process PACKAGE = OS2::Process PREFIX = myWinQuery + +MODULE = OS2::Process PACKAGE = OS2::Process PREFIX = get + +int +getppid() + +int +ppidOf(int pid = getpid()) + +int +sidOf(int pid = getpid()) + +void +getscrsize(OUTLIST int wp, OUTLIST int hp) + PROTOTYPE: + +bool +scrsize_set(int w_or_h, int h = -9999) + +void +get_InvalidateRect(HWND hwnd, char *prcl, bool fIncludeChildren) + +void +get_CreateFrameControls(HWND hwndFrame, char *pfcdata, char* pszTitle) + +MODULE = OS2::Process PACKAGE = OS2::Process PREFIX = ul + +unsigned long +ulMPFROMSHORT(unsigned short i) + +unsigned long +ulMPVOID() + +unsigned long +ulMPFROMCHAR(unsigned char i) + +unsigned long +ulMPFROM2SHORT(unsigned short x1, unsigned short x2) + PROTOTYPE: DISABLE + +unsigned long +ulMPFROMSH2CH(unsigned short s, unsigned char c1, unsigned char c2) + PROTOTYPE: DISABLE + +unsigned long +ulMPFROMLONG(unsigned long x) + diff --git a/os2/OS2/OS2-Process/t/os2_atoms.t b/os2/OS2/OS2-Process/t/os2_atoms.t new file mode 100644 index 0000000000..5d9603f2c9 --- /dev/null +++ b/os2/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/OS2-Process/t/os2_clipboard.t b/os2/OS2/OS2-Process/t/os2_clipboard.t new file mode 100644 index 0000000000..398a5fee7d --- /dev/null +++ b/os2/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/OS2-Process/t/os2_process.t b/os2/OS2/OS2-Process/t/os2_process.t new file mode 100644 index 0000000000..18d8fe2a11 --- /dev/null +++ b/os2/OS2/OS2-Process/t/os2_process.t @@ -0,0 +1,529 @@ +#! /usr/bin/perl -w + +#END { +# sleep 10; +#} + +sub propagate_INC { + my $inc = $ENV{PERL5LIB}; + $inc = $ENV{PERLLIB} unless defined $inc; + $inc = '' unless defined $inc; + $ENV{PERL5LIB} = join ';', @INC, split /;/, $inc; +} + +my $separate_session; +BEGIN { # Remap I/O to the parent's window + $separate_session = $ENV{OS2_PROCESS_TEST_SEPARATE_SESSION}; + propagate_INC, return unless $separate_session; # done by the parent + my @fn = split " ", $ENV{NEW_FD}; + my @fh = (*STDOUT, *STDERR); + my @how = qw( > > ); + # warn $_ for @fn; + open $fh[$_], "$how[$_]&=$fn[$_]" + or warn "Cannot reopen $fh[$_], $how[$_]&=$fn[$_]: $!" for 0..1; +} + +use strict; +use Test::More tests => 235; +use OS2::Process; + +sub SWP_flags ($) { + my @nkpos = WindowPos shift; + $nkpos[2]; +} + +my $interactive_wait = @ARGV && $ARGV[0] eq 'wait'; + +my @l = OS2::Process::process_entry(); +ok(@l == 11, 'all the fields of the process_entry() are there'); + +# 1: FS 2: Window-VIO +ok( ($l[9] == 1 or $l[9] == 2), 'we are FS or Windowed-VIO'); + +#print "# $_\n" for @l; + +eval <<'EOE' or die; +#use OS2::Process qw(WM_SYSCOMMAND WM_DBCSLAST FID_CLIENT HWND_DESKTOP); +use OS2::Process qw(WM_SYSCOMMAND WM_DBCSLAST HWND_DESKTOP); + +ok( WM_SYSCOMMAND == 0x0021, 'correct WM_SYSCOMMAND' ); +ok( WM_DBCSLAST == 0x00cf, 'correct WM_DBCSLAST' ); +#ok( FID_CLIENT == 0x8008 ); +ok( HWND_DESKTOP == 0x0001, 'correct HWND_DESKTOP' ); +1; +EOE + +my $t = Title; +my $wint = winTitle; + +ok($t, 'got session title'); +ok($wint, 'got titlebar text'); + +my $newt = "test OS2::Process $$"; +ok(Title_set($newt), 'successfully set Title'); +is(Title, $newt, 'correctly set Title'); +my $wt = winTitle or warn "winTitle: $!, $^E"; +is(winTitle, $newt, 'winTitle changed its value too'); +ok(Title_set $t, 'successfully set Title back'); +is(Title, $t, 'correctly set Title back'); +is(winTitle, $wint, 'winTitle restored its value too'); + +$newt = "test OS2::Process both-$$"; +ok(bothTitle_set($newt), 'successfully set both titles via Win* API'); +is(Title, $newt, 'session title correctly set'); +is(winTitle, $newt, 'winTitle correctly set'); +ok(bothTitle_set($t), 'successfully reset both titles via Win* API'); +is(Title, $t, 'session title correctly reset'); +is(winTitle, $wint, 'winTitle correctly reset'); + +$newt = "test OS2::Process win-$$"; +ok(winTitle_set($newt), 'successfully set titlebar title via Win* API'); +is(Title, $t, 'session title remained the same'); +is(winTitle, $newt, 'winTitle changed value'); +ok(winTitle_set($wint), 'successfully reset titlebar title via Win* API'); +is(Title, $t, 'session title remained the same'); +is(winTitle, $wint, 'winTitle restored value'); + +$newt = "test OS2::Process sw-$$"; +ok(swTitle_set($newt), 'successfully set session title via Win* API'); +is(Title, $newt, 'session title correctly set'); +is(winTitle, $wint, 'winTitle has unchanged value'); +ok(swTitle_set($t), 'successfully reset session title via Win* API'); +is(Title, $t, 'session title correctly set'); +is(winTitle, $wint, 'winTitle has unchanged value'); + +$newt = "test OS2::Process again-$$"; +ok(Title_set($newt), 'successfully set Title again'); +is(Title, $newt, 'correctly set Title again'); +is(winTitle, $newt, 'winTitle changed its value too again'); +ok(Title_set($t), 'successfully set Title back'); +is(Title, $t, 'correctly set Title back'); +is(winTitle, $wint, 'winTitle restored its value too again'); + +my $hwnd = process_hwnd; +ok($hwnd, 'found session owner hwnd'); +my $c_subhwnd = WindowFromId $hwnd, 0x8008; # FID_CLIENT; +ok($c_subhwnd, 'found client hwnd'); +my $a_subhwnd = ActiveWindow $hwnd; # or $^E and warn $^E; +ok((not $a_subhwnd and not $^E), 'No active subwindow in a VIO frame'); + +my $ahwnd = ActiveWindow; +ok($ahwnd, 'found active window'); +my $fhwnd = FocusWindow; +ok($fhwnd, 'found focus window'); + +# This call without morphing results in VIO window with active highlight, but +# no keyboard focus (even after Alt-Tabbing to it; you cannot Alt-Tab off it!) + +# Interestingly, Desktop is active on the switch list, but the +# switch list is not acting on keyboard events. + +# Give up focus +{ my $force_PM = OS2::localMorphPM->new(0); + ok $force_PM, 'morphed to PM locally'; + ok FocusWindow_set(1), 'set focus to DESKTOP'; # HWND_DESKTOP +} +my $dtop = DesktopWindow; +ok($dtop, 'found the desktop window'); + +#OS2::Process::ResetWinError; # XXXX Should not be needed! +$ahwnd = ActiveWindow or $^E and warn $^E; +ok( (not $ahwnd and not $^E), 'desktop is not active'); +$fhwnd = FocusWindow; +ok($fhwnd, 'there is a focus window'); +is($fhwnd, $dtop, 'which is the desktop'); + +# XXXX Well, no need to skip it now... +SKIP: { + skip 'We already have focus', 4 if $hwnd == $ahwnd; + my $force_PM = OS2::localMorphPM->new(0); + ok $force_PM, 'morphed to PM locally again'; + ok FocusWindow_set($c_subhwnd), 'set focus to the client of the session owner'; + # If we do not morph, then when the focus is in another VIO frame, + # we get two VIO frames with activated titlebars. + # The only (?) way to take the activated state from another frame + # is to switch to it via the switch list + $ahwnd = ActiveWindow; + ok($ahwnd, 'there is an active window'); + $fhwnd = FocusWindow; + ok($fhwnd, 'there is a focus window'); + is($hwnd, $ahwnd, 'the active window is the session owner'); + is($fhwnd, $c_subhwnd, 'the focus window is the client of the session owner'); +} + +# Give up focus again +{ my $force_PM = OS2::localMorphPM->new(0); + ok $force_PM, 'morphed to PM locally again'; + ok FocusWindow_set(1), 'set focus to DESKTOP again'; # HWND_DESKTOP +} + +$ahwnd = ActiveWindow or $^E and warn $^E; +ok( (not $ahwnd and not $^E), 'desktop is not active again'); +$fhwnd = FocusWindow; +ok($fhwnd, 'there is a focus window'); +is($fhwnd, $dtop, 'which is the desktop'); + +# XXXX Well, no need to skip it now... +SKIP: { + skip 'We already have focus', 4 if $hwnd == $ahwnd; + my $force_PM = OS2::localMorphPM->new(0); + ok $force_PM, 'morphed to PM locally again'; + ok ActiveWindow_set($hwnd), 'activate the session owner'; + $ahwnd = ActiveWindow; + ok($ahwnd, 'there is an active window'); + $fhwnd = FocusWindow; + ok($fhwnd, 'there is a focus window'); + is($hwnd, $ahwnd, 'the active window is the session owner'); +} + +# XXXX Well, no need to skip it now... +SKIP: { + skip 'Tests assume we have focus', 1 unless $hwnd == $ahwnd; + # We have focus + # is($fhwnd, $ahwnd); + # is($a_subhwnd, $c_subhwnd); + is($fhwnd, $c_subhwnd, 'the focus window is the client of the session owner'); +} + +# Check enumeration of switch entries: +my $skid_title = "temporary s-kid ppid=$$"; +my $spid = system P_SESSION, $^X, '-wle', "END {sleep 25} use OS2::Process; eval {Title_set '$skid_title'} or warn \$@; \$SIG{TERM} = sub {exit 0}"; +ok ($spid, 'start the new VIO session with unique title'); +sleep 1; +my @sw = grep $_->{title} eq $skid_title, process_hentries; +sleep 1000 unless @sw; +is(scalar @sw, 1, 'exactly one session with this title'); +my $sw = $sw[0]; +ok $sw, 'have the data about the session'; +is($sw->{owner_pid}, $spid, 'session has a correct pid'); +my $k_hwnd = $sw->{owner_hwnd}; +ok $k_hwnd, 'found the session window handle'; +is sidOf($spid), $sw->{owner_sid}, 'we know sid of the session'; + +# Give up focus again +{ my $force_PM = OS2::localMorphPM->new(0); + ok $force_PM, 'morphed to PM locally again'; + ok FocusWindow_set($k_hwnd), 'set focus to kid session window'; +} + +$ahwnd = ActiveWindow; +ok $ahwnd, 'there is an active window'; +is $ahwnd, $k_hwnd, 'after focusing the active window is the owner_hwnd'; +$fhwnd = FocusWindow; +ok $fhwnd, 'there is a focus window'; +my $c_sub_ahwnd = WindowFromId $ahwnd, 0x8008; # FID_CLIENT; +ok $c_sub_ahwnd, 'the active window has a FID_CLIENT'; +is($fhwnd, $ahwnd, 'the focus window = the active window'); + +ok hWindowPos_set({behind => 3}, $k_hwnd), # HWND_TOP + 'put kid to the 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, $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_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_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'; + +# This does not work, the result is the handle of "Window List" +# is((hWindowPos $k_hwnd)->{behind}, 4, 'kis is at back'); + +my (@list, $next, @list1); +{ 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'; + push @list, $next while $next = GetNextWindow $enum_handle; + @list1 = ChildWindows; + ok 1, 'embedded ChildWindows()'; + ok EndEnumWindows($enum_handle), 'end enumeration'; + + is_deeply \@list, \@list1, 'Manual list same as by ChildWindows()'; + # Apparently, the 'Desktop' window is still behind us; + # Note that this window is *not* what is returned by DesktopWindow + pop @list if WindowText($list[-1]) eq 'Desktop'; +} +is ($list[-1], $k_hwnd, 'kid is the last in z-order enumeration'); +# print "# kid=$k_hwnd in @list\n"; +@list = ChildWindows; +is_deeply \@list, \@list1, 'Other ChildWindows(), same result'; +ok scalar @list, 'ChildWindows works'; +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'; + +$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'; +#print "# win=$k_hwnd => err=$^E\n"; +my $c_sub_khwnd = WindowFromId $k_hwnd, 0x8008; # FID_CLIENT +ok $c_sub_khwnd, 'have kids client window'; +ok IsWindow($c_sub_khwnd), 'IsWindow works on the client'; +#print "# win=$c_sub_khwnd => IsWindow err=$^E\n"; +my ($pkid,$tkid) = WindowProcess $c_sub_khwnd; +my ($pkid1,$tkid1) = WindowProcess $hwnd; +ok($pkid1 > 0, 'our window has a governing process'); +ok($tkid1 > 0, 'our window has a governing thread'); +is($pkid, $pkid1, 'kid\'s window is governed by the same process as our (PMSHELL:1)'); +is($tkid, $tkid1, 'likewise for threads'); +is $pkid, ppidOf($spid), 'the governer is the parent of the kid session'; + +my $my_pos = hWindowPos($hwnd); +ok $my_pos, 'got my position'; +{ my $force_PM = OS2::localMorphPM->new(0); + ok $force_PM, 'morphed to PM locally again'; + my @pos = WindowPos $hwnd; + my @ppos = WindowPos $k_hwnd; + # ok hWindowPos_set({%$my_pos, behind => $hwnd}, $k_hwnd), 'hide the kid behind us'; + # Hide it completely behind our window + ok hWindowPos_set({x => $my_pos->{x}, y => $my_pos->{y}, behind => $hwnd, + width => $my_pos->{width}, height => $my_pos->{height}}, + $k_hwnd), 'hide the kid behind us'; + # ok WindowPos_set($k_hwnd, $pos[0], $pos[1]), 'hide the kid behind us'; + my @kpos = WindowPos $k_hwnd; + # print "# kidpos=@ppos\n"; + # print "# mypos=@pos\n"; + # print "# kidpos=@kpos\n"; +# kidpos=252 630 4111 808 478 3 66518088 502482793 +# mypos=276 78 4111 491 149 2147484137 66518060 502532977 +# kidpos=276 78 4111 491 149 2147484255 1392374582 213000 + print "# Before window position\n" if $interactive_wait; + sleep 5 if $interactive_wait; + + my $w_at = WindowFromPoint($kpos[0] + 5, $kpos[0] + 5, 1, 0); # HWND_DESKTOP, no grandchildren + ok $w_at, 'got window near LL corner of the kid'; + print "# we=$hwnd, our client=$c_subhwnd, kid=$k_hwnd, kid's client=$c_sub_khwnd\n"; + #is $w_at, $c_sub_khwnd, 'it is the kids client'; + #is $w_at, $k_hwnd, 'it is the kids frame'; + # Apparently, this result is accidental only... +# is $w_at, $hwnd, 'it is our frame - is on top, but no focus'; + #is $w_at, $c_subhwnd, 'it is our client'; + print "# text: `", WindowText $w_at, "'.\n"; + $w_at = WindowFromPoint($kpos[0] + 5, $kpos[0] + 5); # HWND_DESKTOP, grandchildren too + ok $w_at, 'got grandkid window near LL corner of the kid'; + # Apparently, this result is accidental only... +# is $w_at, $c_subhwnd, 'it is our client'; + print "# text: `", WindowText $w_at, "'.\n"; + ok IsWindowVisible $k_hwnd, 'kid is flaged as visible'; + ok IsWindowEnabled $k_hwnd, 'kid is flaged as enabled'; + ok IsWindowShowing $hwnd, 'we are showing'; + ok ((not IsWindowShowing $k_hwnd), 'kid is not showing'); + ok ((not eval { IsWindowShowing 12; 1 }), 'wrong kid causes errors'); + is $^E+0, 0x1001, 'error is 0x1001'; + like $@, qr/\Q[Win]IsWindowShowing/, 'error message shows function'; + like $@, qr/SYS4097\b/, 'error message shows error number'; + like $@, qr/\b0x1001\b/, 'error message shows error number in hex'; + + ok WindowPos_set($k_hwnd, @ppos[0..5]), 'restore the kid position'; + my @nkpos = WindowPos $k_hwnd; + my $fl = $nkpos[2]; + is_deeply([@ppos[0..5]], [@nkpos[0..5]], 'position restored'); + ok IsWindowShowing $k_hwnd, 'kid is showing'; + ok IsWindowVisible $k_hwnd, 'kid is flaged as visible'; + ok IsWindowEnabled $k_hwnd, 'kid is flaged as enabled'; + sleep 5 if $interactive_wait; + ok EnableWindow($k_hwnd, 0), 'disable the kid'; + ok IsWindowShowing $k_hwnd, 'kid is showing'; + ok IsWindowVisible $k_hwnd, 'kid is flaged as visible'; + ok !IsWindowEnabled $k_hwnd, 'kid is flaged as not enabled'; + ok EnableWindow($k_hwnd), 'enable the kid'; + ok IsWindowShowing $k_hwnd, 'kid is showing'; + ok IsWindowVisible $k_hwnd, 'kid is flaged as visible'; + ok IsWindowEnabled $k_hwnd, 'kid is flaged as enabled'; + ok ShowWindow($k_hwnd, 0), 'hide the kid'; + ok !IsWindowShowing $k_hwnd, 'kid is not showing'; + ok !IsWindowVisible $k_hwnd, 'kid is flaged as not visible'; + ok IsWindowEnabled $k_hwnd, 'kid is flaged as enabled'; + ok ShowWindow($k_hwnd), 'show the kid'; + ok IsWindowShowing $k_hwnd, 'kid is showing'; + ok IsWindowVisible $k_hwnd, 'kid is flaged as visible'; + ok IsWindowEnabled $k_hwnd, 'kid is flaged as enabled'; + ok( ($fl & 0x1800), 'window is maximized or restored'); # SWP_MAXIMIZE SWP_RESTORE + ok( ($fl & 0x1800) != 0x1800, 'window is not maximized AND restored'); # SWP_MAXIMIZE SWP_RESTORE + + ok PostMsg( $k_hwnd, 0x21, # WM_SYSCOMMAND, SC_MINIMIZE + OS2::Process::MPFROMSHORT 0x8002), 'post minimize message'; + sleep 1; + ok !IsWindowShowing $k_hwnd, 'kid is not showing'; + ok IsWindowVisible $k_hwnd, 'kid is flaged as visible'; + ok IsWindowEnabled $k_hwnd, 'kid is flaged as enabled'; + is 0x1c00 & SWP_flags $k_hwnd, 0x400, 'kid is minimized'; # SWP_MINIMIZE + + ok PostMsg($k_hwnd, 0x21, # WM_SYSCOMMAND, SC_RESTORE + OS2::Process::MPFROMSHORT 0x8008), 'post restore message'; + sleep 1; + ok IsWindowShowing $k_hwnd, 'kid is showing'; + ok IsWindowVisible $k_hwnd, 'kid is flaged as visible'; + ok IsWindowEnabled $k_hwnd, 'kid is flaged as enabled'; + is 0x1c00 & SWP_flags $k_hwnd, 0x1000, 'kid is restored'; # SWP_RESTORE + + ok PostMsg($k_hwnd, 0x21, # WM_SYSCOMMAND, SC_MAXIMIZE + OS2::Process::MPFROMSHORT 0x8003), 'post maximize message'; + sleep 1; + ok IsWindowShowing $k_hwnd, 'kid is showing'; + ok IsWindowVisible $k_hwnd, 'kid is flaged as visible'; + ok IsWindowEnabled $k_hwnd, 'kid is flaged as enabled'; + is 0x1c00 & SWP_flags $k_hwnd, 0x800, 'kid is maximized'; # SWP_MAXIMIZE + + ok PostMsg( $k_hwnd, 0x21, # WM_SYSCOMMAND, SC_MINIMIZE + OS2::Process::MPFROMSHORT 0x8002), 'post minimize message again'; + sleep 1; + ok !IsWindowShowing $k_hwnd, 'kid is not showing'; + ok IsWindowVisible $k_hwnd, 'kid is flaged as visible'; + ok IsWindowEnabled $k_hwnd, 'kid is flaged as enabled'; + is 0x1c00 & SWP_flags $k_hwnd, 0x400, 'kid is minimized'; # SWP_MINIMIZE + + ok PostMsg($k_hwnd, 0x21, # WM_SYSCOMMAND, SC_RESTORE + OS2::Process::MPFROMSHORT 0x8008), 'post restore message again'; + sleep 1; + ok IsWindowShowing $k_hwnd, 'kid is showing'; + ok IsWindowVisible $k_hwnd, 'kid is flaged as visible'; + ok IsWindowEnabled $k_hwnd, 'kid is flaged as enabled'; + is 0x1c00 & SWP_flags $k_hwnd, 0x1000, 'kid is restored'; # SWP_RESTORE + + ok PostMsg( $k_hwnd, 0x21, # WM_SYSCOMMAND, SC_MINIMIZE + OS2::Process::MPFROMSHORT 0x8002), 'post minimize message again'; + sleep 1; + ok !IsWindowShowing $k_hwnd, 'kid is not showing'; + ok IsWindowVisible $k_hwnd, 'kid is flaged as visible'; + ok IsWindowEnabled $k_hwnd, 'kid is flaged as enabled'; + is 0x1c00 & SWP_flags $k_hwnd, 0x400, 'kid is minimized'; # SWP_MINIMIZE + + ok PostMsg($k_hwnd, 0x21, # WM_SYSCOMMAND, SC_RESTORE + OS2::Process::MPFROMSHORT (($fl & 0x800) ? 0x8003 : 0x8008)), # SWP_MAXIMIZE + 'return back to the initial MAXIMIZE/RESTORE state'; + sleep 1; + ok IsWindowShowing $k_hwnd, 'kid is showing'; + ok IsWindowVisible $k_hwnd, 'kid is flaged as visible'; + ok IsWindowEnabled $k_hwnd, 'kid is flaged as enabled'; + SKIP: { + skip 'if defaultVIO=MAXIMIZED, new windows are shifted, but maximize to UL corner', 1 unless $fl & 0x800; + ok hWindowPos_set({x => $ppos[0], y => $ppos[1]}, $k_hwnd), 'x,y-restore for de-minimization of MAXIMIZED'; + } + @nkpos = WindowPos $k_hwnd; + is_deeply([@ppos[0..5]], [@nkpos[0..5]], 'position restored'); + + + # Now the other way + ok hWindowPos_set( {flags => 0x400}, $k_hwnd), 'set to minimized'; + ok !IsWindowShowing $k_hwnd, 'kid is not showing'; + ok IsWindowVisible $k_hwnd, 'kid is flaged as visible'; + ok IsWindowEnabled $k_hwnd, 'kid is flaged as enabled'; + is 0x1c00 & SWP_flags $k_hwnd, 0x400, 'kid is minimized'; # SWP_MINIMIZE + + ok hWindowPos_set( {flags => 0x1000}, $k_hwnd), 'set to restore'; + ok IsWindowShowing $k_hwnd, 'kid is showing'; + ok IsWindowVisible $k_hwnd, 'kid is flaged as visible'; + ok IsWindowEnabled $k_hwnd, 'kid is flaged as enabled'; + is 0x1c00 & SWP_flags $k_hwnd, 0x1000, 'kid is restored'; # SWP_RESTORE + + ok hWindowPos_set( {flags => 0x800}, $k_hwnd), 'set to maximized'; + ok IsWindowShowing $k_hwnd, 'kid is showing'; + ok IsWindowVisible $k_hwnd, 'kid is flaged as visible'; + ok IsWindowEnabled $k_hwnd, 'kid is flaged as enabled'; + is 0x1c00 & SWP_flags $k_hwnd, 0x800, 'kid is maximized'; # SWP_MAXIMIZE + + ok hWindowPos_set( {flags => 0x400}, $k_hwnd), 'set to minimized again'; + ok !IsWindowShowing $k_hwnd, 'kid is not showing'; + ok IsWindowVisible $k_hwnd, 'kid is flaged as visible'; + ok IsWindowEnabled $k_hwnd, 'kid is flaged as enabled'; + is 0x1c00 & SWP_flags $k_hwnd, 0x400, 'kid is minimized'; # SWP_MINIMIZE + + ok hWindowPos_set( {flags => 0x1000}, $k_hwnd), 'set to restore again'; + ok IsWindowShowing $k_hwnd, 'kid is showing'; + ok IsWindowVisible $k_hwnd, 'kid is flaged as visible'; + ok IsWindowEnabled $k_hwnd, 'kid is flaged as enabled'; + is 0x1c00 & SWP_flags $k_hwnd, 0x1000, 'kid is restored'; # SWP_RESTORE + + ok hWindowPos_set( {flags => 0x400}, $k_hwnd), 'set to minimized again'; + ok !IsWindowShowing $k_hwnd, 'kid is not showing'; + ok IsWindowVisible $k_hwnd, 'kid is flaged as visible'; + ok IsWindowEnabled $k_hwnd, 'kid is flaged as enabled'; + is 0x1c00 & SWP_flags $k_hwnd, 0x400, 'kid is minimized'; # SWP_MINIMIZE + + ok hWindowPos_set( {flags => ($fl & 0x1800)}, $k_hwnd), + 'set back to the initial MAXIMIZE/RESTORE state'; + ok IsWindowShowing $k_hwnd, 'kid is showing'; + ok IsWindowVisible $k_hwnd, 'kid is flaged as visible'; + ok IsWindowEnabled $k_hwnd, 'kid is flaged as enabled'; + SKIP: { + skip 'if defaultVIO=MAXIMIZED, new windows are shifted, but maximize to UL corner', 1 unless $fl & 0x800; + ok hWindowPos_set({x => $ppos[0], y => $ppos[1]}, $k_hwnd), 'x,y-restore for de-minimization of MAXIMIZED'; + } + @nkpos = WindowPos $k_hwnd; + is_deeply([@ppos[0..5]], [@nkpos[0..5]], 'position restored'); + +} + +# XXXX Well, no need to skip it now... +SKIP: { + skip 'We already have focus', 4 if $hwnd == $ahwnd; + my $force_PM = OS2::localMorphPM->new(0); + ok($force_PM, 'morphed to catch focus again'); + ok FocusWindow_set($c_subhwnd), 'set focus to the client of the session owner'; + # If we do not morph, then when the focus is in another VIO frame, + # we get two VIO frames with activated titlebars. + # The only (?) way to take the activated state from another frame + # is to switch to it via the switch list + $ahwnd = ActiveWindow; + ok($ahwnd, 'there is an active window'); + $fhwnd = FocusWindow; + ok($fhwnd, 'there is a focus window'); + is($hwnd, $ahwnd, 'the active window is the session owner'); + is($fhwnd, $c_subhwnd, 'the focus window is the client of the session owner'); +} + +SKIP: { + skip 'Potentially destructive session modifications, done in a separate session only', + 12, unless $separate_session; + # Manipulate process' hentry + my $he = process_hentry; + ok($he, 'got process hentry'); + ok($he->{visible}, 'session switch is visible');# 4? Assume nobody manipulated it... + + ok change_entryh($he), 'can change it (without modifications)'; + my $nhe = process_hentry; + ok $nhe, 'could refetch the process hentry'; + is_deeply($nhe, $he, 'it did not change'); + + sleep 5 if $interactive_wait; + # Try removing the process entry from the switch list + $nhe->{visible} = 0; + ok change_entryh($nhe), 'can change it to be invisible'; + my $nnhe = process_hentry; + ok($nnhe, 'could refetch the process hentry'); + is_deeply($nnhe, $nhe, 'it is modified as expected'); + is($nnhe->{visible}, 0, 'it is not visible'); + + sleep 5 if $interactive_wait; + + $nhe->{visible} = 1; + ok change_entryh ($nhe), 'can change it to be visible'; + $nnhe = process_hentry; + ok($nnhe, 'could refetch the process hentry'); + ok($nnhe->{visible}, 'it is visible'); + sleep 5 if $interactive_wait; +} diff --git a/os2/OS2/OS2-Process/t/os2_process_kid.t b/os2/OS2/OS2-Process/t/os2_process_kid.t new file mode 100644 index 0000000000..7551d41bda --- /dev/null +++ b/os2/OS2/OS2-Process/t/os2_process_kid.t @@ -0,0 +1,64 @@ +#! /usr/bin/perl -w + +use strict; +use OS2::Process; # qw(P_SESSION P_UNRELATED P_NOWAIT); + +my $pl = $0; +$pl =~ s/_kid\.t$/.t/i; +die "Can't find the kid script" unless -r $pl; + +my $inc = $ENV{PERL5LIB}; +$inc = $ENV{PERLLIB} unless defined $inc; +$inc = '' unless defined $inc; +$ENV{PERL5LIB} = join ';', @INC, split /;/, $inc; + +# The thest in $pl modify the session too bad. We run the tests +# in a different session to keep the current session cleaner + +# Apparently, this affects things at open() time, not at system() time +$^F = 40; + +# These do not work... Apparently, the kid "interprets" file handles +# open to CON as output to *its* CON (shortcut in the kernel via the +# device flags?). + +#my @fh = ('<&STDIN', '>&STDOUT', '>&STDERR'); +#my @nfd; +#open $nfd[$_], $fh[$_] or die "Cannot remap FH" for 0..2; +#my @fn = map fileno $_, @nfd; +#$ENV{NEW_FD} = "@fn"; + +my ($stdout_r,$stdout_w,$stderr_r,$stderr_w); +pipe $stderr_r, $stderr_w or die; + +# Duper for $stderr_r to STDERR +my ($e_r, $e_w) = map fileno $_, $stderr_r, $stderr_w; +my $k = system P_NOWAIT, $^X, '-we', <<'EOS', $e_r, $e_w or die "Cannot start a STDERR duper"; + my ($e_r, $e_w) = @ARGV; + # close the other end by the implicit close: + { open my $closeit, ">&=$e_w" or die "kid: open >&=$e_w: $!, `$^E'" } + open IN, "<&=$e_r" or die "kid: open <&=$e_r: $!, `$^E'"; + select STDERR; $| = 1; print while sysread IN, $_, 1<<16; +EOS +close $stderr_r or die; # Now the kid is the owner + +pipe $stdout_r, $stdout_w or die; + +my @fn = (map fileno $_, $stdout_w, $stderr_w); +$ENV{NEW_FD} = "@fn"; +# print "# fns=@fn\n"; + +$ENV{OS2_PROCESS_TEST_SEPARATE_SESSION} = 1; +my $pid = system P_SESSION, $^X, $pl, @ARGV or die; +close $stderr_w or die; # Leave these two FH to the kid only +close $stdout_w or die; + +# Duplicate the STDOUT of the kid: +# These are workarounds for bug in sysread: it is reading in binary... +binmode $stdout_r; +binmode STDOUT; +$| = 1; print while sysread $stdout_r, $_, 1<<16; + +waitpid($pid, 0) >= 0 or die; + +# END { print "# parent finished\r\n" } diff --git a/os2/OS2/OS2-Process/t/os2_process_text.t b/os2/OS2/OS2-Process/t/os2_process_text.t new file mode 100644 index 0000000000..7367327ca4 --- /dev/null +++ b/os2/OS2/OS2-Process/t/os2_process_text.t @@ -0,0 +1,52 @@ +#! /usr/bin/perl -w + +BEGIN { + my $inc = $ENV{PERL5LIB}; + $inc = $ENV{PERLLIB} unless defined $inc; + $inc = '' unless defined $inc; + $ENV{PERL5LIB} = join ';', @INC, split /;/, $inc; +} + +use strict; +use Test::More tests => 11; +use OS2::Process; + +my $cmd = <<'EOA'; +use OS2::Process; +$| = 1; +print for $$, ppid, sidOf; +$SIG{TERM} = $SIG{INT} = sub {exit}; +sleep 10; +EOA + +#my $PID = open my $fh, '-|', $^X, '-wle', $cmd; +$ENV{CMD_RUN} = $cmd; +my $PID = open my $fh, '-|', "$^X -wle 'eval \$ENV{CMD_RUN} or die'"; +ok $PID, 'opened a pipe'; +my ($kpid, $kppid, $sid); +$kpid = <$fh>; +$kppid = <$fh>; +$sid = <$fh>; +chomp ($kpid, $kppid, $sid); + +# This does not work with the intervening shell... +my $extra_fork = $kppid == $PID; # Temporary implementation of multi-arg open() + +print "# us=$$, immediate-pid=$PID, parent-of-kid=$kppid, kid=$kpid\n"; +if ($ENV{CMD_RUN}) { # Two copies of the shell intervene... + is( ppidOf($kppid), $PID, 'correct pid of the kid or its parent'); + is( ppidOf($PID), $$, 'we know our child\'s parent'); +} else { + is( ($extra_fork ? $kppid : $kpid), $PID, 'correct pid of the kid'); + is( $kppid, ($extra_fork ? $PID : $$), 'kid knows its ppid'); +} +ok $sid >= 0, 'kid got its sid'; +is($sid, sidOf, 'sid of kid same as our'); +is(sidOf($kpid), $sid, 'we know sid of kid'); +is(sidOf($PID), $sid, 'we know sid of inter-kid'); +is(ppidOf($kpid), $kppid, 'we know ppid of kid'); +is(ppidOf($PID), $$, 'we know ppid of inter-kid'); + +ok kill('TERM', $kpid), 'killed the kid'; +#ok( ($PID == $kpid or kill('TERM', $PID)), 'killed the inter-kid'); +ok close $fh, 'closed the pipe'; # No kid any more diff --git a/os2/OS2/OS2-REXX/Changes b/os2/OS2/OS2-REXX/Changes new file mode 100644 index 0000000000..7c19710db6 --- /dev/null +++ b/os2/OS2/OS2-REXX/Changes @@ -0,0 +1,7 @@ +0.2: + After fixpak17 a lot of other places have mismatched lengths +returned in the REXXPool interface. + Also drop does not work on stems any more. +0.22: + A subsystem module OS2::DLL extracted which does not link + with REXX runtime library. diff --git a/os2/OS2/OS2-REXX/DLL/Changes b/os2/OS2/OS2-REXX/DLL/Changes new file mode 100644 index 0000000000..07c41da30a --- /dev/null +++ b/os2/OS2/OS2-REXX/DLL/Changes @@ -0,0 +1,6 @@ +0.01: + 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/OS2-REXX/DLL/DLL.pm b/os2/OS2/OS2-REXX/DLL/DLL.pm new file mode 100644 index 0000000000..2a2486e863 --- /dev/null +++ b/os2/OS2/OS2-REXX/DLL/DLL.pm @@ -0,0 +1,308 @@ +package OS2::DLL; + +our $VERSION = '1.03'; + +use Carp; +use XSLoader; + +@libs = split(/;/, $ENV{'PERL5REXX'} || $ENV{'PERLREXX'} || $ENV{'LIBPATH'} || $ENV{'PATH'}); +%dlls = (); + +# Preloaded methods go here. Autoload methods go after __END__, and are +# processed by the autosplit program. + +# Cannot be autoload, the autoloader is used for the REXX functions. + +my $load_with_dirs = sub { + my ($class, $file, @where) = (@_); + return $dlls{$file} if $dlls{$file}; + my $handle; + foreach (@where) { + $handle = DynaLoader::dl_load_file("$_/$file.dll"); + last if $handle; + } + $handle = DynaLoader::dl_load_file($file) unless $handle; + return undef unless $handle; + my @packs = $INC{'OS2/REXX.pm'} ? qw(OS2::DLL::dll OS2::REXX) : 'OS2::DLL::dll'; + my $p = "OS2::DLL::dll::$file"; + @{"$p\::ISA"} = @packs; + *{"$p\::AUTOLOAD"} = \&OS2::DLL::dll::AUTOLOAD; + return $dlls{$file} = + bless {Handle => $handle, File => $file, Queue => 'SESSION' }, $p; +}; + +my $new_dll = sub { + my ($dirs, $class, $file) = (shift, shift, shift); + my $handle; + push @_, @libs if $dirs; + $handle = $load_with_dirs->($class, $file, @_) + and return $handle; + my $path = @_ ? " from '@_'" : ''; + my $err = DynaLoader::dl_error(); + $err =~ s/\s+at\s+\S+\s+line\s+\S+\s*\z//; + croak "Can't load '$file'$path: $err"; +}; + +sub new { + confess 'Usage: OS2::DLL->new( [] )' unless @_ >= 2; + $new_dll->(1, @_); +} + +sub module { + confess 'Usage: OS2::DLL->module( [] )' unless @_ >= 2; + $new_dll->(0, @_); +} + +sub load { + confess 'Usage: load OS2::DLL []' unless $#_ >= 1; + $load_with_dirs->(@_, @libs); +} + +sub libPath_find { + my ($name, $flags, @path) = (shift, shift); + $flags = 0x7 unless defined $flags; + 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; + $name .= ".dll" unless $name =~ /\.[^\\\/]*$/; + $_ .= $name for @path; + return grep -f $_, @path if $flags & 0x8; + -f $_ and return $_ for @path; + return; +} + +package OS2::DLL::dll; +use Carp; +@ISA = 'OS2::DLL'; + +sub AUTOLOAD { + $AUTOLOAD =~ /^OS2::DLL::dll::.+::(.+)$/ + or confess("Undefined subroutine &$AUTOLOAD called"); + return undef if $1 eq "DESTROY"; + die "AUTOLOAD loop" if $1 eq "AUTOLOAD"; + $_[0]->find($1) or confess($@); + goto &$AUTOLOAD; +} + +sub wrapper_REXX { + confess 'Usage: $dllhandle->wrapper_REXX($func_name)' unless @_ == 2; + my $self = shift; + my $file = $self->{File}; + my $handle = $self->{Handle}; + my $prefix = exists($self->{Prefix}) ? $self->{Prefix} : ""; + my $queue = $self->{Queue}; + my $name = shift; + $prefix = '' if $name =~ /^#\d+/; # loading by ordinal + my $addr = (DynaLoader::dl_find_symbol($handle, uc $prefix.$name) + || DynaLoader::dl_find_symbol($handle, $prefix.$name)); + return sub { + OS2::DLL::_call($name, $addr, $queue, @_); + } if $addr; + my $err = DynaLoader::dl_error(); + $err =~ s/\s+at\s+\S+\s+line\s+\S+\s*\z//; + croak "Can't find symbol `$name' in DLL `$file': $err"; +} + +sub find +{ + my $self = shift; + my $file = $self->{File}; + my $p = ref $self; + foreach (@_) { + my $f = eval {$self->wrapper_REXX($_)} or return 0; + ${"${p}::"}{$_} = sub { shift; $f->(@_) }; + } + return 1; +} + +sub handle { shift->{Handle} } +sub fullname { OS2::DLLname(0x202, shift->handle) } +#sub modname { OS2::DLLname(0x201, shift->handle) } + +sub has_f32 { + my $handle = shift->handle; + my $name = shift; + DynaLoader::dl_find_symbol($handle, $name); +} + +XSLoader::load 'OS2::DLL'; + +1; +__END__ + +=head1 NAME + +OS2::DLL - access to DLLs with REXX calling convention. + +=head2 NOTE + +When you use this module, the REXX variable pool is not available. + +See documentation of L module if you need the variable pool. + +=head1 SYNOPSIS + + use OS2::DLL; + $emx_dll = OS2::DLL->module('emx'); + $emx_version = $emx_dll->emx_revision(); + $func_emx_version = $emx_dll->wrapper_REXX('#128'); # emx_revision + $emx_version = $func_emx_version->(); + +=head1 DESCRIPTION + +=head2 Create a DLL handle + + $dll = OS2::DLL->module( NAME [, WHERE] ); + +Loads an OS/2 module NAME, looking in directories WHERE (adding the +extension F<.dll>), if the DLL is not found there, loads in the usual OS/2 way +(via LIBPATH and other settings). Croaks with a verbose report on failure. + +The DLL is not unloaded when the return value is destroyed. + +=head2 Create a DLL handle (looking in some strange locations) + + $dll = OS2::DLL->new( NAME [, WHERE] ); + +Same as L|Create a DLL handle>, but in addition to WHERE, looks +in environment paths PERL5REXX, PERLREXX, PATH (provided for backward +compatibility). + +=head2 Loads DLL by name + + $dll = load OS2::DLL NAME [, WHERE]; + +Same as L|Create a DLL handle (looking in some strange locations)>, +but returns DLL object reference, or undef on failure (in this case one can +get the reason via C) (provided for backward +compatibility). + +=head2 Check for functions (optional): + + BOOL = $dll->find(NAME [, NAME [, ...]]); + +Returns true if all functions are available. As a side effect, creates +a REXX wrapper with the specified name in the package constructed by the name +of the DLL so that the next call to C<$dll->NAME()> will pick up the cached +method. + +=head2 Create a Perl wrapper (optional): + + $func = $dll->wrapper_REXX(NAME); + +Returns a reference to a Perl function wrapper for the entry point NAME +in the DLL. Similar to the OS/2 API, the NAME may be C<"#123"> - in this case +the ordinal is loaded. Croaks with a meaningful error message if NAME does +not exists (although the message for the case when the name is an ordinal may +be confusing). + +=head2 Call external function with REXX calling convention: + + $ret_string = $dll->function_name(arguments); + +Returns the return string if the REXX return code is 0, else undef. +Dies with error message if the function is not available. On the first call +resolves the name in the DLL and caches the Perl wrapper; future calls go +through the wrapper. + +Unless used inside REXX environment (see L), the REXX runtime +environment (variable pool, queue etc.) is not available to the called +function. + +=head1 Inspecting the module + +=over + +=item $module->handle + +=item $module->fullname + +Return the (integer) handle and full path name of a loaded DLL. + +TODO: the module name (whatever is specified in the C statement +of F<.def> file when linking) via OS2::Proc. + +=item $module->has_f32($name) + +Returns the address of a 32-bit entry point with name $name, or 0 if none +found. (Keep in mind that some entry points may be 16-bit, and some may have +capitalized names comparing to callable-from-C counterparts.) Name of the +form C<#197> will find entry point with ordinal 197. + +=item libPath_find($name [, $flags]) + +Looks for the DLL $name on C, C, C if +bits 0x1, 0x2, 0x4 of $flags are set correspondingly. If called with no +arguments, looks on all 3 locations. Returns the full name of the found +file. B + +$name has F<.dll> appended unless it already has an extension. + +=back + +=head1 Low-level API + +=over + +=item Call a _System linkage function via a pointer + +If a function takes up to 20 ULONGs and returns ULONG: + + $res = call20( $pointer, $arg0, $arg1, ...); + +=item Same for packed arguments: + + $res = call20_p( $pointer, pack 'L20', $arg0, $arg1, ...); + +=item Same for C function: + + $res = call20_rp3( $pointer, $arg0, $arg1, ...); + +=item Same for packed arguments and C function + + $res = call20_rp3_p( $pointer, pack 'L20', $arg0, $arg1, ...); + +=item Same for a function which returns non-0 and sets system-error on error + + call20_Dos( $msg, $pointer, $arg0, $arg1, ...); # die("$msg: $^E") if error + +[Good for C API - and rare C calls.] + +=item Same for a function which returns 0 and sets WinLastError() on error + + $res = call20_Win( $msg, $pointer, $arg0, $arg1, ...); + # would die("$msg: $^E") if error + +[Good for most of C API.] + +=item Same for a function which returns 0 and sets WinLastError() on error but +0 is also a valid return + + $res = call20_Win_0OK( $msg, $pointer, $arg0, $arg1, ...); + # would die("$msg: $^E") if error + +[Good for some of C API.] + +=item As previous, but without die() + + $res = call20_Win_0OK_survive( $pointer, $arg0, $arg1, ...); + if ($res == 0 and $^E) { # Do error processing here + } + +[Good for some of C API.] + +=back + +=head1 ENVIRONMENT + +If C is set, emits debugging output. Looks for DLLs +in C, C, C. + +=head1 AUTHOR + +Extracted by Ilya Zakharevich perl-module-OS2-DLL@ilyaz.org from L +written by Andreas Kaiser ak@ananke.s.bawue.de. + +=cut diff --git a/os2/OS2/OS2-REXX/DLL/DLL.xs b/os2/OS2/OS2-REXX/DLL/DLL.xs new file mode 100644 index 0000000000..90b14eaf85 --- /dev/null +++ b/os2/OS2/OS2-REXX/DLL/DLL.xs @@ -0,0 +1,172 @@ +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#define INCL_BASE +#define INCL_REXXSAA +#include + +static RXSTRING * strs; +static int nstrs; +static char * trace; + +static void +needstrs(int n) +{ + if (n > nstrs) { + if (strs) + free(strs); + nstrs = 2 * n; + strs = malloc(nstrs * sizeof(RXSTRING)); + } +} + +typedef ULONG (*fptr_UL_20)(ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG); +typedef __attribute__((regparm(3))) ULONG (*fptr_UL_20_rp3)(ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG); + +static inline unsigned long +call20_p(unsigned long fp, char* str) +{ + ULONG *argv = (ULONG*)str; + fptr_UL_20 f = (fptr_UL_20)fp; + + return f(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5], argv[6], argv[7], argv[8], argv[9], argv[10], argv[11], argv[12], argv[13], argv[14], argv[15], argv[16], argv[17], argv[18], argv[19]); +} + +static inline unsigned long +call20(unsigned long fp, unsigned long arg0, unsigned long arg1, unsigned long arg2, unsigned long arg3, unsigned long arg4, unsigned long arg5, unsigned long arg6, unsigned long arg7, unsigned long arg8, unsigned long arg9, unsigned long arg10, unsigned long arg11, unsigned long arg12, unsigned long arg13, unsigned long arg14, unsigned long arg15, unsigned long arg16, unsigned long arg17, unsigned long arg18, unsigned long arg19) +{ + fptr_UL_20 f = (fptr_UL_20)fp; + + return f(arg0, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8, arg9, arg10, arg11, arg12, arg13, arg14, arg15, arg16, arg17, arg18, arg19); +} + +static inline unsigned long +call20_rp3_p(unsigned long fp, char* str) +{ + ULONG *argv = (ULONG*)str; + fptr_UL_20_rp3 f = (fptr_UL_20_rp3)fp; + + return f(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5], argv[6], argv[7], argv[8], argv[9], argv[10], argv[11], argv[12], argv[13], argv[14], argv[15], argv[16], argv[17], argv[18], argv[19]); +} + +static inline unsigned long +call20_rp3(unsigned long fp, unsigned long arg0, unsigned long arg1, unsigned long arg2, unsigned long arg3, unsigned long arg4, unsigned long arg5, unsigned long arg6, unsigned long arg7, unsigned long arg8, unsigned long arg9, unsigned long arg10, unsigned long arg11, unsigned long arg12, unsigned long arg13, unsigned long arg14, unsigned long arg15, unsigned long arg16, unsigned long arg17, unsigned long arg18, unsigned long arg19) +{ + fptr_UL_20_rp3 f = (fptr_UL_20_rp3)fp; + + return f(arg0, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8, arg9, arg10, arg11, arg12, arg13, arg14, arg15, arg16, arg17, arg18, arg19); +} + +static inline void +call20_Dos(char *msg, unsigned long fp, unsigned long arg0, unsigned long arg1, unsigned long arg2, unsigned long arg3, unsigned long arg4, unsigned long arg5, unsigned long arg6, unsigned long arg7, unsigned long arg8, unsigned long arg9, unsigned long arg10, unsigned long arg11, unsigned long arg12, unsigned long arg13, unsigned long arg14, unsigned long arg15, unsigned long arg16, unsigned long arg17, unsigned long arg18, unsigned long arg19) +{ + fptr_UL_20 f = (fptr_UL_20)fp; + ULONG rc; + + if (CheckOSError(f(arg0, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8, arg9, arg10, arg11, arg12, arg13, arg14, arg15, arg16, arg17, arg18, arg19))) + croak_with_os2error(msg); +} + +static inline unsigned long +call20_Win(char *msg, unsigned long fp, unsigned long arg0, unsigned long arg1, unsigned long arg2, unsigned long arg3, unsigned long arg4, unsigned long arg5, unsigned long arg6, unsigned long arg7, unsigned long arg8, unsigned long arg9, unsigned long arg10, unsigned long arg11, unsigned long arg12, unsigned long arg13, unsigned long arg14, unsigned long arg15, unsigned long arg16, unsigned long arg17, unsigned long arg18, unsigned long arg19) +{ + fptr_UL_20 f = (fptr_UL_20)fp; + + if (CheckWinError(f(arg0, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8, arg9, arg10, arg11, arg12, arg13, arg14, arg15, arg16, arg17, arg18, arg19))) + croak_with_os2error(msg); +} + +static inline unsigned long +call20_Win_0OK(char *msg, unsigned long fp, unsigned long arg0, unsigned long arg1, unsigned long arg2, unsigned long arg3, unsigned long arg4, unsigned long arg5, unsigned long arg6, unsigned long arg7, unsigned long arg8, unsigned long arg9, unsigned long arg10, unsigned long arg11, unsigned long arg12, unsigned long arg13, unsigned long arg14, unsigned long arg15, unsigned long arg16, unsigned long arg17, unsigned long arg18, unsigned long arg19) +{ + fptr_UL_20 f = (fptr_UL_20)fp; + + ResetWinError(); + return SaveCroakWinError(f(arg0, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8, arg9, arg10, arg11, arg12, arg13, arg14, arg15, arg16, arg17, arg18, arg19), + 1 /* Die on error */, /* No prefix */, msg); +} + +static inline unsigned long +call20_Win_0OK_survive(unsigned long fp, unsigned long arg0, unsigned long arg1, unsigned long arg2, unsigned long arg3, unsigned long arg4, unsigned long arg5, unsigned long arg6, unsigned long arg7, unsigned long arg8, unsigned long arg9, unsigned long arg10, unsigned long arg11, unsigned long arg12, unsigned long arg13, unsigned long arg14, unsigned long arg15, unsigned long arg16, unsigned long arg17, unsigned long arg18, unsigned long arg19) +{ + fptr_UL_20 f = (fptr_UL_20)fp; + + ResetWinError(); + return SaveCroakWinError(f(arg0, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8, arg9, arg10, arg11, arg12, arg13, arg14, arg15, arg16, arg17, arg18, arg19), + 0 /* No die on error */, /* No prefix */, "N/A"); +} + +MODULE = OS2::DLL PACKAGE = OS2::DLL + +BOOT: + needstrs(8); + trace = getenv("PERL_REXX_DEBUG"); + +unsigned long +call20_p(unsigned long fp, char* argv) + +unsigned long +call20(unsigned long fp, unsigned long arg0 = 0, unsigned long arg1 = 0, unsigned long arg2 = 0, unsigned long arg3 = 0, unsigned long arg4 = 0, unsigned long arg5 = 0, unsigned long arg6 = 0, unsigned long arg7 = 0, unsigned long arg8 = 0, unsigned long arg9 = 0, unsigned long arg10 = 0, unsigned long arg11 = 0, unsigned long arg12 = 0, unsigned long arg13 = 0, unsigned long arg14 = 0, unsigned long arg15 = 0, unsigned long arg16 = 0, unsigned long arg17 = 0, unsigned long arg18 = 0, unsigned long arg19 = 0) + +void +call20_Dos(char* msg, unsigned long fp, unsigned long arg0 = 0, unsigned long arg1 = 0, unsigned long arg2 = 0, unsigned long arg3 = 0, unsigned long arg4 = 0, unsigned long arg5 = 0, unsigned long arg6 = 0, unsigned long arg7 = 0, unsigned long arg8 = 0, unsigned long arg9 = 0, unsigned long arg10 = 0, unsigned long arg11 = 0, unsigned long arg12 = 0, unsigned long arg13 = 0, unsigned long arg14 = 0, unsigned long arg15 = 0, unsigned long arg16 = 0, unsigned long arg17 = 0, unsigned long arg18 = 0, unsigned long arg19 = 0) + +unsigned long +call20_Win(char *msg, unsigned long fp, unsigned long arg0 = 0, unsigned long arg1 = 0, unsigned long arg2 = 0, unsigned long arg3 = 0, unsigned long arg4 = 0, unsigned long arg5 = 0, unsigned long arg6 = 0, unsigned long arg7 = 0, unsigned long arg8 = 0, unsigned long arg9 = 0, unsigned long arg10 = 0, unsigned long arg11 = 0, unsigned long arg12 = 0, unsigned long arg13 = 0, unsigned long arg14 = 0, unsigned long arg15 = 0, unsigned long arg16 = 0, unsigned long arg17 = 0, unsigned long arg18 = 0, unsigned long arg19 = 0) + +unsigned long +call20_Win_0OK(char *msg, unsigned long fp, unsigned long arg0 = 0, unsigned long arg1 = 0, unsigned long arg2 = 0, unsigned long arg3 = 0, unsigned long arg4 = 0, unsigned long arg5 = 0, unsigned long arg6 = 0, unsigned long arg7 = 0, unsigned long arg8 = 0, unsigned long arg9 = 0, unsigned long arg10 = 0, unsigned long arg11 = 0, unsigned long arg12 = 0, unsigned long arg13 = 0, unsigned long arg14 = 0, unsigned long arg15 = 0, unsigned long arg16 = 0, unsigned long arg17 = 0, unsigned long arg18 = 0, unsigned long arg19 = 0) + +unsigned long +call20_Win_0OK_survive(unsigned long fp, unsigned long arg0 = 0, unsigned long arg1 = 0, unsigned long arg2 = 0, unsigned long arg3 = 0, unsigned long arg4 = 0, unsigned long arg5 = 0, unsigned long arg6 = 0, unsigned long arg7 = 0, unsigned long arg8 = 0, unsigned long arg9 = 0, unsigned long arg10 = 0, unsigned long arg11 = 0, unsigned long arg12 = 0, unsigned long arg13 = 0, unsigned long arg14 = 0, unsigned long arg15 = 0, unsigned long arg16 = 0, unsigned long arg17 = 0, unsigned long arg18 = 0, unsigned long arg19 = 0) + +unsigned long +call20_rp3_p(unsigned long fp, char* argv) + +unsigned long +call20_rp3(unsigned long fp, unsigned long arg0 = 0, unsigned long arg1 = 0, unsigned long arg2 = 0, unsigned long arg3 = 0, unsigned long arg4 = 0, unsigned long arg5 = 0, unsigned long arg6 = 0, unsigned long arg7 = 0, unsigned long arg8 = 0, unsigned long arg9 = 0, unsigned long arg10 = 0, unsigned long arg11 = 0, unsigned long arg12 = 0, unsigned long arg13 = 0, unsigned long arg14 = 0, unsigned long arg15 = 0, unsigned long arg16 = 0, unsigned long arg17 = 0, unsigned long arg18 = 0, unsigned long arg19 = 0) + +SV * +_call(name, address, queue="SESSION", ...) + char * name + void * address + char * queue + CODE: + { + ULONG rc; + int argc, i; + RXSTRING result; + UCHAR resbuf[256]; + RexxFunctionHandler *fcn = address; + argc = items-3; + needstrs(argc); + if (trace) + fprintf(stderr, "REXXCALL::_call name: '%s' args:", name); + for (i = 0; i < argc; ++i) { + STRLEN len; + char *ptr = SvPV(ST(3+i), len); + MAKERXSTRING(strs[i], ptr, len); + if (trace) + fprintf(stderr, " '%.*s'", len, ptr); + } + if (!*queue) + queue = "SESSION"; + if (trace) + fprintf(stderr, "\n"); + MAKERXSTRING(result, resbuf, sizeof resbuf); + rc = fcn(name, argc, strs, queue, &result); + if (trace) + fprintf(stderr, " rc=%X, result='%.*s'\n", rc, + result.strlength, result.strptr); + ST(0) = sv_newmortal(); + if (rc == 0) { + if (result.strptr) + sv_setpvn(ST(0), result.strptr, result.strlength); + else + sv_setpvn(ST(0), "", 0); + } + if (result.strptr && result.strptr != resbuf) + DosFreeMem(result.strptr); + } + diff --git a/os2/OS2/OS2-REXX/DLL/MANIFEST b/os2/OS2/OS2-REXX/DLL/MANIFEST new file mode 100644 index 0000000000..d7ad9b6338 --- /dev/null +++ b/os2/OS2/OS2-REXX/DLL/MANIFEST @@ -0,0 +1,5 @@ +Changes +MANIFEST +Makefile.PL +DLL.pm +DLL.xs diff --git a/os2/OS2/OS2-REXX/DLL/Makefile.PL b/os2/OS2/OS2-REXX/DLL/Makefile.PL new file mode 100644 index 0000000000..6756402c2f --- /dev/null +++ b/os2/OS2/OS2-REXX/DLL/Makefile.PL @@ -0,0 +1,9 @@ +use ExtUtils::MakeMaker; + +WriteMakefile( + NAME => 'OS2::DLL', + VERSION_FROM => 'DLL.pm', + MAN3PODS => {}, # Pods will be built by installman. + XSPROTOARG => '-noprototypes', + PERL_MALLOC_OK => 1, +); diff --git a/os2/OS2/OS2-REXX/MANIFEST b/os2/OS2/OS2-REXX/MANIFEST new file mode 100644 index 0000000000..4ac81492e4 --- /dev/null +++ b/os2/OS2/OS2-REXX/MANIFEST @@ -0,0 +1,14 @@ +Changes +MANIFEST +Makefile.PL +REXX.pm +REXX.xs +t/rx_cmprt.t +t/rx_dllld.t +t/rx_objcall.t +t/rx_sql.test +t/rx_tiesql.test +t/rx_tievar.t +t/rx_tieydb.t +t/rx_varset.t +t/rx_vrexx.t diff --git a/os2/OS2/OS2-REXX/Makefile.PL b/os2/OS2/OS2-REXX/Makefile.PL new file mode 100644 index 0000000000..9b4c0baf25 --- /dev/null +++ b/os2/OS2/OS2-REXX/Makefile.PL @@ -0,0 +1,9 @@ +use ExtUtils::MakeMaker; + +WriteMakefile( + NAME => 'OS2::REXX', + VERSION_FROM => 'REXX.pm', + MAN3PODS => {}, # Pods will be built by installman. + XSPROTOARG => '-noprototypes', + PERL_MALLOC_OK => 1, +); diff --git a/os2/OS2/OS2-REXX/REXX.pm b/os2/OS2/OS2-REXX/REXX.pm new file mode 100644 index 0000000000..ca9fee69ce --- /dev/null +++ b/os2/OS2/OS2-REXX/REXX.pm @@ -0,0 +1,483 @@ +package OS2::REXX; + +require Exporter; +use XSLoader; +require OS2::DLL; + +@ISA = qw(Exporter); +# Items to export into callers namespace by default +# (move infrequently used names to @EXPORT_OK below) +@EXPORT = qw(REXX_call REXX_eval REXX_eval_with); +# Other items we are prepared to export if requested +@EXPORT_OK = qw(drop register); + +$VERSION = '1.04'; + +# We cannot just put OS2::DLL in @ISA, since some scripts would use +# function interface, not method interface... + +*_call = \&OS2::DLL::_call; +*load = \&OS2::DLL::load; +*find = \&OS2::DLL::find; + +XSLoader::load 'OS2::REXX'; + +# Preloaded methods go here. Autoload methods go after __END__, and are +# processed by the autosplit program. + +sub register {_register($_) for @_} + +sub prefix +{ + my $self = shift; + $self->{Prefix} = shift; +} + +sub queue +{ + my $self = shift; + $self->{Queue} = shift; +} + +sub drop +{ # Supposedly should drop anything with + # the given prefix. Unfortunately a + # loop is needed after fixpack17. +&OS2::REXX::_drop(@_); +} + +sub dropall +{ # Supposedly should drop anything with + # the given prefix. Unfortunately a + # loop is needed after fixpack17. + &OS2::REXX::_drop(@_); # Try to drop them all. + my $name; + for (@_) { + if (/\.$/) { + OS2::REXX::_fetch('DUMMY'); # reset REXX's first/next iterator + while (($name) = OS2::REXX::_next($_)) { + OS2::REXX::_drop($_ . $name); + } + } + } +} + +sub TIESCALAR +{ + my ($obj, $name) = @_; + $name =~ s/^([\w!?]+)/\U$1\E/; + return bless \$name, OS2::REXX::_SCALAR; +} + +sub TIEARRAY +{ + my ($obj, $name) = @_; + $name =~ s/^([\w!?]+)/\U$1\E/; + return bless [$name, 0], OS2::REXX::_ARRAY; +} + +sub TIEHASH +{ + my ($obj, $name) = @_; + $name =~ s/^([\w!?]+)/\U$1\E/; + return bless {Stem => $name}, OS2::REXX::_HASH; +} + +############################################################################# +package OS2::REXX::_SCALAR; + +sub FETCH +{ + return OS2::REXX::_fetch(${$_[0]}); +} + +sub STORE +{ + return OS2::REXX::_set(${$_[0]}, $_[1]); +} + +sub DESTROY +{ + return OS2::REXX::_drop(${$_[0]}); +} + +############################################################################# +package OS2::REXX::_ARRAY; + +sub FETCH +{ + $_[0]->[1] = $_[1] if $_[1] > $_[0]->[1]; + return OS2::REXX::_fetch($_[0]->[0].'.'.(0+$_[1])); +} + +sub STORE +{ + $_[0]->[1] = $_[1] if $_[1] > $_[0]->[1]; + return OS2::REXX::_set($_[0]->[0].'.'.(0+$_[1]), $_[2]); +} + +############################################################################# +package OS2::REXX::_HASH; + +require Tie::Hash; +@ISA = ('Tie::Hash'); + +sub FIRSTKEY +{ + my ($self) = @_; + my $stem = $self->{Stem}; + + delete $self->{List} if exists $self->{List}; + + my @list = (); + my ($name, $value); + OS2::REXX::_fetch('DUMMY'); # reset REXX's first/next iterator + while (($name) = OS2::REXX::_next($stem)) { + push @list, $name; + } + my $key = pop @list; + + $self->{List} = \@list; + return $key; +} + +sub NEXTKEY +{ + return pop @{$_[0]->{List}}; +} + +sub EXISTS +{ + return defined OS2::REXX::_fetch($_[0]->{Stem}.$_[1]); +} + +sub FETCH +{ + return OS2::REXX::_fetch($_[0]->{Stem}.$_[1]); +} + +sub STORE +{ + return OS2::REXX::_set($_[0]->{Stem}.$_[1], $_[2]); +} + +sub DELETE +{ + OS2::REXX::_drop($_[0]->{Stem}.$_[1]); +} + +############################################################################# +package OS2::REXX; + +1; +__END__ + +=head1 NAME + +OS2::REXX - access to DLLs with REXX calling convention and REXX runtime. + +=head2 NOTE + +By default, the REXX variable pool is not available, neither +to Perl, nor to external REXX functions. To enable it, you need to put +your code inside C function. REXX functions which do not use +variables may be usable even without C though. + +=head1 SYNOPSIS + + use OS2::REXX; + $ydb = load OS2::REXX "ydbautil" or die "Cannot load: $!"; + @pid = $ydb->RxProcId(); + REXX_call { + tie $s, OS2::REXX, "TEST"; + $s = 1; + }; + +=head1 DESCRIPTION + +=head2 Load REXX DLL + + $dll = load OS2::REXX NAME [, WHERE]; + +NAME is DLL name, without path and extension. + +Directories are searched WHERE first (list of dirs), then environment +paths PERL5REXX, PERLREXX, PATH or, as last resort, OS/2-ish search +is performed in default DLL path (without adding paths and extensions). + +The DLL is not unloaded when the variable dies. + +Returns DLL object reference, or undef on failure. + +=head2 Define function prefix: + + $dll->prefix(NAME); + +Define the prefix of external functions, prepended to the function +names used within your program, when looking for the entries in the +DLL. + +=head2 Example + + $dll = load OS2::REXX "RexxBase"; + $dll->prefix("RexxBase_"); + $dll->Init(); + +is the same as + + $dll = load OS2::REXX "RexxBase"; + $dll->RexxBase_Init(); + +=head2 Define queue: + + $dll->queue(NAME); + +Define the name of the REXX queue passed to all external +functions of this module. Defaults to "SESSION". + +Check for functions (optional): + + BOOL = $dll->find(NAME [, NAME [, ...]]); + +Returns true if all functions are available. + +=head2 Call external REXX function: + + $dll->function(arguments); + +Returns the return string if the return code is 0, else undef. +Dies with error message if the function is not available. + +=head1 Accessing REXX-runtime + +While calling functions with REXX signature does not require the presence +of the system REXX DLL, there are some actions which require REXX-runtime +present. Among them is the access to REXX variables by name. + +One enables REXX runtime by bracketing your code by + + REXX_call BLOCK; + +(trailing semicolon required!) or + + REXX_call \&subroutine_name; + +Inside such a call one has access to REXX variables (see below). + +An alternative way to execute code inside a REXX compartment is + + REXX_eval EXPR; + REXX_eval_with EXPR, + subroutine_name_in_REXX => \&Perl_subroutine + +Here C is a REXX code to run; to execute Perl code one needs to put +it inside Perl_subroutine(), and call this subroutine from REXX, as in + + REXX_eval_with < sub { 123 * shift }; + say foo(2) + EOE + +If one needs more Perl subroutines available, one can "import" them into +REXX from inside Perl_subroutine(); since REXX is not case-sensitive, +the names should be uppercased. + + use OS2::REXX 'register'; + + sub BAR { 123 + shift} + sub BAZ { 789 } + sub importer { register qw(BAR BAZ) } + + REXX_eval_with <<'EOE', importer => \&importer; + call importer + say bar(34) + say baz() + EOE + +=head2 Bind scalar variable to REXX variable: + + tie $var, OS2::REXX, "NAME"; + +=head2 Bind array variable to REXX stem variable: + + tie @var, OS2::REXX, "NAME."; + +Only scalar operations work so far. No array assignments, no array +operations, ... FORGET IT. + +=head2 Bind hash array variable to REXX stem variable: + + tie %var, OS2::REXX, "NAME."; + +To access all visible REXX variables via hash array, bind to ""; + +No array assignments. No array operations, other than hash array +operations. Just like the *dbm based implementations. + +For the usual REXX stem variables, append a "." to the name, +as shown above. If the hash key is part of the stem name, for +example if you bind to "", you cannot use lower case in the stem +part of the key and it is subject to character set restrictions. + +=head2 Erase individual REXX variables (bound or not): + + OS2::REXX::drop("NAME" [, "NAME" [, ...]]); + +=head2 Erase REXX variables with given stem (bound or not): + + OS2::REXX::dropall("STEM" [, "STEM" [, ...]]); + +=head2 Make Perl functions available in REXX: + + OS2::REXX::register("NAME" [, "NAME" [, ...]]); + +Since REXX is not case-sensitive, the names should be uppercase. + +=head1 Subcommand handlers + +By default, the executed REXX code runs without any default subcommand +handler present. A subcommand handler named C is defined, but +not made a default. Use C
REXX command to make it a default +handler; alternatively, use C
to direct a command +to the handler you like. + +Experiments show that the handler C is also available; probably it is +provided by the REXX runtime. + +=head1 Interfacing from REXX to Perl + +This module provides an interface from Perl to REXX, and from REXX-inside-Perl +back to Perl. There is an alternative scenario which allows usage of Perl +from inside REXX. + +A DLL F provides an API to Perl as REXX functions + + PERL + PERLTERM + PERLINIT + PERLEXIT + PERLEVAL + PERLLASTERROR + PERLEXPORTALL + PERLDROPALL + PERLDROPALLEXIT + +A subcommand handler C can also be registered. Calling +the function PERLEXPORTALL() exports all these functions, as well as +exports this subcommand handler under the name C. PERLDROPALL() +inverts this action (and unloads PERLEXPORTALL() as well). In particular + + rc = RxFuncAdd("PerlExportAll", 'PerlRexx', "PERLEXPORTALL") + rc = PerlExportAll() + res = PERLEVAL(perlarg) + ADDRESS EVALPERL perlarg1 + rc = PerlDropAllExit() + +loads all the functions above, evals the Perl code in the REXX variable +C, putting the result into the REXX variable C, +then evals the Perl code in the REXX variable C, and, finally, +drops the loaded functions and the subcommand handler, deinitializes +the Perl interpreter, and exits the Perl's C runtime library. + +PERLEXIT() or PERLDROPALLEXIT() should be called as the last command of +the REXX program. (This is considered as a bug.) Their purpose is to flush +all the output buffers of the Perl's C runtime library. + +C gives the reason for the failure of the last PERLEVAL(). +It is useful inside C handler. PERLINIT() and PERLTERM() +initialize and deinitialize the Perl interpreter. + +C initializes the Perl interpreter (if needed), and +evaluates C as Perl code. The result is returned to REXX stringified, +undefined result is considered as failure. + +C does the same as C wrapped by calls to +PERLINIT() and PERLEXIT(). + +=head1 NOTES + +Note that while function and variable names are case insensitive in the +REXX language, function names exported by a DLL and the REXX variables +(as seen by Perl through the chosen API) are all case sensitive! + +Most REXX DLLs export function names all upper case, but there are a +few which export mixed case names (such as RxExtras). When trying to +find the entry point, both exact case and all upper case are searched. +If the DLL exports "RxNap", you have to specify the exact case, if it +exports "RXOPEN", you can use any case. + +To avoid interfering with subroutine names defined by Perl (DESTROY) +or used within the REXX module (prefix, find), it is best to use mixed +case and to avoid lowercase only or uppercase only names when calling +REXX functions. Be consistent. The same function written in different +ways results in different Perl stubs. + +There is no REXX interpolation on variable names, so the REXX variable +name TEST.ONE is not affected by some other REXX variable ONE. And it +is not the same variable as TEST.one! + +You cannot call REXX functions which are not exported by the DLL. +While most DLLs export all their functions, some, like RxFTP, export +only "...LoadFuncs", which registers the functions within REXX only. + +You cannot call 16-bit DLLs. The few interesting ones I found +(FTP,NETB,APPC) do not export their functions. + +I do not know whether the REXX API is reentrant with respect to +exceptions (signals) when the REXX top-level exception handler is +overridden. So unless you know better than I do, do not access REXX +variables (probably tied to Perl variables) or call REXX functions +which access REXX queues or REXX variables in signal handlers. + +See C and the next section for examples. + +=head1 EXAMPLE + + use OS2::REXX; + + sub Ender::DESTROY { $vrexx->VExit; print "Exiting...\n" } + + $vrexx = OS2::REXX->load('VREXX'); + REXX_call { # VOpenWindow takes a stem + local $SIG{TERM} = sub {die}; # enable Ender::DESTROY + local $SIG{INT} = sub {die}; # enable Ender::DESTROY + + $code = $vrexx->VInit; + print "Init code = `$code'\n"; + die "error initializing VREXX" if $code eq 'ERROR'; + + my $ender = bless [], 'Ender'; # Call Ender::DESTROY on exit + + print "VREXX Version ", $vrexx->VGetVersion, "\n"; + + tie %pos, 'OS2::REXX', 'POS.' or die; + %pos = ( LEFT => 0, RIGHT => 7, TOP => 5, BOTTOM => 0 ); + + $id = $vrexx->VOpenWindow('To disconnect:', 'WHITE', 'POS'); + $vrexx->VForeColor($id, 'BLACK'); + $vrexx->VSetFont($id, 'TIME', '30'); + $tlim = time + 60; + while ( ($r = $tlim - time) >= 0 ) { + $vrexx->VClearWindow($id); + $vrexx->VSay($id, 100, 50, (sprintf "%02i:%02i", int($r/60), $r % 60)); + sleep 1; + } + print "Close code = `$res'\n" if $res = $vrexx->VCloseWindow($id); + }; + + + +=head1 ENVIRONMENT + +If C is set, prints trace info on calls to REXX runtime +environment. + +=head1 AUTHOR + +Andreas Kaiser ak@ananke.s.bawue.de, with additions by Ilya Zakharevich +ilya@math.ohio-state.edu. + +=head1 SEE ALSO + +L. + +=cut diff --git a/os2/OS2/OS2-REXX/REXX.xs b/os2/OS2/OS2-REXX/REXX.xs new file mode 100644 index 0000000000..428dfd57f5 --- /dev/null +++ b/os2/OS2/OS2-REXX/REXX.xs @@ -0,0 +1,566 @@ +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#define INCL_BASE +#define INCL_REXXSAA +#include + +#if 0 +#define INCL_REXXSAA +#pragma pack(1) +#define _Packed +#include +#pragma pack() +#endif + +extern ULONG _emx_exception ( EXCEPTIONREPORTRECORD *, + EXCEPTIONREGISTRATIONRECORD *, + CONTEXTRECORD *, + void *); + +static RXSTRING * strs; +static int nstrs; +static SHVBLOCK * vars; +static int nvars; +static char * trace; + +/* +static RXSTRING rxcommand = { 9, "RXCOMMAND" }; +static RXSTRING rxsubroutine = { 12, "RXSUBROUTINE" }; +static RXSTRING rxfunction = { 11, "RXFUNCTION" }; +*/ + +static ULONG PERLCALL(PCSZ name, ULONG argc, PRXSTRING argv, PCSZ queue, PRXSTRING ret); +static ULONG PERLCALLcv(PCSZ name, SV *cv, ULONG argc, PRXSTRING argv, PCSZ queue, PRXSTRING ret); +static ULONG PERLSTART(PCSZ name, ULONG argc, PRXSTRING argv, PCSZ queue, PRXSTRING ret); +static RexxSubcomHandler SubCommandPerlEval; + +#if 1 + #define Set RXSHV_SET + #define Fetch RXSHV_FETCH + #define Drop RXSHV_DROPV +#else + #define Set RXSHV_SYSET + #define Fetch RXSHV_SYFET + #define Drop RXSHV_SYDRO +#endif + +static long incompartment; /* May be used to unload the REXX */ + +static LONG APIENTRY (*pRexxStart) (LONG, PRXSTRING, PSZ, PRXSTRING, + PSZ, LONG, PRXSYSEXIT, PSHORT, PRXSTRING); +static APIRET APIENTRY (*pRexxRegisterFunctionExe) (PSZ, + RexxFunctionHandler *); +static APIRET APIENTRY (*pRexxRegisterSubcomExe) (PCSZ pszEnvName, PFN pfnEntryPoint, + PUCHAR pUserArea); +static APIRET APIENTRY (*pRexxDeregisterFunction) (PSZ); + +static ULONG (*pRexxVariablePool) (PSHVBLOCK pRequest); + +static SV* exec_cv; + +/* Create a REXX compartment, + register `n' callbacks `handlers' with the REXX names `handlerNames', + evaluate the REXX expression `cmd'. + */ +static SV* +exec_in_REXX_with(pTHX_ char *cmd, int c, char **handlerNames, RexxFunctionHandler **handlers) +{ + RXSTRING args[1]; + RXSTRING inst[2]; + RXSTRING result; + USHORT retcode; + LONG rc; + SV *res; + char *subs = 0; + int n = c, have_nl = 0; + char *ocmd = cmd, *s, *t; + + incompartment++; + + if (c) + Newxz(subs, c, char); + while (n--) { + rc = pRexxRegisterFunctionExe(handlerNames[n], handlers[n]); + if (rc == RXFUNC_DEFINED) + subs[n] = 1; + } + + s = cmd; + while (*s) { + if (*s == '\n') { /* Is not preceeded by \r! */ + Newx(cmd, 2*strlen(cmd)+1, char); + s = ocmd; + t = cmd; + while (*s) { + if (*s == '\n') + *t++ = '\r'; + *t++ = *s++; + } + *t = 0; + break; + } else if (*s == '\r') + s++; + s++; + } + MAKERXSTRING(args[0], NULL, 0); + MAKERXSTRING(inst[0], cmd, strlen(cmd)); + MAKERXSTRING(inst[1], NULL, 0); + MAKERXSTRING(result, NULL, 0); + rc = pRexxStart(0, args, /* No arguments */ + "REXX_in_Perl", /* Returned on REXX' PARSE SOURCE, + and the "macrospace function name" */ + inst, /* inst[0] - the code to execute, + inst[1] will contain tokens. */ + "Perl", /* Pass string-cmds to this callback */ + RXSUBROUTINE, /* Many arguments, maybe result */ + NULL, /* No callbacks/exits to register */ + &retcode, &result); + + incompartment--; + n = c; + while (n--) + if (!subs[n]) + pRexxDeregisterFunction(handlerNames[n]); + if (c) + Safefree(subs); + if (cmd != ocmd) + Safefree(cmd); +#if 0 /* Do we want to restore these? */ + DosFreeModule(hRexxAPI); + DosFreeModule(hRexx); +#endif + + if (RXSTRPTR(inst[1])) /* Free the tokenized version */ + DosFreeMem(RXSTRPTR(inst[1])); + if (!RXNULLSTRING(result)) { + res = newSVpv(RXSTRPTR(result), RXSTRLEN(result)); + DosFreeMem(RXSTRPTR(result)); + } else { + res = newSV(0); + } + if (rc || SvTRUE(GvSV(PL_errgv))) { + if (SvTRUE(GvSV(PL_errgv))) { + STRLEN n_a; + Perl_croak(aTHX_ "Error inside perl function called from REXX compartment:\n%s", SvPV(GvSV(PL_errgv), n_a)) ; + } + Perl_croak(aTHX_ "REXX compartment returned non-zero status %li", rc); + } + + return res; +} + +/* Call the Perl function given by name, or if name=0, by cv, + with the given arguments. Return the stringified result to REXX. */ +static ULONG +PERLCALLcv(PCSZ name, SV *cv, ULONG argc, PRXSTRING argv, PCSZ queue, PRXSTRING ret) +{ + dTHX; + EXCEPTIONREGISTRATIONRECORD xreg = { NULL, _emx_exception }; + int i, rc; + unsigned long len; + char *str; + SV *res; + dSP; + + DosSetExceptionHandler(&xreg); + + ENTER; + SAVETMPS; + PUSHMARK(SP); + +#if 0 + if (!my_perl) { + DosUnsetExceptionHandler(&xreg); + return 1; + } +#endif + + for (i = 0; i < argc; ++i) + XPUSHs(sv_2mortal(newSVpvn(argv[i].strptr, argv[i].strlength))); + PUTBACK; + if (name) + rc = perl_call_pv(name, G_SCALAR | G_EVAL); + else if (cv) + rc = perl_call_sv(cv, G_SCALAR | G_EVAL); + else + rc = -1; + + SPAGAIN; + + if (rc == 1) /* must be! */ + res = POPs; + if (rc == 1 && SvOK(res)) { + str = SvPVx(res, len); + if (len <= 256 /* Default buffer is 256-char long */ + || !CheckOSError(DosAllocMem((PPVOID)&ret->strptr, len, + PAG_READ|PAG_WRITE|PAG_COMMIT))) { + memcpy(ret->strptr, str, len); + ret->strlength = len; + } else + rc = 0; + } else + rc = 0; + + PUTBACK ; + FREETMPS ; + LEAVE ; + + DosUnsetExceptionHandler(&xreg); + return rc == 1 ? 0 : 1; /* 0 means SUCCESS */ +} + +static ULONG +PERLSTART(PCSZ name, ULONG argc, PRXSTRING argv, PCSZ queue, PRXSTRING ret) +{ + SV *cv = exec_cv; + + exec_cv = NULL; + return PERLCALLcv(NULL, cv, argc, argv, queue, ret); +} + +static ULONG +PERLCALL(PCSZ name, ULONG argc, PRXSTRING argv, PCSZ queue, PRXSTRING ret) +{ + return PERLCALLcv(name, NULL, argc, argv, queue, ret); +} + +RexxFunctionHandler* PF = &PERLSTART; +char* PF_name = "StartPerl"; + +#define REXX_eval_with(cmd,name,cv) \ + ( exec_cv = cv, exec_in_REXX_with(aTHX_ (cmd),1, &(name), &PF)) +#define REXX_call(cv) REXX_eval_with("return StartPerl()\r\n", PF_name, (cv)) +#define REXX_eval(cmd) ( exec_in_REXX_with(aTHX_ (cmd), 0, NULL, NULL)) + +static ULONG +SubCommandPerlEval( + PRXSTRING command, /* command to issue */ + PUSHORT flags, /* error/failure flags */ + PRXSTRING retstr ) /* return code */ +{ + dSP; + STRLEN len; + int ret; + char *str = 0; + SV *in, *res; + + ENTER; + SAVETMPS; + + PUSHMARK(SP); + in = sv_2mortal(newSVpvn(command->strptr, command->strlength)); + eval_sv(in, G_SCALAR); + SPAGAIN; + res = POPs; + PUTBACK; + + ret = 0; + if (SvTRUE(ERRSV)) { + *flags = RXSUBCOM_ERROR; /* raise error condition */ + str = SvPV(ERRSV, len); + } else if (!SvOK(res)) { + *flags = RXSUBCOM_ERROR; /* raise error condition */ + str = "undefined value returned by Perl-in-REXX"; + len = strlen(str); + } else + str = SvPV(res, len); + if (len <= 256 /* Default buffer is 256-char long */ + || !DosAllocMem((PPVOID)&retstr->strptr, len, + PAG_READ|PAG_WRITE|PAG_COMMIT)) { + memcpy(retstr->strptr, str, len); + retstr->strlength = len; + } else { + *flags = RXSUBCOM_ERROR; /* raise error condition */ + strcpy(retstr->strptr, "Not enough memory for the return string of Perl-in-REXX"); + retstr->strlength = strlen(retstr->strptr); + } + + FREETMPS; + LEAVE; + + return 0; /* finished */ +} + +static void +needstrs(int n) +{ + if (n > nstrs) { + if (strs) + free(strs); + nstrs = 2 * n; + strs = malloc(nstrs * sizeof(RXSTRING)); + } +} + +static void +needvars(int n) +{ + if (n > nvars) { + if (vars) + free(vars); + nvars = 2 * n; + vars = malloc(nvars * sizeof(SHVBLOCK)); + } +} + +static void +initialize(void) +{ + ULONG rc; + *(PFN *)&pRexxStart = loadByOrdinal(ORD_RexxStart, 1); + *(PFN *)&pRexxRegisterFunctionExe + = loadByOrdinal(ORD_RexxRegisterFunctionExe, 1); + *(PFN *)&pRexxDeregisterFunction + = loadByOrdinal(ORD_RexxDeregisterFunction, 1); + *(PFN *)&pRexxVariablePool = loadByOrdinal(ORD_RexxVariablePool, 1); + *(PFN *)&pRexxRegisterSubcomExe + = loadByOrdinal(ORD_RexxRegisterSubcomExe, 1); + needstrs(8); + needvars(8); + trace = getenv("PERL_REXX_DEBUG"); + + rc = pRexxRegisterSubcomExe("PERLEVAL", (PFN)&SubCommandPerlEval, NULL); +} + +static int +constant(char *name, int arg) +{ + errno = EINVAL; + return 0; +} + + +MODULE = OS2::REXX PACKAGE = OS2::REXX + +BOOT: + initialize(); + +int +constant(name,arg) + char * name + int arg + +int +_set(name,value,...) + char * name + char * value + CODE: + { + int i; + int n = (items + 1) / 2; + ULONG rc; + needvars(n); + if (trace) + fprintf(stderr, "REXXCALL::_set"); + for (i = 0; i < n; ++i) { + SHVBLOCK * var = &vars[i]; + STRLEN namelen; + STRLEN valuelen; + name = SvPV(ST(2*i+0),namelen); + if (2*i+1 < items) { + value = SvPV(ST(2*i+1),valuelen); + } + else { + value = ""; + valuelen = 0; + } + var->shvcode = RXSHV_SET; + var->shvnext = &vars[i+1]; + var->shvnamelen = namelen; + var->shvvaluelen = valuelen; + MAKERXSTRING(var->shvname, name, namelen); + MAKERXSTRING(var->shvvalue, value, valuelen); + if (trace) + fprintf(stderr, " %.*s='%.*s'", + (int)var->shvname.strlength, var->shvname.strptr, + (int)var->shvvalue.strlength, var->shvvalue.strptr); + } + if (trace) + fprintf(stderr, "\n"); + vars[n-1].shvnext = NULL; + rc = pRexxVariablePool(vars); + if (trace) + fprintf(stderr, " rc=%#lX\n", rc); + RETVAL = (rc & ~RXSHV_NEWV) ? FALSE : TRUE; + } + OUTPUT: + RETVAL + +void +_fetch(name, ...) + char * name + PPCODE: + { + int i; + ULONG rc; + EXTEND(SP, items); + needvars(items); + if (trace) + fprintf(stderr, "REXXCALL::_fetch"); + for (i = 0; i < items; ++i) { + SHVBLOCK * var = &vars[i]; + STRLEN namelen; + name = SvPV(ST(i),namelen); + var->shvcode = RXSHV_FETCH; + var->shvnext = &vars[i+1]; + var->shvnamelen = namelen; + var->shvvaluelen = 0; + MAKERXSTRING(var->shvname, name, namelen); + MAKERXSTRING(var->shvvalue, NULL, 0); + if (trace) + fprintf(stderr, " '%s'", name); + } + if (trace) + fprintf(stderr, "\n"); + vars[items-1].shvnext = NULL; + rc = pRexxVariablePool(vars); + if (!(rc & ~RXSHV_NEWV)) { + for (i = 0; i < items; ++i) { + int namelen; + SHVBLOCK * var = &vars[i]; + /* returned lengths appear to be swapped */ + /* but beware of "future bug fixes" */ + namelen = var->shvvalue.strlength; /* should be */ + if (var->shvvaluelen < var->shvvalue.strlength) + namelen = var->shvvaluelen; /* is */ + if (trace) + fprintf(stderr, " %.*s='%.*s'\n", + (int)var->shvname.strlength, var->shvname.strptr, + namelen, var->shvvalue.strptr); + if (var->shvret & RXSHV_NEWV || !var->shvvalue.strptr) + PUSHs(&PL_sv_undef); + else + PUSHs(sv_2mortal(newSVpv(var->shvvalue.strptr, + namelen))); + } + } else { + if (trace) + fprintf(stderr, " rc=%#lX\n", rc); + } + } + +void +_next(stem) + char * stem + PPCODE: + { + SHVBLOCK sv; + BYTE name[4096]; + ULONG rc; + int len = strlen(stem), namelen, valuelen; + if (trace) + fprintf(stderr, "REXXCALL::_next stem='%s'\n", stem); + sv.shvcode = RXSHV_NEXTV; + sv.shvnext = NULL; + MAKERXSTRING(sv.shvvalue, NULL, 0); + do { + sv.shvnamelen = sizeof name; + sv.shvvaluelen = 0; + MAKERXSTRING(sv.shvname, name, sizeof name); + if (sv.shvvalue.strptr) { + DosFreeMem(sv.shvvalue.strptr); + MAKERXSTRING(sv.shvvalue, NULL, 0); + } + rc = pRexxVariablePool(&sv); + } while (!rc && memcmp(stem, sv.shvname.strptr, len) != 0); + if (!rc) { + EXTEND(SP, 2); + /* returned lengths appear to be swapped */ + /* but beware of "future bug fixes" */ + namelen = sv.shvname.strlength; /* should be */ + if (sv.shvnamelen < sv.shvname.strlength) + namelen = sv.shvnamelen; /* is */ + valuelen = sv.shvvalue.strlength; /* should be */ + if (sv.shvvaluelen < sv.shvvalue.strlength) + valuelen = sv.shvvaluelen; /* is */ + if (trace) + fprintf(stderr, " %.*s='%.*s'\n", + namelen, sv.shvname.strptr, + valuelen, sv.shvvalue.strptr); + PUSHs(sv_2mortal(newSVpv(sv.shvname.strptr+len, namelen-len))); + if (sv.shvvalue.strptr) { + PUSHs(sv_2mortal(newSVpv(sv.shvvalue.strptr, valuelen))); + DosFreeMem(sv.shvvalue.strptr); + } else + PUSHs(&PL_sv_undef); + } else if (rc != RXSHV_LVAR) { + die("Error %i when in _next", rc); + } else { + if (trace) + fprintf(stderr, " rc=%#lX\n", rc); + } + } + +int +_drop(name,...) + char * name + CODE: + { + int i; + needvars(items); + for (i = 0; i < items; ++i) { + SHVBLOCK * var = &vars[i]; + STRLEN namelen; + name = SvPV(ST(i),namelen); + var->shvcode = RXSHV_DROPV; + var->shvnext = &vars[i+1]; + var->shvnamelen = namelen; + var->shvvaluelen = 0; + MAKERXSTRING(var->shvname, name, var->shvnamelen); + MAKERXSTRING(var->shvvalue, NULL, 0); + } + vars[items-1].shvnext = NULL; + RETVAL = (pRexxVariablePool(vars) & ~RXSHV_NEWV) ? FALSE : TRUE; + } + OUTPUT: + RETVAL + +int +_register(name) + char * name + CODE: + RETVAL = pRexxRegisterFunctionExe(name, PERLCALL); + OUTPUT: + RETVAL + +SV* +REXX_call(cv) + SV *cv + PROTOTYPE: & + +SV* +REXX_eval(cmd) + char *cmd + +SV* +REXX_eval_with(cmd,name,cv) + char *cmd + char *name + SV *cv + +#ifdef THIS_IS_NOT_FINISHED + +SV* +_REXX_eval_with(cmd,...) + char *cmd + CODE: + { + int n = (items - 1)/2; + char **names; + SV **cvs; + + if ((items % 2) == 0) + Perl_croak(aTHX_ "Name/values should come in pairs in REXX_eval_with()"); + Newx(names, n, char*); + Newx(cvs, n, SV*); + /* XXX Unfinished... */ + RETVAL = NULL; + Safefree(names); + Safefree(cvs); + } + OUTPUT: + RETVAL + +#endif diff --git a/os2/OS2/OS2-REXX/t/rx_cmprt.t b/os2/OS2/OS2-REXX/t/rx_cmprt.t new file mode 100644 index 0000000000..6db785be51 --- /dev/null +++ b/os2/OS2/OS2-REXX/t/rx_cmprt.t @@ -0,0 +1,54 @@ +BEGIN { + chdir 't' if -d 't/lib'; + @INC = '../lib' if -d 'lib'; + require Config; import Config; + if (-d 'lib' and $Config{'extensions'} !~ /\bOS2(::|\/)REXX\b/) { + print "1..0\n"; + exit 0; + } +} + +use OS2::REXX qw(:DEFAULT register); + +$| = 1; # Otherwise data from REXX may come first + +print "1..18\n"; + +$n = 1; +sub do_me { + print "ok $n\n"; + "OK"; +} + +@res = REXX_call(\&do_me); +print "ok 2\n"; +@res == 1 ? print "ok 3\n" : print "not ok 3\n"; +$res[0] eq "OK" ? print "ok 4\n" : print "not ok 4\n# `$res[0]'\n"; + +# Try again +$n = 5; +@res = REXX_call(\&do_me); +print "ok 6\n"; +@res == 1 ? print "ok 7\n" : print "not ok 7\n"; +$res[0] eq "OK" ? print "ok 8\n" : print "not ok 8\n# `$res[0]'\n"; + +REXX_call { print "ok 9\n" }; +REXX_eval 'say "ok 10"'; +# Try again +REXX_eval 'say "ok 11"'; +print "ok 12\n" if REXX_eval("return 2 + 3") eq 5; +REXX_eval_with 'say myfunc()', myfunc => sub {"ok 13"}; +REXX_eval_with "call myout 'ok' 14", myout => sub {print shift, "\n"}; +REXX_eval_with "say 'ok 'myfunc(3,5)", myfunc => sub {shift() * shift()}; + +sub MYFUNC1 {shift} +sub MYFUNC2 {3 * shift} +REXX_eval_with "call myfunc + say 'ok 'myfunc1(1)myfunc2(2)", + myfunc => sub { register qw(myfunc1 myfunc2) }; + +REXX_eval_with "say 'ok 'myfunc(10,7)", + myfunc => sub { REXX_eval "return $_[0] + $_[1]" }; + +sub MyFunc3 {print 'ok ', shift() + shift(), "\n"} +REXX_eval "address perleval\n'MyFunc3(10,8)'"; diff --git a/os2/OS2/OS2-REXX/t/rx_dllld.t b/os2/OS2/OS2-REXX/t/rx_dllld.t new file mode 100644 index 0000000000..406bd63a33 --- /dev/null +++ b/os2/OS2/OS2-REXX/t/rx_dllld.t @@ -0,0 +1,36 @@ +BEGIN { + chdir 't' if -d 't/lib'; + @INC = '../lib' if -d 'lib'; + require Config; import Config; + if (-d 'lib' and $Config{'extensions'} !~ /\bOS2(::|\/)REXX\b/) { + print "1..0\n"; + exit 0; + } +} + +use OS2::REXX; + +$path = $ENV{LIBPATH} || $ENV{PATH} or die; +foreach $dir (split(';', $path)) { + next unless -f "$dir/RXU.DLL"; + $found = "$dir/RXU.DLL"; + last; +} +$found or print "1..0 # skipped: cannot find RXU.DLL\n" and exit; + +print "1..5\n"; + +$module = DynaLoader::dl_load_file($found) or die "not ok 1\n# load\n"; +print "ok 1\n"; + +$address = DynaLoader::dl_find_symbol($module, "RXPROCID") + or die "not ok 2\n# find\n"; +print "ok 2\n"; + +$result = OS2::REXX::_call("RxProcId", $address) or die "not ok 3\n# REXX"; +print "ok 3\n"; + +($pid, $ppid, $ssid) = split(/\s+/, $result); +$pid == $$ ? print "ok 4\n" : print "not ok 4\n# pid\n"; +$ssid == 1 ? print "ok 5\n" : print "not ok 5\n# pid\n"; +print "# pid=$pid, ppid=$ppid, ssid=$ssid\n"; diff --git a/os2/OS2/OS2-REXX/t/rx_emxrv.t b/os2/OS2/OS2-REXX/t/rx_emxrv.t new file mode 100644 index 0000000000..5df8c32785 --- /dev/null +++ b/os2/OS2/OS2-REXX/t/rx_emxrv.t @@ -0,0 +1,61 @@ +BEGIN { + chdir 't' if -d 't/lib'; + @INC = '../lib' if -d 'lib'; + require Config; import Config; + if (-d 'lib' and $Config{'extensions'} !~ /\bOS2(::|\/)REXX\b/) { + print "1..0\n"; + exit 0; + } +} + +print "1..20\n"; + +require OS2::DLL; +print "ok 1\n"; +$emx_dll = OS2::DLL->load('emx'); +print "ok 2\n"; +$emx_version = $emx_dll->emx_revision(); +print "ok 3\n"; +$emx_version >= 40 or print "not "; # We cannot work with old EMXs +print "ok 4\n"; + +$reason = ''; +$emx_version >= 99 and $reason = ' # skipped: version of EMX 100 or more'; # Be safe +print "ok 5$reason\n"; + +$emx_fullname = OS2::DLLname 0x202, $emx_dll->{Handle}; # Handle ==> fullname +print "ok 6\n"; +$emx_dll1 = OS2::DLL->module($emx_fullname); +print "ok 7\n"; +$emx_dll->{Handle} == $emx_dll1->{Handle} or print "not "; +print "ok 8\n"; + +$emx_version1 = $emx_dll1->emx_revision(); +print "ok 9\n"; +$emx_version1 eq $emx_version or print "not "; +print "ok 10\n"; + +$emx_revision = $emx_dll->wrapper_REXX('emx_revision'); +print "ok 11\n"; +$emx_version2 = $emx_revision->(); +print "ok 12\n"; +$emx_version2 eq $emx_version or print "not "; +print "ok 13\n"; + +$emx_revision1 = $emx_dll1->wrapper_REXX('#128'); +print "ok 14\n"; +$emx_version3 = $emx_revision1->(); +print "ok 15\n"; +$emx_version3 eq $emx_version or print "not "; +print "ok 16\n"; + +($emx_fullname1 = $emx_fullname) =~ s,/,\\,g; +$emx_dll2 = OS2::DLL->new($emx_fullname1); +print "ok 17\n"; +$emx_dll->{Handle} == $emx_dll2->{Handle} or print "not "; +print "ok 18\n"; + +$emx_version4 = $emx_dll2->emx_revision(); +print "ok 19\n"; +$emx_version4 eq $emx_version or print "not "; +print "ok 20\n"; diff --git a/os2/OS2/OS2-REXX/t/rx_objcall.t b/os2/OS2/OS2-REXX/t/rx_objcall.t new file mode 100644 index 0000000000..0ec67b112d --- /dev/null +++ b/os2/OS2/OS2-REXX/t/rx_objcall.t @@ -0,0 +1,38 @@ +BEGIN { + chdir 't' if -d 't/lib'; + @INC = '../lib' if -d 'lib'; + require Config; import Config; + if (-d 'lib' and $Config{'extensions'} !~ /\bOS2(::|\/)REXX\b/) { + print "1..0\n"; + exit 0; + } +} + +use OS2::REXX; + +# +# DLL +# +$rxu = load OS2::REXX "rxu" + or print "1..0 # skipped: cannot find RXU.DLL\n" and exit; +print "1..5\n", "ok 1\n"; + +# +# function +# +@pid = $rxu->RxProcId(); +@pid == 1 ? print "ok 2\n" : print "not ok 2\n"; +@res = split " ", $pid[0]; +print "ok 3\n" if $res[0] == $$; +@pid = $rxu->RxProcId(); +@res = split " ", $pid[0]; +print "ok 4\n" if $res[0] == $$; +print "# @pid\n"; + +eval { $rxu->nixda(); }; +my $err = $@; +if ($err) { + $err =~ s/\n/\n#\t/g; + print "# \$\@ = '$err'\n"; +} +print "ok 5\n" if $@ =~ /^Can't find symbol `nixda\'/; diff --git a/os2/OS2/OS2-REXX/t/rx_sql.test b/os2/OS2/OS2-REXX/t/rx_sql.test new file mode 100644 index 0000000000..602c76dc47 --- /dev/null +++ b/os2/OS2/OS2-REXX/t/rx_sql.test @@ -0,0 +1,97 @@ +BEGIN { + chdir 't' if -d 't/lib'; + @INC = '../lib'; + require Config; import Config; + if ($Config{'extensions'} !~ /\bOS2(::|\/)REXX\b/) { + print "1..0\n"; + exit 0; + } +} + +use OS2::REXX; + +sub stmt +{ + my ($s) = @_; + $s =~ s/\s*\n\s*/ /g; + $s =~ s/^\s+//; + $s =~ s/\s+$//; + return $s; +} + +sub sqlcode +{ + OS2::REXX::_fetch("SQLCA.SQLCODE"); +} + +sub sqlstate +{ + OS2::REXX::_fetch("SQLCA.SQLSTATE"); +} + +sub sql +{ + my ($stmt) = stmt(@_); + return 0 if OS2::REXX::_call("sqlexec", $sqlexec, "", $stmt); + return sqlcode() >= 0; +} + +sub dbs +{ + my ($stmt) = stmt(@_); + return 0 if OS2::REXX::_call("sqldbs", $sqldbs, "", $stmt); + return sqlcode() >= 0; +} + +sub error +{ + my ($where) = @_; + print "ERROR in $where: sqlcode=", sqlcode(), " sqlstate=", sqlstate(), "\n"; + dbs("GET MESSAGE INTO :MSG LINEWIDTH 75"); + my $msg = OS2::REXX::_fetch("MSG"); + print "\n", $msg; + exit 1; +} + +REXX_call { + + $sqlar = DynaLoader::dl_load_file("h:/sqllib/dll/sqlar.dll") or die "load"; + $sqldbs = DynaLoader::dl_find_symbol($sqlar, "SQLDBS") or die "find sqldbs"; + $sqlexec = DynaLoader::dl_find_symbol($sqlar, "SQLEXEC") or die "find sqlexec"; + + sql(<<) or error("connect"); + CONNECT TO sample IN SHARE MODE + + OS2::REXX::_set("STMT" => stmt(<<)); + SELECT name FROM sysibm.systables + + sql(<<) or error("prepare"); + PREPARE s1 FROM :stmt + + sql(<<) or error("declare"); + DECLARE c1 CURSOR FOR s1 + + sql(<<) or error("open"); + OPEN c1 + + while (1) { + sql(<<) or error("fetch"); + FETCH c1 INTO :name + + last if sqlcode() == 100; + + print "Table name is ", OS2::REXX::_fetch("NAME"), "\n"; + } + + sql(<<) or error("close"); + CLOSE c1 + + sql(<<) or error("rollback"); + ROLLBACK + + sql(<<) or error("disconnect"); + CONNECT RESET + +}; + +exit 0; diff --git a/os2/OS2/OS2-REXX/t/rx_tiesql.test b/os2/OS2/OS2-REXX/t/rx_tiesql.test new file mode 100644 index 0000000000..c85a1e990b --- /dev/null +++ b/os2/OS2/OS2-REXX/t/rx_tiesql.test @@ -0,0 +1,86 @@ +BEGIN { + chdir 't' if -d 't/lib'; + @INC = '../lib'; + require Config; import Config; + if ($Config{'extensions'} !~ /\bOS2(::|\/)REXX\b/) { + print "1..0\n"; + exit 0; + } +} + +#extproc perl5 -Rx +#! perl + +use REXX; + +$db2 = load REXX "sqlar" or die "load"; +tie $sqlcode, REXX, "SQLCA.SQLCODE"; +tie $sqlstate, REXX, "SQLCA.SQLSTATE"; +tie %rexx, REXX, ""; + +sub stmt +{ + my ($s) = @_; + $s =~ s/\s*\n\s*/ /g; + $s =~ s/^\s+//; + $s =~ s/\s+$//; + return $s; +} + +sub sql +{ + my ($stmt) = stmt(@_); + return 0 if $db2->SqlExec($stmt); + return $sqlcode >= 0; +} + +sub dbs +{ + my ($stmt) = stmt(@_); + return 0 if $db2->SqlDBS($stmt); + return $sqlcode >= 0; +} + +sub error +{ + my ($where) = @_; + print "ERROR in $where: sqlcode=$sqlcode, sqlstate=$sqlstate\n"; + dbs("GET MESSAGE INTO :msg LINEWIDTH 75"); + print "\n", $rexx{'MSG'}; + exit 1; +} + +sql(<<) or error("connect"); + CONNECT TO sample IN SHARE MODE + +$rexx{'STMT'} = stmt(<<); + SELECT name FROM sysibm.systables + +sql(<<) or error("prepare"); + PREPARE s1 FROM :stmt + +sql(<<) or error("declare"); + DECLARE c1 CURSOR FOR s1 + +sql(<<) or error("open"); + OPEN c1 + +while (1) { + sql(<<) or error("fetch"); + FETCH c1 INTO :name + + last if $sqlcode == 100; + + print "Table name is $rexx{'NAME'}\n"; +} + +sql(<<) or error("close"); + CLOSE c1 + +sql(<<) or error("rollback"); + ROLLBACK + +sql(<<) or error("disconnect"); + CONNECT RESET + +exit 0; diff --git a/os2/OS2/OS2-REXX/t/rx_tievar.t b/os2/OS2/OS2-REXX/t/rx_tievar.t new file mode 100644 index 0000000000..9c9ea7d466 --- /dev/null +++ b/os2/OS2/OS2-REXX/t/rx_tievar.t @@ -0,0 +1,89 @@ +BEGIN { + chdir 't' if -d 't/lib'; + @INC = '../lib' if -d 'lib'; + require Config; import Config; + if (-d 'lib' and $Config{'extensions'} !~ /\bOS2(::|\/)REXX\b/) { + print "1..0\n"; + exit 0; + } +} + +use OS2::REXX; + +# +# DLL +# +load OS2::REXX "rxu" + or print "1..0 # skipped: cannot find RXU.DLL\n" and exit; + +print "1..19\n"; + +REXX_call { + print "ok 1\n"; + + # + # scalar + # + tie $s, OS2::REXX, "TEST"; + print "ok 2\n"; + $s = 1; + print "ok 3\n" if $s eq 1; + print "not ok 3\n# `$s'\n" unless $s eq 1; + untie $s; + + # + # hash + # + + tie %all, OS2::REXX, ""; # all REXX vars + print "ok 4\n"; + + sub show { + # show all REXX vars + print "--@_--\n"; + foreach (keys %all) { + $v = $all{$_}; + print "$_ => $v\n"; + } + } + + sub check { + # check all REXX vars + my ($test, @arr) = @_; + my @rx; + foreach $key (sort keys %all) { push @rx, $key, $all{$key} } + if ("@rx" eq "@arr") {print "ok $test\n"} + else { print "not ok $test\n# expect `@arr', got `@rx'\n" } + } + + + tie %h, OS2::REXX, "TEST."; + print "ok 5\n"; + check(6); + + $h{"one"} = 1; + check(7, "TEST.one", 1); + + $h{"two"} = 2; + check(8, "TEST.one", 1, "TEST.two", 2); + + $h{"one"} = ""; + check(9, "TEST.one", "", "TEST.two", 2); + print "ok 10\n" if exists $h{"one"}; + print "ok 11\n" if exists $h{"two"}; + + delete $h{"one"}; + check(12, "TEST.two", 2); + print "ok 13\n" if not exists $h{"one"}; + print "ok 14\n" if exists $h{"two"}; + + OS2::REXX::dropall("TEST."); + print "ok 15\n"; + check(16); + print "ok 17\n" if not exists $h{"one"}; + print "ok 18\n" if not exists $h{"two"}; + + untie %h; + print "ok 19"; + +}; diff --git a/os2/OS2/OS2-REXX/t/rx_tieydb.t b/os2/OS2/OS2-REXX/t/rx_tieydb.t new file mode 100644 index 0000000000..ec6bfca20e --- /dev/null +++ b/os2/OS2/OS2-REXX/t/rx_tieydb.t @@ -0,0 +1,33 @@ +BEGIN { + chdir 't' if -d 't/lib'; + @INC = '../lib' if -d 'lib'; + require Config; import Config; + if (-d 'lib' and $Config{'extensions'} !~ /\bOS2(::|\/)REXX\b/) { + print "1..0\n"; + exit 0; + } +} + +use OS2::REXX; +$rx = load OS2::REXX "RXU" # from RXU1a.ZIP + or print "1..0 # skipped: cannot find RXU.DLL\n" and exit; + +print "1..7\n", "ok 1\n"; + +$rx->prefix("Rx"); # implicit function prefix +print "ok 2\n"; + +REXX_call { + tie @pib, OS2::REXX, "IB.P"; # bind array to REXX stem variable + print "ok 3\n"; + tie %tib, OS2::REXX, "IB.T."; # bind associative array to REXX stem var + print "ok 4\n"; + + $rx->GetInfoBlocks("IB."); # call REXX function + print "ok 5\n"; + defined $pib[6] ? print "ok 6\n" : print "not ok 6\n# pib\n"; + defined $tib{7} && $tib{7} =~ /^\d+$/ ? print "ok 7\n" + : print "not ok 7\n# tib\n"; + print "# Process status is ", unpack("I", $pib[6]), + ", thread ordinal is $tib{7}\n"; +}; diff --git a/os2/OS2/OS2-REXX/t/rx_varset.t b/os2/OS2/OS2-REXX/t/rx_varset.t new file mode 100644 index 0000000000..166cf53623 --- /dev/null +++ b/os2/OS2/OS2-REXX/t/rx_varset.t @@ -0,0 +1,39 @@ +BEGIN { + chdir 't' if -d 't/lib'; + @INC = '../lib' if -d 'lib'; + require Config; import Config; + if (-d 'lib' and $Config{'extensions'} !~ /\bOS2(::|\/)REXX\b/) { + print "1..0\n"; + exit 0; + } +} + +use OS2::REXX; + +print "1..9\n"; + +REXX_call { + OS2::REXX::_set("X" => sqrt(2)) and print "ok 1\n"; + $x = OS2::REXX::_fetch("X") and print "ok 2\n"; + if (abs($x - sqrt(2)) < 5e-15) { + print "ok 3\n"; + } else { print "not ok 3\n# sqrt(2) = @{[sqrt(2)]} != `$x'\n" } + OS2::REXX::_set("Y" => sqrt(3)) and print "ok 4\n"; + $i = 0; + $n = 4; + while (($name, $value) = OS2::REXX::_next("")) { + $i++; $n++; + if ($i <= 2 and $name eq "Y" ) { + if ($value eq sqrt(3)) { + print "ok $n\n"; + } else { + print "not ok $n\n# `$name' => `$value'\n" ; + } + } elsif ($i <= 2 and $name eq "X") { + print "ok $n\n" if $value eq sqrt(2); + } else { print "not ok 7\n# name `$name', value `$value'\n" } + } + print "ok 7\n" if $i == 2; + OS2::REXX::_drop("X") and print "ok 8\n"; + $x = OS2::REXX::_fetch("X") or print "ok 9\n"; +}; diff --git a/os2/OS2/OS2-REXX/t/rx_vrexx.t b/os2/OS2/OS2-REXX/t/rx_vrexx.t new file mode 100644 index 0000000000..3611894682 --- /dev/null +++ b/os2/OS2/OS2-REXX/t/rx_vrexx.t @@ -0,0 +1,63 @@ +BEGIN { + chdir 't' if -d 't/lib'; + @INC = '../lib' if -d 'lib'; + require Config; import Config; + if (-d 'lib' and $Config{'extensions'} !~ /\bOS2(::|\/)REXX\b/) { + print "1..0 # skipped: OS2::REXX not built\n"; + exit 0; + } + if (defined $ENV{PERL_TEST_NOVREXX}) { + print "1..0 # skipped: request via PERL_TEST_NOVREXX\n"; + exit 0; + } +} + +use OS2::REXX; + +$name = "VREXX"; +$path = $ENV{LIBPATH} || $ENV{PATH} or die; +foreach $dir (split(';', $path)) { + next unless -f "$dir/$name.DLL"; + $found = "$dir/$name.DLL"; + print "# found at `$found'\n"; + last; +} +$found or print "1..0 # skipped: cannot find $name.DLL\n" and exit; + +print "1..10\n"; + +REXX_call { + $vrexx = DynaLoader::dl_load_file($found) or die "not ok 1\n# load\n"; + print "ok 1\n"; + $vinit = DynaLoader::dl_find_symbol($vrexx, "VINIT") or die "find vinit"; + print "ok 2\n"; + $vexit = DynaLoader::dl_find_symbol($vrexx, "VEXIT") or die "find vexit"; + print "ok 3\n"; + $vmsgbox = DynaLoader::dl_find_symbol($vrexx, "VMSGBOX") or die "find vmsgbox"; + print "ok 4\n"; + $vversion= DynaLoader::dl_find_symbol($vrexx, "VGETVERSION") or die "find vgetversion"; + print "ok 5\n"; + + $result = OS2::REXX::_call("VInit", $vinit) or die "VInit"; + print "ok 6\n"; + print "# VInit: $result\n"; + + OS2::REXX::_set("MBOX.0" => 4, + "MBOX.1" => "Perl VREXX Access Test", + "MBOX.2" => "", + "MBOX.3" => "(C) Andreas Kaiser", + "MBOX.4" => "December 1994") + or die "set var"; + print "ok 7\n"; + + $result = OS2::REXX::_call("VGetVersion", $vversion) or die "VMsgBox"; + print "ok 8\n"; + print "# VGetVersion: $result\n"; + + $result = OS2::REXX::_call("VMsgBox", $vmsgbox, "", "Perl", "MBOX", 1) or die "VMsgBox"; + print "ok 9\n"; + print "# VMsgBox: $result\n"; + + OS2::REXX::_call("VExit", $vexit); + print "ok 10\n"; +}; diff --git a/os2/OS2/OS2-typemap b/os2/OS2/OS2-typemap new file mode 100644 index 0000000000..12bd58d347 --- /dev/null +++ b/os2/OS2/OS2-typemap @@ -0,0 +1,28 @@ +BOOL T_IV +ULONG T_UV +HINI T_UV +HAB T_UV +HWND T_UV +ATOM T_UV +HATOMTBL T_UV +HSWITCH T_UV +ULONG T_UV +USHORT T_UV +LONG T_IV +SHORT T_IV + +PSZ T_PVNULL +PCSZ T_PVNULLC + +############################################################################# +INPUT +T_PVNULL + $var = ( SvOK($arg) ? ($type)SvPV_nolen($arg) : NULL ) +T_PVNULLC + $var = ( SvOK($arg) ? ($type)SvPV_nolen($arg) : NULL ) +############################################################################# +OUTPUT +T_PVNULL + sv_setpv((SV*)$arg, $var); +T_PVNULLC + NOTIMPLEMENTED diff --git a/os2/OS2/PrfDB/Changes b/os2/OS2/PrfDB/Changes deleted file mode 100644 index 49ac8c1a43..0000000000 --- a/os2/OS2/PrfDB/Changes +++ /dev/null @@ -1,6 +0,0 @@ -Revision history for Perl extension OS2::PrfDB. - -0.01 Tue Mar 26 19:35:27 1996 - - original version; created by h2xs 1.16 -0.02: Field do-not-close added to OS2::Prf::Hini. -0.03: Update to XSLoader and 'our'. diff --git a/os2/OS2/PrfDB/MANIFEST b/os2/OS2/PrfDB/MANIFEST deleted file mode 100644 index fb96b03c5d..0000000000 --- a/os2/OS2/PrfDB/MANIFEST +++ /dev/null @@ -1,7 +0,0 @@ -Changes -MANIFEST -Makefile.PL -PrfDB.pm -PrfDB.xs -t/os2_prfdb.t -typemap diff --git a/os2/OS2/PrfDB/Makefile.PL b/os2/OS2/PrfDB/Makefile.PL deleted file mode 100644 index 2d4a6a7ae5..0000000000 --- a/os2/OS2/PrfDB/Makefile.PL +++ /dev/null @@ -1,11 +0,0 @@ -use ExtUtils::MakeMaker; -# See lib/ExtUtils/MakeMaker.pm for details of how to influence -# the contents of the Makefile that is written. -WriteMakefile( - 'NAME' => 'OS2::PrfDB', - 'VERSION_FROM' => 'PrfDB.pm', # finds $VERSION - MAN3PODS => {}, # Pods will be built by installman. - 'LIBS' => [''], # e.g., '-lm' - 'DEFINE' => '', # e.g., '-DHAVE_SOMETHING' - 'INC' => '', # e.g., '-I/usr/include/other' -); diff --git a/os2/OS2/PrfDB/PrfDB.pm b/os2/OS2/PrfDB/PrfDB.pm deleted file mode 100644 index a1bdc33a1c..0000000000 --- a/os2/OS2/PrfDB/PrfDB.pm +++ /dev/null @@ -1,312 +0,0 @@ -package OS2::PrfDB; - -use strict; - -require Exporter; -use XSLoader; -use Tie::Hash; - -our $debug; -our @ISA = qw(Exporter Tie::Hash); -# Items to export into callers namespace by default. Note: do not export -# names by default without a very good reason. Use EXPORT_OK instead. -# Do not simply export all your public functions/methods/constants. -our @EXPORT = qw( - AnyIni UserIni SystemIni - ); -our $VERSION = '0.04'; - -XSLoader::load 'OS2::PrfDB', $VERSION; - -# Preloaded methods go here. - -sub AnyIni { - new_from_int OS2::PrfDB::Hini OS2::Prf::System(0), - 'Anyone of two "systemish" databases', 1; -} - -sub UserIni { - new_from_int OS2::PrfDB::Hini OS2::Prf::System(1), 'User settings database', 1; -} - -sub SystemIni { - new_from_int OS2::PrfDB::Hini OS2::Prf::System(2),'System settings database',1; -} - -# Internal structure 0 => HINI, 1 => array of entries, 2 => iterator. - -sub TIEHASH { - die "Usage: tie %arr, OS2::PrfDB, filename\n" unless @_ == 2; - my ($obj, $file) = @_; - my $hini = ref $file eq 'OS2::PrfDB::Hini' ? $file - : new OS2::PrfDB::Hini $file; - die "Error opening profile database `$file': $!" unless $hini; - # print "tiehash `@_', hini $hini\n" if $debug; - bless [$hini, undef, undef]; -} - -sub STORE { - my ($self, $key, $val) = @_; - die unless @_ == 3; - die unless ref $val eq 'HASH'; - my %sub; - tie %sub, 'OS2::PrfDB::Sub', $self->[0], $key; - %sub = %$val; -} - -sub FETCH { - my ($self, $key) = @_; - die unless @_ == 2; - my %sub; - tie %sub, 'OS2::PrfDB::Sub', $self->[0], $key; - \%sub; -} - -sub DELETE { - my ($self, $key) = @_; - die unless @_ == 2; - my %sub; - tie %sub, 'OS2::PrfDB::Sub', $self->[0], $key; - %sub = (); -} - -# CLEAR ???? - deletion of the whole - -sub EXISTS { - my ($self, $key) = @_; - die unless @_ == 2; - return OS2::Prf::GetLength($self->[0]->[0], $key, undef) >= 0; -} - -sub FIRSTKEY { - my $self = shift; - my $keys = OS2::Prf::Get($self->[0]->[0], undef, undef); - return undef unless defined $keys; - chop($keys); - $self->[1] = [split /\0/, $keys]; - # print "firstkey1 $self, `$self->[3]->[0], $self->[3]->[1]'\n" if $debug; - $self->[2] = 0; - return $self->[1]->[0]; - # OS2::Prf::Get($self->[0]->[0], $self->[2], $self->[3]->[0])); -} - -sub NEXTKEY { - # print "nextkey `@_'\n" if $debug; - my $self = shift; - return undef unless $self->[2]++ < $#{$self->[1]}; - my $key = $self->[1]->[$self->[2]]; - return $key; #, OS2::Prf::Get($self->[0]->[0], $self->[2], $key)); -} - -package OS2::PrfDB::Hini; - -sub new { - die "Usage: new OS2::PrfDB::Hini filename\n" unless @_ == 2; - shift; - my $file = shift; - my $hini = OS2::Prf::Open($file); - die "Error opening profile database `$file': $!" unless $hini; - bless [$hini, $file]; -} - -# Takes HINI and file name: - -sub new_from_int { shift; bless [@_] } - -# Internal structure 0 => HINI, 1 => filename, 2 => do-not-close. - -sub DESTROY { - my $self = shift; - my $hini = $self->[0]; - unless ($self->[2]) { - OS2::Prf::Close($hini) or die "Error closing profile `$self->[1]': $!"; - } -} - -package OS2::PrfDB::Sub; -use Tie::Hash; - -our $debug; -our @ISA = qw{Tie::Hash}; - -# Internal structure 0 => HINI, 1 => array of entries, 2 => iterator, -# 3 => appname. - -sub TIEHASH { - die "Usage: tie %arr, OS2::PrfDB::Sub, filename, appname\n" unless @_ == 3; - my ($obj, $file, $app) = @_; - my $hini = ref $file eq 'OS2::PrfDB::Hini' ? $file - : new OS2::PrfDB::Hini $file; - die "Error opening profile database `$file': $!" unless $hini; - # print "tiehash `@_', hini $hini\n" if $debug; - bless [$hini, undef, undef, $app]; -} - -sub STORE { - my ($self, $key, $val) = @_; - die unless @_ == 3; - OS2::Prf::Set($self->[0]->[0], $self->[3], $key, $val); -} - -sub FETCH { - my ($self, $key) = @_; - die unless @_ == 2; - OS2::Prf::Get($self->[0]->[0], $self->[3], $key); -} - -sub DELETE { - my ($self, $key) = @_; - die unless @_ == 2; - OS2::Prf::Set($self->[0]->[0], $self->[3], $key, undef); -} - -# CLEAR ???? - deletion of the whole - -sub EXISTS { - my ($self, $key) = @_; - die unless @_ == 2; - return OS2::Prf::GetLength($self->[0]->[0], $self->[3], $key) >= 0; -} - -sub FIRSTKEY { - my $self = shift; - my $keys = OS2::Prf::Get($self->[0]->[0], $self->[3], undef); - return undef unless defined $keys; - chop($keys); - $self->[1] = [split /\0/, $keys]; - # print "firstkey1 $self, `$self->[3]->[0], $self->[3]->[1]'\n" if $debug; - $self->[2] = 0; - return $self->[1]->[0]; - # OS2::Prf::Get($self->[0]->[0], $self->[2], $self->[3]->[0])); -} - -sub NEXTKEY { - # print "nextkey `@_'\n" if $debug; - my $self = shift; - return undef unless $self->[2]++ < $#{$self->[1]}; - my $key = $self->[1]->[$self->[2]]; - return $key; #, OS2::Prf::Get($self->[0]->[0], $self->[2], $key)); -} - -# Autoload methods go after =cut, and are processed by the autosplit program. - -1; -__END__ -# Below is the stub of documentation for your module. You better edit it! - -=head1 NAME - -OS2::PrfDB - Perl extension for access to OS/2 setting database. - -=head1 SYNOPSIS - - use OS2::PrfDB; - tie %settings, OS2::PrfDB, 'my.ini'; - tie %subsettings, OS2::PrfDB::Sub, 'my.ini', 'mykey'; - - print "$settings{firstkey}{subkey}\n"; - print "$subsettings{subkey}\n"; - - tie %system, OS2::PrfDB, SystemIni; - $system{myapp}{mykey} = "myvalue"; - - -=head1 DESCRIPTION - -The extension provides both high-level and low-level access to .ini -files. - -=head2 High level access - -High-level access is the tie-hash access via two packages: -C and C. First one supports one argument, -the name of the file to open, the second one the name of the file to -open and so called I, or the primary key of the -database. - - tie %settings, OS2::PrfDB, 'my.ini'; - tie %subsettings, OS2::PrfDB::Sub, 'my.ini', 'mykey'; - -One may substitute a handle for already opened ini-file instead of the -file name (obtained via low-level access functions). In particular, 3 -functions SystemIni(), UserIni(), and AnyIni() provide handles to the -"systemish" databases. AniIni will read from both, and write into User -database. - -=head2 Low-level access - -Low-level access functions reside in the package C. They are - -=over 14 - -=item C - -Opens the database, returns an I. - -=item C - -Closes the database given an I. - -=item C - -Retrieves data from the database given 2-part-key C C. -If C is C, return the "\0" delimited list of Cs, -terminated by \0. If C is C, returns the list of -possible Cs in the same form. - -=item C - -Same as above, but returns the length of the value. - -=item C - -Sets the value. If the C is not defined, removes the C. If -the C is not defined, removes the C. - -=item C - -Return an I associated with the system database. If -C is 1, it is I database, if 2, I database, if -0, handle for "both" of them: the handle works for read from any one, -and for write into I one. - -=item C - -returns a reference to a list of two strings, giving names of the -I and I databases. - -=item C - -B<(Not tested.)> Sets the profile name of the I database. The -application should have a message queue to use this function! - -=back - -=head2 Integer handles - -To convert a name or an integer handle into an object acceptable as -argument to tie() interface, one may use the following functions from -the package C: - -=over 14 - -=item C - -=item C - -=back - -=head2 Exports - -SystemIni(), UserIni(), and AnyIni(). - -=head1 AUTHOR - -Ilya Zakharevich, ilya@math.ohio-state.edu - -=head1 SEE ALSO - -perl(1). - -=cut - diff --git a/os2/OS2/PrfDB/PrfDB.xs b/os2/OS2/PrfDB/PrfDB.xs deleted file mode 100644 index bc4661a5d6..0000000000 --- a/os2/OS2/PrfDB/PrfDB.xs +++ /dev/null @@ -1,173 +0,0 @@ -#define INCL_WINSHELLDATA /* Or use INCL_WIN, INCL_PM, */ - -#ifdef __cplusplus -extern "C" { -#endif -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" -#include -#ifdef __cplusplus -} -#endif - -#define Prf_Open(pszFileName) SaveWinError(pPrfOpenProfile(Perl_hab, (pszFileName))) -#define Prf_Close(hini) (!CheckWinError(pPrfCloseProfile(hini))) - -BOOL (*pPrfCloseProfile) (HINI hini); -HINI (*pPrfOpenProfile) (HAB hab, PCSZ pszFileName); -BOOL (*pPrfQueryProfile) (HAB hab, PPRFPROFILE pPrfProfile); -BOOL (*pPrfQueryProfileData) (HINI hini, PCSZ pszApp, PCSZ pszKey, PVOID pBuffer, - PULONG pulBufferLength); -/* -LONG (*pPrfQueryProfileInt) (HINI hini, PCSZ pszApp, PCSZ pszKey, LONG sDefault); - */ -BOOL (*pPrfQueryProfileSize) (HINI hini, PCSZ pszApp, PCSZ pszKey, - PULONG pulReqLen); -/* -ULONG (*pPrfQueryProfileString) (HINI hini, PCSZ pszApp, PCSZ pszKey, - PCSZ pszDefault, PVOID pBuffer, ULONG ulBufferLength); - */ -BOOL (*pPrfReset) (HAB hab, __const__ PRFPROFILE *pPrfProfile); -BOOL (*pPrfWriteProfileData) (HINI hini, PCSZ pszApp, PCSZ pszKey, - CPVOID pData, ULONG ulDataLength); -/* -BOOL (*pPrfWriteProfileString) (HINI hini, PCSZ pszApp, PCSZ pszKey, - PCSZ pszData); - */ - -SV * -Prf_Get(pTHX_ HINI hini, PSZ app, PSZ key) { - ULONG len; - BOOL rc; - SV *sv; - - if (CheckWinError(pPrfQueryProfileSize(hini, app, key, &len))) return &PL_sv_undef; - sv = newSVpv("", 0); - SvGROW(sv, len + 1); - if (CheckWinError(pPrfQueryProfileData(hini, app, key, SvPVX(sv), &len)) - || (len == 0 && (app == NULL || key == NULL))) { /* Somewhy needed. */ - SvREFCNT_dec(sv); - return &PL_sv_undef; - } - SvCUR_set(sv, len); - *SvEND(sv) = 0; - return sv; -} - -I32 -Prf_GetLength(HINI hini, PSZ app, PSZ key) { - U32 len; - - if (CheckWinError(pPrfQueryProfileSize(hini, app, key, &len))) return -1; - return len; -} - -#define Prf_Set(hini, app, key, s, l) \ - (!(CheckWinError(pPrfWriteProfileData(hini, app, key, s, l)))) - -#define Prf_System(key) \ - ( (key) ? ( (key) == 1 ? HINI_USERPROFILE \ - : ( (key) == 2 ? HINI_SYSTEMPROFILE \ - : (die("Wrong profile id %i", key), 0) )) \ - : HINI_PROFILE) - -SV* -Prf_Profiles(pTHX) -{ - AV *av = newAV(); - SV *rv; - char user[257]; - char system[257]; - PRFPROFILE info = { 257, user, 257, system}; - - if (CheckWinError(pPrfQueryProfile(Perl_hab, &info))) return &PL_sv_undef; - if (info.cchUserName > 257 || info.cchSysName > 257) - die("Panic: Profile names too long"); - av_push(av, newSVpv(user, info.cchUserName - 1)); - av_push(av, newSVpv(system, info.cchSysName - 1)); - rv = newRV((SV*)av); - SvREFCNT_dec(av); - return rv; -} - -BOOL -Prf_SetUser(pTHX_ SV *sv) -{ - char user[257]; - char system[257]; - PRFPROFILE info = { 257, user, 257, system}; - - if (!SvPOK(sv)) die("User profile name not defined"); - if (SvCUR(sv) > 256) die("User profile name too long"); - if (CheckWinError(pPrfQueryProfile(Perl_hab, &info))) return 0; - if (info.cchSysName > 257) - die("Panic: System profile name too long"); - info.cchUserName = SvCUR(sv) + 1; - info.pszUserName = SvPVX(sv); - return !CheckWinError(pPrfReset(Perl_hab, &info)); -} - -MODULE = OS2::PrfDB PACKAGE = OS2::Prf PREFIX = Prf_ - -HINI -Prf_Open(pszFileName) - PSZ pszFileName; - -BOOL -Prf_Close(hini) - HINI hini; - -SV * -Prf_Get(hini, app, key) - HINI hini; - PSZ app; - PSZ key; -CODE: - RETVAL = Prf_Get(aTHX_ hini, app, key); -OUTPUT: - RETVAL - -int -Prf_Set(hini, app, key, s, l = (SvPOK(ST(3)) ? SvCUR(ST(3)): -1)) - HINI hini; - PSZ app; - PSZ key; - PSZ s; - ULONG l; - -I32 -Prf_GetLength(hini, app, key) - HINI hini; - PSZ app; - PSZ key; - -HINI -Prf_System(key) - int key; - -SV* -Prf_Profiles() -CODE: - RETVAL = Prf_Profiles(aTHX); -OUTPUT: - RETVAL - -BOOL -Prf_SetUser(sv) - SV *sv -CODE: - RETVAL = Prf_SetUser(aTHX_ sv); -OUTPUT: - RETVAL - -BOOT: - Acquire_hab(); - AssignFuncPByORD(pPrfQueryProfileSize, ORD_PRF32QUERYPROFILESIZE); - AssignFuncPByORD(pPrfOpenProfile, ORD_PRF32OPENPROFILE); - AssignFuncPByORD(pPrfCloseProfile, ORD_PRF32CLOSEPROFILE); - AssignFuncPByORD(pPrfQueryProfile, ORD_PRF32QUERYPROFILE); - AssignFuncPByORD(pPrfReset, ORD_PRF32RESET); - AssignFuncPByORD(pPrfQueryProfileData, ORD_PRF32QUERYPROFILEDATA); - AssignFuncPByORD(pPrfWriteProfileData, ORD_PRF32WRITEPROFILEDATA); - diff --git a/os2/OS2/PrfDB/t/os2_prfdb.t b/os2/OS2/PrfDB/t/os2_prfdb.t deleted file mode 100644 index b9f7d90ae2..0000000000 --- a/os2/OS2/PrfDB/t/os2_prfdb.t +++ /dev/null @@ -1,190 +0,0 @@ -BEGIN { - chdir 't' if -d 't/lib'; - @INC = '../lib' if -d 'lib'; - require Config; import Config; - if (-d 'lib' and $Config{'extensions'} !~ /\bOS2(::|\/)PrfDB\b/) { - print "1..0\n"; - exit 0; - } -} - -# Before `make install' is performed this script should be runnable with -# `make test'. After `make install' it should work as `perl test.pl' - -######################### We start with some black magic to print on failure. - -# Change 1..1 below to 1..last_test_to_print . -# (It may become useful if the test is moved to ./t subdirectory.) - -BEGIN { $| = 1; print "1..48\n"; } -END {print "not ok 1\n" unless $loaded;} -use OS2::PrfDB; -$loaded = 1; -use strict; - -print "ok 1\n"; - -######################### End of black magic. - -# Insert your test code below (better if it prints "ok 13" -# (correspondingly "not ok 13") depending on the success of chunk 13 -# of the test code): - -my $inifile = "my.ini"; - -unlink $inifile if -w $inifile; - -my $ini = OS2::Prf::Open($inifile); -print( ($ini ? "": "not "), "ok 2\n# HINI=`$ini'\n"); - -print( (OS2::Prf::GetLength($ini,'aaa', 'bbb') != -1) ? - "not ok 3\n# err: `$^E'\n" : "ok 3\n"); - - -print( OS2::Prf::Set($ini,'aaa', 'bbb','xyz') ? "ok 4\n" : - "not ok 4\n# err: `$^E'\n"); - -my $len = OS2::Prf::GetLength($ini,'aaa', 'bbb'); -print( $len == 3 ? "ok 5\n" : "not ok 5# len: `$len' err: `$^E'\n"); - -my $val = OS2::Prf::Get($ini,'aaa', 'bbb'); -print( $val eq 'xyz' ? "ok 6\n" : "not ok 6# val: `$val' err: `$^E'\n"); - -$val = OS2::Prf::Get($ini,'aaa', undef); -print( $val eq "bbb\0" ? "ok 7\n" : "not ok 7# val: `$val' err: `$^E'\n"); - -$val = OS2::Prf::Get($ini, undef, undef); -print( $val eq "aaa\0" ? "ok 8\n" : "not ok 8# val: `$val' err: `$^E'\n"); - -my $res = OS2::Prf::Set($ini,'aaa', 'bbb',undef); -print( $res ? "ok 9\n" : "not ok 9# err: `$^E'\n"); - -$val = OS2::Prf::Get($ini, undef, undef); -print( (! defined $val) ? "ok 10\n" : "not ok 10# val: `$val' err: `$^E'\n"); - -$val = OS2::Prf::Get($ini,'aaa', undef); -print( (! defined $val) ? "ok 11\n" : "not ok 11# val: `$val' err: `$^E'\n"); - -print((OS2::Prf::Close($ini) ? "" : "not ") . "ok 12\n"); - -my $files = OS2::Prf::Profiles(); -print( (defined $files) ? "ok 13\n" : "not ok 13# err: `$^E'\n"); -print( (@$files == 2) ? "ok 14\n" : "not ok 14# `@$files' err: `$^E'\n"); -print "# `@$files'\n"; - -$ini = OS2::Prf::Open($inifile); -print( ($ini ? "": "not "), "ok 15\n# HINI=`$ini'\n"); - - -print( OS2::Prf::Set($ini,'aaa', 'ccc','xyz') ? "ok 16\n" : - "not ok 16\n# err: `$^E'\n"); - -print( OS2::Prf::Set($ini,'aaa', 'ddd','123') ? "ok 17\n" : - "not ok 17\n# err: `$^E'\n"); - -print( OS2::Prf::Set($ini,'bbb', 'xxx','abc') ? "ok 18\n" : - "not ok 18\n# err: `$^E'\n"); - -print( OS2::Prf::Set($ini,'bbb', 'yyy','456') ? "ok 19\n" : - "not ok 19\n# err: `$^E'\n"); - -OS2::Prf::Close($ini); - -my %hash1; - -tie %hash1, 'OS2::PrfDB::Sub', $inifile, 'aaa'; -$OS2::PrfDB::Sub::debug = 1; -print "ok 20\n"; - -my @a1 = keys %hash1; -print (@a1 == 2 ? "ok 21\n" : "not ok 21\n# `@a1'\n"); - -my @a2 = sort @a1; -print ("@a2" eq "ccc ddd" ? "ok 22\n" : "not ok 22\n# `@a2'\n"); - -$val = $hash1{ccc}; -print ($val eq "xyz" ? "ok 23\n" : "not ok 23\n# `$val'\n"); - -$val = $hash1{ddd}; -print ($val eq "123" ? "ok 24\n" : "not ok 24\n# `$val'\n"); - -print (exists $hash1{ccc} ? "ok 25\n" : "not ok 25\n# `$val'\n"); - -print (!exists $hash1{hhh} ? "ok 26\n" : "not ok 26\n# `$val'\n"); - -$hash1{hhh} = 12; -print (exists $hash1{hhh} ? "ok 27\n" : "not ok 27\n# `$val'\n"); - -$val = $hash1{hhh}; -print ($val eq "12" ? "ok 28\n" : "not ok 28\n# `$val'\n"); - -delete $hash1{ccc}; - -untie %hash1; -print "ok 29\n"; - -tie %hash1, 'OS2::PrfDB::Sub', $inifile, 'aaa'; -print "ok 30\n"; - -@a1 = keys %hash1; -print (@a1 == 2 ? "ok 31\n" : "not ok 31\n# `@a1'\n"); - -@a2 = sort @a1; -print ("@a2" eq "ddd hhh" ? "ok 32\n" : "not ok 32\n# `@a2'\n"); - -print (exists $hash1{hhh} ? "ok 33\n" : "not ok 33\n# `$val'\n"); - -$val = $hash1{hhh}; -print ($val eq "12" ? "ok 34\n" : "not ok 34\n# `$val'\n"); - -%hash1 = (); -print "ok 35\n"; - -%hash1 = ( hhh => 12, ddd => 5); - -untie %hash1; - -my %hash; - -tie %hash, 'OS2::PrfDB', $inifile; -print "ok 36\n"; - -@a1 = keys %hash; -print (@a1 == 2 ? "ok 37\n" : "not ok 37\n# `@a1'\n"); - -@a2 = sort @a1; -print ("@a2" eq "aaa bbb" ? "ok 38\n" : "not ok 38\n# `@a2'\n"); - -print (exists $hash{aaa} ? "ok 39\n" : "not ok 39\n# `$val'\n"); - -$val = $hash{aaa}; -print (ref $val eq "HASH" ? "ok 40\n" : "not ok 40\n# `$val'\n"); - -%hash1 = %$val; -print "ok 41\n"; - -@a1 = keys %hash1; -print (@a1 == 2 ? "ok 42\n" : "not ok 31\n# `@a1'\n"); - -@a2 = sort @a1; -print ("@a2" eq "ddd hhh" ? "ok 43\n" : "not ok 43\n# `@a2'\n"); - -print (exists $hash1{hhh} ? "ok 44\n" : "not ok 44\n# `$val'\n"); - -$val = $hash1{hhh}; -print ($val eq "12" ? "ok 45\n" : "not ok 45\n# `$val'\n"); - -$hash{nnn}{mmm} = 67; -print "ok 46\n"; - -untie %hash; - -my %hash2; - -tie %hash2, 'OS2::PrfDB', $inifile; -print "ok 47\n"; - -print ($hash2{nnn}->{mmm} eq "67" ? "ok 48\n" : "not ok 48\n# `$val'\n"); - -untie %hash2; -unlink $inifile; diff --git a/os2/OS2/Process/MANIFEST b/os2/OS2/Process/MANIFEST deleted file mode 100644 index 125e55fd50..0000000000 --- a/os2/OS2/Process/MANIFEST +++ /dev/null @@ -1,7 +0,0 @@ -MANIFEST -Makefile.PL -Process.pm -Process.xs -t/os2_process.t -t/os2_process_kid.t -t/os2_process_text.t diff --git a/os2/OS2/Process/Makefile.PL b/os2/OS2/Process/Makefile.PL deleted file mode 100644 index c24af0c1ed..0000000000 --- a/os2/OS2/Process/Makefile.PL +++ /dev/null @@ -1,44 +0,0 @@ -use ExtUtils::MakeMaker; - -create_constants(); # Make a module - -# See lib/ExtUtils/MakeMaker.pm for details of how to influence -# the contents of the Makefile that is written. -WriteMakefile( - 'NAME' => 'OS2::Process', - VERSION_FROM=> 'Process.pm', - MAN3PODS => {}, # Pods will be built by installman. - 'LIBS' => [''], # e.g., '-lm' - 'DEFINE' => '', # e.g., '-DHAVE_SOMETHING' - 'INC' => '', # e.g., '-I/usr/include/other' - IMPORTS => { _16_DosSmSetTitle => 'sesmgr.DOSSMSETTITLE', - # _16_Win16SetTitle => 'pmshapi.93', - }, -); - -sub create_constants { - return if -d 'Process_constants'; - my $src_dir; - my @try = qw(.. ../.. ../../.. ../../../..); - for (@try) { - $src_dir = $_, last if -d "$_/utils" and -r "$_/utils/h2xs"; - } - warn("Can't find \$PERL_SRC/utils/h2xs in @try, falling back to no constants"), - return unless defined $src_dir; - # Can't name it *::Constants, otherwise constants.xs would overwrite it... - # This produces warnings from PSZ-conversion on WS_* constants. - system $^X, "-I$src_dir/lib", "$src_dir/utils/h2xs", '-fn', 'OS2::Process::Const', - '--skip-exporter', '--skip-autoloader', # too large memory overhead - '--skip-strict', '--skip-warnings', # likewise - '--skip-ppport', # will not work without dynaloading. - # Most useful for OS2::Process: - '-M^(HWND|WM|SC|SWP|WC|PROG|QW|EDI|WS|QWS|QWP|QWL|FF|FI|LS|FS|FCF|BS|MS|TBM|CF|CFI|FID|MB|MBID|CF|CFI|SPTR)_', - '-F', '-DINCL_NLS -DINCL_BASE -DINCL_PM', # Define more symbols - 'os2emx.h' # EMX version of OS/2 API - and warn("Can't build module with contants, falling back to no constants"), - return; - rename 'OS2/Process/Const', 'Process_constants' - or warn("Error renaming module, falling back to no constants: $!"), - return; - return 1; -} diff --git a/os2/OS2/Process/Process.pm b/os2/OS2/Process/Process.pm deleted file mode 100644 index 70583617b1..0000000000 --- a/os2/OS2/Process/Process.pm +++ /dev/null @@ -1,2372 +0,0 @@ -package OS2::localMorphPM; -# use strict; - -sub new { - my ($c,$f) = @_; - OS2::MorphPM($f); - # print STDERR ">>>>>\n"; - bless [$f], $c -} -sub DESTROY { - # print STDERR "<<<<<\n"; - OS2::UnMorphPM(shift->[0]) -} - -package OS2::Process; - -BEGIN { - require Exporter; - require XSLoader; - #require AutoLoader; - - our @ISA = qw(Exporter); - our $VERSION = "1.03"; - XSLoader::load('OS2::Process', $VERSION); -} - -# Items to export into callers namespace by default. Note: do not export -# names by default without a very good reason. Use EXPORT_OK instead. -# Do not simply export all your public functions/methods/constants. -our @EXPORT = qw( - P_BACKGROUND - P_DEBUG - P_DEFAULT - P_DETACH - P_FOREGROUND - P_FULLSCREEN - P_MAXIMIZE - P_MINIMIZE - P_NOCLOSE - P_NOSESSION - P_NOWAIT - P_OVERLAY - P_PM - P_QUOTE - P_SESSION - P_TILDE - P_UNRELATED - P_WAIT - P_WINDOWED - my_type - file_type - T_NOTSPEC - T_NOTWINDOWCOMPAT - T_WINDOWCOMPAT - T_WINDOWAPI - T_BOUND - T_DLL - T_DOS - T_PHYSDRV - T_VIRTDRV - T_PROTDLL - T_32BIT - - os2constant - - ppid - ppidOf - sidOf - scrsize - scrsize_set - kbdChar - kbdhChar - kbdStatus - _kbdStatus_set - kbdhStatus - kbdhStatus_set - vioConfig - viohConfig - vioMode - viohMode - viohMode_set - _vioMode_set - _vioState - _vioState_set - vioFont - vioFont_set - process_entry - process_entries - process_hentry - process_hentries - change_entry - change_entryh - process_hwnd - Title_set - Title - winTitle_set - winTitle - swTitle_set - bothTitle_set - WindowText - WindowText_set - WindowPos - WindowPos_set - hWindowPos - hWindowPos_set - WindowProcess - SwitchToProgram - DesktopWindow - ActiveWindow - ActiveWindow_set - ClassName - FocusWindow - FocusWindow_set - ShowWindow - PostMsg - BeginEnumWindows - EndEnumWindows - GetNextWindow - IsWindow - ChildWindows - out_codepage - out_codepage_set - process_codepage_set - in_codepage - in_codepage_set - cursor - cursor_set - screen - screen_set - process_codepages - QueryWindow - WindowFromId - WindowFromPoint - EnumDlgItem - EnableWindow - EnableWindowUpdate - IsWindowEnabled - IsWindowVisible - IsWindowShowing - WindowPtr - WindowULong - WindowUShort - WindowStyle - SetWindowBits - SetWindowPtr - SetWindowULong - SetWindowUShort - WindowBits_set - WindowPtr_set - WindowULong_set - WindowUShort_set - TopLevel - FocusWindow_set_keep_Zorder - - ActiveDesktopPathname - InvalidateRect - CreateFrameControls - - ClipbrdFmtInfo - ClipbrdOwner - ClipbrdViewer - ClipbrdData - OpenClipbrd - CloseClipbrd - ClipbrdData_set - ClipbrdOwner_set - ClipbrdViewer_set - EnumClipbrdFmts - EmptyClipbrd - ClipbrdFmtNames - ClipbrdFmtAtoms - AddAtom - FindAtom - DeleteAtom - AtomUsage - AtomName - AtomLength - SystemAtomTable - CreateAtomTable - DestroyAtomTable - - _ClipbrdData_set - ClipbrdText - ClipbrdText_set - ClipbrdText_2byte - ClipbrdTextUCS2le - MemoryRegionSize - - _MessageBox - MessageBox - _MessageBox2 - MessageBox2 - get_pointer - LoadPointer - SysPointer - Alarm - FlashWindow - - get_title - set_title - io_term -); -our @EXPORT_OK = qw( - ResetWinError - MPFROMSHORT - MPVOID - MPFROMCHAR - MPFROM2SHORT - MPFROMSH2CH - MPFROMLONG -); - -our $AUTOLOAD; - -sub AUTOLOAD { - # This AUTOLOAD is used to 'autoload' constants from the constant() - # XS function. If a constant is not found then control is passed - # to the AUTOLOAD in AutoLoader. - - (my $constname = $AUTOLOAD) =~ s/.*:://; - my $val = constant($constname, @_ ? $_[0] : 0); - if ($! != 0) { - if ($! =~ /Invalid/ || $!{EINVAL}) { - die "Unsupported function $AUTOLOAD" - } else { - my ($pack,$file,$line) = caller; - die "Your vendor has not defined OS2::Process macro $constname, used at $file line $line. -"; - } - } - eval "sub $AUTOLOAD { $val }"; - goto &$AUTOLOAD; -} - -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; - - *{"$p\::$sym"} = sub () { $val }; - (); # needed by import() -} - -sub import { - my $class = shift; - my $ini = @_; - @_ = ($class, - map { - /^(HWND|WM|SC|SWP|WC|PROG|QW|EDI|WS|QWS|QWP|QWL|FF|FI|LS|FS|FCF|BS|MS|TBM|CF|CFI|FID|MB|MBID|CF|CFI|SPTR)_/ ? const_import($_) : $_ - } @_); - goto &Exporter::import if @_ > 1 or $ini == 0; -} - -# Preloaded methods go here. - -sub Title () { (process_entry())[0] } - -# *Title_set = \&sesmgr_title_set; - -sub swTitle_set_sw { - my ($title, @sw) = @_; - $sw[0] = $title; - change_entry(@sw); -} - -sub swTitle_set ($) { - my (@sw) = process_entry(); - swTitle_set_sw(shift, @sw); -} - -sub winTitle_set_sw { - my ($title, @sw) = @_; - my $h = OS2::localMorphPM->new(0); - WindowText_set $sw[1], $title; -} - -sub winTitle_set ($) { - my (@sw) = process_entry(); - winTitle_set_sw(shift, @sw); -} - -sub winTitle () { - my (@sw) = process_entry(); - my $h = OS2::localMorphPM->new(0); - WindowText $sw[1]; -} - -sub bothTitle_set ($) { - my (@sw) = process_entry(); - my $t = shift; - winTitle_set_sw($t, @sw); - swTitle_set_sw($t, @sw); -} - -sub Title_set ($) { - my $t = shift; - return 1 if sesmgr_title_set($t); - return 0 unless $^E == 372; - my (@sw) = process_entry(); - winTitle_set_sw($t, @sw); - swTitle_set_sw($t, @sw); -} - -sub process_entry { swentry_expand(process_swentry(@_)) } - -our @hentry_fields = qw( title owner_hwnd icon_hwnd - owner_phandle owner_pid owner_sid - visible nonswitchable jumpable ptype sw_entry ); - -sub swentry_hexpand ($) { - my %h; - @h{@hentry_fields} = swentry_expand(shift); - \%h; -} - -sub process_hentry { swentry_hexpand(process_swentry(@_)) } -sub process_hwnd { process_hentry()->{owner_hwnd} } - -my $swentry_size = swentry_size(); - -sub sw_entries () { - my $s = swentries_list(); - my ($c, $s1) = unpack 'La*', $s; - die "Unconsistent size in swentries_list()" unless 4+$c*$swentry_size == length $s; - my (@l, $e); - push @l, $e while $e = substr $s1, 0, $swentry_size, ''; - @l; -} - -sub process_entries () { - map [swentry_expand($_)], sw_entries; -} - -sub process_hentries () { - map swentry_hexpand($_), sw_entries; -} - -sub change_entry { - change_swentry(create_swentry(@_)); -} - -sub create_swentryh ($) { - my $h = shift; - create_swentry(@$h{@hentry_fields}); -} - -sub change_entryh ($) { - change_swentry(create_swentryh(shift)); -} - -# Massage entries into the same order as WindowPos_set: -sub WindowPos ($) { - my ($fl, $h, $w, $y, $x, $behind, $hwnd, @rest) - = unpack 'L l4 L4', WindowSWP(shift); - ($x, $y, $fl, $w, $h, $behind, @rest); -} - -# Put them into a hash -sub hWindowPos ($) { - my %h; - @h{ qw(flags height width y x behind hwnd reserved1 reserved2) } - = unpack 'L l4 L4', WindowSWP(shift); - \%h; -} - -my @SWP_keys = ( [qw(width height)], # SWP_SIZE=1 - [qw(x y)], # SWP_MOVE=2 - [qw(behind)] ); # SWP_ZORDER=3 -my %SWP_def; -@SWP_def{ map @$_, @SWP_keys } = (0) x 20; - -# Get them from a hash -sub hWindowPos_set ($$) { - my $hash = shift; - my $hwnd = (@_ ? shift : $hash->{hwnd} ); - my $flags; - if (exists $hash->{flags}) { - $flags = $hash->{flags}; - } else { # Set flags according to existing keys in $hash - $flags = 0; - for my $bit (0..2) { - exists $hash->{$_} and $flags |= (1<<$bit) for @{$SWP_keys[$bit]}; - } - } - for my $bit (0..2) { # Check for required keys - next unless $flags & (1<<$bit); - exists $hash->{$_} - or die sprintf "key $_ required for flags=%#x", $flags - for @{$SWP_keys[$bit]}; - } - my %h = (%SWP_def, flags => $flags, %$hash); # Avoid warnings - my ($x, $y, $fl, $w, $h, $behind) = @h{ qw(x y flags width height behind) }; - WindowPos_set($hwnd, $x, $y, $fl, $w, $h, $behind); -} - -sub ChildWindows (;$) { - my $hm = OS2::localMorphPM->new(0); - my @kids; - my $h = BeginEnumWindows(@_ ? shift : 1); # HWND_DESKTOP - my $w; - push @kids, $w while $w = GetNextWindow $h; - EndEnumWindows $h; - @kids; -} - -sub TopLevel ($) { - my $d = DesktopWindow; - my $w = shift; - while (1) { - my $p = QueryWindow $w, 5; # QW_PARENT; - return $w if not $p or $p == $d; - $w = $p; - } -} - -sub FocusWindow_set_keep_Zorder ($) { - my $w = shift; - my $t = TopLevel $w; - my $b = hWindowPos($t)->{behind}; # we are behind this - EnableWindowUpdate($t, 0); - FocusWindow_set($w); -# sleep 1; # Make flicker stronger when present - hWindowPos_set {behind => $b}, $t; - EnableWindowUpdate($t, 1); -} - -sub 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(); -} - -sub OS2::localFlashWindow::new ($$) { - my ($c, $w) = (shift, shift); - my $morph = OS2::localMorphPM->new(0); - 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, @_); -} - -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 ($;$$$$$) { - my $morph = OS2::localMorphPM->new(0); - die "MessageBox needs text" unless @_; - push @_ , ($0 eq '-e' ? "Perl one-liner's message" : "$0 message") if @_ == 1; - &_MessageBox; -} - -my %pointers; - -sub get_pointer ($;$$) { - my $id = $_[0]; - return $pointers{$id} if exists $pointers{$id}; - $pointers{$id} = &SysPointer; -} - -# $button needs to be of the form 'String', ['String'] or ['String', flag]. -# If ['String'], it is assumed the default button; same for 'String' if $only -# is set. -sub process_MB2 ($$;$) { - die "process_MB2() needs 2 arguments, got '@_'" unless @_ == 2 or @_ == 3; - my ($button, $ret, $only) = @_; - # default is BS_PUSHBUTTON, add BS_DEFAULT if $only is set - $button = [$button, $only ? 0x400 : 0] unless ref $button eq 'ARRAY'; - push @$button, 0x400 if @$button == 1; # BS_PUSHBUTTON|BS_DEFAULT - die "Button needs to be of the form 'String', ['String'] or ['String', flag]" - unless @$button == 2; - pack "Z71 x L l", $button->[0], $ret, $button->[1]; # name, retval, flag -} - -# If one button, make it the default one even if it is of 'String' => val form. -# If icon is of the form 'SP#', load this via SysPointer. -sub process_MB2_INFO ($;$$$) { - my $l = 0; - my $out; - die "process_MB2_INFO() needs 1..4 arguments" unless @_ and @_ < 5; - my $buttons = shift; - die "Buttons array should consist of pairs" if @$buttons % 2; - - push @_, 0 unless @_; # Icon id; 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 - - my ($icon, $style, $notify) = (shift, shift, shift); - $icon = get_pointer $1 if $icon =~ /^SP#(\d+)\z/; - $out = pack "L L L L", # icon, #buttons, style, notify, buttons - $icon, @$buttons/2, $style, $notify; - $out .= join '', - map process_MB2($buttons->[2*$_], $buttons->[2*$_+1], @$buttons == 2), - 0..@$buttons/2-1; - pack('L', length(pack 'L', 0) + length $out) . $out; -} - -# MessageBox2 'Try this', OS2::Process::process_MB2_INFO([['Dismiss', 0] => 0x1000], OS2::Process::get_pointer(22),0x4080,0), 'me', 1, 0, 0 -# or the shortcut -# MessageBox2 'Try this', [[['Dismiss', 0] => 0x1000], 'SP#22'], 'me' -# 0x80 means MB_CUSTOMICON (does not focus?!). This focuses: -# MessageBox2 'Try this', [[['Dismiss',0x400] => 0x1000], 0, 0x4030,0] -# 0x400 means BS_DEFAULT. This is the same as the shortcut -# MessageBox2 'Try this', [[Dismiss => 0x1000]] -sub MessageBox2 ($;$$$$$) { - my $morph = OS2::localMorphPM->new(0); - die "MessageBox needs text" unless @_; - push @_ , [[Dismiss => 0x1000], # Name, retval (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" : $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 (;$$) { - my $data = &_vioConfig; - my @out = unpack 'x[S]SSLSSSLLLSS', $data; - # If present, offset points to S/S (with only the first work making sense) - my (@adaptersEMU, @displayEMU); - @displaysEMU = unpack("x[$out[10]]S/S", $data), pop @out if @out > 10; - @adaptersEMU = unpack("x[$out[ 9]]S/S", $data), pop @out if @out > 9; - $out[9] = $adaptersEMU[0] if @adaptersEMU; - $out[10] = $displaysEMU[0] if @displaysEMU; - @out; -} - -my @vioConfig = qw(adapter display cbMemory Configuration VDHVersion Flags - HWBufferSize FullSaveSize PartSaveSize EMAdapters EMDisplays); - -sub viohConfig (;$$) { - my %h; - @h{@vioConfig} = &vioConfig; - %h; -} - -# fbType; color; col; row; hres; vres; fmt_ID; attrib; buf_addr; buf_length; -# full_length; partial_length; ext_data_addr; -sub vioMode() {unpack 'x[S]CCSSSSCCLLLLL', _vioMode} - -my @vioMode = qw( fbType color col row hres vres fmt_ID attrib buf_addr - buf_length full_length partial_length ext_data_addr); - -sub viohMode() { - my %h; - @h{@vioMode} = vioMode; - %h; -} - -sub viohMode_set { - my %h = (viohMode, @_); - my $o = pack 'x[S]CCSSSSCCLLLLL', @h{@vioMode}; - $o = pack 'SCCSSSSCCLLLLL', length $o, @h{@vioMode}; - _vioMode_set($o); -} - -sub kbdChar (;$$) {unpack 'CCCCSL', &_kbdChar} - -my @kbdChar = qw(ascii scancode status nlsstate shifts time); -sub kbdhChar (;$$) { - my %h; - @h{@kbdChar} = &kbdChar; - %h -} - -sub kbdStatus (;$) {unpack 'x[S]SSSS', &_kbdStatus} -my @kbdStatus = qw(state turnChar intCharFlags shifts); -sub kbdhStatus (;$) { - my %h; - @h{@kbdStatus} = &kbdStatus; - %h -} -sub kbdhStatus_set { - my $h = (@_ % 2 ? shift @_ : 0); - my %h = (kbdhStatus($h), @_); - my $o = pack 'x[S]SSSS', @h{@kbdStatus}; - $o = pack 'SSSSS', length $o, @h{@kbdStatus}; - _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. - -1; -__END__ - -=head1 NAME - -OS2::Process - exports constants for system() call, and process control on OS2. - -=head1 SYNOPSIS - - use OS2::Process; - $pid = system(P_PM | P_BACKGROUND, "epm.exe"); - -=head1 DESCRIPTION - -=head2 Optional argument to system() - -the builtin function system() under OS/2 allows an optional first -argument which denotes the mode of the process. Note that this argument is -recognized only if it is strictly numerical. - -You can use either one of the process modes: - - P_WAIT (0) = wait until child terminates (default) - P_NOWAIT = do not wait until child terminates - P_SESSION = new session - P_DETACH = detached - P_PM = PM program - -and optionally add PM and session option bits: - - P_DEFAULT (0) = default - P_MINIMIZE = minimized - P_MAXIMIZE = maximized - P_FULLSCREEN = fullscreen (session only) - P_WINDOWED = windowed (session only) - - P_FOREGROUND = foreground (if running in foreground) - P_BACKGROUND = background - - P_NOCLOSE = don't close window on exit (session only) - - P_QUOTE = quote all arguments - P_TILDE = MKS argument passing convention - P_UNRELATED = do not kill child when father terminates - -=head2 Access to process properties - -On OS/2 processes have the usual I semantic; -additionally, there is a hierarchy of sessions with their own -I tree. A session is either a FS session, or a windowed -pseudo-session created by PM. A session is a "unit of user -interaction", a change to in/out settings in one of them does not -affect other sessions. - -=over - -=item my_type() - -returns the type of the current process (one of -"FS", "DOS", "VIO", "PM", "DETACH" and "UNKNOWN"), or C on error. - -=item C - -returns the type of the executable file C, or -dies on error. The bits 0-2 of the result contain one of the values - -=over - -=item C (0) - -Application type is not specified in the executable header. - -=item C (1) - -Application type is not-window-compatible. - -=item C (2) - -Application type is window-compatible. - -=item C (3) - -Application type is window-API. - -=back - -The remaining bits should be masked with the following values to -determine the type of the executable: - -=over - -=item C (8) - -Set to 1 if the executable file has been "bound" (by the BIND command) -as a Family API application. Bits 0, 1, and 2 still apply. - -=item C (0x10) - -Set to 1 if the executable file is a dynamic link library (DLL) -module. Bits 0, 1, 2, 3, and 5 will be set to 0. - -=item C (0x20) - -Set to 1 if the executable file is in PC/DOS format. Bits 0, 1, 2, 3, -and 4 will be set to 0. - -=item C (0x40) - -Set to 1 if the executable file is a physical device driver. - -=item C (0x80) - -Set to 1 if the executable file is a virtual device driver. - -=item C (0x100) - -Set to 1 if the executable file is a protected-memory dynamic link -library module. - -=item C (0x4000) - -Set to 1 for 32-bit executable files. - -=back - -file_type() may croak with one of the strings C<"Invalid EXE -signature"> or C<"EXE marked invalid"> to indicate typical error -conditions. If given non-absolute path, will look on C, will -add extension F<.exe> if no extension is present (add extension F<.> -to suppress). - -=item C<@list = process_codepages()> - -the first element is the currently active codepage, up to 2 additional -entries specify the system's "prepared codepages": the codepages the -user can switch to. The active codepage of a process is one of the -prepared codepages of the system (if present). - -=item C - -sets the currently active codepage. [Affects printer output, in/out -codepages of sessions started by this process, and the default -codepage for drawing in PM; is inherited by kids. Does not affect the -out- and in-codepages of the session.] - -=item ppid() - -returns the PID of the parent process. - -=item C - -returns the PID of the parent process of $pid. -1 on error. - -=item C - -returns the session id of the process id $pid. -1 on error. - -=back - -=head2 Control of VIO sessions - -VIO applications are applications running in a text-mode session. - -=over - -=item out_codepage() - -gets code page used for screen output (glyphs). -1 means that a user font -was loaded. - -=item C - -sets code page used for screen output (glyphs). -1 switches to a preloaded -user font. -2 switches off the preloaded user font. - -=item in_codepage() - -gets code page used for keyboard input. 0 means that a hardware codepage -is used. - -=item C - -sets code page used for keyboard input. - -=item C<($w, $h) = scrsize()> - -width and height of the given console window in character cells. - -=item C - -set height (and optionally width) of the given console window in -character cells. Use 0 size to keep the old size. - -=item C<($s, $e, $w, $a) = cursor()> - -gets start/end lines of the blinking cursor in the charcell, its width -(1 on text modes) and attribute (-1 for hidden, in text modes other -values mean visible, in graphic modes color). - -=item C - -sets start/end lines of the blinking cursor in the charcell. Negative -values mean percents of the character cell height. - -=item screen() - -gets a buffer with characters and attributes of the screen. - -=item C - -restores the screen given the result of screen(). E.g., if the file -C<$file> contains the screen contents, then - - open IN, $file or die; - binmode IN; - read IN, $in, -s IN; - $s = screen; - $in .= qq(\0) x (length($s) - length $in); - substr($in, length $s) = ''; - screen_set $in; - -will restore the screen content even if the height of the window -changed (if the width changed, more manipulation is needed). - -=back - -=head2 Control of the process list - -With the exception of Title_set(), all these calls require that PM is -running, they would not work under alternative Session Managers. - -=over - -=item process_entry() - -returns a list of the following data: - -=over - -=item - -Title of the process (in the C list); - -=item - -window handle of switch entry of the process (in the C list); - -=item - -window handle of the icon of the process; - -=item - -process handle of the owner of the entry in C list; - -=item - -process id of the owner of the entry in C list; - -=item - -session id of the owner of the entry in C list; - -=item - -whether visible in C list; - -=item - -whether item cannot be switched to (note that it is not actually -grayed in the C list)); - -=item - -whether participates in jump sequence; - -=item - -program type. Possible values are: - - PROG_DEFAULT 0 - PROG_FULLSCREEN 1 - PROG_WINDOWABLEVIO 2 - PROG_PM 3 - PROG_VDM 4 - PROG_WINDOWEDVDM 7 - -Although there are several other program types for WIN-OS/2 programs, -these do not show up in this field. Instead, the PROG_VDM or -PROG_WINDOWEDVDM program types are used. For instance, for -PROG_31_STDSEAMLESSVDM, PROG_WINDOWEDVDM is used. This is because all -the WIN-OS/2 programs run in DOS sessions. For example, if a program -is a windowed WIN-OS/2 program, it runs in a PROG_WINDOWEDVDM -session. Likewise, if it's a full-screen WIN-OS/2 program, it runs in -a PROG_VDM session. - -=item - -switch-entry handle. - -=back - -Optional arguments: the pid and the window-handle of the application running -in the OS/2 session to query. - -=item process_hentry() - -similar to process_entry(), but returns a hash reference, the keys being - - title owner_hwnd icon_hwnd owner_phandle owner_pid owner_sid - visible nonswitchable jumpable ptype sw_entry - -(a copy of the list of keys is in @hentry_fields). - -=item process_entries() - -similar to process_entry(), but returns a list of array reference for all -the elements in the switch list (one controlling C window). - -=item process_hentries() - -similar to process_hentry(), but returns a list of hash reference for all -the elements in the switch list (one controlling C window). - -=item change_entry() - -changes a process entry, arguments are the same as process_entry() returns. - -=item change_entryh() - -Similar to change_entry(), but takes a hash reference as an argument. - -=item process_hwnd() - -returns the C of the process entry (for VIO windowed processes -this is the frame window of the session). - -=item Title() - -returns the text of the task switch menu entry of the current session. -(There is no way to get this info in non-standard Session Managers. This -implementation is a shortcut via process_entry().) - -=item C - -tries two different interfaces. The Session Manager one does not work -with some windows (if the title is set from the start). -This is a limitation of OS/2, in such a case $^E is set to 372 (type - - help 372 - -for a funny - and wrong - explanation ;-). In such cases a -direct-manipulation of low-level entries is used (same as bothTitle_set()). -Keep in mind that some versions of OS/2 leak memory with such a manipulation. - -=item winTitle() - -returns text of the titlebar of the current process' window. - -=item C - -sets text of the titlebar of the current process' window. The change does not -affect the text of the switch entry of the current window. - -=item C - -sets text of the task switch menu entry of the current process' window. [There -is no API to query this title.] Does it via SwitchEntry interface, -not Session manager interface. The change does not affect the text of the -titlebar of the current window. - -=item C - -sets text of the titlebar and task switch menu of the current process' window -via direct manipulation of the windows' texts. - -=item C - -switch to session given by a switch list handle (defaults to the entry of our process). - -Use of this function causes another window (and its related windows) -of a PM session to appear on the front of the screen, or a switch to -another session in the case of a non-PM program. In either case, -the keyboard (and mouse for the non-PM case) input is directed to -the new program. - -=back - -=head2 Control of the PM windows - -Some of these API's require sending a message to the specified window. -In such a case the process needs to be a PM process, or to be morphed -to a PM process via OS2::MorphPM(). - -For a temporary morphing to PM use L. - -Keep in mind that PM windows are engaged in 2 "orthogonal" window -trees, as well as in the z-order list. - -One tree is given by the I relationship. This -relationship affects drawing (child is drawn relative to its parent -(lower-left corner), and the drawing is clipped by the parent's -boundary; parent may request that I drawing is clipped to be -confined to the outsize of the childs and/or siblings' windows); -hiding; minimizing/restoring; and destroying windows. - -Another tree (not necessarily connected?) is given by I -relationship. Ownership relationship assumes cooperation of the -engaged windows via passing messages on "important events"; e.g., -scrollbars send information messages when the "bar" is moved, menus -send messages when an item is selected; frames -move/hide/unhide/minimize/restore/change-z-order-of owned frames when -the owner is moved/etc., and destroy the owned frames (even when these -frames are not descendants) when the owner is destroyed; etc. [An -important restriction on ownership is that owner should be created by -the same thread as the owned thread, so they engage in the same -message queue.] - -Windows may be in many different state: Focused (take keyboard events) or not, -Activated (=Frame windows in the I tree between the root and -the window with the focus; usually indicate such "active state" by titlebar -highlights, and take mouse events) or not, Enabled/Disabled (this influences -the ability to update the graphic, and may change appearance, as for -enabled/disabled buttons), Visible/Hidden, Minimized/Maximized/Restored, Modal -or not, etc. - -The APIs below all die() on error with the message being $^E. - -=over - -=item C - -gets "a text content" of a window. Requires (morphing to) PM. - -=item C - -sets "a text content" of a window. Requires (morphing to) PM. - -=item C<($x, $y, $flags, $width, $height, $behind, @rest) = WindowPos($hwnd)> - -gets window position info as 8 integers (of C), in the order suitable -for WindowPos_set(). @rest is marked as "reserved" in PM docs. $flags -is a combination of C constants. - -=item C<$hash = hWindowPos($hwnd)> - -gets window position info as a hash reference; the keys are C. - -Example: - - exit unless $hash->{flags} & SWP_MAXIMIZE; # Maximized - -=item C - -Set state of the window: position, size, zorder, show/hide, activation, -minimize/maximize/restore etc. Which of these operations to perform -is governed by $flags. - -=item C - -Same as C, but takes the position from keys C of the hash referenced by $hash. If $hwnd is explicitly -specified, it overrides C<$hash->{hwnd}>. If $hash->{flags} is not specified, -it is calculated basing on the existing keys of $hash. Requires (morphing to) PM. - -Example: - - hWindowPos_set {flags => SWP_MAXIMIZE}, $hwnd; # Maximize - -=item C<($pid, $tid) = WindowProcess($hwnd)> - -gets I and I of the process associated to the window. - -=item C - -returns the class name of the window. - -If this window is of any of the preregistered WC_* classes the class -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 -the desktop to use. - -=item C - -set the focus window by handle. Optional argument for specifying the desktop -to use. E.g, the first entry in program_entries() is the C list. -To show an application, use either one of - - WinShowWindow( $hwnd, 1 ); - FocusWindow_set( $hwnd ); - SwitchToProgram($switch_handle); - -(Which work with alternative focus-to-front policies?) Requires -(morphing to) PM. - -Switching focus to currently-unfocused window moves the window to the -front in Z-order; use FocusWindow_set_keep_Zorder() to avoid this. - -=item C - -same as FocusWindow_set(), but preserves the Z-order of windows. - -=item C - -gets the active subwindow's handle for $parentHwnd or desktop. -Returns FALSE if none. - -=item C - -sets the active subwindow's handle for $parentHwnd or desktop. Requires (morphing to) PM. - -=item C - -Set visible/hidden flag of the window. Default: $show is TRUE. - -=item C - -Set window visibility state flag for the window for subsequent drawing. -No actual drawing is done at this moment. Use C -when redrawing is needed. While update is disabled, changes to the "window -state" do not change the appearance of the window. Default: $update is TRUE. - -(What is manipulated is the bit C of the window style.) - -=item C - -Set the window enabled state. Default: $enable is TRUE. - -Results in C message sent to the window. Typically, this -would change the appearence of the window. If at the moment of disabling -focus is in the window (or a descendant), focus is lost (no focus anywhere). -If focus is needed, it can be reassigned explicitly later. - -=item IsWindowEnabled(), IsWindowVisible(), IsWindowShowing() - -these functions take $hwnd as an argument. IsWindowEnabled() queries -the state changed by EnableWindow(), IsWindowVisible() the state changed -by ShowWindow(), IsWindowShowing() is true if there is a part of the window -visible on the screen. - -=item C - -post message to a window. The meaning of $mp1, $mp2 is specific for each -message id $msg, they default to 0. E.g., - - use OS2::Process qw(:DEFAULT WM_SYSCOMMAND WM_CONTEXTMENU - WM_SAVEAPPLICATION WM_QUIT WM_CLOSE - SC_MAXIMIZE SC_RESTORE); - $hwnd = process_hentry()->{owner_hwnd}; - # Emulate choosing `Restore' from the window menu: - PostMsg $hwnd, WM_SYSCOMMAND, MPFROMSHORT(SC_RESTORE); # Not immediate - - # Emulate `Show-Contextmenu' (Double-Click-2), two ways: - PostMsg ActiveWindow, WM_CONTEXTMENU; - PostMsg FocusWindow, WM_CONTEXTMENU; - - /* Emulate `Close' */ - PostMsg ActiveWindow, WM_CLOSE; - - /* Same but with some "warnings" to the application */ - $hwnd = ActiveWindow; - PostMsg $hwnd, WM_SAVEAPPLICATION; - PostMsg $hwnd, WM_CLOSE; - PostMsg $hwnd, WM_QUIT; - -In fact, MPFROMSHORT() may be omitted above. - -For messages to other processes, messages which take/return a pointer are -not supported. - -=item C - -The functions MPFROMSHORT(), MPVOID(), MPFROMCHAR(), MPFROM2SHORT(), -MPFROMSH2CH(), MPFROMLONG() can be used the same way as from C. Use them -to construct parameters $m1, $m2 to PostMsg(). - -These functions are not exported by default. - -=item C<$eh = BeginEnumWindows($hwnd)> - -starts enumerating immediate child windows of $hwnd in z-order. The -enumeration reflects the state at the moment of BeginEnumWindows() calls; -use IsWindow() to be sure. All the functions in this group require (morphing to) PM. - -=item C<$kid_hwnd = GetNextWindow($eh)> - -gets the next kid in the list. Gets 0 on error or when the list ends. - -=item C - -End enumeration and release the list. - -=item C<@list = ChildWindows([$hwnd])> - -returns the list of child windows at the moment of the call. Same remark -as for enumeration interface applies. Defaults to HWND_DESKTOP. -Example of usage: - - sub l { - my ($o,$h) = @_; - printf ' ' x $o . "%#x\n", $h; - l($o+2,$_) for ChildWindows $h; - } - l 0, $HWND_DESKTOP - -=item C - -true if the window handle is still valid. - -=item C - -gets the handle of a related window. $type should be one of C constants. - -=item C - -return TRUE if $hwnd is a descendant of $parent. - -=item C - -return a window handle of a child of $hwnd with the given $id. - - hwndSysMenu = WinWindowFromID(hwndDlg, FID_SYSMENU); - WinSendMsg(hwndSysMenu, MM_SETITEMATTR, - MPFROM2SHORT(SC_CLOSE, TRUE), - MPFROM2SHORT(MIA_DISABLED, MIA_DISABLED)); - -=item C - -gets a handle of a child of $hwndParent at C<($x,$y)>. If $descedantsToo -(defaulting to 1) then children of children may be returned too. May return -$hwndParent (defaults to desktop) if no suitable children are found, -or 0 if the point is outside the parent. - -$x and $y are relative to $hwndParent. - -=item C - -gets a dialog item window handle for an item of type $type of $dlgHwnd -relative to $relativeHwnd, which is descendant of $dlgHwnd. -$relativeHwnd may be specified if $type is EDI_FIRSTTABITEM or -EDI_LASTTABITEM. - -The return is always an immediate child of hwndDlg, even if hwnd is -not an immediate child window. $type may be - -=over - -=item EDI_FIRSTGROUPITEM - -First item in the same group. - -=item EDI_FIRSTTABITEM - -First item in dialog with style WS_TABSTOP. hwnd is ignored. - -=item EDI_LASTGROUPITEM - -Last item in the same group. - -=item EDI_LASTTABITEM - -Last item in dialog with style WS_TABSTOP. hwnd is ignored. - -=item EDI_NEXTGROUPITEM - -Next item in the same group. Wraps around to beginning of group when -the end of the group is reached. - -=item EDI_NEXTTABITEM - -Next item with style WS_TABSTOP. Wraps around to beginning of dialog -item list when end is reached. - -=item EDI_PREVGROUPITEM - -Previous item in the same group. Wraps around to end of group when the -start of the group is reached. For information on the WS_GROUP style, -see Window Styles. - -=item EDI_PREVTABITEM - -Previous item with style WS_TABSTOP. Wraps around to end of dialog -item list when beginning is reached. - -=back - -=item DesktopWindow() - -gets the actual window handle of the PM desktop; most APIs accept the -pseudo-handle C instead. Keep in mind that the WPS -desktop (one with WindowText() being C<"Desktop">) is a different beast?! - -=item TopLevel($hwnd) - -gets the toplevel window of $hwnd. - -=item ResetWinError() - -Resets $^E. One may need to call it before the C-class APIs which may -return 0 during normal operation. In such a case one should check both -for return value being zero and $^E being non-zero. The following APIs -do ResetWinError() themselves, thus do not need an explicit one: - - WindowPtr - WindowULong - WindowUShort - WindowTextLength - ActiveWindow - PostMsg - -This function is normally not needed. Not exported by default. - -=back - -=head2 Control of the PM data - -=over - -=item ActiveDesktopPathname() - -gets the path of the directory which corresponds to Desktop. - -=item 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). 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. This function will only work with clipboard -data types which are delimited by C<"\0"> byte (not included in the result). - -=item ClipbrdText_2byte - -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 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 ] ]) - -returns the $fmtInfo flags set by the application which filled the -format $fmt of the clipboard. $fmt defaults to C. - -=item ClipbrdOwner( [ $hab ] ) - -Returns window handle of the current clipboard owner. - -=item ClipbrdViewer( [ $hab ] ) - -Returns window handle of the current clipboard viewer. - -=item ClipbrdData( [$fmt, [ $hab ] ]) - -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). - -Clipboard should be opened before calling this function. May croak with error -C if no data of given $fmt is present. - -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 OpenClipbrd( [ $hab ] ) - -claim read access to the clipboard. May need a message queue to operate. -May block until other processes finish dealing with clipboard. - -=item CloseClipbrd( [ $hab ] ) - -Allow other processes access to clipboard. -Clipboard should be opened before calling this function. - -=item ClipbrdData_set($data, [$convert_nl, [$fmt, [$fmtInfo, [ $hab] ] ] ] ) - -Sets the clipboard data of format given by atom $fmt. Format defaults to -CF_TEXT. - -$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. - -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 _ClipbrdData_set($data, [$fmt, [$fmtInfo, [ $hab] ] ] ) - -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. - -$fmtInfo has the same semantic as for ClipbrdData_set(). - -=item ClipbrdOwner_set( $hwnd, [ $hab ] ) - -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 - -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 - -=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); - # Do something - } - -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: - - SwitchToProgram - ClassName - out_codepage - out_codepage_set - in_codepage - in_codepage_set - cursor - cursor_set - screen - screen_set - process_codepages - QueryWindow - EnumDlgItem - WindowPtr - WindowUShort - SetWindowBits - SetWindowPtr - SetWindowULong - SetWindowUShort - my_type - file_type - scrsize - scrsize_set - -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. - - - >But I wish to change the default button if the user enters some - >text into an entryfield. I can detect the entry ok, but can't - >seem to get the button to change to default. - > - >No matter what message I send it, it's being ignored. - - You need to get the style of the buttons using WinQueryWindowULong/QWL_STYLE, - set and reset the BS_DEFAULT bits as appropriate and then use - WinSetWindowULong/QWL_STYLE to set the button style. - Something like this: - hwnd1 = WinWindowFromID (hwnd, id1); - hwnd2 = WinWindowFromID (hwnd, id2); - style1 = WinQueryWindowULong (hwnd1, QWL_STYLE); - style2 = WinQueryWindowULong (hwnd2, QWL_STYLE); - style1 |= style2 & BS_DEFAULT; - style2 &= ~BS_DEFAULT; - WinSetWindowULong (hwnd1, QWL_STYLE, style1); - WinSetWindowULong (hwnd2, QWL_STYLE, style2); - - > How to do query and change a frame creation flags for existing window? - - Set the style bits that correspond to the FCF_* flag for the frame - window and then send a WM_UPDATEFRAME message with the appropriate FCF_* - flag in mp1. - - ULONG ulFrameStyle; - ulFrameStyle = WinQueryWindowULong( WinQueryWindow(hwnd, QW_PARENT), - QWL_STYLE ); - ulFrameStyle = (ulFrameStyle & ~FS_SIZEBORDER) | FS_BORDER; - WinSetWindowULong( WinQueryWindow(hwnd, QW_PARENT), - QWL_STYLE, - ulFrameStyle ); - WinSendMsg( WinQueryWindow(hwnd, QW_PARENT), - WM_UPDATEFRAME, - MPFROMP(FCF_SIZEBORDER), - MPVOID ); - - If the FCF_* flags you want to change does not have a corresponding FS_* - style (i.e. the FCF_* flag corresponds to the presence/lack of a frame - control rather than a property of the frame itself) then you create or - destroy the appropriate control window using the correct FID_* window - identifier and then send the WM_UPDATEFRAME message with the appropriate - FCF_* flag in mp1. - - /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -* - | SetFrameBorder() | - | Changes a frame window's border to the requested type. | - | | - | Parameters on entry: | - | hwndFrame -> Frame window whose border is to be changed. | - | ulBorderStyle -> Type of border to change to. | - | | - | Returns: | - | BOOL -> Success indicator. | - | | - * - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -*/ - BOOL SetFrameBorder( HWND hwndFrame, ULONG ulBorderType ) { - ULONG ulFrameStyle; - BOOL fSuccess = TRUE; - - ulFrameStyle = WinQueryWindowULong( hwndFrame, QWL_STYLE ); - - switch ( ulBorderType ) { - case FS_SIZEBORDER : - ulFrameStyle = (ulFrameStyle & ~(FS_DLGBORDER | FS_BORDER)) - | FS_SIZEBORDER; - break; - - case FS_DLGBORDER : - ulFrameStyle = (ulFrameStyle & ~(FS_SIZEBORDER | FS_BORDER)) - | FS_DLGBORDER; - break; - - case FS_BORDER : - ulFrameStyle = (ulFrameStyle & ~(FS_SIZEBORDER | FS_DLGBORDER)) - | FS_BORDER; - break; - - default : - fSuccess = FALSE; - break; - } // end switch - - if ( fSuccess ) { - fSuccess = WinSetWindowULong( hwndFrame, QWL_STYLE, ulFrameStyle ); - - if ( fSuccess ) { - fSuccess = (BOOL)WinSendMsg( hwndFrame, WM_UPDATEFRAME, 0, 0 ); - if ( fSuccess ) - fSuccess = WinInvalidateRect( hwndFrame, NULL, TRUE ); - } - } - - return ( fSuccess ); - - } // End SetFrameBorder() - - hwndMenu=WinLoadMenu(hwndParent,NULL,WND_IMAGE); - WinSetWindowUShort(hwndMenu,QWS_ID,FID_MENU); - ulStyle=WinQueryWindowULong(hwndMenu,QWL_STYLE); - WinSetWindowULong(hwndMenu,QWL_STYLE,ulStyle|MS_ACTIONBAR); - WinSendMsg(hwndParent,WM_UPDATEFRAME,MPFROMSHORT(FCF_MENU),0L); - - OS/2-windows have another "parent" called the *owner*, - which must be set separately - to get a close relationship: - - WinSetOwner (hwndFrameChild, hwndFrameMain); - - Now your child should move with your main window! - And always stays on top of it.... - - To avoid this, for example for dialogwindows, you can - also "disconnect" this relationship with: - - WinSetWindowBits (hwndFrameChild, QWL_STYLE - , FS_NOMOVEWITHOWNER - , FS_NOMOVEWITHOWNER); - - Adding a button icon later: - - /* switch the button style to BS_MINIICON */ - WinSetWindowBits(hwndBtn, QWL_STYLE, BS_MINIICON, BS_MINIICON) ; - - /* set up button control data */ - BTNCDATA bcd; - bcd.cb = sizeof(BTNCDATA); - bcd.hImage = WinLoadPointer(HWND_DESKTOP, dllHandle, ID_ICON_BUTTON1) ; - bcd.fsCheckState = bcd.fsHiliteState = 0 ; - - - WNDPARAMS wp; - wp.fsStatus = WPM_CTLDATA; - wp.pCtlData = &bcd; - - /* add the icon on the button */ - WinSendMsg(hwndBtn, WM_SETWINDOWPARAMS, (MPARAM)&wp, NULL); - - MO> Can anyone tell what OS/2 expects of an application to be properly - MO> minimized to the desktop? - case WM MINMAXFRAME : - { - BOOL fShow = ! (((PSWP) mp1)->fl & SWP MINIMIZE); - HENUM henum; - - HWND hwndChild; - - WinEnableWindowUpdate ( hwnd, FALSE ); - - for (henum=WinBeginEnumWindows(hwnd); - (hwndChild = WinGetNextWindow (henum)) != 0; ) - WinShowWindow ( hwndChild, fShow ); - - WinEndEnumWindows ( henum ); - WinEnableWindowUpdate ( hwnd, TRUE ); - } - break; - -Why C gives C<< behind => HWND_TOP >>? - -=head1 $^E - -the majority of the APIs of this module set $^E on failure (no matter -whether they die() on failure or not). By the semantic of PM API -which returns something other than a boolean, it is impossible to -distinguish failure from a "normal" 0-return. In such cases C<$^E == -0> indicates an absence of error. - -=head1 EXPORTS - -In addition to symbols described above, the following constants (available -also via module C) are exportable. Note that these -symbols live in package C, they are not available -by full name through C! - - HWND_* Standard (abstract) window handles - WM_* Message ids - SC_* WM_SYSCOMMAND flavor - SWP_* Size/move etc flag - WC_* Standard window classes - PROG_* Program category (PM, VIO etc) - QW_* Query-Window flag - EDI_* Enumerate-Dialog-Item code - WS_* Window Style flag - QWS_* Query-window-UShort offsets - QWP_* Query-window-pointer offsets - QWL_* Query-window-ULong offsets - FF_* Frame-window state flags - FI_* Frame-window information flags - LS_* List box styles - FS_* Frame style - FCF_* Frame creation flags - BS_* Button style - MS_* Menu style - TBM_* Title bar messages? - CF_* Clipboard formats - CFI_* Clipboard storage type - FID_* ids of subwindows of frames - -=head1 BUGS - -whether a given API dies or returns FALSE/empty-list on error may be -confusing. This may change in the future. - -=head1 AUTHOR - -Andreas Kaiser , -Ilya Zakharevich . - -=head1 SEE ALSO - -C() system calls, L and L modules. - -=cut diff --git a/os2/OS2/Process/Process.xs b/os2/OS2/Process/Process.xs deleted file mode 100644 index 05befa02cc..0000000000 --- a/os2/OS2/Process/Process.xs +++ /dev/null @@ -1,1896 +0,0 @@ -#include -#define INCL_DOS -#define INCL_DOSERRORS -#define INCL_DOSNLS -#define INCL_WINSWITCHLIST -#define INCL_WINWINDOWMGR -#define INCL_WININPUT -#define INCL_VIO -#define INCL_KBD -#define INCL_WINCLIPBOARD -#define INCL_WINATOM -#include - -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" - -static unsigned long -constant(char *name, int arg) -{ - errno = 0; - if (name[0] == 'P' && name[1] == '_') { - if (strEQ(name, "P_BACKGROUND")) -#ifdef P_BACKGROUND - return P_BACKGROUND; -#else - goto not_there; -#endif - if (strEQ(name, "P_DEBUG")) -#ifdef P_DEBUG - return P_DEBUG; -#else - goto not_there; -#endif - if (strEQ(name, "P_DEFAULT")) -#ifdef P_DEFAULT - return P_DEFAULT; -#else - goto not_there; -#endif - if (strEQ(name, "P_DETACH")) -#ifdef P_DETACH - return P_DETACH; -#else - goto not_there; -#endif - if (strEQ(name, "P_FOREGROUND")) -#ifdef P_FOREGROUND - return P_FOREGROUND; -#else - goto not_there; -#endif - if (strEQ(name, "P_FULLSCREEN")) -#ifdef P_FULLSCREEN - return P_FULLSCREEN; -#else - goto not_there; -#endif - if (strEQ(name, "P_MAXIMIZE")) -#ifdef P_MAXIMIZE - return P_MAXIMIZE; -#else - goto not_there; -#endif - if (strEQ(name, "P_MINIMIZE")) -#ifdef P_MINIMIZE - return P_MINIMIZE; -#else - goto not_there; -#endif - if (strEQ(name, "P_NOCLOSE")) -#ifdef P_NOCLOSE - return P_NOCLOSE; -#else - goto not_there; -#endif - if (strEQ(name, "P_NOSESSION")) -#ifdef P_NOSESSION - return P_NOSESSION; -#else - goto not_there; -#endif - if (strEQ(name, "P_NOWAIT")) -#ifdef P_NOWAIT - return P_NOWAIT; -#else - goto not_there; -#endif - if (strEQ(name, "P_OVERLAY")) -#ifdef P_OVERLAY - return P_OVERLAY; -#else - goto not_there; -#endif - if (strEQ(name, "P_PM")) -#ifdef P_PM - return P_PM; -#else - goto not_there; -#endif - if (strEQ(name, "P_QUOTE")) -#ifdef P_QUOTE - return P_QUOTE; -#else - goto not_there; -#endif - if (strEQ(name, "P_SESSION")) -#ifdef P_SESSION - return P_SESSION; -#else - goto not_there; -#endif - if (strEQ(name, "P_TILDE")) -#ifdef P_TILDE - return P_TILDE; -#else - goto not_there; -#endif - if (strEQ(name, "P_UNRELATED")) -#ifdef P_UNRELATED - return P_UNRELATED; -#else - goto not_there; -#endif - if (strEQ(name, "P_WAIT")) -#ifdef P_WAIT - return P_WAIT; -#else - goto not_there; -#endif - if (strEQ(name, "P_WINDOWED")) -#ifdef P_WINDOWED - return P_WINDOWED; -#else - goto not_there; -#endif - } else if (name[0] == 'T' && name[1] == '_') { - if (strEQ(name, "FAPPTYP_NOTSPEC")) -#ifdef FAPPTYP_NOTSPEC - return FAPPTYP_NOTSPEC; -#else - goto not_there; -#endif - if (strEQ(name, "T_NOTWINDOWCOMPAT")) -#ifdef FAPPTYP_NOTWINDOWCOMPAT - return FAPPTYP_NOTWINDOWCOMPAT; -#else - goto not_there; -#endif - if (strEQ(name, "T_WINDOWCOMPAT")) -#ifdef FAPPTYP_WINDOWCOMPAT - return FAPPTYP_WINDOWCOMPAT; -#else - goto not_there; -#endif - if (strEQ(name, "T_WINDOWAPI")) -#ifdef FAPPTYP_WINDOWAPI - return FAPPTYP_WINDOWAPI; -#else - goto not_there; -#endif - if (strEQ(name, "T_BOUND")) -#ifdef FAPPTYP_BOUND - return FAPPTYP_BOUND; -#else - goto not_there; -#endif - if (strEQ(name, "T_DLL")) -#ifdef FAPPTYP_DLL - return FAPPTYP_DLL; -#else - goto not_there; -#endif - if (strEQ(name, "T_DOS")) -#ifdef FAPPTYP_DOS - return FAPPTYP_DOS; -#else - goto not_there; -#endif - if (strEQ(name, "T_PHYSDRV")) -#ifdef FAPPTYP_PHYSDRV - return FAPPTYP_PHYSDRV; -#else - goto not_there; -#endif - if (strEQ(name, "T_VIRTDRV")) -#ifdef FAPPTYP_VIRTDRV - return FAPPTYP_VIRTDRV; -#else - goto not_there; -#endif - if (strEQ(name, "T_PROTDLL")) -#ifdef FAPPTYP_PROTDLL - return FAPPTYP_PROTDLL; -#else - goto not_there; -#endif - if (strEQ(name, "T_32BIT")) -#ifdef FAPPTYP_32BIT - return FAPPTYP_32BIT; -#else - goto not_there; -#endif - } - - errno = EINVAL; - return 0; - -not_there: - errno = ENOENT; - return 0; -} - -const char* const ptypes[] = { "FS", "DOS", "VIO", "PM", "DETACH" }; - -static char * -my_type() -{ - int rc; - TIB *tib; - PIB *pib; - - if (!(_emx_env & 0x200)) return (char*)ptypes[1]; /* not OS/2. */ - if (CheckOSError(DosGetInfoBlocks(&tib, &pib))) - return NULL; - - return (pib->pib_ultype <= 4 ? (char*)ptypes[pib->pib_ultype] : "UNKNOWN"); -} - -static ULONG -file_type(char *path) -{ - int rc; - ULONG apptype; - - if (!(_emx_env & 0x200)) - croak("file_type not implemented on DOS"); /* not OS/2. */ - if (CheckOSError(DosQueryAppType(path, &apptype))) { -#if 0 - if (rc == ERROR_INVALID_EXE_SIGNATURE) - croak("Invalid EXE signature"); - else if (rc == ERROR_EXE_MARKED_INVALID) { - croak("EXE marked invalid"); - } -#endif - croak_with_os2error("DosQueryAppType"); - } - - return apptype; -} - -/* These use different type of wrapper. Good to check wrappers. ;-) */ -/* XXXX This assumes DOS type return type, without SEVERITY?! */ -DeclFuncByORD(HSWITCH, myWinQuerySwitchHandle, ORD_WinQuerySwitchHandle, - (HWND hwnd, PID pid), (hwnd, pid)) -DeclFuncByORD(ULONG, myWinQuerySwitchEntry, ORD_WinQuerySwitchEntry, - (HSWITCH hsw, PSWCNTRL pswctl), (hsw, pswctl)) -DeclFuncByORD(ULONG, myWinSetWindowText, ORD_WinSetWindowText, - (HWND hwnd, char* text), (hwnd, text)) -DeclFuncByORD(BOOL, myWinQueryWindowProcess, ORD_WinQueryWindowProcess, - (HWND hwnd, PPID ppid, PTID ptid), (hwnd, ppid, ptid)) -DeclFuncByORD(ULONG, XmyWinSwitchToProgram, ORD_WinSwitchToProgram, - (HSWITCH hsw), (hsw)) -#define myWinSwitchToProgram(hsw) (!CheckOSError(XmyWinSwitchToProgram(hsw))) - - -/* These function croak if the return value is 0. */ -DeclWinFunc_CACHE(HWND, QueryWindow, (HWND hwnd, LONG cmd), (hwnd, cmd)) -DeclWinFunc_CACHE(BOOL, QueryWindowPos, (HWND hwnd, PSWP pswp), - (hwnd, pswp)) -DeclWinFunc_CACHE(LONG, QueryWindowText, - (HWND hwnd, LONG cchBufferMax, PCH pchBuffer), - (hwnd, cchBufferMax, pchBuffer)) -DeclWinFunc_CACHE(LONG, QueryClassName, (HWND hwnd, LONG cchMax, PCH pch), - (hwnd, cchMax, pch)) -DeclWinFunc_CACHE(HWND, QueryFocus, (HWND hwndDesktop), (hwndDesktop)) -DeclWinFunc_CACHE(BOOL, SetFocus, (HWND hwndDesktop, HWND hwndFocus), - (hwndDesktop, hwndFocus)) -DeclWinFunc_CACHE(BOOL, ShowWindow, (HWND hwnd, BOOL fShow), (hwnd, fShow)) -DeclWinFunc_CACHE(BOOL, EnableWindow, (HWND hwnd, BOOL fEnable), - (hwnd, fEnable)) -DeclWinFunc_CACHE(BOOL, SetWindowPos, - (HWND hwnd, HWND hwndInsertBehind, LONG x, LONG y, - LONG cx, LONG cy, ULONG fl), - (hwnd, hwndInsertBehind, x, y, cx, cy, fl)) -DeclWinFunc_CACHE(HENUM, BeginEnumWindows, (HWND hwnd), (hwnd)) -DeclWinFunc_CACHE(BOOL, EndEnumWindows, (HENUM henum), (henum)) -DeclWinFunc_CACHE(BOOL, EnableWindowUpdate, (HWND hwnd, BOOL fEnable), - (hwnd, fEnable)) -DeclWinFunc_CACHE(BOOL, SetWindowBits, - (HWND hwnd, LONG index, ULONG flData, ULONG flMask), - (hwnd, index, flData, flMask)) -DeclWinFunc_CACHE(BOOL, SetWindowPtr, (HWND hwnd, LONG index, PVOID p), - (hwnd, index, p)) -DeclWinFunc_CACHE(BOOL, SetWindowULong, (HWND hwnd, LONG index, ULONG ul), - (hwnd, index, ul)) -DeclWinFunc_CACHE(BOOL, SetWindowUShort, (HWND hwnd, LONG index, USHORT us), - (hwnd, index, us)) -DeclWinFunc_CACHE(HWND, IsChild, (HWND hwnd, HWND hwndParent), - (hwnd, hwndParent)) -DeclWinFunc_CACHE(HWND, WindowFromId, (HWND hwnd, ULONG id), (hwnd, id)) -DeclWinFunc_CACHE(HWND, EnumDlgItem, (HWND hwndDlg, HWND hwnd, ULONG code), - (hwndDlg, hwnd, code)) -DeclWinFunc_CACHE(HWND, QueryDesktopWindow, (HAB hab, HDC hdc), (hab, hdc)); -DeclWinFunc_CACHE(BOOL, SetActiveWindow, (HWND hwndDesktop, HWND hwnd), - (hwndDesktop, hwnd)); -DeclWinFunc_CACHE(BOOL, QueryActiveDesktopPathname, (PSZ pszPathName, ULONG ulSize), - (pszPathName, ulSize)); -DeclWinFunc_CACHE(BOOL, InvalidateRect, - (HWND hwnd, /*RECTL*/ char *prcl, BOOL fIncludeChildren), - (hwnd, prcl, fIncludeChildren)); -DeclWinFunc_CACHE(BOOL, CreateFrameControls, - (HWND hwndFrame, /*PFRAMECDATA*/ char* pfcdata, PCSZ pszTitle), - (hwndFrame, pfcdata, pszTitle)); -DeclWinFunc_CACHE(BOOL, OpenClipbrd, (HAB hab), (hab)); -DeclWinFunc_CACHE(BOOL, EmptyClipbrd, (HAB hab), (hab)); -DeclWinFunc_CACHE(BOOL, CloseClipbrd, (HAB hab), (hab)); -DeclWinFunc_CACHE(BOOL, QueryClipbrdFmtInfo, (HAB hab, ULONG fmt, PULONG prgfFmtInfo), (hab, fmt, prgfFmtInfo)); -DeclWinFunc_CACHE(ULONG, QueryClipbrdData, (HAB hab, ULONG fmt), (hab, fmt)); -DeclWinFunc_CACHE(HWND, SetClipbrdViewer, (HAB hab, HWND hwnd), (hab, hwnd)); -DeclWinFunc_CACHE(HWND, SetClipbrdOwner, (HAB hab, HWND hwnd), (hab, hwnd)); -DeclWinFunc_CACHE(ULONG, EnumClipbrdFmts, (HAB hab, ULONG fmt), (hab, fmt)); -DeclWinFunc_CACHE(ATOM, AddAtom, (HATOMTBL hAtomTbl, PCSZ pszAtomName), - (hAtomTbl, pszAtomName)); -DeclWinFunc_CACHE(ULONG, QueryAtomUsage, (HATOMTBL hAtomTbl, ATOM atom), - (hAtomTbl, atom)); -DeclWinFunc_CACHE(ULONG, QueryAtomLength, (HATOMTBL hAtomTbl, ATOM atom), - (hAtomTbl, atom)); -DeclWinFunc_CACHE(ULONG, QueryAtomName, - (HATOMTBL hAtomTbl, ATOM atom, PSZ pchBuffer, ULONG cchBufferMax), - (hAtomTbl, atom, pchBuffer, cchBufferMax)); -DeclWinFunc_CACHE(HATOMTBL, QuerySystemAtomTable, (VOID), ()); -DeclWinFunc_CACHE(HATOMTBL, CreateAtomTable, (ULONG initial, ULONG buckets), - (initial, buckets)); -DeclWinFunc_CACHE(ULONG, MessageBox, (HWND hwndParent, HWND hwndOwner, PCSZ pszText, PCSZ pszCaption, ULONG idWindow, ULONG flStyle), (hwndParent, hwndOwner, pszText, pszCaption, idWindow, flStyle)); -DeclWinFunc_CACHE(ULONG, MessageBox2, - (HWND hwndParent, HWND hwndOwner, PCSZ pszText, - PCSZ pszCaption, ULONG idWindow, PMB2INFO pmb2info), - (hwndParent, hwndOwner, pszText, pszCaption, idWindow, pmb2info)); -DeclWinFunc_CACHE(HPOINTER, LoadPointer, - (HWND hwndDesktop, HMODULE hmod, ULONG idres), - (hwndDesktop, hmod, idres)); -DeclWinFunc_CACHE(HPOINTER, QuerySysPointer, - (HWND hwndDesktop, LONG lId, BOOL fCopy), - (hwndDesktop, lId, fCopy)); -DeclWinFunc_CACHE(BOOL, Alarm, (HWND hwndDesktop, ULONG rgfType), (hwndDesktop, rgfType)); -DeclWinFunc_CACHE(BOOL, FlashWindow, (HWND hwndFrame, BOOL fFlash), (hwndFrame, fFlash)); - -#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, - (HAB hab, ULONG ulData, ULONG fmt, ULONG rgfFmtInfo), - (hab, ulData, fmt, rgfFmtInfo)); - -#define get_InvalidateRect InvalidateRect -#define get_CreateFrameControls CreateFrameControls - -/* These functions may return 0 on success; check $^E/Perl_rc on res==0: */ -DeclWinFunc_CACHE_resetError(PVOID, QueryWindowPtr, (HWND hwnd, LONG index), - (hwnd, index)) -DeclWinFunc_CACHE_resetError(ULONG, QueryWindowULong, (HWND hwnd, LONG index), - (hwnd, index)) -DeclWinFunc_CACHE_resetError(SHORT, QueryWindowUShort, (HWND hwnd, LONG index), - (hwnd, index)) -DeclWinFunc_CACHE_resetError(LONG, QueryWindowTextLength, (HWND hwnd), (hwnd)) -DeclWinFunc_CACHE_resetError(HWND, QueryActiveWindow, (HWND hwnd), (hwnd)) -DeclWinFunc_CACHE_resetError(BOOL, PostMsg, - (HWND hwnd, ULONG msg, MPARAM mp1, MPARAM mp2), - (hwnd, msg, mp1, mp2)) -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)) - -/* These functions are called frow complicated wrappers: */ -ULONG (*pWinQuerySwitchList) (HAB hab, PSWBLOCK pswblk, ULONG usDataLength); -ULONG (*pWinChangeSwitchEntry) (HSWITCH hsw, __const__ SWCNTRL *pswctl); -HWND (*pWinWindowFromPoint)(HWND hwnd, __const__ POINTL *pptl, BOOL fChildren); - - -/* These functions have different names/signatures than what is - declared above */ -#define QueryFocusWindow QueryFocus -#define FocusWindow_set(hwndFocus, hwndDesktop) SetFocus(hwndDesktop, hwndFocus) -#define WindowPos_set(hwnd, x, y, fl, cx, cy, hwndInsertBehind) \ - SetWindowPos(hwnd, hwndInsertBehind, x, y, cx, cy, fl) -#define myWinQueryWindowPtr(hwnd, i) ((ULONG)QueryWindowPtr(hwnd, i)) -#define _ClipbrdData_set SetClipbrdData -#define ClipbrdOwner_set SetClipbrdOwner -#define ClipbrdViewer_set SetClipbrdViewer - -int -WindowText_set(HWND hwnd, char* text) -{ - return !CheckWinError(myWinSetWindowText(hwnd, text)); -} - -SV * -myQueryWindowText(HWND hwnd) -{ - LONG l = QueryWindowTextLength(hwnd), len; - SV *sv; - STRLEN n_a; - - if (l == 0) { - if (Perl_rc) /* Last error */ - return &PL_sv_undef; - return &PL_sv_no; - } - sv = newSVpvn("", 0); - SvGROW(sv, l + 1); - len = QueryWindowText(hwnd, l + 1, SvPV_force(sv, n_a)); - if (len != l) { - Safefree(sv); - croak("WinQueryWindowText() uncompatible with WinQueryWindowTextLength()"); - } - SvCUR_set(sv, l); - return sv; -} - -SWP -QueryWindowSWP_(HWND hwnd) -{ - SWP swp; - - if (!QueryWindowPos(hwnd, &swp)) - croak("WinQueryWindowPos() error"); - return swp; -} - -SV * -QueryWindowSWP(HWND hwnd) -{ - SWP swp = QueryWindowSWP_(hwnd); - - return newSVpvn((char*)&swp, sizeof(swp)); -} - -SV * -myQueryClassName(HWND hwnd) -{ - SV *sv = newSVpvn("",0); - STRLEN l = 46, len = 0, n_a; - - while (l + 1 >= len) { - if (len) - len = 2*len + 10; /* Grow quick */ - else - len = l + 2; - SvGROW(sv, len); - l = QueryClassName(hwnd, len, SvPV_force(sv, n_a)); - } - SvCUR_set(sv, l); - return sv; -} - -HWND -WindowFromPoint(long x, long y, HWND hwnd, BOOL fChildren) -{ - POINTL ppl; - - ppl.x = x; ppl.y = y; - if (!pWinWindowFromPoint) - AssignFuncPByORD(pWinWindowFromPoint, ORD_WinWindowFromPoint); - return SaveWinError(pWinWindowFromPoint(hwnd, &ppl, fChildren)); -} - -static HSWITCH -switch_of(HWND hwnd, PID pid) -{ - HSWITCH hSwitch; - - if (!(_emx_env & 0x200)) - croak("switch_entry not implemented on DOS"); /* not OS/2. */ - if (CheckWinError(hSwitch = - myWinQuerySwitchHandle(hwnd, pid))) - croak_with_os2error("WinQuerySwitchHandle"); - return hSwitch; -} - - -static void -fill_swentry(SWENTRY *swentryp, HWND hwnd, PID pid) -{ - int rc; - HSWITCH hSwitch = switch_of(hwnd, pid); - - swentryp->hswitch = hSwitch; - if (CheckOSError(myWinQuerySwitchEntry(hSwitch, &swentryp->swctl))) - croak_with_os2error("WinQuerySwitchEntry"); -} - -static void -fill_swentry_default(SWENTRY *swentryp) -{ - fill_swentry(swentryp, NULLHANDLE, getpid()); -} - -static SV* -myWinQueryActiveDesktopPathname() -{ - SV *buf = newSVpv("",0); - STRLEN n_a; - - SvGROW(buf, MAXPATHLEN); - QueryActiveDesktopPathname(SvPV(buf,n_a), MAXPATHLEN); - SvCUR_set(buf, strlen(SvPV(buf, n_a))); - return buf; -} - -SV * -myWinQueryAtomName(ATOM atom, HATOMTBL hAtomTbl) -{ - ULONG len = QueryAtomLength(hAtomTbl, atom); - - if (len) { /* Probably always so... */ - SV *sv = newSVpvn("",0); - STRLEN n_a; - - SvGROW(sv, len + 1); - 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 - -/* Put data into shared memory, then call SetClipbrdData */ -void -ClipbrdData_set(SV *sv, int convert_nl, unsigned long fmt, unsigned long rgfFmtInfo, HAB hab) -{ - STRLEN len; - char *buf; - char *pByte = 0, *s, c; - ULONG nls = 0, rc, handle; - - 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, - PAG_WRITE | PAG_COMMIT | OBJ_GIVEABLE | OBJ_GETTABLE))) - croak_with_os2error("ClipbrdData_set: DosAllocSharedMem error"); - - if (!nls) - memcpy(pByte, buf, len + 1); - else { - char *t = pByte, *e = buf + len; - - while (buf < e) { - c = *t++ = *buf++; - if (c == '\n' && (t == pByte + 1 || t[-2] != '\r')) - t[-1] = '\r', *t++ = '\n'; - } - } - handle = (ULONG)pByte; - } else { - handle = (ULONG)SvUV(sv); - } - - 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 -myWinMessageBox(HWND hwndParent, HWND hwndOwner, PCSZ pszText, PCSZ pszCaption, ULONG idWindow, ULONG flStyle) -{ - ULONG rc = MessageBox(hwndParent, hwndOwner, pszText, pszCaption, - idWindow, flStyle); - - if (rc == MBID_ERROR) - rc = 0; - if (CheckWinError(rc)) - croak_with_os2error("MessageBox"); - return rc; -} - -ULONG -myWinMessageBox2(HWND hwndParent, HWND hwndOwner, PCSZ pszText, - PCSZ pszCaption, ULONG idWindow, PMB2INFO pmb2info) -{ - ULONG rc = MessageBox2(hwndParent, hwndOwner, pszText, pszCaption, idWindow, pmb2info); - - if (rc == MBID_ERROR) - rc = 0; - if (CheckWinError(rc)) - croak_with_os2error("MessageBox2"); - return rc; -} -#endif - -/* static ULONG (* APIENTRY16 pDosSmSetTitle)(ULONG, PSZ); */ -ULONG _THUNK_FUNCTION(DosSmSetTitle)(ULONG, PSZ); - -#if 0 /* Does not work. */ -static ULONG (*pDosSmSetTitle)(ULONG, PSZ); - -static void -sesmgr_title_set(char *s) -{ - SWENTRY swentry; - static HMODULE hdosc = 0; - BYTE buf[20]; - long rc; - - fill_swentry_default(&swentry); - if (!pDosSmSetTitle || !hdosc) { - if (CheckOSError(DosLoadModule(buf, sizeof buf, "sesmgr", &hdosc))) - croak("Cannot load SESMGR: no `%s'", buf); - if (CheckOSError(DosQueryProcAddr(hdosc, 0, "DOSSMSETTITLE", - (PFN*)&pDosSmSetTitle))) - croak("Cannot load SESMGR.DOSSMSETTITLE, err=%ld", rc); - } -/* (pDosSmSetTitle)(swcntrl.idSession,s); */ - rc = ((USHORT) - (_THUNK_PROLOG (2+4); - _THUNK_SHORT (swcntrl.idSession); - _THUNK_FLAT (s); - _THUNK_CALLI (*pDosSmSetTitle))); - if (CheckOSError(rc)) - warn("*DOSSMSETTITLE: err=%ld, ses=%ld, addr=%x, *paddr=%x", - rc, swcntrl.idSession, &_THUNK_FUNCTION(DosSmSetTitle), - pDosSmSetTitle); -} - -#else /* !0 */ - -static bool -sesmgr_title_set(char *s) -{ - SWENTRY swentry; - long rc; - - fill_swentry_default(&swentry); - rc = ((USHORT) - (_THUNK_PROLOG (2+4); - _THUNK_SHORT (swentry.swctl.idSession); - _THUNK_FLAT (s); - _THUNK_CALL (DosSmSetTitle))); -#if 0 - if (CheckOSError(rc)) - warn("DOSSMSETTITLE: err=%ld, ses=%ld, addr=%x", - rc, swcntrl.idSession, _THUNK_FUNCTION(DosSmSetTitle)); -#endif - return !CheckOSError(rc); -} -#endif /* !0 */ - -#if 0 /* Does not work. */ -USHORT _THUNK_FUNCTION(Win16SetTitle) (); - -static void -set_title2(char *s) -{ - long rc; - - rc = ((USHORT) - (_THUNK_PROLOG (4); - _THUNK_FLAT (s); - _THUNK_CALL (Win16SetTitle))); - if (CheckWinError(rc)) - warn("Win16SetTitle: err=%ld", rc); -} -#endif - -SV * -process_swentry(unsigned long pid, HWND hwnd) -{ - SWENTRY swentry; - - if (!(_emx_env & 0x200)) - croak("process_swentry not implemented on DOS"); /* not OS/2. */ - fill_swentry(&swentry, hwnd, pid); - return newSVpvn((char*)&swentry, sizeof(swentry)); -} - -SV * -swentries_list() -{ - int num, n = 0; - STRLEN n_a; - PSWBLOCK pswblk; - SV *sv = newSVpvn("",0); - - if (!(_emx_env & 0x200)) - croak("swentries_list not implemented on DOS"); /* not OS/2. */ - if (!pWinQuerySwitchList) - AssignFuncPByORD(pWinQuerySwitchList, ORD_WinQuerySwitchList); - num = pWinQuerySwitchList(0, NULL, 0); /* HAB is not required */ - if (!num) - croak("(Unknown) error during WinQuerySwitchList()"); - /* Allow one extra entry to allow overflow detection (may happen - if the list has been changed). */ - while (num > n) { - if (n == 0) - n = num + 1; - else - n = 2*num + 10; /* Enlarge quickly */ - SvGROW(sv, sizeof(ULONG) + sizeof(SWENTRY) * n + 1); - pswblk = (PSWBLOCK) SvPV_force(sv, n_a); - num = pWinQuerySwitchList(0, pswblk, SvLEN(sv)); - } - SvCUR_set(sv, sizeof(ULONG) + sizeof(SWENTRY) * num); - *SvEND(sv) = 0; - return sv; -} - -SWENTRY -swentry( char *title, HWND sw_hwnd, HWND icon_hwnd, HPROGRAM owner_phandle, - PID owner_pid, ULONG owner_sid, ULONG visible, ULONG nonswitchable, - ULONG jumpable, ULONG ptype, HSWITCH sw_entry) -{ - SWENTRY e; - - strncpy(e.swctl.szSwtitle, title, MAXNAMEL); - e.swctl.szSwtitle[60] = 0; - e.swctl.hwnd = sw_hwnd; - e.swctl.hwndIcon = icon_hwnd; - e.swctl.hprog = owner_phandle; - e.swctl.idProcess = owner_pid; - e.swctl.idSession = owner_sid; - e.swctl.uchVisibility = ((visible ? SWL_VISIBLE : SWL_INVISIBLE) - | (nonswitchable ? SWL_GRAYED : 0)); - e.swctl.fbJump = (jumpable ? SWL_JUMPABLE : 0); - e.swctl.bProgType = ptype; - e.hswitch = sw_entry; - return e; -} - -SV * -create_swentry( char *title, HWND owner_hwnd, HWND icon_hwnd, HPROGRAM owner_phandle, - PID owner_pid, ULONG owner_sid, ULONG visible, ULONG nonswitchable, - ULONG jumpable, ULONG ptype, HSWITCH sw_entry) -{ - SWENTRY e = swentry(title, owner_hwnd, icon_hwnd, owner_phandle, owner_pid, - owner_sid, visible, nonswitchable, jumpable, ptype, - sw_entry); - - return newSVpvn((char*)&e, sizeof(e)); -} - -int -change_swentrysw(SWENTRY *sw) -{ - ULONG rc; /* For CheckOSError */ - - if (!(_emx_env & 0x200)) - croak("change_entry() not implemented on DOS"); /* not OS/2. */ - if (!pWinChangeSwitchEntry) - AssignFuncPByORD(pWinChangeSwitchEntry, ORD_WinChangeSwitchEntry); - return !CheckOSError(pWinChangeSwitchEntry(sw->hswitch, &sw->swctl)); -} - -int -change_swentry(SV *sv) -{ - STRLEN l; - PSWENTRY pswentry = (PSWENTRY)SvPV(sv, l); - - if (l != sizeof(SWENTRY)) - croak("Wrong structure size %ld!=%ld in change_swentry()", (long)l, (long)sizeof(SWENTRY)); - return change_swentrysw(pswentry); -} - - -#define swentry_size() (sizeof(SWENTRY)) - -void -getscrsize(int *wp, int *hp) -{ - int i[2]; - - _scrsize(i); - *wp = i[0]; - *hp = i[1]; -} - -/* Force vio to not cross 64K-boundary: */ -#define VIO_FROM_VIOB \ - vio = viob; \ - if (!_THUNK_PTR_STRUCT_OK(vio)) \ - vio++ - -bool -scrsize_set(int w, int h) -{ - VIOMODEINFO viob[2], *vio; - ULONG rc; - - VIO_FROM_VIOB; - - if (h == -9999) - h = w, w = 0; - vio->cb = sizeof(*vio); - if (CheckOSError(VioGetMode( vio, 0 ))) - return 0; - - if( w > 0 ) - vio->col = (USHORT)w; - - if( h > 0 ) - vio->row = (USHORT)h; - - vio->cb = 8; - if (CheckOSError(VioSetMode( vio, 0 ))) - return 0; - return 1; -} - -void -cursor(int *sp, int *ep, int *wp, int *ap) -{ - VIOCURSORINFO viob[2], *vio; - ULONG rc; - - VIO_FROM_VIOB; - - if (CheckOSError(VioGetCurType( vio, 0 ))) - croak_with_os2error("VioGetCurType() error"); - - *sp = vio->yStart; - *ep = vio->cEnd; - *wp = vio->cx; - *ep = vio->attr; -} - -bool -cursor__(int is_a) -{ - int s,e,w,a; - - cursor(&s, &e, &w, &a); - if (is_a) - return a; - else - return w; -} - -bool -cursor_set(int s, int e, int w, int a) -{ - VIOCURSORINFO viob[2], *vio; - ULONG rc; - - VIO_FROM_VIOB; - - vio->yStart = s; - vio->cEnd = e; - vio->cx = w; - vio->attr = a; - return !CheckOSError(VioSetCurType( vio, 0 )); -} - -static int -bufsize(void) -{ -#if 1 - VIOMODEINFO viob[2], *vio; - ULONG rc; - - VIO_FROM_VIOB; - - vio->cb = sizeof(*vio); - if (CheckOSError(VioGetMode( vio, 0 ))) - croak_with_os2error("Can't get size of buffer for screen"); -#if 0 /* buf=323552247, full=1118455, partial=0 */ - croak("Lengths: buf=%d, full=%d, partial=%d",vio->buf_length,vio->full_length,vio->partial_length); - return newSVpvn((char*)vio->buf_addr, vio->full_length); -#endif - return vio->col * vio->row * 2; /* How to get bytes/cell? 2 or 4? */ -#else /* 0 */ - int i[2]; - - _scrsize(i); - return i[0]*i[1]*2; -#endif /* 0 */ -} - -SV* -_kbdChar(unsigned int nowait, int handle) -{ - KBDKEYINFO viob[2], *vio; - ULONG rc; - - VIO_FROM_VIOB; - - if (nowait > 2) - croak("unexpected nowait"); - if (CheckOSError(nowait == 2 - ? KbdPeek( vio, handle ) - : KbdCharIn( vio, nowait == 1, handle ))) - croak_with_os2error("Can't _kbdChar"); - return newSVpvn((char*)vio, sizeof(*vio)); -} - -SV* -_kbdStatus(int handle) -{ - KBDINFO viob[2], *vio; - ULONG rc; - - VIO_FROM_VIOB; - - vio->cb = sizeof(*vio); - if (CheckOSError(KbdGetStatus( vio, handle ))) - croak_with_os2error("Can't _kbdStatus"); - return newSVpvn((char*)vio, sizeof(*vio)); -} - -void -_kbdStatus_set(SV* sv, int handle) -{ - KBDINFO viob[2], *vio; - ULONG rc; - STRLEN l; - char *s = SvPV(sv, l); - - VIO_FROM_VIOB; - - if (l != sizeof(*vio)) - croak("unexpected datasize"); - Copy((KBDINFO*)s, vio, 1, KBDINFO); - if (vio->cb != sizeof(*vio)) - croak("unexpected datasize"); - if (CheckOSError(KbdSetStatus( vio, handle ))) - croak_with_os2error("Can't kbdStatus_set()"); -} - -SV* -_vioConfig(int which, int handle) -{ - struct {VIOCONFIGINFO i; short a[20];} viob[2], *vio; - ULONG rc; - - VIO_FROM_VIOB; - - vio->i.cb = 2; - if (CheckOSError(VioGetConfig( which, &vio->i, handle ))) - croak_with_os2error("Can't get VIO config size"); - if (vio->i.cb > sizeof(*vio)) - vio->i.cb = sizeof(*vio); - if (CheckOSError(VioGetConfig( which, &vio->i, handle ))) - croak_with_os2error("Can't get VIO config"); - return newSVpvn((char*)vio, vio->i.cb); -} - -SV* -_vioMode(void) -{ - VIOMODEINFO viob[2], *vio; - ULONG rc; - - VIO_FROM_VIOB; - - vio->cb = sizeof(*vio); - if (CheckOSError(VioGetMode( vio, 0 ))) - croak_with_os2error("Can't get VIO mode"); - return newSVpvn((char*)vio, sizeof(*vio)); -} - -void -_vioMode_set(SV* sv) -{ - VIOMODEINFO viob[2], *vio; - ULONG rc; - STRLEN l; - char *s = SvPV(sv, l); - - VIO_FROM_VIOB; - - Copy((VIOMODEINFO*)s, vio, 1, VIOMODEINFO); - if (vio->cb != sizeof(*vio) || l != vio->cb) - croak("unexpected datasize"); - if (CheckOSError(VioSetMode( vio, 0 ))) - croak_with_os2error("Can't set VIO mode"); -} - -SV* -vioFont(int type, int *w, int *h) /* 0 for actual RAM font, 1 for ROM font */ -{ - VIOFONTINFO viob[2], *vio; - ULONG rc; - UCHAR b[1<<17]; - UCHAR *buf = b; - SV *sv; - - VIO_FROM_VIOB; - - /* Should not cross 64K boundaries too: */ - if (((ULONG)buf) & 0xFFFF) - buf += 0x10000 - (((ULONG)buf) & 0xFFFF); - - vio->cb = sizeof(*vio); - vio->type = type; /* BIOS or the loaded font. */ - vio->cbData = 0xFFFF; /* How large is my buffer? */ - vio->pbData = _emx_32to16(buf); /* Wants an 16:16 pointer */ - if (CheckOSError(VioGetFont( vio, 0 ))) - croak_with_os2error("Can't get VIO font"); - *w = vio->cxCell; - *h = vio->cyCell; - return newSVpvn(buf,vio->cbData); -} - -void -vioFont_set(SV *sv, int cellwidth, int cellheight, int type) -{ - VIOFONTINFO viob[2], *vio; - ULONG rc; - UCHAR b[1<<17]; - UCHAR *buf = b; - STRLEN l; - char *s = SvPV(sv, l); - - VIO_FROM_VIOB; - - /* Should not cross 64K boundaries too: */ - if (((ULONG)buf) & 0xFFFF) - buf += 0x10000 - (((ULONG)buf) & 0xFFFF); - - if (l > 0xFFFF) - croak("length overflow of VIO font"); - if (l != (cellwidth + 7)/8 * cellheight * 256) - warn("unexpected length of VIO font"); - vio->cb = sizeof(*vio); - vio->type = type; /* BIOS or the loaded font. */ - vio->cbData = l; /* How large is my buffer? */ - vio->pbData = _emx_32to16(buf); /* Wants an 16:16 pointer */ - vio->cxCell = cellwidth; - vio->cyCell = cellheight; - Copy(s, buf, l, char); - - if (CheckOSError(VioSetFont( vio, 0 ))) - croak_with_os2error("Can't set VIO font"); -} - -/* - uses use32,os2def,os2base,crt,defs; - var Plt :Plt256; - const Pal :VioPalState=(Cb:sizeof(VioPalState);rType:0;iFirst:0; - Acolor:($FF,$FF,$FF,$FF,$FF,$FF,$FF,$FF,$FF,$FF,$FF,$FF,$FF,$FF,$FF,$FF)); - CReg:VioColorReg=(Cb:sizeof(VioColorReg);rType:3;FirstColorReg:0; - NumColorRegs:256; ColorRegAddr:@Plt); - var ii:Pointer; - begin - VioGetState(Pal,0); - Pal.Acolor[09]:=$0F; - Pal.Acolor[10]:=$A; - Pal.Acolor[13]:=$2F; - VioSetState(Pal,0); // ce smena EGA registrov - asm - lea eax,Plt - call DosFlatToSel - mov ii,eax - end; - CReg.ColorRegAddr:=ii; - VioGetState(CReg,0); - Plt[10,0]:=$00; - Plt[10,1]:=$32; - Plt[10,2]:=$2A; - VioSetState(CReg,0); // a ce - VGA registrov - end. -*/ - -typedef union { - VIOPALSTATE pal; - struct { VIOPALSTATE pal; USHORT a[15]; } pal_padded; - VIOOVERSCAN overscan; - VIOINTENSITY intensity; - VIOCOLORREG colorreg; - struct { VIOCOLORREG reg; char rgb[3*256]; } colorreg_padded; - VIOSETULINELOC lineloc; - VIOSETTARGET target; -} my_VIOSTATE; - -int -vio_state_size(int what) -{ - static const char sizes[] = { - sizeof(VIOPALSTATE), - sizeof(VIOOVERSCAN), - sizeof(VIOINTENSITY), - sizeof(VIOCOLORREG), - 6, /* Random number: Reserved entry */ - sizeof(VIOSETULINELOC), - sizeof(VIOSETTARGET) - }; - if (what < 0 || what >= sizeof(sizes)) - croak("Unexpected VIO state type"); - return sizes[what]; -} - -SV* -_vioState(int what, int first, int count) -{ - my_VIOSTATE viob[2], *vio; - ULONG rc, size = vio_state_size(what); - - VIO_FROM_VIOB; - - vio->pal.cb = size; - vio->pal.type = what; - if (what == 0) { - vio->pal.iFirst = first; - if (first < 0 || first >= 16) - croak("unexpected palette start value"); - if (count < 0 || count > 16) - croak("unexpected palette count"); - vio->pal.cb = (size += (count - 1) * sizeof(short)); - } else if (what == 3) { - /* Wants an 16:16 pointer */ - if (count < 0 || count > 256) - croak("unexpected palette count"); - vio->colorreg.colorregaddr = (PCH)_emx_32to16(vio->colorreg_padded.rgb); - vio->colorreg.numcolorregs = count; /* 256 is max */ - vio->colorreg.firstcolorreg = first; - size += 3 * count; - } - if (CheckOSError(VioGetState( (void*)vio, 0 ))) - croak_with_os2error("Can't get VIO state"); - return newSVpvn((char*)vio, size); -} - -void -_vioState_set(SV *sv) -{ - my_VIOSTATE viob[2], *ovio = (my_VIOSTATE*)SvPV_nolen(sv), *vio = ovio; - int what = ovio->pal.type, cb = ovio->pal.cb; - ULONG rc, size = vio_state_size(what); - STRLEN l; - char *s = SvPV(sv, l); - - VIO_FROM_VIOB; - - switch (what) { - case 0: - if ( cb < size || cb > size + 15*sizeof(SHORT) || l != cb) - croak("unexpected datasize"); - size = l; - break; - case 3: - if (l != cb + 3 * ovio->colorreg.numcolorregs || cb != size) - croak("unexpected datasize"); - size = l; - break; - default: - if (l != cb || l != size ) - croak("unexpected datasize"); - break; - } - Copy(s, (char*)vio, size, char); - if (what == 3) /* We expect colors put after VIOCOLORREG */ - vio->colorreg.colorregaddr = (PCH)_emx_32to16(vio->colorreg_padded.rgb); - - if (CheckOSError(VioSetState( (void*)vio, 0 ))) - croak_with_os2error("Can't set VIO state"); -} - -SV * -screen(void) -{ - ULONG rc; - USHORT bufl = bufsize(); - char b[(1<<16) * 3]; /* This/3 is enough for 16-bit calls, we need - 2x overhead due to 2 vs 4 issue, and extra - 64K due to alignment logic */ - char *buf = b; - - if (((ULONG)buf) & 0xFFFF) - buf += 0x10000 - (((ULONG)buf) & 0xFFFF); - if ((sizeof(b) - (buf - b)) < 2*bufl) - croak("panic: VIO buffer allocation"); - if (CheckOSError(VioReadCellStr( buf, &bufl, 0, 0, 0 ))) - return &PL_sv_undef; - return newSVpvn(buf,bufl); -} - -bool -screen_set(SV *sv) -{ - ULONG rc; - STRLEN l = SvCUR(sv), bufl = bufsize(); - char b[(1<<16) * 2]; /* This/2 is enough for 16-bit calls, we need - extra 64K due to alignment logic */ - char *buf = b; - - if (((ULONG)buf) & 0xFFFF) - buf += 0x10000 - (((ULONG)buf) & 0xFFFF); - if (!SvPOK(sv) || ((l != bufl) && (l != 2*bufl))) - croak("Wrong size %d of saved screen data", SvCUR(sv)); - if ((sizeof(b) - (buf - b)) < l) - croak("panic: VIO buffer allocation"); - Copy(SvPV(sv,l), buf, bufl, char); - if (CheckOSError(VioWrtCellStr( buf, bufl, 0, 0, 0 ))) - return 0; - return 1; -} - -int -process_codepages() -{ - ULONG cps[4], cp, rc; - - if (CheckOSError(DosQueryCp( sizeof(cps), cps, &cp ))) - croak_with_os2error("DosQueryCp()"); - return cp; -} - -int -out_codepage() -{ - USHORT cp, rc; - - if (CheckOSError(VioGetCp( 0, &cp, 0 ))) - croak_with_os2error("VioGetCp()"); - return cp; -} - -bool -out_codepage_set(int cp) -{ - USHORT rc; - - return !(CheckOSError(VioSetCp( 0, cp, 0 ))); -} - -int -in_codepage() -{ - USHORT cp, rc; - - if (CheckOSError(KbdGetCp( 0, &cp, 0 ))) - croak_with_os2error("KbdGetCp()"); - return cp; -} - -bool -in_codepage_set(int cp) -{ - USHORT rc; - - return !(CheckOSError(KbdSetCp( 0, cp, 0 ))); -} - -bool -process_codepage_set(int cp) -{ - USHORT rc; - - return !(CheckOSError(DosSetProcessCp( cp ))); -} - -int -ppidOf(int pid) -{ - PQTOPLEVEL psi; - int ppid; - - if (!pid) - return -1; - psi = get_sysinfo(pid, QSS_PROCESS); - if (!psi) - return -1; - ppid = psi->procdata->ppid; - Safefree(psi); - return ppid; -} - -int -sidOf(int pid) -{ - PQTOPLEVEL psi; - int sid; - - if (!pid) - return -1; - psi = get_sysinfo(pid, QSS_PROCESS); - if (!psi) - return -1; - sid = psi->procdata->sessid; - Safefree(psi); - 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)) -#define ulMPFROM2SHORT(x1,x2) ((unsigned long)MPFROM2SHORT(x1,x2)) -#define ulMPFROMSH2CH(s, c1, c2) ((unsigned long)MPFROMSH2CH(s, c1, c2)) -#define ulMPFROMLONG(x) ((unsigned long)MPFROMLONG(x)) - -#define _MessageBox MessageBox -#define _MessageBox2 MessageBox2 - -MODULE = OS2::Process PACKAGE = OS2::Process - -PROTOTYPES: ENABLE - -unsigned long -constant(name,arg) - char * name - int arg - -char * -my_type() - -U32 -file_type(path) - char *path - -SV * -swentry_expand( SV *sv ) - PPCODE: - { - STRLEN l; - PSWENTRY pswentry = (PSWENTRY)SvPV(sv, l); - - if (l != sizeof(SWENTRY)) - croak("Wrong structure size %ld!=%ld in swentry_expand()", (long)l, (long)sizeof(SWENTRY)); - EXTEND(sp,11); - PUSHs(sv_2mortal(newSVpv(pswentry->swctl.szSwtitle, 0))); - PUSHs(sv_2mortal(newSVnv(pswentry->swctl.hwnd))); - PUSHs(sv_2mortal(newSVnv(pswentry->swctl.hwndIcon))); - PUSHs(sv_2mortal(newSViv(pswentry->swctl.hprog))); - PUSHs(sv_2mortal(newSViv(pswentry->swctl.idProcess))); - PUSHs(sv_2mortal(newSViv(pswentry->swctl.idSession))); - PUSHs(sv_2mortal(newSViv(pswentry->swctl.uchVisibility & SWL_VISIBLE))); - PUSHs(sv_2mortal(newSViv(pswentry->swctl.uchVisibility & SWL_GRAYED))); - PUSHs(sv_2mortal(newSViv(pswentry->swctl.fbJump == SWL_JUMPABLE))); - PUSHs(sv_2mortal(newSViv(pswentry->swctl.bProgType))); - PUSHs(sv_2mortal(newSViv(pswentry->hswitch))); - } - -SV * -create_swentry( char *title, unsigned long sw_hwnd, unsigned long icon_hwnd, unsigned long owner_phandle, unsigned long owner_pid, unsigned long owner_sid, unsigned long visible, unsigned long switchable, unsigned long jumpable, unsigned long ptype, unsigned long sw_entry) -PROTOTYPE: DISABLE - -int -change_swentry( SV *sv ) - -bool -sesmgr_title_set(s) - char *s - -SV * -process_swentry(unsigned long pid = getpid(), HWND hwnd = NULLHANDLE); - PROTOTYPE: DISABLE - -int -swentry_size() - -SV * -swentries_list() - -void -ResetWinError() - POSTCALL: - XSRETURN_YES; - -int -WindowText_set(HWND hwndFrame, char *title) - -bool -FocusWindow_set(HWND hwndFocus, HWND hwndDesktop = HWND_DESKTOP) - -bool -ShowWindow(HWND hwnd, bool fShow = TRUE) - -bool -EnableWindow(HWND hwnd, bool fEnable = TRUE) - -bool -PostMsg(HWND hwnd, unsigned long msg, unsigned long mp1 = 0, unsigned long mp2 = 0) - C_ARGS: hwnd, msg, (MPARAM)mp1, (MPARAM)mp2 - -bool -WindowPos_set(HWND hwnd, long x, long y, unsigned long fl = SWP_MOVE, long cx = 0, long cy = 0, HWND hwndInsertBehind = HWND_TOP) - PROTOTYPE: DISABLE - -unsigned long -BeginEnumWindows(HWND hwnd) - -bool -EndEnumWindows(unsigned long henum) - -unsigned long -GetNextWindow(unsigned long henum) - -bool -IsWindowVisible(HWND hwnd) - -bool -IsWindowEnabled(HWND hwnd) - -bool -IsWindowShowing(HWND hwnd) - -unsigned long -QueryWindow(HWND hwnd, long cmd) - -unsigned long -IsChild(HWND hwnd, HWND hwndParent) - -unsigned long -WindowFromId(HWND hwndParent, unsigned long id) - -unsigned long -WindowFromPoint(long x, long y, HWND hwnd = HWND_DESKTOP, bool fChildren = TRUE) -PROTOTYPE: DISABLE - -unsigned long -EnumDlgItem(HWND hwndDlg, unsigned long code, HWND hwnd = NULLHANDLE) - C_ARGS: hwndDlg, hwnd, code - -bool -EnableWindowUpdate(HWND hwnd, bool fEnable = TRUE) - -bool -SetWindowBits(HWND hwnd, long index, unsigned long flData, unsigned long flMask) - -bool -SetWindowPtr(HWND hwnd, long index, unsigned long p) - C_ARGS: hwnd, index, (PVOID)p - -bool -SetWindowULong(HWND hwnd, long index, unsigned long i) - -bool -SetWindowUShort(HWND hwnd, long index, unsigned short i) - -bool -IsWindow(HWND hwnd, HAB hab = Acquire_hab()) - C_ARGS: hab, hwnd - -BOOL -ActiveWindow_set(HWND hwnd, HWND hwndDesktop = HWND_DESKTOP) - CODE: - RETVAL = SetActiveWindow(hwndDesktop, hwnd); - -unsigned long -LoadPointer(unsigned long idres, unsigned long hmod = 0, HWND hwndDesktop = HWND_DESKTOP) - C_ARGS: hwndDesktop, hmod, idres - -int -out_codepage() - -bool -out_codepage_set(int cp) - -int -in_codepage() - -bool -in_codepage_set(int cp) - -SV * -screen() - -bool -screen_set(SV *sv) - -SV * -process_codepages() - PPCODE: - { - ULONG cps[4], c, i = 0, rc; - - if (CheckOSError(DosQueryCp( sizeof(cps), cps, &c ))) - c = 0; - c /= sizeof(ULONG); - if (c >= 3) - EXTEND(sp, c); - while (i < c) - PUSHs(sv_2mortal(newSViv(cps[i++]))); - } - -bool -process_codepage_set(int cp) - -void -cursor(OUTLIST int stp, OUTLIST int ep, OUTLIST int wp, OUTLIST int ap) - PROTOTYPE: - -bool -cursor_set(int s, int e, int w = cursor__(0), int a = cursor__(1)) - -SV* -_kbdChar(int nowait = 0, int handle = 0) - -SV* -_kbdStatus(int handle = 0) - -void -_kbdStatus_set(SV *sv, int handle = 0) - POSTCALL: - XSRETURN_YES; - -SV* -_vioConfig(int which = 0, int handle = 0) - -SV* -_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 = 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 = 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()) - C_ARGS: hab, fmt - -unsigned long -AddAtom(char *pszAtomName, HATOMTBL hAtomTbl = QuerySystemAtomTable()) - C_ARGS: hAtomTbl, pszAtomName - -unsigned long -FindAtom(char *pszAtomName, HATOMTBL hAtomTbl = QuerySystemAtomTable()) - C_ARGS: hAtomTbl, pszAtomName - -unsigned long -_DeleteAtom(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 - -SV * -myQueryWindowText(HWND hwnd) - -SV * -myQueryClassName(HWND hwnd) - -MODULE = OS2::Process PACKAGE = OS2::Process PREFIX = Query - -unsigned long -QueryFocusWindow(HWND hwndDesktop = HWND_DESKTOP) - -long -QueryWindowTextLength(HWND hwnd) - -SV * -QueryWindowSWP(HWND hwnd) - -unsigned long -QueryWindowULong(HWND hwnd, long index) - -unsigned short -QueryWindowUShort(HWND hwnd, long index) - -unsigned long -QueryActiveWindow(HWND hwnd = HWND_DESKTOP) - -unsigned long -QueryDesktopWindow(HAB hab = Acquire_hab(), unsigned long hdc = NULLHANDLE) - -unsigned long -QueryClipbrdData(unsigned long fmt = CF_TEXT, HAB hab = perl_hab_GET()) - C_ARGS: hab, fmt - PROTOTYPE: DISABLE - -ULONG -QueryMemoryRegionSize(ULONG addr, OUTLIST ULONG flagp, ULONG len = 0xFFFFFFFF - addr, I32 interrupt = 1) - -unsigned long -QueryClipbrdViewer(HAB hab = perl_hab_GET()) - -unsigned long -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()) - -unsigned long -QueryAtomUsage(ATOM atom, HATOMTBL hAtomTbl = QuerySystemAtomTable()) - C_ARGS: hAtomTbl, atom - -unsigned long -QueryAtomLength(ATOM atom, HATOMTBL hAtomTbl = QuerySystemAtomTable()) - C_ARGS: hAtomTbl, atom - POSTCALL: - if (!RETVAL) - XSRETURN_EMPTY; - -unsigned long -QuerySystemAtomTable() - -unsigned long -QuerySysPointer(long lId, bool fCopy = 1, HWND hwndDesktop = HWND_DESKTOP) - C_ARGS: hwndDesktop, lId, fCopy - -unsigned long -CreateAtomTable(unsigned long initial = 0, unsigned long buckets = 0) - -unsigned long -_DestroyAtomTable(HATOMTBL hAtomTbl) - PROTOTYPE: DISABLE - - -MODULE = OS2::Process PACKAGE = OS2::Process PREFIX = myWinQuery - -unsigned long -myWinQueryWindowPtr(HWND hwnd, long index) - -NO_OUTPUT BOOL -myWinQueryWindowProcess(HWND hwnd, OUTLIST unsigned long pid, OUTLIST unsigned long tid) - PROTOTYPE: $ - POSTCALL: - if (CheckWinError(RETVAL)) - croak_with_os2error("WindowProcess() error"); - -SV * -myWinQueryActiveDesktopPathname() - -void -myWinQueryClipbrdFmtInfo(OUTLIST unsigned long prgfFmtInfo, unsigned long fmt = CF_TEXT, HAB hab = perl_hab_GET()) - C_ARGS: hab, fmt, &prgfFmtInfo - -SV * -myWinQueryAtomName(ATOM atom, HATOMTBL hAtomTbl = QuerySystemAtomTable()) - -MODULE = OS2::Process PACKAGE = OS2::Process PREFIX = myWin - -int -myWinSwitchToProgram(HSWITCH hsw = switch_of(NULLHANDLE, getpid())) - PREINIT: - ULONG rc; - -#if 0 - -unsigned long -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 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 = "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) - RETVAL = 0; - -MODULE = OS2::Process PACKAGE = OS2::Process PREFIX = myWinQuery - -MODULE = OS2::Process PACKAGE = OS2::Process PREFIX = get - -int -getppid() - -int -ppidOf(int pid = getpid()) - -int -sidOf(int pid = getpid()) - -void -getscrsize(OUTLIST int wp, OUTLIST int hp) - PROTOTYPE: - -bool -scrsize_set(int w_or_h, int h = -9999) - -void -get_InvalidateRect(HWND hwnd, char *prcl, bool fIncludeChildren) - -void -get_CreateFrameControls(HWND hwndFrame, char *pfcdata, char* pszTitle) - -MODULE = OS2::Process PACKAGE = OS2::Process PREFIX = ul - -unsigned long -ulMPFROMSHORT(unsigned short i) - -unsigned long -ulMPVOID() - -unsigned long -ulMPFROMCHAR(unsigned char i) - -unsigned long -ulMPFROM2SHORT(unsigned short x1, unsigned short x2) - PROTOTYPE: DISABLE - -unsigned long -ulMPFROMSH2CH(unsigned short s, unsigned char c1, unsigned char c2) - PROTOTYPE: DISABLE - -unsigned long -ulMPFROMLONG(unsigned long x) - diff --git a/os2/OS2/Process/t/os2_atoms.t b/os2/OS2/Process/t/os2_atoms.t deleted file mode 100644 index 5d9603f2c9..0000000000 --- a/os2/OS2/Process/t/os2_atoms.t +++ /dev/null @@ -1,88 +0,0 @@ -#! /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 deleted file mode 100644 index 398a5fee7d..0000000000 --- a/os2/OS2/Process/t/os2_clipboard.t +++ /dev/null @@ -1,211 +0,0 @@ -#! /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 deleted file mode 100644 index 18d8fe2a11..0000000000 --- a/os2/OS2/Process/t/os2_process.t +++ /dev/null @@ -1,529 +0,0 @@ -#! /usr/bin/perl -w - -#END { -# sleep 10; -#} - -sub propagate_INC { - my $inc = $ENV{PERL5LIB}; - $inc = $ENV{PERLLIB} unless defined $inc; - $inc = '' unless defined $inc; - $ENV{PERL5LIB} = join ';', @INC, split /;/, $inc; -} - -my $separate_session; -BEGIN { # Remap I/O to the parent's window - $separate_session = $ENV{OS2_PROCESS_TEST_SEPARATE_SESSION}; - propagate_INC, return unless $separate_session; # done by the parent - my @fn = split " ", $ENV{NEW_FD}; - my @fh = (*STDOUT, *STDERR); - my @how = qw( > > ); - # warn $_ for @fn; - open $fh[$_], "$how[$_]&=$fn[$_]" - or warn "Cannot reopen $fh[$_], $how[$_]&=$fn[$_]: $!" for 0..1; -} - -use strict; -use Test::More tests => 235; -use OS2::Process; - -sub SWP_flags ($) { - my @nkpos = WindowPos shift; - $nkpos[2]; -} - -my $interactive_wait = @ARGV && $ARGV[0] eq 'wait'; - -my @l = OS2::Process::process_entry(); -ok(@l == 11, 'all the fields of the process_entry() are there'); - -# 1: FS 2: Window-VIO -ok( ($l[9] == 1 or $l[9] == 2), 'we are FS or Windowed-VIO'); - -#print "# $_\n" for @l; - -eval <<'EOE' or die; -#use OS2::Process qw(WM_SYSCOMMAND WM_DBCSLAST FID_CLIENT HWND_DESKTOP); -use OS2::Process qw(WM_SYSCOMMAND WM_DBCSLAST HWND_DESKTOP); - -ok( WM_SYSCOMMAND == 0x0021, 'correct WM_SYSCOMMAND' ); -ok( WM_DBCSLAST == 0x00cf, 'correct WM_DBCSLAST' ); -#ok( FID_CLIENT == 0x8008 ); -ok( HWND_DESKTOP == 0x0001, 'correct HWND_DESKTOP' ); -1; -EOE - -my $t = Title; -my $wint = winTitle; - -ok($t, 'got session title'); -ok($wint, 'got titlebar text'); - -my $newt = "test OS2::Process $$"; -ok(Title_set($newt), 'successfully set Title'); -is(Title, $newt, 'correctly set Title'); -my $wt = winTitle or warn "winTitle: $!, $^E"; -is(winTitle, $newt, 'winTitle changed its value too'); -ok(Title_set $t, 'successfully set Title back'); -is(Title, $t, 'correctly set Title back'); -is(winTitle, $wint, 'winTitle restored its value too'); - -$newt = "test OS2::Process both-$$"; -ok(bothTitle_set($newt), 'successfully set both titles via Win* API'); -is(Title, $newt, 'session title correctly set'); -is(winTitle, $newt, 'winTitle correctly set'); -ok(bothTitle_set($t), 'successfully reset both titles via Win* API'); -is(Title, $t, 'session title correctly reset'); -is(winTitle, $wint, 'winTitle correctly reset'); - -$newt = "test OS2::Process win-$$"; -ok(winTitle_set($newt), 'successfully set titlebar title via Win* API'); -is(Title, $t, 'session title remained the same'); -is(winTitle, $newt, 'winTitle changed value'); -ok(winTitle_set($wint), 'successfully reset titlebar title via Win* API'); -is(Title, $t, 'session title remained the same'); -is(winTitle, $wint, 'winTitle restored value'); - -$newt = "test OS2::Process sw-$$"; -ok(swTitle_set($newt), 'successfully set session title via Win* API'); -is(Title, $newt, 'session title correctly set'); -is(winTitle, $wint, 'winTitle has unchanged value'); -ok(swTitle_set($t), 'successfully reset session title via Win* API'); -is(Title, $t, 'session title correctly set'); -is(winTitle, $wint, 'winTitle has unchanged value'); - -$newt = "test OS2::Process again-$$"; -ok(Title_set($newt), 'successfully set Title again'); -is(Title, $newt, 'correctly set Title again'); -is(winTitle, $newt, 'winTitle changed its value too again'); -ok(Title_set($t), 'successfully set Title back'); -is(Title, $t, 'correctly set Title back'); -is(winTitle, $wint, 'winTitle restored its value too again'); - -my $hwnd = process_hwnd; -ok($hwnd, 'found session owner hwnd'); -my $c_subhwnd = WindowFromId $hwnd, 0x8008; # FID_CLIENT; -ok($c_subhwnd, 'found client hwnd'); -my $a_subhwnd = ActiveWindow $hwnd; # or $^E and warn $^E; -ok((not $a_subhwnd and not $^E), 'No active subwindow in a VIO frame'); - -my $ahwnd = ActiveWindow; -ok($ahwnd, 'found active window'); -my $fhwnd = FocusWindow; -ok($fhwnd, 'found focus window'); - -# This call without morphing results in VIO window with active highlight, but -# no keyboard focus (even after Alt-Tabbing to it; you cannot Alt-Tab off it!) - -# Interestingly, Desktop is active on the switch list, but the -# switch list is not acting on keyboard events. - -# Give up focus -{ my $force_PM = OS2::localMorphPM->new(0); - ok $force_PM, 'morphed to PM locally'; - ok FocusWindow_set(1), 'set focus to DESKTOP'; # HWND_DESKTOP -} -my $dtop = DesktopWindow; -ok($dtop, 'found the desktop window'); - -#OS2::Process::ResetWinError; # XXXX Should not be needed! -$ahwnd = ActiveWindow or $^E and warn $^E; -ok( (not $ahwnd and not $^E), 'desktop is not active'); -$fhwnd = FocusWindow; -ok($fhwnd, 'there is a focus window'); -is($fhwnd, $dtop, 'which is the desktop'); - -# XXXX Well, no need to skip it now... -SKIP: { - skip 'We already have focus', 4 if $hwnd == $ahwnd; - my $force_PM = OS2::localMorphPM->new(0); - ok $force_PM, 'morphed to PM locally again'; - ok FocusWindow_set($c_subhwnd), 'set focus to the client of the session owner'; - # If we do not morph, then when the focus is in another VIO frame, - # we get two VIO frames with activated titlebars. - # The only (?) way to take the activated state from another frame - # is to switch to it via the switch list - $ahwnd = ActiveWindow; - ok($ahwnd, 'there is an active window'); - $fhwnd = FocusWindow; - ok($fhwnd, 'there is a focus window'); - is($hwnd, $ahwnd, 'the active window is the session owner'); - is($fhwnd, $c_subhwnd, 'the focus window is the client of the session owner'); -} - -# Give up focus again -{ my $force_PM = OS2::localMorphPM->new(0); - ok $force_PM, 'morphed to PM locally again'; - ok FocusWindow_set(1), 'set focus to DESKTOP again'; # HWND_DESKTOP -} - -$ahwnd = ActiveWindow or $^E and warn $^E; -ok( (not $ahwnd and not $^E), 'desktop is not active again'); -$fhwnd = FocusWindow; -ok($fhwnd, 'there is a focus window'); -is($fhwnd, $dtop, 'which is the desktop'); - -# XXXX Well, no need to skip it now... -SKIP: { - skip 'We already have focus', 4 if $hwnd == $ahwnd; - my $force_PM = OS2::localMorphPM->new(0); - ok $force_PM, 'morphed to PM locally again'; - ok ActiveWindow_set($hwnd), 'activate the session owner'; - $ahwnd = ActiveWindow; - ok($ahwnd, 'there is an active window'); - $fhwnd = FocusWindow; - ok($fhwnd, 'there is a focus window'); - is($hwnd, $ahwnd, 'the active window is the session owner'); -} - -# XXXX Well, no need to skip it now... -SKIP: { - skip 'Tests assume we have focus', 1 unless $hwnd == $ahwnd; - # We have focus - # is($fhwnd, $ahwnd); - # is($a_subhwnd, $c_subhwnd); - is($fhwnd, $c_subhwnd, 'the focus window is the client of the session owner'); -} - -# Check enumeration of switch entries: -my $skid_title = "temporary s-kid ppid=$$"; -my $spid = system P_SESSION, $^X, '-wle', "END {sleep 25} use OS2::Process; eval {Title_set '$skid_title'} or warn \$@; \$SIG{TERM} = sub {exit 0}"; -ok ($spid, 'start the new VIO session with unique title'); -sleep 1; -my @sw = grep $_->{title} eq $skid_title, process_hentries; -sleep 1000 unless @sw; -is(scalar @sw, 1, 'exactly one session with this title'); -my $sw = $sw[0]; -ok $sw, 'have the data about the session'; -is($sw->{owner_pid}, $spid, 'session has a correct pid'); -my $k_hwnd = $sw->{owner_hwnd}; -ok $k_hwnd, 'found the session window handle'; -is sidOf($spid), $sw->{owner_sid}, 'we know sid of the session'; - -# Give up focus again -{ my $force_PM = OS2::localMorphPM->new(0); - ok $force_PM, 'morphed to PM locally again'; - ok FocusWindow_set($k_hwnd), 'set focus to kid session window'; -} - -$ahwnd = ActiveWindow; -ok $ahwnd, 'there is an active window'; -is $ahwnd, $k_hwnd, 'after focusing the active window is the owner_hwnd'; -$fhwnd = FocusWindow; -ok $fhwnd, 'there is a focus window'; -my $c_sub_ahwnd = WindowFromId $ahwnd, 0x8008; # FID_CLIENT; -ok $c_sub_ahwnd, 'the active window has a FID_CLIENT'; -is($fhwnd, $ahwnd, 'the focus window = the active window'); - -ok hWindowPos_set({behind => 3}, $k_hwnd), # HWND_TOP - 'put kid to the 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, $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_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_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'; - -# This does not work, the result is the handle of "Window List" -# is((hWindowPos $k_hwnd)->{behind}, 4, 'kis is at back'); - -my (@list, $next, @list1); -{ 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'; - push @list, $next while $next = GetNextWindow $enum_handle; - @list1 = ChildWindows; - ok 1, 'embedded ChildWindows()'; - ok EndEnumWindows($enum_handle), 'end enumeration'; - - is_deeply \@list, \@list1, 'Manual list same as by ChildWindows()'; - # Apparently, the 'Desktop' window is still behind us; - # Note that this window is *not* what is returned by DesktopWindow - pop @list if WindowText($list[-1]) eq 'Desktop'; -} -is ($list[-1], $k_hwnd, 'kid is the last in z-order enumeration'); -# print "# kid=$k_hwnd in @list\n"; -@list = ChildWindows; -is_deeply \@list, \@list1, 'Other ChildWindows(), same result'; -ok scalar @list, 'ChildWindows works'; -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'; - -$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'; -#print "# win=$k_hwnd => err=$^E\n"; -my $c_sub_khwnd = WindowFromId $k_hwnd, 0x8008; # FID_CLIENT -ok $c_sub_khwnd, 'have kids client window'; -ok IsWindow($c_sub_khwnd), 'IsWindow works on the client'; -#print "# win=$c_sub_khwnd => IsWindow err=$^E\n"; -my ($pkid,$tkid) = WindowProcess $c_sub_khwnd; -my ($pkid1,$tkid1) = WindowProcess $hwnd; -ok($pkid1 > 0, 'our window has a governing process'); -ok($tkid1 > 0, 'our window has a governing thread'); -is($pkid, $pkid1, 'kid\'s window is governed by the same process as our (PMSHELL:1)'); -is($tkid, $tkid1, 'likewise for threads'); -is $pkid, ppidOf($spid), 'the governer is the parent of the kid session'; - -my $my_pos = hWindowPos($hwnd); -ok $my_pos, 'got my position'; -{ my $force_PM = OS2::localMorphPM->new(0); - ok $force_PM, 'morphed to PM locally again'; - my @pos = WindowPos $hwnd; - my @ppos = WindowPos $k_hwnd; - # ok hWindowPos_set({%$my_pos, behind => $hwnd}, $k_hwnd), 'hide the kid behind us'; - # Hide it completely behind our window - ok hWindowPos_set({x => $my_pos->{x}, y => $my_pos->{y}, behind => $hwnd, - width => $my_pos->{width}, height => $my_pos->{height}}, - $k_hwnd), 'hide the kid behind us'; - # ok WindowPos_set($k_hwnd, $pos[0], $pos[1]), 'hide the kid behind us'; - my @kpos = WindowPos $k_hwnd; - # print "# kidpos=@ppos\n"; - # print "# mypos=@pos\n"; - # print "# kidpos=@kpos\n"; -# kidpos=252 630 4111 808 478 3 66518088 502482793 -# mypos=276 78 4111 491 149 2147484137 66518060 502532977 -# kidpos=276 78 4111 491 149 2147484255 1392374582 213000 - print "# Before window position\n" if $interactive_wait; - sleep 5 if $interactive_wait; - - my $w_at = WindowFromPoint($kpos[0] + 5, $kpos[0] + 5, 1, 0); # HWND_DESKTOP, no grandchildren - ok $w_at, 'got window near LL corner of the kid'; - print "# we=$hwnd, our client=$c_subhwnd, kid=$k_hwnd, kid's client=$c_sub_khwnd\n"; - #is $w_at, $c_sub_khwnd, 'it is the kids client'; - #is $w_at, $k_hwnd, 'it is the kids frame'; - # Apparently, this result is accidental only... -# is $w_at, $hwnd, 'it is our frame - is on top, but no focus'; - #is $w_at, $c_subhwnd, 'it is our client'; - print "# text: `", WindowText $w_at, "'.\n"; - $w_at = WindowFromPoint($kpos[0] + 5, $kpos[0] + 5); # HWND_DESKTOP, grandchildren too - ok $w_at, 'got grandkid window near LL corner of the kid'; - # Apparently, this result is accidental only... -# is $w_at, $c_subhwnd, 'it is our client'; - print "# text: `", WindowText $w_at, "'.\n"; - ok IsWindowVisible $k_hwnd, 'kid is flaged as visible'; - ok IsWindowEnabled $k_hwnd, 'kid is flaged as enabled'; - ok IsWindowShowing $hwnd, 'we are showing'; - ok ((not IsWindowShowing $k_hwnd), 'kid is not showing'); - ok ((not eval { IsWindowShowing 12; 1 }), 'wrong kid causes errors'); - is $^E+0, 0x1001, 'error is 0x1001'; - like $@, qr/\Q[Win]IsWindowShowing/, 'error message shows function'; - like $@, qr/SYS4097\b/, 'error message shows error number'; - like $@, qr/\b0x1001\b/, 'error message shows error number in hex'; - - ok WindowPos_set($k_hwnd, @ppos[0..5]), 'restore the kid position'; - my @nkpos = WindowPos $k_hwnd; - my $fl = $nkpos[2]; - is_deeply([@ppos[0..5]], [@nkpos[0..5]], 'position restored'); - ok IsWindowShowing $k_hwnd, 'kid is showing'; - ok IsWindowVisible $k_hwnd, 'kid is flaged as visible'; - ok IsWindowEnabled $k_hwnd, 'kid is flaged as enabled'; - sleep 5 if $interactive_wait; - ok EnableWindow($k_hwnd, 0), 'disable the kid'; - ok IsWindowShowing $k_hwnd, 'kid is showing'; - ok IsWindowVisible $k_hwnd, 'kid is flaged as visible'; - ok !IsWindowEnabled $k_hwnd, 'kid is flaged as not enabled'; - ok EnableWindow($k_hwnd), 'enable the kid'; - ok IsWindowShowing $k_hwnd, 'kid is showing'; - ok IsWindowVisible $k_hwnd, 'kid is flaged as visible'; - ok IsWindowEnabled $k_hwnd, 'kid is flaged as enabled'; - ok ShowWindow($k_hwnd, 0), 'hide the kid'; - ok !IsWindowShowing $k_hwnd, 'kid is not showing'; - ok !IsWindowVisible $k_hwnd, 'kid is flaged as not visible'; - ok IsWindowEnabled $k_hwnd, 'kid is flaged as enabled'; - ok ShowWindow($k_hwnd), 'show the kid'; - ok IsWindowShowing $k_hwnd, 'kid is showing'; - ok IsWindowVisible $k_hwnd, 'kid is flaged as visible'; - ok IsWindowEnabled $k_hwnd, 'kid is flaged as enabled'; - ok( ($fl & 0x1800), 'window is maximized or restored'); # SWP_MAXIMIZE SWP_RESTORE - ok( ($fl & 0x1800) != 0x1800, 'window is not maximized AND restored'); # SWP_MAXIMIZE SWP_RESTORE - - ok PostMsg( $k_hwnd, 0x21, # WM_SYSCOMMAND, SC_MINIMIZE - OS2::Process::MPFROMSHORT 0x8002), 'post minimize message'; - sleep 1; - ok !IsWindowShowing $k_hwnd, 'kid is not showing'; - ok IsWindowVisible $k_hwnd, 'kid is flaged as visible'; - ok IsWindowEnabled $k_hwnd, 'kid is flaged as enabled'; - is 0x1c00 & SWP_flags $k_hwnd, 0x400, 'kid is minimized'; # SWP_MINIMIZE - - ok PostMsg($k_hwnd, 0x21, # WM_SYSCOMMAND, SC_RESTORE - OS2::Process::MPFROMSHORT 0x8008), 'post restore message'; - sleep 1; - ok IsWindowShowing $k_hwnd, 'kid is showing'; - ok IsWindowVisible $k_hwnd, 'kid is flaged as visible'; - ok IsWindowEnabled $k_hwnd, 'kid is flaged as enabled'; - is 0x1c00 & SWP_flags $k_hwnd, 0x1000, 'kid is restored'; # SWP_RESTORE - - ok PostMsg($k_hwnd, 0x21, # WM_SYSCOMMAND, SC_MAXIMIZE - OS2::Process::MPFROMSHORT 0x8003), 'post maximize message'; - sleep 1; - ok IsWindowShowing $k_hwnd, 'kid is showing'; - ok IsWindowVisible $k_hwnd, 'kid is flaged as visible'; - ok IsWindowEnabled $k_hwnd, 'kid is flaged as enabled'; - is 0x1c00 & SWP_flags $k_hwnd, 0x800, 'kid is maximized'; # SWP_MAXIMIZE - - ok PostMsg( $k_hwnd, 0x21, # WM_SYSCOMMAND, SC_MINIMIZE - OS2::Process::MPFROMSHORT 0x8002), 'post minimize message again'; - sleep 1; - ok !IsWindowShowing $k_hwnd, 'kid is not showing'; - ok IsWindowVisible $k_hwnd, 'kid is flaged as visible'; - ok IsWindowEnabled $k_hwnd, 'kid is flaged as enabled'; - is 0x1c00 & SWP_flags $k_hwnd, 0x400, 'kid is minimized'; # SWP_MINIMIZE - - ok PostMsg($k_hwnd, 0x21, # WM_SYSCOMMAND, SC_RESTORE - OS2::Process::MPFROMSHORT 0x8008), 'post restore message again'; - sleep 1; - ok IsWindowShowing $k_hwnd, 'kid is showing'; - ok IsWindowVisible $k_hwnd, 'kid is flaged as visible'; - ok IsWindowEnabled $k_hwnd, 'kid is flaged as enabled'; - is 0x1c00 & SWP_flags $k_hwnd, 0x1000, 'kid is restored'; # SWP_RESTORE - - ok PostMsg( $k_hwnd, 0x21, # WM_SYSCOMMAND, SC_MINIMIZE - OS2::Process::MPFROMSHORT 0x8002), 'post minimize message again'; - sleep 1; - ok !IsWindowShowing $k_hwnd, 'kid is not showing'; - ok IsWindowVisible $k_hwnd, 'kid is flaged as visible'; - ok IsWindowEnabled $k_hwnd, 'kid is flaged as enabled'; - is 0x1c00 & SWP_flags $k_hwnd, 0x400, 'kid is minimized'; # SWP_MINIMIZE - - ok PostMsg($k_hwnd, 0x21, # WM_SYSCOMMAND, SC_RESTORE - OS2::Process::MPFROMSHORT (($fl & 0x800) ? 0x8003 : 0x8008)), # SWP_MAXIMIZE - 'return back to the initial MAXIMIZE/RESTORE state'; - sleep 1; - ok IsWindowShowing $k_hwnd, 'kid is showing'; - ok IsWindowVisible $k_hwnd, 'kid is flaged as visible'; - ok IsWindowEnabled $k_hwnd, 'kid is flaged as enabled'; - SKIP: { - skip 'if defaultVIO=MAXIMIZED, new windows are shifted, but maximize to UL corner', 1 unless $fl & 0x800; - ok hWindowPos_set({x => $ppos[0], y => $ppos[1]}, $k_hwnd), 'x,y-restore for de-minimization of MAXIMIZED'; - } - @nkpos = WindowPos $k_hwnd; - is_deeply([@ppos[0..5]], [@nkpos[0..5]], 'position restored'); - - - # Now the other way - ok hWindowPos_set( {flags => 0x400}, $k_hwnd), 'set to minimized'; - ok !IsWindowShowing $k_hwnd, 'kid is not showing'; - ok IsWindowVisible $k_hwnd, 'kid is flaged as visible'; - ok IsWindowEnabled $k_hwnd, 'kid is flaged as enabled'; - is 0x1c00 & SWP_flags $k_hwnd, 0x400, 'kid is minimized'; # SWP_MINIMIZE - - ok hWindowPos_set( {flags => 0x1000}, $k_hwnd), 'set to restore'; - ok IsWindowShowing $k_hwnd, 'kid is showing'; - ok IsWindowVisible $k_hwnd, 'kid is flaged as visible'; - ok IsWindowEnabled $k_hwnd, 'kid is flaged as enabled'; - is 0x1c00 & SWP_flags $k_hwnd, 0x1000, 'kid is restored'; # SWP_RESTORE - - ok hWindowPos_set( {flags => 0x800}, $k_hwnd), 'set to maximized'; - ok IsWindowShowing $k_hwnd, 'kid is showing'; - ok IsWindowVisible $k_hwnd, 'kid is flaged as visible'; - ok IsWindowEnabled $k_hwnd, 'kid is flaged as enabled'; - is 0x1c00 & SWP_flags $k_hwnd, 0x800, 'kid is maximized'; # SWP_MAXIMIZE - - ok hWindowPos_set( {flags => 0x400}, $k_hwnd), 'set to minimized again'; - ok !IsWindowShowing $k_hwnd, 'kid is not showing'; - ok IsWindowVisible $k_hwnd, 'kid is flaged as visible'; - ok IsWindowEnabled $k_hwnd, 'kid is flaged as enabled'; - is 0x1c00 & SWP_flags $k_hwnd, 0x400, 'kid is minimized'; # SWP_MINIMIZE - - ok hWindowPos_set( {flags => 0x1000}, $k_hwnd), 'set to restore again'; - ok IsWindowShowing $k_hwnd, 'kid is showing'; - ok IsWindowVisible $k_hwnd, 'kid is flaged as visible'; - ok IsWindowEnabled $k_hwnd, 'kid is flaged as enabled'; - is 0x1c00 & SWP_flags $k_hwnd, 0x1000, 'kid is restored'; # SWP_RESTORE - - ok hWindowPos_set( {flags => 0x400}, $k_hwnd), 'set to minimized again'; - ok !IsWindowShowing $k_hwnd, 'kid is not showing'; - ok IsWindowVisible $k_hwnd, 'kid is flaged as visible'; - ok IsWindowEnabled $k_hwnd, 'kid is flaged as enabled'; - is 0x1c00 & SWP_flags $k_hwnd, 0x400, 'kid is minimized'; # SWP_MINIMIZE - - ok hWindowPos_set( {flags => ($fl & 0x1800)}, $k_hwnd), - 'set back to the initial MAXIMIZE/RESTORE state'; - ok IsWindowShowing $k_hwnd, 'kid is showing'; - ok IsWindowVisible $k_hwnd, 'kid is flaged as visible'; - ok IsWindowEnabled $k_hwnd, 'kid is flaged as enabled'; - SKIP: { - skip 'if defaultVIO=MAXIMIZED, new windows are shifted, but maximize to UL corner', 1 unless $fl & 0x800; - ok hWindowPos_set({x => $ppos[0], y => $ppos[1]}, $k_hwnd), 'x,y-restore for de-minimization of MAXIMIZED'; - } - @nkpos = WindowPos $k_hwnd; - is_deeply([@ppos[0..5]], [@nkpos[0..5]], 'position restored'); - -} - -# XXXX Well, no need to skip it now... -SKIP: { - skip 'We already have focus', 4 if $hwnd == $ahwnd; - my $force_PM = OS2::localMorphPM->new(0); - ok($force_PM, 'morphed to catch focus again'); - ok FocusWindow_set($c_subhwnd), 'set focus to the client of the session owner'; - # If we do not morph, then when the focus is in another VIO frame, - # we get two VIO frames with activated titlebars. - # The only (?) way to take the activated state from another frame - # is to switch to it via the switch list - $ahwnd = ActiveWindow; - ok($ahwnd, 'there is an active window'); - $fhwnd = FocusWindow; - ok($fhwnd, 'there is a focus window'); - is($hwnd, $ahwnd, 'the active window is the session owner'); - is($fhwnd, $c_subhwnd, 'the focus window is the client of the session owner'); -} - -SKIP: { - skip 'Potentially destructive session modifications, done in a separate session only', - 12, unless $separate_session; - # Manipulate process' hentry - my $he = process_hentry; - ok($he, 'got process hentry'); - ok($he->{visible}, 'session switch is visible');# 4? Assume nobody manipulated it... - - ok change_entryh($he), 'can change it (without modifications)'; - my $nhe = process_hentry; - ok $nhe, 'could refetch the process hentry'; - is_deeply($nhe, $he, 'it did not change'); - - sleep 5 if $interactive_wait; - # Try removing the process entry from the switch list - $nhe->{visible} = 0; - ok change_entryh($nhe), 'can change it to be invisible'; - my $nnhe = process_hentry; - ok($nnhe, 'could refetch the process hentry'); - is_deeply($nnhe, $nhe, 'it is modified as expected'); - is($nnhe->{visible}, 0, 'it is not visible'); - - sleep 5 if $interactive_wait; - - $nhe->{visible} = 1; - ok change_entryh ($nhe), 'can change it to be visible'; - $nnhe = process_hentry; - ok($nnhe, 'could refetch the process hentry'); - ok($nnhe->{visible}, 'it is visible'); - sleep 5 if $interactive_wait; -} diff --git a/os2/OS2/Process/t/os2_process_kid.t b/os2/OS2/Process/t/os2_process_kid.t deleted file mode 100644 index 7551d41bda..0000000000 --- a/os2/OS2/Process/t/os2_process_kid.t +++ /dev/null @@ -1,64 +0,0 @@ -#! /usr/bin/perl -w - -use strict; -use OS2::Process; # qw(P_SESSION P_UNRELATED P_NOWAIT); - -my $pl = $0; -$pl =~ s/_kid\.t$/.t/i; -die "Can't find the kid script" unless -r $pl; - -my $inc = $ENV{PERL5LIB}; -$inc = $ENV{PERLLIB} unless defined $inc; -$inc = '' unless defined $inc; -$ENV{PERL5LIB} = join ';', @INC, split /;/, $inc; - -# The thest in $pl modify the session too bad. We run the tests -# in a different session to keep the current session cleaner - -# Apparently, this affects things at open() time, not at system() time -$^F = 40; - -# These do not work... Apparently, the kid "interprets" file handles -# open to CON as output to *its* CON (shortcut in the kernel via the -# device flags?). - -#my @fh = ('<&STDIN', '>&STDOUT', '>&STDERR'); -#my @nfd; -#open $nfd[$_], $fh[$_] or die "Cannot remap FH" for 0..2; -#my @fn = map fileno $_, @nfd; -#$ENV{NEW_FD} = "@fn"; - -my ($stdout_r,$stdout_w,$stderr_r,$stderr_w); -pipe $stderr_r, $stderr_w or die; - -# Duper for $stderr_r to STDERR -my ($e_r, $e_w) = map fileno $_, $stderr_r, $stderr_w; -my $k = system P_NOWAIT, $^X, '-we', <<'EOS', $e_r, $e_w or die "Cannot start a STDERR duper"; - my ($e_r, $e_w) = @ARGV; - # close the other end by the implicit close: - { open my $closeit, ">&=$e_w" or die "kid: open >&=$e_w: $!, `$^E'" } - open IN, "<&=$e_r" or die "kid: open <&=$e_r: $!, `$^E'"; - select STDERR; $| = 1; print while sysread IN, $_, 1<<16; -EOS -close $stderr_r or die; # Now the kid is the owner - -pipe $stdout_r, $stdout_w or die; - -my @fn = (map fileno $_, $stdout_w, $stderr_w); -$ENV{NEW_FD} = "@fn"; -# print "# fns=@fn\n"; - -$ENV{OS2_PROCESS_TEST_SEPARATE_SESSION} = 1; -my $pid = system P_SESSION, $^X, $pl, @ARGV or die; -close $stderr_w or die; # Leave these two FH to the kid only -close $stdout_w or die; - -# Duplicate the STDOUT of the kid: -# These are workarounds for bug in sysread: it is reading in binary... -binmode $stdout_r; -binmode STDOUT; -$| = 1; print while sysread $stdout_r, $_, 1<<16; - -waitpid($pid, 0) >= 0 or die; - -# END { print "# parent finished\r\n" } diff --git a/os2/OS2/Process/t/os2_process_text.t b/os2/OS2/Process/t/os2_process_text.t deleted file mode 100644 index 7367327ca4..0000000000 --- a/os2/OS2/Process/t/os2_process_text.t +++ /dev/null @@ -1,52 +0,0 @@ -#! /usr/bin/perl -w - -BEGIN { - my $inc = $ENV{PERL5LIB}; - $inc = $ENV{PERLLIB} unless defined $inc; - $inc = '' unless defined $inc; - $ENV{PERL5LIB} = join ';', @INC, split /;/, $inc; -} - -use strict; -use Test::More tests => 11; -use OS2::Process; - -my $cmd = <<'EOA'; -use OS2::Process; -$| = 1; -print for $$, ppid, sidOf; -$SIG{TERM} = $SIG{INT} = sub {exit}; -sleep 10; -EOA - -#my $PID = open my $fh, '-|', $^X, '-wle', $cmd; -$ENV{CMD_RUN} = $cmd; -my $PID = open my $fh, '-|', "$^X -wle 'eval \$ENV{CMD_RUN} or die'"; -ok $PID, 'opened a pipe'; -my ($kpid, $kppid, $sid); -$kpid = <$fh>; -$kppid = <$fh>; -$sid = <$fh>; -chomp ($kpid, $kppid, $sid); - -# This does not work with the intervening shell... -my $extra_fork = $kppid == $PID; # Temporary implementation of multi-arg open() - -print "# us=$$, immediate-pid=$PID, parent-of-kid=$kppid, kid=$kpid\n"; -if ($ENV{CMD_RUN}) { # Two copies of the shell intervene... - is( ppidOf($kppid), $PID, 'correct pid of the kid or its parent'); - is( ppidOf($PID), $$, 'we know our child\'s parent'); -} else { - is( ($extra_fork ? $kppid : $kpid), $PID, 'correct pid of the kid'); - is( $kppid, ($extra_fork ? $PID : $$), 'kid knows its ppid'); -} -ok $sid >= 0, 'kid got its sid'; -is($sid, sidOf, 'sid of kid same as our'); -is(sidOf($kpid), $sid, 'we know sid of kid'); -is(sidOf($PID), $sid, 'we know sid of inter-kid'); -is(ppidOf($kpid), $kppid, 'we know ppid of kid'); -is(ppidOf($PID), $$, 'we know ppid of inter-kid'); - -ok kill('TERM', $kpid), 'killed the kid'; -#ok( ($PID == $kpid or kill('TERM', $PID)), 'killed the inter-kid'); -ok close $fh, 'closed the pipe'; # No kid any more diff --git a/os2/OS2/REXX/Changes b/os2/OS2/REXX/Changes deleted file mode 100644 index 7c19710db6..0000000000 --- a/os2/OS2/REXX/Changes +++ /dev/null @@ -1,7 +0,0 @@ -0.2: - After fixpak17 a lot of other places have mismatched lengths -returned in the REXXPool interface. - Also drop does not work on stems any more. -0.22: - A subsystem module OS2::DLL extracted which does not link - with REXX runtime library. diff --git a/os2/OS2/REXX/DLL/Changes b/os2/OS2/REXX/DLL/Changes deleted file mode 100644 index 07c41da30a..0000000000 --- a/os2/OS2/REXX/DLL/Changes +++ /dev/null @@ -1,6 +0,0 @@ -0.01: - 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 deleted file mode 100644 index 2a2486e863..0000000000 --- a/os2/OS2/REXX/DLL/DLL.pm +++ /dev/null @@ -1,308 +0,0 @@ -package OS2::DLL; - -our $VERSION = '1.03'; - -use Carp; -use XSLoader; - -@libs = split(/;/, $ENV{'PERL5REXX'} || $ENV{'PERLREXX'} || $ENV{'LIBPATH'} || $ENV{'PATH'}); -%dlls = (); - -# Preloaded methods go here. Autoload methods go after __END__, and are -# processed by the autosplit program. - -# Cannot be autoload, the autoloader is used for the REXX functions. - -my $load_with_dirs = sub { - my ($class, $file, @where) = (@_); - return $dlls{$file} if $dlls{$file}; - my $handle; - foreach (@where) { - $handle = DynaLoader::dl_load_file("$_/$file.dll"); - last if $handle; - } - $handle = DynaLoader::dl_load_file($file) unless $handle; - return undef unless $handle; - my @packs = $INC{'OS2/REXX.pm'} ? qw(OS2::DLL::dll OS2::REXX) : 'OS2::DLL::dll'; - my $p = "OS2::DLL::dll::$file"; - @{"$p\::ISA"} = @packs; - *{"$p\::AUTOLOAD"} = \&OS2::DLL::dll::AUTOLOAD; - return $dlls{$file} = - bless {Handle => $handle, File => $file, Queue => 'SESSION' }, $p; -}; - -my $new_dll = sub { - my ($dirs, $class, $file) = (shift, shift, shift); - my $handle; - push @_, @libs if $dirs; - $handle = $load_with_dirs->($class, $file, @_) - and return $handle; - my $path = @_ ? " from '@_'" : ''; - my $err = DynaLoader::dl_error(); - $err =~ s/\s+at\s+\S+\s+line\s+\S+\s*\z//; - croak "Can't load '$file'$path: $err"; -}; - -sub new { - confess 'Usage: OS2::DLL->new( [] )' unless @_ >= 2; - $new_dll->(1, @_); -} - -sub module { - confess 'Usage: OS2::DLL->module( [] )' unless @_ >= 2; - $new_dll->(0, @_); -} - -sub load { - confess 'Usage: load OS2::DLL []' unless $#_ >= 1; - $load_with_dirs->(@_, @libs); -} - -sub libPath_find { - my ($name, $flags, @path) = (shift, shift); - $flags = 0x7 unless defined $flags; - 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; - $name .= ".dll" unless $name =~ /\.[^\\\/]*$/; - $_ .= $name for @path; - return grep -f $_, @path if $flags & 0x8; - -f $_ and return $_ for @path; - return; -} - -package OS2::DLL::dll; -use Carp; -@ISA = 'OS2::DLL'; - -sub AUTOLOAD { - $AUTOLOAD =~ /^OS2::DLL::dll::.+::(.+)$/ - or confess("Undefined subroutine &$AUTOLOAD called"); - return undef if $1 eq "DESTROY"; - die "AUTOLOAD loop" if $1 eq "AUTOLOAD"; - $_[0]->find($1) or confess($@); - goto &$AUTOLOAD; -} - -sub wrapper_REXX { - confess 'Usage: $dllhandle->wrapper_REXX($func_name)' unless @_ == 2; - my $self = shift; - my $file = $self->{File}; - my $handle = $self->{Handle}; - my $prefix = exists($self->{Prefix}) ? $self->{Prefix} : ""; - my $queue = $self->{Queue}; - my $name = shift; - $prefix = '' if $name =~ /^#\d+/; # loading by ordinal - my $addr = (DynaLoader::dl_find_symbol($handle, uc $prefix.$name) - || DynaLoader::dl_find_symbol($handle, $prefix.$name)); - return sub { - OS2::DLL::_call($name, $addr, $queue, @_); - } if $addr; - my $err = DynaLoader::dl_error(); - $err =~ s/\s+at\s+\S+\s+line\s+\S+\s*\z//; - croak "Can't find symbol `$name' in DLL `$file': $err"; -} - -sub find -{ - my $self = shift; - my $file = $self->{File}; - my $p = ref $self; - foreach (@_) { - my $f = eval {$self->wrapper_REXX($_)} or return 0; - ${"${p}::"}{$_} = sub { shift; $f->(@_) }; - } - return 1; -} - -sub handle { shift->{Handle} } -sub fullname { OS2::DLLname(0x202, shift->handle) } -#sub modname { OS2::DLLname(0x201, shift->handle) } - -sub has_f32 { - my $handle = shift->handle; - my $name = shift; - DynaLoader::dl_find_symbol($handle, $name); -} - -XSLoader::load 'OS2::DLL'; - -1; -__END__ - -=head1 NAME - -OS2::DLL - access to DLLs with REXX calling convention. - -=head2 NOTE - -When you use this module, the REXX variable pool is not available. - -See documentation of L module if you need the variable pool. - -=head1 SYNOPSIS - - use OS2::DLL; - $emx_dll = OS2::DLL->module('emx'); - $emx_version = $emx_dll->emx_revision(); - $func_emx_version = $emx_dll->wrapper_REXX('#128'); # emx_revision - $emx_version = $func_emx_version->(); - -=head1 DESCRIPTION - -=head2 Create a DLL handle - - $dll = OS2::DLL->module( NAME [, WHERE] ); - -Loads an OS/2 module NAME, looking in directories WHERE (adding the -extension F<.dll>), if the DLL is not found there, loads in the usual OS/2 way -(via LIBPATH and other settings). Croaks with a verbose report on failure. - -The DLL is not unloaded when the return value is destroyed. - -=head2 Create a DLL handle (looking in some strange locations) - - $dll = OS2::DLL->new( NAME [, WHERE] ); - -Same as L|Create a DLL handle>, but in addition to WHERE, looks -in environment paths PERL5REXX, PERLREXX, PATH (provided for backward -compatibility). - -=head2 Loads DLL by name - - $dll = load OS2::DLL NAME [, WHERE]; - -Same as L|Create a DLL handle (looking in some strange locations)>, -but returns DLL object reference, or undef on failure (in this case one can -get the reason via C) (provided for backward -compatibility). - -=head2 Check for functions (optional): - - BOOL = $dll->find(NAME [, NAME [, ...]]); - -Returns true if all functions are available. As a side effect, creates -a REXX wrapper with the specified name in the package constructed by the name -of the DLL so that the next call to C<$dll->NAME()> will pick up the cached -method. - -=head2 Create a Perl wrapper (optional): - - $func = $dll->wrapper_REXX(NAME); - -Returns a reference to a Perl function wrapper for the entry point NAME -in the DLL. Similar to the OS/2 API, the NAME may be C<"#123"> - in this case -the ordinal is loaded. Croaks with a meaningful error message if NAME does -not exists (although the message for the case when the name is an ordinal may -be confusing). - -=head2 Call external function with REXX calling convention: - - $ret_string = $dll->function_name(arguments); - -Returns the return string if the REXX return code is 0, else undef. -Dies with error message if the function is not available. On the first call -resolves the name in the DLL and caches the Perl wrapper; future calls go -through the wrapper. - -Unless used inside REXX environment (see L), the REXX runtime -environment (variable pool, queue etc.) is not available to the called -function. - -=head1 Inspecting the module - -=over - -=item $module->handle - -=item $module->fullname - -Return the (integer) handle and full path name of a loaded DLL. - -TODO: the module name (whatever is specified in the C statement -of F<.def> file when linking) via OS2::Proc. - -=item $module->has_f32($name) - -Returns the address of a 32-bit entry point with name $name, or 0 if none -found. (Keep in mind that some entry points may be 16-bit, and some may have -capitalized names comparing to callable-from-C counterparts.) Name of the -form C<#197> will find entry point with ordinal 197. - -=item libPath_find($name [, $flags]) - -Looks for the DLL $name on C, C, C if -bits 0x1, 0x2, 0x4 of $flags are set correspondingly. If called with no -arguments, looks on all 3 locations. Returns the full name of the found -file. B - -$name has F<.dll> appended unless it already has an extension. - -=back - -=head1 Low-level API - -=over - -=item Call a _System linkage function via a pointer - -If a function takes up to 20 ULONGs and returns ULONG: - - $res = call20( $pointer, $arg0, $arg1, ...); - -=item Same for packed arguments: - - $res = call20_p( $pointer, pack 'L20', $arg0, $arg1, ...); - -=item Same for C function: - - $res = call20_rp3( $pointer, $arg0, $arg1, ...); - -=item Same for packed arguments and C function - - $res = call20_rp3_p( $pointer, pack 'L20', $arg0, $arg1, ...); - -=item Same for a function which returns non-0 and sets system-error on error - - call20_Dos( $msg, $pointer, $arg0, $arg1, ...); # die("$msg: $^E") if error - -[Good for C API - and rare C calls.] - -=item Same for a function which returns 0 and sets WinLastError() on error - - $res = call20_Win( $msg, $pointer, $arg0, $arg1, ...); - # would die("$msg: $^E") if error - -[Good for most of C API.] - -=item Same for a function which returns 0 and sets WinLastError() on error but -0 is also a valid return - - $res = call20_Win_0OK( $msg, $pointer, $arg0, $arg1, ...); - # would die("$msg: $^E") if error - -[Good for some of C API.] - -=item As previous, but without die() - - $res = call20_Win_0OK_survive( $pointer, $arg0, $arg1, ...); - if ($res == 0 and $^E) { # Do error processing here - } - -[Good for some of C API.] - -=back - -=head1 ENVIRONMENT - -If C is set, emits debugging output. Looks for DLLs -in C, C, C. - -=head1 AUTHOR - -Extracted by Ilya Zakharevich perl-module-OS2-DLL@ilyaz.org from L -written by Andreas Kaiser ak@ananke.s.bawue.de. - -=cut diff --git a/os2/OS2/REXX/DLL/DLL.xs b/os2/OS2/REXX/DLL/DLL.xs deleted file mode 100644 index 90b14eaf85..0000000000 --- a/os2/OS2/REXX/DLL/DLL.xs +++ /dev/null @@ -1,172 +0,0 @@ -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" - -#define INCL_BASE -#define INCL_REXXSAA -#include - -static RXSTRING * strs; -static int nstrs; -static char * trace; - -static void -needstrs(int n) -{ - if (n > nstrs) { - if (strs) - free(strs); - nstrs = 2 * n; - strs = malloc(nstrs * sizeof(RXSTRING)); - } -} - -typedef ULONG (*fptr_UL_20)(ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG); -typedef __attribute__((regparm(3))) ULONG (*fptr_UL_20_rp3)(ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG); - -static inline unsigned long -call20_p(unsigned long fp, char* str) -{ - ULONG *argv = (ULONG*)str; - fptr_UL_20 f = (fptr_UL_20)fp; - - return f(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5], argv[6], argv[7], argv[8], argv[9], argv[10], argv[11], argv[12], argv[13], argv[14], argv[15], argv[16], argv[17], argv[18], argv[19]); -} - -static inline unsigned long -call20(unsigned long fp, unsigned long arg0, unsigned long arg1, unsigned long arg2, unsigned long arg3, unsigned long arg4, unsigned long arg5, unsigned long arg6, unsigned long arg7, unsigned long arg8, unsigned long arg9, unsigned long arg10, unsigned long arg11, unsigned long arg12, unsigned long arg13, unsigned long arg14, unsigned long arg15, unsigned long arg16, unsigned long arg17, unsigned long arg18, unsigned long arg19) -{ - fptr_UL_20 f = (fptr_UL_20)fp; - - return f(arg0, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8, arg9, arg10, arg11, arg12, arg13, arg14, arg15, arg16, arg17, arg18, arg19); -} - -static inline unsigned long -call20_rp3_p(unsigned long fp, char* str) -{ - ULONG *argv = (ULONG*)str; - fptr_UL_20_rp3 f = (fptr_UL_20_rp3)fp; - - return f(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5], argv[6], argv[7], argv[8], argv[9], argv[10], argv[11], argv[12], argv[13], argv[14], argv[15], argv[16], argv[17], argv[18], argv[19]); -} - -static inline unsigned long -call20_rp3(unsigned long fp, unsigned long arg0, unsigned long arg1, unsigned long arg2, unsigned long arg3, unsigned long arg4, unsigned long arg5, unsigned long arg6, unsigned long arg7, unsigned long arg8, unsigned long arg9, unsigned long arg10, unsigned long arg11, unsigned long arg12, unsigned long arg13, unsigned long arg14, unsigned long arg15, unsigned long arg16, unsigned long arg17, unsigned long arg18, unsigned long arg19) -{ - fptr_UL_20_rp3 f = (fptr_UL_20_rp3)fp; - - return f(arg0, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8, arg9, arg10, arg11, arg12, arg13, arg14, arg15, arg16, arg17, arg18, arg19); -} - -static inline void -call20_Dos(char *msg, unsigned long fp, unsigned long arg0, unsigned long arg1, unsigned long arg2, unsigned long arg3, unsigned long arg4, unsigned long arg5, unsigned long arg6, unsigned long arg7, unsigned long arg8, unsigned long arg9, unsigned long arg10, unsigned long arg11, unsigned long arg12, unsigned long arg13, unsigned long arg14, unsigned long arg15, unsigned long arg16, unsigned long arg17, unsigned long arg18, unsigned long arg19) -{ - fptr_UL_20 f = (fptr_UL_20)fp; - ULONG rc; - - if (CheckOSError(f(arg0, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8, arg9, arg10, arg11, arg12, arg13, arg14, arg15, arg16, arg17, arg18, arg19))) - croak_with_os2error(msg); -} - -static inline unsigned long -call20_Win(char *msg, unsigned long fp, unsigned long arg0, unsigned long arg1, unsigned long arg2, unsigned long arg3, unsigned long arg4, unsigned long arg5, unsigned long arg6, unsigned long arg7, unsigned long arg8, unsigned long arg9, unsigned long arg10, unsigned long arg11, unsigned long arg12, unsigned long arg13, unsigned long arg14, unsigned long arg15, unsigned long arg16, unsigned long arg17, unsigned long arg18, unsigned long arg19) -{ - fptr_UL_20 f = (fptr_UL_20)fp; - - if (CheckWinError(f(arg0, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8, arg9, arg10, arg11, arg12, arg13, arg14, arg15, arg16, arg17, arg18, arg19))) - croak_with_os2error(msg); -} - -static inline unsigned long -call20_Win_0OK(char *msg, unsigned long fp, unsigned long arg0, unsigned long arg1, unsigned long arg2, unsigned long arg3, unsigned long arg4, unsigned long arg5, unsigned long arg6, unsigned long arg7, unsigned long arg8, unsigned long arg9, unsigned long arg10, unsigned long arg11, unsigned long arg12, unsigned long arg13, unsigned long arg14, unsigned long arg15, unsigned long arg16, unsigned long arg17, unsigned long arg18, unsigned long arg19) -{ - fptr_UL_20 f = (fptr_UL_20)fp; - - ResetWinError(); - return SaveCroakWinError(f(arg0, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8, arg9, arg10, arg11, arg12, arg13, arg14, arg15, arg16, arg17, arg18, arg19), - 1 /* Die on error */, /* No prefix */, msg); -} - -static inline unsigned long -call20_Win_0OK_survive(unsigned long fp, unsigned long arg0, unsigned long arg1, unsigned long arg2, unsigned long arg3, unsigned long arg4, unsigned long arg5, unsigned long arg6, unsigned long arg7, unsigned long arg8, unsigned long arg9, unsigned long arg10, unsigned long arg11, unsigned long arg12, unsigned long arg13, unsigned long arg14, unsigned long arg15, unsigned long arg16, unsigned long arg17, unsigned long arg18, unsigned long arg19) -{ - fptr_UL_20 f = (fptr_UL_20)fp; - - ResetWinError(); - return SaveCroakWinError(f(arg0, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8, arg9, arg10, arg11, arg12, arg13, arg14, arg15, arg16, arg17, arg18, arg19), - 0 /* No die on error */, /* No prefix */, "N/A"); -} - -MODULE = OS2::DLL PACKAGE = OS2::DLL - -BOOT: - needstrs(8); - trace = getenv("PERL_REXX_DEBUG"); - -unsigned long -call20_p(unsigned long fp, char* argv) - -unsigned long -call20(unsigned long fp, unsigned long arg0 = 0, unsigned long arg1 = 0, unsigned long arg2 = 0, unsigned long arg3 = 0, unsigned long arg4 = 0, unsigned long arg5 = 0, unsigned long arg6 = 0, unsigned long arg7 = 0, unsigned long arg8 = 0, unsigned long arg9 = 0, unsigned long arg10 = 0, unsigned long arg11 = 0, unsigned long arg12 = 0, unsigned long arg13 = 0, unsigned long arg14 = 0, unsigned long arg15 = 0, unsigned long arg16 = 0, unsigned long arg17 = 0, unsigned long arg18 = 0, unsigned long arg19 = 0) - -void -call20_Dos(char* msg, unsigned long fp, unsigned long arg0 = 0, unsigned long arg1 = 0, unsigned long arg2 = 0, unsigned long arg3 = 0, unsigned long arg4 = 0, unsigned long arg5 = 0, unsigned long arg6 = 0, unsigned long arg7 = 0, unsigned long arg8 = 0, unsigned long arg9 = 0, unsigned long arg10 = 0, unsigned long arg11 = 0, unsigned long arg12 = 0, unsigned long arg13 = 0, unsigned long arg14 = 0, unsigned long arg15 = 0, unsigned long arg16 = 0, unsigned long arg17 = 0, unsigned long arg18 = 0, unsigned long arg19 = 0) - -unsigned long -call20_Win(char *msg, unsigned long fp, unsigned long arg0 = 0, unsigned long arg1 = 0, unsigned long arg2 = 0, unsigned long arg3 = 0, unsigned long arg4 = 0, unsigned long arg5 = 0, unsigned long arg6 = 0, unsigned long arg7 = 0, unsigned long arg8 = 0, unsigned long arg9 = 0, unsigned long arg10 = 0, unsigned long arg11 = 0, unsigned long arg12 = 0, unsigned long arg13 = 0, unsigned long arg14 = 0, unsigned long arg15 = 0, unsigned long arg16 = 0, unsigned long arg17 = 0, unsigned long arg18 = 0, unsigned long arg19 = 0) - -unsigned long -call20_Win_0OK(char *msg, unsigned long fp, unsigned long arg0 = 0, unsigned long arg1 = 0, unsigned long arg2 = 0, unsigned long arg3 = 0, unsigned long arg4 = 0, unsigned long arg5 = 0, unsigned long arg6 = 0, unsigned long arg7 = 0, unsigned long arg8 = 0, unsigned long arg9 = 0, unsigned long arg10 = 0, unsigned long arg11 = 0, unsigned long arg12 = 0, unsigned long arg13 = 0, unsigned long arg14 = 0, unsigned long arg15 = 0, unsigned long arg16 = 0, unsigned long arg17 = 0, unsigned long arg18 = 0, unsigned long arg19 = 0) - -unsigned long -call20_Win_0OK_survive(unsigned long fp, unsigned long arg0 = 0, unsigned long arg1 = 0, unsigned long arg2 = 0, unsigned long arg3 = 0, unsigned long arg4 = 0, unsigned long arg5 = 0, unsigned long arg6 = 0, unsigned long arg7 = 0, unsigned long arg8 = 0, unsigned long arg9 = 0, unsigned long arg10 = 0, unsigned long arg11 = 0, unsigned long arg12 = 0, unsigned long arg13 = 0, unsigned long arg14 = 0, unsigned long arg15 = 0, unsigned long arg16 = 0, unsigned long arg17 = 0, unsigned long arg18 = 0, unsigned long arg19 = 0) - -unsigned long -call20_rp3_p(unsigned long fp, char* argv) - -unsigned long -call20_rp3(unsigned long fp, unsigned long arg0 = 0, unsigned long arg1 = 0, unsigned long arg2 = 0, unsigned long arg3 = 0, unsigned long arg4 = 0, unsigned long arg5 = 0, unsigned long arg6 = 0, unsigned long arg7 = 0, unsigned long arg8 = 0, unsigned long arg9 = 0, unsigned long arg10 = 0, unsigned long arg11 = 0, unsigned long arg12 = 0, unsigned long arg13 = 0, unsigned long arg14 = 0, unsigned long arg15 = 0, unsigned long arg16 = 0, unsigned long arg17 = 0, unsigned long arg18 = 0, unsigned long arg19 = 0) - -SV * -_call(name, address, queue="SESSION", ...) - char * name - void * address - char * queue - CODE: - { - ULONG rc; - int argc, i; - RXSTRING result; - UCHAR resbuf[256]; - RexxFunctionHandler *fcn = address; - argc = items-3; - needstrs(argc); - if (trace) - fprintf(stderr, "REXXCALL::_call name: '%s' args:", name); - for (i = 0; i < argc; ++i) { - STRLEN len; - char *ptr = SvPV(ST(3+i), len); - MAKERXSTRING(strs[i], ptr, len); - if (trace) - fprintf(stderr, " '%.*s'", len, ptr); - } - if (!*queue) - queue = "SESSION"; - if (trace) - fprintf(stderr, "\n"); - MAKERXSTRING(result, resbuf, sizeof resbuf); - rc = fcn(name, argc, strs, queue, &result); - if (trace) - fprintf(stderr, " rc=%X, result='%.*s'\n", rc, - result.strlength, result.strptr); - ST(0) = sv_newmortal(); - if (rc == 0) { - if (result.strptr) - sv_setpvn(ST(0), result.strptr, result.strlength); - else - sv_setpvn(ST(0), "", 0); - } - if (result.strptr && result.strptr != resbuf) - DosFreeMem(result.strptr); - } - diff --git a/os2/OS2/REXX/DLL/MANIFEST b/os2/OS2/REXX/DLL/MANIFEST deleted file mode 100644 index d7ad9b6338..0000000000 --- a/os2/OS2/REXX/DLL/MANIFEST +++ /dev/null @@ -1,5 +0,0 @@ -Changes -MANIFEST -Makefile.PL -DLL.pm -DLL.xs diff --git a/os2/OS2/REXX/DLL/Makefile.PL b/os2/OS2/REXX/DLL/Makefile.PL deleted file mode 100644 index 6756402c2f..0000000000 --- a/os2/OS2/REXX/DLL/Makefile.PL +++ /dev/null @@ -1,9 +0,0 @@ -use ExtUtils::MakeMaker; - -WriteMakefile( - NAME => 'OS2::DLL', - VERSION_FROM => 'DLL.pm', - MAN3PODS => {}, # Pods will be built by installman. - XSPROTOARG => '-noprototypes', - PERL_MALLOC_OK => 1, -); diff --git a/os2/OS2/REXX/MANIFEST b/os2/OS2/REXX/MANIFEST deleted file mode 100644 index 4ac81492e4..0000000000 --- a/os2/OS2/REXX/MANIFEST +++ /dev/null @@ -1,14 +0,0 @@ -Changes -MANIFEST -Makefile.PL -REXX.pm -REXX.xs -t/rx_cmprt.t -t/rx_dllld.t -t/rx_objcall.t -t/rx_sql.test -t/rx_tiesql.test -t/rx_tievar.t -t/rx_tieydb.t -t/rx_varset.t -t/rx_vrexx.t diff --git a/os2/OS2/REXX/Makefile.PL b/os2/OS2/REXX/Makefile.PL deleted file mode 100644 index 9b4c0baf25..0000000000 --- a/os2/OS2/REXX/Makefile.PL +++ /dev/null @@ -1,9 +0,0 @@ -use ExtUtils::MakeMaker; - -WriteMakefile( - NAME => 'OS2::REXX', - VERSION_FROM => 'REXX.pm', - MAN3PODS => {}, # Pods will be built by installman. - XSPROTOARG => '-noprototypes', - PERL_MALLOC_OK => 1, -); diff --git a/os2/OS2/REXX/REXX.pm b/os2/OS2/REXX/REXX.pm deleted file mode 100644 index ca9fee69ce..0000000000 --- a/os2/OS2/REXX/REXX.pm +++ /dev/null @@ -1,483 +0,0 @@ -package OS2::REXX; - -require Exporter; -use XSLoader; -require OS2::DLL; - -@ISA = qw(Exporter); -# Items to export into callers namespace by default -# (move infrequently used names to @EXPORT_OK below) -@EXPORT = qw(REXX_call REXX_eval REXX_eval_with); -# Other items we are prepared to export if requested -@EXPORT_OK = qw(drop register); - -$VERSION = '1.04'; - -# We cannot just put OS2::DLL in @ISA, since some scripts would use -# function interface, not method interface... - -*_call = \&OS2::DLL::_call; -*load = \&OS2::DLL::load; -*find = \&OS2::DLL::find; - -XSLoader::load 'OS2::REXX'; - -# Preloaded methods go here. Autoload methods go after __END__, and are -# processed by the autosplit program. - -sub register {_register($_) for @_} - -sub prefix -{ - my $self = shift; - $self->{Prefix} = shift; -} - -sub queue -{ - my $self = shift; - $self->{Queue} = shift; -} - -sub drop -{ # Supposedly should drop anything with - # the given prefix. Unfortunately a - # loop is needed after fixpack17. -&OS2::REXX::_drop(@_); -} - -sub dropall -{ # Supposedly should drop anything with - # the given prefix. Unfortunately a - # loop is needed after fixpack17. - &OS2::REXX::_drop(@_); # Try to drop them all. - my $name; - for (@_) { - if (/\.$/) { - OS2::REXX::_fetch('DUMMY'); # reset REXX's first/next iterator - while (($name) = OS2::REXX::_next($_)) { - OS2::REXX::_drop($_ . $name); - } - } - } -} - -sub TIESCALAR -{ - my ($obj, $name) = @_; - $name =~ s/^([\w!?]+)/\U$1\E/; - return bless \$name, OS2::REXX::_SCALAR; -} - -sub TIEARRAY -{ - my ($obj, $name) = @_; - $name =~ s/^([\w!?]+)/\U$1\E/; - return bless [$name, 0], OS2::REXX::_ARRAY; -} - -sub TIEHASH -{ - my ($obj, $name) = @_; - $name =~ s/^([\w!?]+)/\U$1\E/; - return bless {Stem => $name}, OS2::REXX::_HASH; -} - -############################################################################# -package OS2::REXX::_SCALAR; - -sub FETCH -{ - return OS2::REXX::_fetch(${$_[0]}); -} - -sub STORE -{ - return OS2::REXX::_set(${$_[0]}, $_[1]); -} - -sub DESTROY -{ - return OS2::REXX::_drop(${$_[0]}); -} - -############################################################################# -package OS2::REXX::_ARRAY; - -sub FETCH -{ - $_[0]->[1] = $_[1] if $_[1] > $_[0]->[1]; - return OS2::REXX::_fetch($_[0]->[0].'.'.(0+$_[1])); -} - -sub STORE -{ - $_[0]->[1] = $_[1] if $_[1] > $_[0]->[1]; - return OS2::REXX::_set($_[0]->[0].'.'.(0+$_[1]), $_[2]); -} - -############################################################################# -package OS2::REXX::_HASH; - -require Tie::Hash; -@ISA = ('Tie::Hash'); - -sub FIRSTKEY -{ - my ($self) = @_; - my $stem = $self->{Stem}; - - delete $self->{List} if exists $self->{List}; - - my @list = (); - my ($name, $value); - OS2::REXX::_fetch('DUMMY'); # reset REXX's first/next iterator - while (($name) = OS2::REXX::_next($stem)) { - push @list, $name; - } - my $key = pop @list; - - $self->{List} = \@list; - return $key; -} - -sub NEXTKEY -{ - return pop @{$_[0]->{List}}; -} - -sub EXISTS -{ - return defined OS2::REXX::_fetch($_[0]->{Stem}.$_[1]); -} - -sub FETCH -{ - return OS2::REXX::_fetch($_[0]->{Stem}.$_[1]); -} - -sub STORE -{ - return OS2::REXX::_set($_[0]->{Stem}.$_[1], $_[2]); -} - -sub DELETE -{ - OS2::REXX::_drop($_[0]->{Stem}.$_[1]); -} - -############################################################################# -package OS2::REXX; - -1; -__END__ - -=head1 NAME - -OS2::REXX - access to DLLs with REXX calling convention and REXX runtime. - -=head2 NOTE - -By default, the REXX variable pool is not available, neither -to Perl, nor to external REXX functions. To enable it, you need to put -your code inside C function. REXX functions which do not use -variables may be usable even without C though. - -=head1 SYNOPSIS - - use OS2::REXX; - $ydb = load OS2::REXX "ydbautil" or die "Cannot load: $!"; - @pid = $ydb->RxProcId(); - REXX_call { - tie $s, OS2::REXX, "TEST"; - $s = 1; - }; - -=head1 DESCRIPTION - -=head2 Load REXX DLL - - $dll = load OS2::REXX NAME [, WHERE]; - -NAME is DLL name, without path and extension. - -Directories are searched WHERE first (list of dirs), then environment -paths PERL5REXX, PERLREXX, PATH or, as last resort, OS/2-ish search -is performed in default DLL path (without adding paths and extensions). - -The DLL is not unloaded when the variable dies. - -Returns DLL object reference, or undef on failure. - -=head2 Define function prefix: - - $dll->prefix(NAME); - -Define the prefix of external functions, prepended to the function -names used within your program, when looking for the entries in the -DLL. - -=head2 Example - - $dll = load OS2::REXX "RexxBase"; - $dll->prefix("RexxBase_"); - $dll->Init(); - -is the same as - - $dll = load OS2::REXX "RexxBase"; - $dll->RexxBase_Init(); - -=head2 Define queue: - - $dll->queue(NAME); - -Define the name of the REXX queue passed to all external -functions of this module. Defaults to "SESSION". - -Check for functions (optional): - - BOOL = $dll->find(NAME [, NAME [, ...]]); - -Returns true if all functions are available. - -=head2 Call external REXX function: - - $dll->function(arguments); - -Returns the return string if the return code is 0, else undef. -Dies with error message if the function is not available. - -=head1 Accessing REXX-runtime - -While calling functions with REXX signature does not require the presence -of the system REXX DLL, there are some actions which require REXX-runtime -present. Among them is the access to REXX variables by name. - -One enables REXX runtime by bracketing your code by - - REXX_call BLOCK; - -(trailing semicolon required!) or - - REXX_call \&subroutine_name; - -Inside such a call one has access to REXX variables (see below). - -An alternative way to execute code inside a REXX compartment is - - REXX_eval EXPR; - REXX_eval_with EXPR, - subroutine_name_in_REXX => \&Perl_subroutine - -Here C is a REXX code to run; to execute Perl code one needs to put -it inside Perl_subroutine(), and call this subroutine from REXX, as in - - REXX_eval_with < sub { 123 * shift }; - say foo(2) - EOE - -If one needs more Perl subroutines available, one can "import" them into -REXX from inside Perl_subroutine(); since REXX is not case-sensitive, -the names should be uppercased. - - use OS2::REXX 'register'; - - sub BAR { 123 + shift} - sub BAZ { 789 } - sub importer { register qw(BAR BAZ) } - - REXX_eval_with <<'EOE', importer => \&importer; - call importer - say bar(34) - say baz() - EOE - -=head2 Bind scalar variable to REXX variable: - - tie $var, OS2::REXX, "NAME"; - -=head2 Bind array variable to REXX stem variable: - - tie @var, OS2::REXX, "NAME."; - -Only scalar operations work so far. No array assignments, no array -operations, ... FORGET IT. - -=head2 Bind hash array variable to REXX stem variable: - - tie %var, OS2::REXX, "NAME."; - -To access all visible REXX variables via hash array, bind to ""; - -No array assignments. No array operations, other than hash array -operations. Just like the *dbm based implementations. - -For the usual REXX stem variables, append a "." to the name, -as shown above. If the hash key is part of the stem name, for -example if you bind to "", you cannot use lower case in the stem -part of the key and it is subject to character set restrictions. - -=head2 Erase individual REXX variables (bound or not): - - OS2::REXX::drop("NAME" [, "NAME" [, ...]]); - -=head2 Erase REXX variables with given stem (bound or not): - - OS2::REXX::dropall("STEM" [, "STEM" [, ...]]); - -=head2 Make Perl functions available in REXX: - - OS2::REXX::register("NAME" [, "NAME" [, ...]]); - -Since REXX is not case-sensitive, the names should be uppercase. - -=head1 Subcommand handlers - -By default, the executed REXX code runs without any default subcommand -handler present. A subcommand handler named C is defined, but -not made a default. Use C
REXX command to make it a default -handler; alternatively, use C
to direct a command -to the handler you like. - -Experiments show that the handler C is also available; probably it is -provided by the REXX runtime. - -=head1 Interfacing from REXX to Perl - -This module provides an interface from Perl to REXX, and from REXX-inside-Perl -back to Perl. There is an alternative scenario which allows usage of Perl -from inside REXX. - -A DLL F provides an API to Perl as REXX functions - - PERL - PERLTERM - PERLINIT - PERLEXIT - PERLEVAL - PERLLASTERROR - PERLEXPORTALL - PERLDROPALL - PERLDROPALLEXIT - -A subcommand handler C can also be registered. Calling -the function PERLEXPORTALL() exports all these functions, as well as -exports this subcommand handler under the name C. PERLDROPALL() -inverts this action (and unloads PERLEXPORTALL() as well). In particular - - rc = RxFuncAdd("PerlExportAll", 'PerlRexx', "PERLEXPORTALL") - rc = PerlExportAll() - res = PERLEVAL(perlarg) - ADDRESS EVALPERL perlarg1 - rc = PerlDropAllExit() - -loads all the functions above, evals the Perl code in the REXX variable -C, putting the result into the REXX variable C, -then evals the Perl code in the REXX variable C, and, finally, -drops the loaded functions and the subcommand handler, deinitializes -the Perl interpreter, and exits the Perl's C runtime library. - -PERLEXIT() or PERLDROPALLEXIT() should be called as the last command of -the REXX program. (This is considered as a bug.) Their purpose is to flush -all the output buffers of the Perl's C runtime library. - -C gives the reason for the failure of the last PERLEVAL(). -It is useful inside C handler. PERLINIT() and PERLTERM() -initialize and deinitialize the Perl interpreter. - -C initializes the Perl interpreter (if needed), and -evaluates C as Perl code. The result is returned to REXX stringified, -undefined result is considered as failure. - -C does the same as C wrapped by calls to -PERLINIT() and PERLEXIT(). - -=head1 NOTES - -Note that while function and variable names are case insensitive in the -REXX language, function names exported by a DLL and the REXX variables -(as seen by Perl through the chosen API) are all case sensitive! - -Most REXX DLLs export function names all upper case, but there are a -few which export mixed case names (such as RxExtras). When trying to -find the entry point, both exact case and all upper case are searched. -If the DLL exports "RxNap", you have to specify the exact case, if it -exports "RXOPEN", you can use any case. - -To avoid interfering with subroutine names defined by Perl (DESTROY) -or used within the REXX module (prefix, find), it is best to use mixed -case and to avoid lowercase only or uppercase only names when calling -REXX functions. Be consistent. The same function written in different -ways results in different Perl stubs. - -There is no REXX interpolation on variable names, so the REXX variable -name TEST.ONE is not affected by some other REXX variable ONE. And it -is not the same variable as TEST.one! - -You cannot call REXX functions which are not exported by the DLL. -While most DLLs export all their functions, some, like RxFTP, export -only "...LoadFuncs", which registers the functions within REXX only. - -You cannot call 16-bit DLLs. The few interesting ones I found -(FTP,NETB,APPC) do not export their functions. - -I do not know whether the REXX API is reentrant with respect to -exceptions (signals) when the REXX top-level exception handler is -overridden. So unless you know better than I do, do not access REXX -variables (probably tied to Perl variables) or call REXX functions -which access REXX queues or REXX variables in signal handlers. - -See C and the next section for examples. - -=head1 EXAMPLE - - use OS2::REXX; - - sub Ender::DESTROY { $vrexx->VExit; print "Exiting...\n" } - - $vrexx = OS2::REXX->load('VREXX'); - REXX_call { # VOpenWindow takes a stem - local $SIG{TERM} = sub {die}; # enable Ender::DESTROY - local $SIG{INT} = sub {die}; # enable Ender::DESTROY - - $code = $vrexx->VInit; - print "Init code = `$code'\n"; - die "error initializing VREXX" if $code eq 'ERROR'; - - my $ender = bless [], 'Ender'; # Call Ender::DESTROY on exit - - print "VREXX Version ", $vrexx->VGetVersion, "\n"; - - tie %pos, 'OS2::REXX', 'POS.' or die; - %pos = ( LEFT => 0, RIGHT => 7, TOP => 5, BOTTOM => 0 ); - - $id = $vrexx->VOpenWindow('To disconnect:', 'WHITE', 'POS'); - $vrexx->VForeColor($id, 'BLACK'); - $vrexx->VSetFont($id, 'TIME', '30'); - $tlim = time + 60; - while ( ($r = $tlim - time) >= 0 ) { - $vrexx->VClearWindow($id); - $vrexx->VSay($id, 100, 50, (sprintf "%02i:%02i", int($r/60), $r % 60)); - sleep 1; - } - print "Close code = `$res'\n" if $res = $vrexx->VCloseWindow($id); - }; - - - -=head1 ENVIRONMENT - -If C is set, prints trace info on calls to REXX runtime -environment. - -=head1 AUTHOR - -Andreas Kaiser ak@ananke.s.bawue.de, with additions by Ilya Zakharevich -ilya@math.ohio-state.edu. - -=head1 SEE ALSO - -L. - -=cut diff --git a/os2/OS2/REXX/REXX.xs b/os2/OS2/REXX/REXX.xs deleted file mode 100644 index 428dfd57f5..0000000000 --- a/os2/OS2/REXX/REXX.xs +++ /dev/null @@ -1,566 +0,0 @@ -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" - -#define INCL_BASE -#define INCL_REXXSAA -#include - -#if 0 -#define INCL_REXXSAA -#pragma pack(1) -#define _Packed -#include -#pragma pack() -#endif - -extern ULONG _emx_exception ( EXCEPTIONREPORTRECORD *, - EXCEPTIONREGISTRATIONRECORD *, - CONTEXTRECORD *, - void *); - -static RXSTRING * strs; -static int nstrs; -static SHVBLOCK * vars; -static int nvars; -static char * trace; - -/* -static RXSTRING rxcommand = { 9, "RXCOMMAND" }; -static RXSTRING rxsubroutine = { 12, "RXSUBROUTINE" }; -static RXSTRING rxfunction = { 11, "RXFUNCTION" }; -*/ - -static ULONG PERLCALL(PCSZ name, ULONG argc, PRXSTRING argv, PCSZ queue, PRXSTRING ret); -static ULONG PERLCALLcv(PCSZ name, SV *cv, ULONG argc, PRXSTRING argv, PCSZ queue, PRXSTRING ret); -static ULONG PERLSTART(PCSZ name, ULONG argc, PRXSTRING argv, PCSZ queue, PRXSTRING ret); -static RexxSubcomHandler SubCommandPerlEval; - -#if 1 - #define Set RXSHV_SET - #define Fetch RXSHV_FETCH - #define Drop RXSHV_DROPV -#else - #define Set RXSHV_SYSET - #define Fetch RXSHV_SYFET - #define Drop RXSHV_SYDRO -#endif - -static long incompartment; /* May be used to unload the REXX */ - -static LONG APIENTRY (*pRexxStart) (LONG, PRXSTRING, PSZ, PRXSTRING, - PSZ, LONG, PRXSYSEXIT, PSHORT, PRXSTRING); -static APIRET APIENTRY (*pRexxRegisterFunctionExe) (PSZ, - RexxFunctionHandler *); -static APIRET APIENTRY (*pRexxRegisterSubcomExe) (PCSZ pszEnvName, PFN pfnEntryPoint, - PUCHAR pUserArea); -static APIRET APIENTRY (*pRexxDeregisterFunction) (PSZ); - -static ULONG (*pRexxVariablePool) (PSHVBLOCK pRequest); - -static SV* exec_cv; - -/* Create a REXX compartment, - register `n' callbacks `handlers' with the REXX names `handlerNames', - evaluate the REXX expression `cmd'. - */ -static SV* -exec_in_REXX_with(pTHX_ char *cmd, int c, char **handlerNames, RexxFunctionHandler **handlers) -{ - RXSTRING args[1]; - RXSTRING inst[2]; - RXSTRING result; - USHORT retcode; - LONG rc; - SV *res; - char *subs = 0; - int n = c, have_nl = 0; - char *ocmd = cmd, *s, *t; - - incompartment++; - - if (c) - Newxz(subs, c, char); - while (n--) { - rc = pRexxRegisterFunctionExe(handlerNames[n], handlers[n]); - if (rc == RXFUNC_DEFINED) - subs[n] = 1; - } - - s = cmd; - while (*s) { - if (*s == '\n') { /* Is not preceeded by \r! */ - Newx(cmd, 2*strlen(cmd)+1, char); - s = ocmd; - t = cmd; - while (*s) { - if (*s == '\n') - *t++ = '\r'; - *t++ = *s++; - } - *t = 0; - break; - } else if (*s == '\r') - s++; - s++; - } - MAKERXSTRING(args[0], NULL, 0); - MAKERXSTRING(inst[0], cmd, strlen(cmd)); - MAKERXSTRING(inst[1], NULL, 0); - MAKERXSTRING(result, NULL, 0); - rc = pRexxStart(0, args, /* No arguments */ - "REXX_in_Perl", /* Returned on REXX' PARSE SOURCE, - and the "macrospace function name" */ - inst, /* inst[0] - the code to execute, - inst[1] will contain tokens. */ - "Perl", /* Pass string-cmds to this callback */ - RXSUBROUTINE, /* Many arguments, maybe result */ - NULL, /* No callbacks/exits to register */ - &retcode, &result); - - incompartment--; - n = c; - while (n--) - if (!subs[n]) - pRexxDeregisterFunction(handlerNames[n]); - if (c) - Safefree(subs); - if (cmd != ocmd) - Safefree(cmd); -#if 0 /* Do we want to restore these? */ - DosFreeModule(hRexxAPI); - DosFreeModule(hRexx); -#endif - - if (RXSTRPTR(inst[1])) /* Free the tokenized version */ - DosFreeMem(RXSTRPTR(inst[1])); - if (!RXNULLSTRING(result)) { - res = newSVpv(RXSTRPTR(result), RXSTRLEN(result)); - DosFreeMem(RXSTRPTR(result)); - } else { - res = newSV(0); - } - if (rc || SvTRUE(GvSV(PL_errgv))) { - if (SvTRUE(GvSV(PL_errgv))) { - STRLEN n_a; - Perl_croak(aTHX_ "Error inside perl function called from REXX compartment:\n%s", SvPV(GvSV(PL_errgv), n_a)) ; - } - Perl_croak(aTHX_ "REXX compartment returned non-zero status %li", rc); - } - - return res; -} - -/* Call the Perl function given by name, or if name=0, by cv, - with the given arguments. Return the stringified result to REXX. */ -static ULONG -PERLCALLcv(PCSZ name, SV *cv, ULONG argc, PRXSTRING argv, PCSZ queue, PRXSTRING ret) -{ - dTHX; - EXCEPTIONREGISTRATIONRECORD xreg = { NULL, _emx_exception }; - int i, rc; - unsigned long len; - char *str; - SV *res; - dSP; - - DosSetExceptionHandler(&xreg); - - ENTER; - SAVETMPS; - PUSHMARK(SP); - -#if 0 - if (!my_perl) { - DosUnsetExceptionHandler(&xreg); - return 1; - } -#endif - - for (i = 0; i < argc; ++i) - XPUSHs(sv_2mortal(newSVpvn(argv[i].strptr, argv[i].strlength))); - PUTBACK; - if (name) - rc = perl_call_pv(name, G_SCALAR | G_EVAL); - else if (cv) - rc = perl_call_sv(cv, G_SCALAR | G_EVAL); - else - rc = -1; - - SPAGAIN; - - if (rc == 1) /* must be! */ - res = POPs; - if (rc == 1 && SvOK(res)) { - str = SvPVx(res, len); - if (len <= 256 /* Default buffer is 256-char long */ - || !CheckOSError(DosAllocMem((PPVOID)&ret->strptr, len, - PAG_READ|PAG_WRITE|PAG_COMMIT))) { - memcpy(ret->strptr, str, len); - ret->strlength = len; - } else - rc = 0; - } else - rc = 0; - - PUTBACK ; - FREETMPS ; - LEAVE ; - - DosUnsetExceptionHandler(&xreg); - return rc == 1 ? 0 : 1; /* 0 means SUCCESS */ -} - -static ULONG -PERLSTART(PCSZ name, ULONG argc, PRXSTRING argv, PCSZ queue, PRXSTRING ret) -{ - SV *cv = exec_cv; - - exec_cv = NULL; - return PERLCALLcv(NULL, cv, argc, argv, queue, ret); -} - -static ULONG -PERLCALL(PCSZ name, ULONG argc, PRXSTRING argv, PCSZ queue, PRXSTRING ret) -{ - return PERLCALLcv(name, NULL, argc, argv, queue, ret); -} - -RexxFunctionHandler* PF = &PERLSTART; -char* PF_name = "StartPerl"; - -#define REXX_eval_with(cmd,name,cv) \ - ( exec_cv = cv, exec_in_REXX_with(aTHX_ (cmd),1, &(name), &PF)) -#define REXX_call(cv) REXX_eval_with("return StartPerl()\r\n", PF_name, (cv)) -#define REXX_eval(cmd) ( exec_in_REXX_with(aTHX_ (cmd), 0, NULL, NULL)) - -static ULONG -SubCommandPerlEval( - PRXSTRING command, /* command to issue */ - PUSHORT flags, /* error/failure flags */ - PRXSTRING retstr ) /* return code */ -{ - dSP; - STRLEN len; - int ret; - char *str = 0; - SV *in, *res; - - ENTER; - SAVETMPS; - - PUSHMARK(SP); - in = sv_2mortal(newSVpvn(command->strptr, command->strlength)); - eval_sv(in, G_SCALAR); - SPAGAIN; - res = POPs; - PUTBACK; - - ret = 0; - if (SvTRUE(ERRSV)) { - *flags = RXSUBCOM_ERROR; /* raise error condition */ - str = SvPV(ERRSV, len); - } else if (!SvOK(res)) { - *flags = RXSUBCOM_ERROR; /* raise error condition */ - str = "undefined value returned by Perl-in-REXX"; - len = strlen(str); - } else - str = SvPV(res, len); - if (len <= 256 /* Default buffer is 256-char long */ - || !DosAllocMem((PPVOID)&retstr->strptr, len, - PAG_READ|PAG_WRITE|PAG_COMMIT)) { - memcpy(retstr->strptr, str, len); - retstr->strlength = len; - } else { - *flags = RXSUBCOM_ERROR; /* raise error condition */ - strcpy(retstr->strptr, "Not enough memory for the return string of Perl-in-REXX"); - retstr->strlength = strlen(retstr->strptr); - } - - FREETMPS; - LEAVE; - - return 0; /* finished */ -} - -static void -needstrs(int n) -{ - if (n > nstrs) { - if (strs) - free(strs); - nstrs = 2 * n; - strs = malloc(nstrs * sizeof(RXSTRING)); - } -} - -static void -needvars(int n) -{ - if (n > nvars) { - if (vars) - free(vars); - nvars = 2 * n; - vars = malloc(nvars * sizeof(SHVBLOCK)); - } -} - -static void -initialize(void) -{ - ULONG rc; - *(PFN *)&pRexxStart = loadByOrdinal(ORD_RexxStart, 1); - *(PFN *)&pRexxRegisterFunctionExe - = loadByOrdinal(ORD_RexxRegisterFunctionExe, 1); - *(PFN *)&pRexxDeregisterFunction - = loadByOrdinal(ORD_RexxDeregisterFunction, 1); - *(PFN *)&pRexxVariablePool = loadByOrdinal(ORD_RexxVariablePool, 1); - *(PFN *)&pRexxRegisterSubcomExe - = loadByOrdinal(ORD_RexxRegisterSubcomExe, 1); - needstrs(8); - needvars(8); - trace = getenv("PERL_REXX_DEBUG"); - - rc = pRexxRegisterSubcomExe("PERLEVAL", (PFN)&SubCommandPerlEval, NULL); -} - -static int -constant(char *name, int arg) -{ - errno = EINVAL; - return 0; -} - - -MODULE = OS2::REXX PACKAGE = OS2::REXX - -BOOT: - initialize(); - -int -constant(name,arg) - char * name - int arg - -int -_set(name,value,...) - char * name - char * value - CODE: - { - int i; - int n = (items + 1) / 2; - ULONG rc; - needvars(n); - if (trace) - fprintf(stderr, "REXXCALL::_set"); - for (i = 0; i < n; ++i) { - SHVBLOCK * var = &vars[i]; - STRLEN namelen; - STRLEN valuelen; - name = SvPV(ST(2*i+0),namelen); - if (2*i+1 < items) { - value = SvPV(ST(2*i+1),valuelen); - } - else { - value = ""; - valuelen = 0; - } - var->shvcode = RXSHV_SET; - var->shvnext = &vars[i+1]; - var->shvnamelen = namelen; - var->shvvaluelen = valuelen; - MAKERXSTRING(var->shvname, name, namelen); - MAKERXSTRING(var->shvvalue, value, valuelen); - if (trace) - fprintf(stderr, " %.*s='%.*s'", - (int)var->shvname.strlength, var->shvname.strptr, - (int)var->shvvalue.strlength, var->shvvalue.strptr); - } - if (trace) - fprintf(stderr, "\n"); - vars[n-1].shvnext = NULL; - rc = pRexxVariablePool(vars); - if (trace) - fprintf(stderr, " rc=%#lX\n", rc); - RETVAL = (rc & ~RXSHV_NEWV) ? FALSE : TRUE; - } - OUTPUT: - RETVAL - -void -_fetch(name, ...) - char * name - PPCODE: - { - int i; - ULONG rc; - EXTEND(SP, items); - needvars(items); - if (trace) - fprintf(stderr, "REXXCALL::_fetch"); - for (i = 0; i < items; ++i) { - SHVBLOCK * var = &vars[i]; - STRLEN namelen; - name = SvPV(ST(i),namelen); - var->shvcode = RXSHV_FETCH; - var->shvnext = &vars[i+1]; - var->shvnamelen = namelen; - var->shvvaluelen = 0; - MAKERXSTRING(var->shvname, name, namelen); - MAKERXSTRING(var->shvvalue, NULL, 0); - if (trace) - fprintf(stderr, " '%s'", name); - } - if (trace) - fprintf(stderr, "\n"); - vars[items-1].shvnext = NULL; - rc = pRexxVariablePool(vars); - if (!(rc & ~RXSHV_NEWV)) { - for (i = 0; i < items; ++i) { - int namelen; - SHVBLOCK * var = &vars[i]; - /* returned lengths appear to be swapped */ - /* but beware of "future bug fixes" */ - namelen = var->shvvalue.strlength; /* should be */ - if (var->shvvaluelen < var->shvvalue.strlength) - namelen = var->shvvaluelen; /* is */ - if (trace) - fprintf(stderr, " %.*s='%.*s'\n", - (int)var->shvname.strlength, var->shvname.strptr, - namelen, var->shvvalue.strptr); - if (var->shvret & RXSHV_NEWV || !var->shvvalue.strptr) - PUSHs(&PL_sv_undef); - else - PUSHs(sv_2mortal(newSVpv(var->shvvalue.strptr, - namelen))); - } - } else { - if (trace) - fprintf(stderr, " rc=%#lX\n", rc); - } - } - -void -_next(stem) - char * stem - PPCODE: - { - SHVBLOCK sv; - BYTE name[4096]; - ULONG rc; - int len = strlen(stem), namelen, valuelen; - if (trace) - fprintf(stderr, "REXXCALL::_next stem='%s'\n", stem); - sv.shvcode = RXSHV_NEXTV; - sv.shvnext = NULL; - MAKERXSTRING(sv.shvvalue, NULL, 0); - do { - sv.shvnamelen = sizeof name; - sv.shvvaluelen = 0; - MAKERXSTRING(sv.shvname, name, sizeof name); - if (sv.shvvalue.strptr) { - DosFreeMem(sv.shvvalue.strptr); - MAKERXSTRING(sv.shvvalue, NULL, 0); - } - rc = pRexxVariablePool(&sv); - } while (!rc && memcmp(stem, sv.shvname.strptr, len) != 0); - if (!rc) { - EXTEND(SP, 2); - /* returned lengths appear to be swapped */ - /* but beware of "future bug fixes" */ - namelen = sv.shvname.strlength; /* should be */ - if (sv.shvnamelen < sv.shvname.strlength) - namelen = sv.shvnamelen; /* is */ - valuelen = sv.shvvalue.strlength; /* should be */ - if (sv.shvvaluelen < sv.shvvalue.strlength) - valuelen = sv.shvvaluelen; /* is */ - if (trace) - fprintf(stderr, " %.*s='%.*s'\n", - namelen, sv.shvname.strptr, - valuelen, sv.shvvalue.strptr); - PUSHs(sv_2mortal(newSVpv(sv.shvname.strptr+len, namelen-len))); - if (sv.shvvalue.strptr) { - PUSHs(sv_2mortal(newSVpv(sv.shvvalue.strptr, valuelen))); - DosFreeMem(sv.shvvalue.strptr); - } else - PUSHs(&PL_sv_undef); - } else if (rc != RXSHV_LVAR) { - die("Error %i when in _next", rc); - } else { - if (trace) - fprintf(stderr, " rc=%#lX\n", rc); - } - } - -int -_drop(name,...) - char * name - CODE: - { - int i; - needvars(items); - for (i = 0; i < items; ++i) { - SHVBLOCK * var = &vars[i]; - STRLEN namelen; - name = SvPV(ST(i),namelen); - var->shvcode = RXSHV_DROPV; - var->shvnext = &vars[i+1]; - var->shvnamelen = namelen; - var->shvvaluelen = 0; - MAKERXSTRING(var->shvname, name, var->shvnamelen); - MAKERXSTRING(var->shvvalue, NULL, 0); - } - vars[items-1].shvnext = NULL; - RETVAL = (pRexxVariablePool(vars) & ~RXSHV_NEWV) ? FALSE : TRUE; - } - OUTPUT: - RETVAL - -int -_register(name) - char * name - CODE: - RETVAL = pRexxRegisterFunctionExe(name, PERLCALL); - OUTPUT: - RETVAL - -SV* -REXX_call(cv) - SV *cv - PROTOTYPE: & - -SV* -REXX_eval(cmd) - char *cmd - -SV* -REXX_eval_with(cmd,name,cv) - char *cmd - char *name - SV *cv - -#ifdef THIS_IS_NOT_FINISHED - -SV* -_REXX_eval_with(cmd,...) - char *cmd - CODE: - { - int n = (items - 1)/2; - char **names; - SV **cvs; - - if ((items % 2) == 0) - Perl_croak(aTHX_ "Name/values should come in pairs in REXX_eval_with()"); - Newx(names, n, char*); - Newx(cvs, n, SV*); - /* XXX Unfinished... */ - RETVAL = NULL; - Safefree(names); - Safefree(cvs); - } - OUTPUT: - RETVAL - -#endif diff --git a/os2/OS2/REXX/t/rx_cmprt.t b/os2/OS2/REXX/t/rx_cmprt.t deleted file mode 100644 index 6db785be51..0000000000 --- a/os2/OS2/REXX/t/rx_cmprt.t +++ /dev/null @@ -1,54 +0,0 @@ -BEGIN { - chdir 't' if -d 't/lib'; - @INC = '../lib' if -d 'lib'; - require Config; import Config; - if (-d 'lib' and $Config{'extensions'} !~ /\bOS2(::|\/)REXX\b/) { - print "1..0\n"; - exit 0; - } -} - -use OS2::REXX qw(:DEFAULT register); - -$| = 1; # Otherwise data from REXX may come first - -print "1..18\n"; - -$n = 1; -sub do_me { - print "ok $n\n"; - "OK"; -} - -@res = REXX_call(\&do_me); -print "ok 2\n"; -@res == 1 ? print "ok 3\n" : print "not ok 3\n"; -$res[0] eq "OK" ? print "ok 4\n" : print "not ok 4\n# `$res[0]'\n"; - -# Try again -$n = 5; -@res = REXX_call(\&do_me); -print "ok 6\n"; -@res == 1 ? print "ok 7\n" : print "not ok 7\n"; -$res[0] eq "OK" ? print "ok 8\n" : print "not ok 8\n# `$res[0]'\n"; - -REXX_call { print "ok 9\n" }; -REXX_eval 'say "ok 10"'; -# Try again -REXX_eval 'say "ok 11"'; -print "ok 12\n" if REXX_eval("return 2 + 3") eq 5; -REXX_eval_with 'say myfunc()', myfunc => sub {"ok 13"}; -REXX_eval_with "call myout 'ok' 14", myout => sub {print shift, "\n"}; -REXX_eval_with "say 'ok 'myfunc(3,5)", myfunc => sub {shift() * shift()}; - -sub MYFUNC1 {shift} -sub MYFUNC2 {3 * shift} -REXX_eval_with "call myfunc - say 'ok 'myfunc1(1)myfunc2(2)", - myfunc => sub { register qw(myfunc1 myfunc2) }; - -REXX_eval_with "say 'ok 'myfunc(10,7)", - myfunc => sub { REXX_eval "return $_[0] + $_[1]" }; - -sub MyFunc3 {print 'ok ', shift() + shift(), "\n"} -REXX_eval "address perleval\n'MyFunc3(10,8)'"; diff --git a/os2/OS2/REXX/t/rx_dllld.t b/os2/OS2/REXX/t/rx_dllld.t deleted file mode 100644 index 406bd63a33..0000000000 --- a/os2/OS2/REXX/t/rx_dllld.t +++ /dev/null @@ -1,36 +0,0 @@ -BEGIN { - chdir 't' if -d 't/lib'; - @INC = '../lib' if -d 'lib'; - require Config; import Config; - if (-d 'lib' and $Config{'extensions'} !~ /\bOS2(::|\/)REXX\b/) { - print "1..0\n"; - exit 0; - } -} - -use OS2::REXX; - -$path = $ENV{LIBPATH} || $ENV{PATH} or die; -foreach $dir (split(';', $path)) { - next unless -f "$dir/RXU.DLL"; - $found = "$dir/RXU.DLL"; - last; -} -$found or print "1..0 # skipped: cannot find RXU.DLL\n" and exit; - -print "1..5\n"; - -$module = DynaLoader::dl_load_file($found) or die "not ok 1\n# load\n"; -print "ok 1\n"; - -$address = DynaLoader::dl_find_symbol($module, "RXPROCID") - or die "not ok 2\n# find\n"; -print "ok 2\n"; - -$result = OS2::REXX::_call("RxProcId", $address) or die "not ok 3\n# REXX"; -print "ok 3\n"; - -($pid, $ppid, $ssid) = split(/\s+/, $result); -$pid == $$ ? print "ok 4\n" : print "not ok 4\n# pid\n"; -$ssid == 1 ? print "ok 5\n" : print "not ok 5\n# pid\n"; -print "# pid=$pid, ppid=$ppid, ssid=$ssid\n"; diff --git a/os2/OS2/REXX/t/rx_emxrv.t b/os2/OS2/REXX/t/rx_emxrv.t deleted file mode 100644 index 5df8c32785..0000000000 --- a/os2/OS2/REXX/t/rx_emxrv.t +++ /dev/null @@ -1,61 +0,0 @@ -BEGIN { - chdir 't' if -d 't/lib'; - @INC = '../lib' if -d 'lib'; - require Config; import Config; - if (-d 'lib' and $Config{'extensions'} !~ /\bOS2(::|\/)REXX\b/) { - print "1..0\n"; - exit 0; - } -} - -print "1..20\n"; - -require OS2::DLL; -print "ok 1\n"; -$emx_dll = OS2::DLL->load('emx'); -print "ok 2\n"; -$emx_version = $emx_dll->emx_revision(); -print "ok 3\n"; -$emx_version >= 40 or print "not "; # We cannot work with old EMXs -print "ok 4\n"; - -$reason = ''; -$emx_version >= 99 and $reason = ' # skipped: version of EMX 100 or more'; # Be safe -print "ok 5$reason\n"; - -$emx_fullname = OS2::DLLname 0x202, $emx_dll->{Handle}; # Handle ==> fullname -print "ok 6\n"; -$emx_dll1 = OS2::DLL->module($emx_fullname); -print "ok 7\n"; -$emx_dll->{Handle} == $emx_dll1->{Handle} or print "not "; -print "ok 8\n"; - -$emx_version1 = $emx_dll1->emx_revision(); -print "ok 9\n"; -$emx_version1 eq $emx_version or print "not "; -print "ok 10\n"; - -$emx_revision = $emx_dll->wrapper_REXX('emx_revision'); -print "ok 11\n"; -$emx_version2 = $emx_revision->(); -print "ok 12\n"; -$emx_version2 eq $emx_version or print "not "; -print "ok 13\n"; - -$emx_revision1 = $emx_dll1->wrapper_REXX('#128'); -print "ok 14\n"; -$emx_version3 = $emx_revision1->(); -print "ok 15\n"; -$emx_version3 eq $emx_version or print "not "; -print "ok 16\n"; - -($emx_fullname1 = $emx_fullname) =~ s,/,\\,g; -$emx_dll2 = OS2::DLL->new($emx_fullname1); -print "ok 17\n"; -$emx_dll->{Handle} == $emx_dll2->{Handle} or print "not "; -print "ok 18\n"; - -$emx_version4 = $emx_dll2->emx_revision(); -print "ok 19\n"; -$emx_version4 eq $emx_version or print "not "; -print "ok 20\n"; diff --git a/os2/OS2/REXX/t/rx_objcall.t b/os2/OS2/REXX/t/rx_objcall.t deleted file mode 100644 index 0ec67b112d..0000000000 --- a/os2/OS2/REXX/t/rx_objcall.t +++ /dev/null @@ -1,38 +0,0 @@ -BEGIN { - chdir 't' if -d 't/lib'; - @INC = '../lib' if -d 'lib'; - require Config; import Config; - if (-d 'lib' and $Config{'extensions'} !~ /\bOS2(::|\/)REXX\b/) { - print "1..0\n"; - exit 0; - } -} - -use OS2::REXX; - -# -# DLL -# -$rxu = load OS2::REXX "rxu" - or print "1..0 # skipped: cannot find RXU.DLL\n" and exit; -print "1..5\n", "ok 1\n"; - -# -# function -# -@pid = $rxu->RxProcId(); -@pid == 1 ? print "ok 2\n" : print "not ok 2\n"; -@res = split " ", $pid[0]; -print "ok 3\n" if $res[0] == $$; -@pid = $rxu->RxProcId(); -@res = split " ", $pid[0]; -print "ok 4\n" if $res[0] == $$; -print "# @pid\n"; - -eval { $rxu->nixda(); }; -my $err = $@; -if ($err) { - $err =~ s/\n/\n#\t/g; - print "# \$\@ = '$err'\n"; -} -print "ok 5\n" if $@ =~ /^Can't find symbol `nixda\'/; diff --git a/os2/OS2/REXX/t/rx_sql.test b/os2/OS2/REXX/t/rx_sql.test deleted file mode 100644 index 602c76dc47..0000000000 --- a/os2/OS2/REXX/t/rx_sql.test +++ /dev/null @@ -1,97 +0,0 @@ -BEGIN { - chdir 't' if -d 't/lib'; - @INC = '../lib'; - require Config; import Config; - if ($Config{'extensions'} !~ /\bOS2(::|\/)REXX\b/) { - print "1..0\n"; - exit 0; - } -} - -use OS2::REXX; - -sub stmt -{ - my ($s) = @_; - $s =~ s/\s*\n\s*/ /g; - $s =~ s/^\s+//; - $s =~ s/\s+$//; - return $s; -} - -sub sqlcode -{ - OS2::REXX::_fetch("SQLCA.SQLCODE"); -} - -sub sqlstate -{ - OS2::REXX::_fetch("SQLCA.SQLSTATE"); -} - -sub sql -{ - my ($stmt) = stmt(@_); - return 0 if OS2::REXX::_call("sqlexec", $sqlexec, "", $stmt); - return sqlcode() >= 0; -} - -sub dbs -{ - my ($stmt) = stmt(@_); - return 0 if OS2::REXX::_call("sqldbs", $sqldbs, "", $stmt); - return sqlcode() >= 0; -} - -sub error -{ - my ($where) = @_; - print "ERROR in $where: sqlcode=", sqlcode(), " sqlstate=", sqlstate(), "\n"; - dbs("GET MESSAGE INTO :MSG LINEWIDTH 75"); - my $msg = OS2::REXX::_fetch("MSG"); - print "\n", $msg; - exit 1; -} - -REXX_call { - - $sqlar = DynaLoader::dl_load_file("h:/sqllib/dll/sqlar.dll") or die "load"; - $sqldbs = DynaLoader::dl_find_symbol($sqlar, "SQLDBS") or die "find sqldbs"; - $sqlexec = DynaLoader::dl_find_symbol($sqlar, "SQLEXEC") or die "find sqlexec"; - - sql(<<) or error("connect"); - CONNECT TO sample IN SHARE MODE - - OS2::REXX::_set("STMT" => stmt(<<)); - SELECT name FROM sysibm.systables - - sql(<<) or error("prepare"); - PREPARE s1 FROM :stmt - - sql(<<) or error("declare"); - DECLARE c1 CURSOR FOR s1 - - sql(<<) or error("open"); - OPEN c1 - - while (1) { - sql(<<) or error("fetch"); - FETCH c1 INTO :name - - last if sqlcode() == 100; - - print "Table name is ", OS2::REXX::_fetch("NAME"), "\n"; - } - - sql(<<) or error("close"); - CLOSE c1 - - sql(<<) or error("rollback"); - ROLLBACK - - sql(<<) or error("disconnect"); - CONNECT RESET - -}; - -exit 0; diff --git a/os2/OS2/REXX/t/rx_tiesql.test b/os2/OS2/REXX/t/rx_tiesql.test deleted file mode 100644 index c85a1e990b..0000000000 --- a/os2/OS2/REXX/t/rx_tiesql.test +++ /dev/null @@ -1,86 +0,0 @@ -BEGIN { - chdir 't' if -d 't/lib'; - @INC = '../lib'; - require Config; import Config; - if ($Config{'extensions'} !~ /\bOS2(::|\/)REXX\b/) { - print "1..0\n"; - exit 0; - } -} - -#extproc perl5 -Rx -#! perl - -use REXX; - -$db2 = load REXX "sqlar" or die "load"; -tie $sqlcode, REXX, "SQLCA.SQLCODE"; -tie $sqlstate, REXX, "SQLCA.SQLSTATE"; -tie %rexx, REXX, ""; - -sub stmt -{ - my ($s) = @_; - $s =~ s/\s*\n\s*/ /g; - $s =~ s/^\s+//; - $s =~ s/\s+$//; - return $s; -} - -sub sql -{ - my ($stmt) = stmt(@_); - return 0 if $db2->SqlExec($stmt); - return $sqlcode >= 0; -} - -sub dbs -{ - my ($stmt) = stmt(@_); - return 0 if $db2->SqlDBS($stmt); - return $sqlcode >= 0; -} - -sub error -{ - my ($where) = @_; - print "ERROR in $where: sqlcode=$sqlcode, sqlstate=$sqlstate\n"; - dbs("GET MESSAGE INTO :msg LINEWIDTH 75"); - print "\n", $rexx{'MSG'}; - exit 1; -} - -sql(<<) or error("connect"); - CONNECT TO sample IN SHARE MODE - -$rexx{'STMT'} = stmt(<<); - SELECT name FROM sysibm.systables - -sql(<<) or error("prepare"); - PREPARE s1 FROM :stmt - -sql(<<) or error("declare"); - DECLARE c1 CURSOR FOR s1 - -sql(<<) or error("open"); - OPEN c1 - -while (1) { - sql(<<) or error("fetch"); - FETCH c1 INTO :name - - last if $sqlcode == 100; - - print "Table name is $rexx{'NAME'}\n"; -} - -sql(<<) or error("close"); - CLOSE c1 - -sql(<<) or error("rollback"); - ROLLBACK - -sql(<<) or error("disconnect"); - CONNECT RESET - -exit 0; diff --git a/os2/OS2/REXX/t/rx_tievar.t b/os2/OS2/REXX/t/rx_tievar.t deleted file mode 100644 index 9c9ea7d466..0000000000 --- a/os2/OS2/REXX/t/rx_tievar.t +++ /dev/null @@ -1,89 +0,0 @@ -BEGIN { - chdir 't' if -d 't/lib'; - @INC = '../lib' if -d 'lib'; - require Config; import Config; - if (-d 'lib' and $Config{'extensions'} !~ /\bOS2(::|\/)REXX\b/) { - print "1..0\n"; - exit 0; - } -} - -use OS2::REXX; - -# -# DLL -# -load OS2::REXX "rxu" - or print "1..0 # skipped: cannot find RXU.DLL\n" and exit; - -print "1..19\n"; - -REXX_call { - print "ok 1\n"; - - # - # scalar - # - tie $s, OS2::REXX, "TEST"; - print "ok 2\n"; - $s = 1; - print "ok 3\n" if $s eq 1; - print "not ok 3\n# `$s'\n" unless $s eq 1; - untie $s; - - # - # hash - # - - tie %all, OS2::REXX, ""; # all REXX vars - print "ok 4\n"; - - sub show { - # show all REXX vars - print "--@_--\n"; - foreach (keys %all) { - $v = $all{$_}; - print "$_ => $v\n"; - } - } - - sub check { - # check all REXX vars - my ($test, @arr) = @_; - my @rx; - foreach $key (sort keys %all) { push @rx, $key, $all{$key} } - if ("@rx" eq "@arr") {print "ok $test\n"} - else { print "not ok $test\n# expect `@arr', got `@rx'\n" } - } - - - tie %h, OS2::REXX, "TEST."; - print "ok 5\n"; - check(6); - - $h{"one"} = 1; - check(7, "TEST.one", 1); - - $h{"two"} = 2; - check(8, "TEST.one", 1, "TEST.two", 2); - - $h{"one"} = ""; - check(9, "TEST.one", "", "TEST.two", 2); - print "ok 10\n" if exists $h{"one"}; - print "ok 11\n" if exists $h{"two"}; - - delete $h{"one"}; - check(12, "TEST.two", 2); - print "ok 13\n" if not exists $h{"one"}; - print "ok 14\n" if exists $h{"two"}; - - OS2::REXX::dropall("TEST."); - print "ok 15\n"; - check(16); - print "ok 17\n" if not exists $h{"one"}; - print "ok 18\n" if not exists $h{"two"}; - - untie %h; - print "ok 19"; - -}; diff --git a/os2/OS2/REXX/t/rx_tieydb.t b/os2/OS2/REXX/t/rx_tieydb.t deleted file mode 100644 index ec6bfca20e..0000000000 --- a/os2/OS2/REXX/t/rx_tieydb.t +++ /dev/null @@ -1,33 +0,0 @@ -BEGIN { - chdir 't' if -d 't/lib'; - @INC = '../lib' if -d 'lib'; - require Config; import Config; - if (-d 'lib' and $Config{'extensions'} !~ /\bOS2(::|\/)REXX\b/) { - print "1..0\n"; - exit 0; - } -} - -use OS2::REXX; -$rx = load OS2::REXX "RXU" # from RXU1a.ZIP - or print "1..0 # skipped: cannot find RXU.DLL\n" and exit; - -print "1..7\n", "ok 1\n"; - -$rx->prefix("Rx"); # implicit function prefix -print "ok 2\n"; - -REXX_call { - tie @pib, OS2::REXX, "IB.P"; # bind array to REXX stem variable - print "ok 3\n"; - tie %tib, OS2::REXX, "IB.T."; # bind associative array to REXX stem var - print "ok 4\n"; - - $rx->GetInfoBlocks("IB."); # call REXX function - print "ok 5\n"; - defined $pib[6] ? print "ok 6\n" : print "not ok 6\n# pib\n"; - defined $tib{7} && $tib{7} =~ /^\d+$/ ? print "ok 7\n" - : print "not ok 7\n# tib\n"; - print "# Process status is ", unpack("I", $pib[6]), - ", thread ordinal is $tib{7}\n"; -}; diff --git a/os2/OS2/REXX/t/rx_varset.t b/os2/OS2/REXX/t/rx_varset.t deleted file mode 100644 index 166cf53623..0000000000 --- a/os2/OS2/REXX/t/rx_varset.t +++ /dev/null @@ -1,39 +0,0 @@ -BEGIN { - chdir 't' if -d 't/lib'; - @INC = '../lib' if -d 'lib'; - require Config; import Config; - if (-d 'lib' and $Config{'extensions'} !~ /\bOS2(::|\/)REXX\b/) { - print "1..0\n"; - exit 0; - } -} - -use OS2::REXX; - -print "1..9\n"; - -REXX_call { - OS2::REXX::_set("X" => sqrt(2)) and print "ok 1\n"; - $x = OS2::REXX::_fetch("X") and print "ok 2\n"; - if (abs($x - sqrt(2)) < 5e-15) { - print "ok 3\n"; - } else { print "not ok 3\n# sqrt(2) = @{[sqrt(2)]} != `$x'\n" } - OS2::REXX::_set("Y" => sqrt(3)) and print "ok 4\n"; - $i = 0; - $n = 4; - while (($name, $value) = OS2::REXX::_next("")) { - $i++; $n++; - if ($i <= 2 and $name eq "Y" ) { - if ($value eq sqrt(3)) { - print "ok $n\n"; - } else { - print "not ok $n\n# `$name' => `$value'\n" ; - } - } elsif ($i <= 2 and $name eq "X") { - print "ok $n\n" if $value eq sqrt(2); - } else { print "not ok 7\n# name `$name', value `$value'\n" } - } - print "ok 7\n" if $i == 2; - OS2::REXX::_drop("X") and print "ok 8\n"; - $x = OS2::REXX::_fetch("X") or print "ok 9\n"; -}; diff --git a/os2/OS2/REXX/t/rx_vrexx.t b/os2/OS2/REXX/t/rx_vrexx.t deleted file mode 100644 index 3611894682..0000000000 --- a/os2/OS2/REXX/t/rx_vrexx.t +++ /dev/null @@ -1,63 +0,0 @@ -BEGIN { - chdir 't' if -d 't/lib'; - @INC = '../lib' if -d 'lib'; - require Config; import Config; - if (-d 'lib' and $Config{'extensions'} !~ /\bOS2(::|\/)REXX\b/) { - print "1..0 # skipped: OS2::REXX not built\n"; - exit 0; - } - if (defined $ENV{PERL_TEST_NOVREXX}) { - print "1..0 # skipped: request via PERL_TEST_NOVREXX\n"; - exit 0; - } -} - -use OS2::REXX; - -$name = "VREXX"; -$path = $ENV{LIBPATH} || $ENV{PATH} or die; -foreach $dir (split(';', $path)) { - next unless -f "$dir/$name.DLL"; - $found = "$dir/$name.DLL"; - print "# found at `$found'\n"; - last; -} -$found or print "1..0 # skipped: cannot find $name.DLL\n" and exit; - -print "1..10\n"; - -REXX_call { - $vrexx = DynaLoader::dl_load_file($found) or die "not ok 1\n# load\n"; - print "ok 1\n"; - $vinit = DynaLoader::dl_find_symbol($vrexx, "VINIT") or die "find vinit"; - print "ok 2\n"; - $vexit = DynaLoader::dl_find_symbol($vrexx, "VEXIT") or die "find vexit"; - print "ok 3\n"; - $vmsgbox = DynaLoader::dl_find_symbol($vrexx, "VMSGBOX") or die "find vmsgbox"; - print "ok 4\n"; - $vversion= DynaLoader::dl_find_symbol($vrexx, "VGETVERSION") or die "find vgetversion"; - print "ok 5\n"; - - $result = OS2::REXX::_call("VInit", $vinit) or die "VInit"; - print "ok 6\n"; - print "# VInit: $result\n"; - - OS2::REXX::_set("MBOX.0" => 4, - "MBOX.1" => "Perl VREXX Access Test", - "MBOX.2" => "", - "MBOX.3" => "(C) Andreas Kaiser", - "MBOX.4" => "December 1994") - or die "set var"; - print "ok 7\n"; - - $result = OS2::REXX::_call("VGetVersion", $vversion) or die "VMsgBox"; - print "ok 8\n"; - print "# VGetVersion: $result\n"; - - $result = OS2::REXX::_call("VMsgBox", $vmsgbox, "", "Perl", "MBOX", 1) or die "VMsgBox"; - print "ok 9\n"; - print "# VMsgBox: $result\n"; - - OS2::REXX::_call("VExit", $vexit); - print "ok 10\n"; -}; diff --git a/os2/OS2/typemap b/os2/OS2/typemap deleted file mode 100644 index 12bd58d347..0000000000 --- a/os2/OS2/typemap +++ /dev/null @@ -1,28 +0,0 @@ -BOOL T_IV -ULONG T_UV -HINI T_UV -HAB T_UV -HWND T_UV -ATOM T_UV -HATOMTBL T_UV -HSWITCH T_UV -ULONG T_UV -USHORT T_UV -LONG T_IV -SHORT T_IV - -PSZ T_PVNULL -PCSZ T_PVNULLC - -############################################################################# -INPUT -T_PVNULL - $var = ( SvOK($arg) ? ($type)SvPV_nolen($arg) : NULL ) -T_PVNULLC - $var = ( SvOK($arg) ? ($type)SvPV_nolen($arg) : NULL ) -############################################################################# -OUTPUT -T_PVNULL - sv_setpv((SV*)$arg, $var); -T_PVNULLC - NOTIMPLEMENTED -- cgit v1.2.1