diff options
Diffstat (limited to 'os2/OS2')
33 files changed, 2836 insertions, 0 deletions
diff --git a/os2/OS2/ExtAttr/Changes b/os2/OS2/ExtAttr/Changes new file mode 100644 index 0000000000..55fdc5f6d5 --- /dev/null +++ b/os2/OS2/ExtAttr/Changes @@ -0,0 +1,5 @@ +Revision history for Perl extension OS2::ExtAttr. + +0.01 Sun Apr 21 11:07:04 1996 + - original version; created by h2xs 1.16 + diff --git a/os2/OS2/ExtAttr/ExtAttr.pm b/os2/OS2/ExtAttr/ExtAttr.pm new file mode 100644 index 0000000000..bebbcc963e --- /dev/null +++ b/os2/OS2/ExtAttr/ExtAttr.pm @@ -0,0 +1,186 @@ +package OS2::ExtAttr; + +use strict; +use vars qw($VERSION @ISA @EXPORT); + +require Exporter; +require DynaLoader; + +@ISA = qw(Exporter DynaLoader); +# 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. +@EXPORT = qw( + +); +$VERSION = '0.01'; + +bootstrap 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<tie> + +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<update> +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<eas> 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<flag> 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 new file mode 100644 index 0000000000..566b6595c8 --- /dev/null +++ b/os2/OS2/ExtAttr/ExtAttr.xs @@ -0,0 +1,193 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" +#ifdef __cplusplus +} +#endif + +#include "myea.h" + +SV * +my_eadvalue(_ead ead, int index) +{ + SV *sv; + int size = _ead_value_size(ead, index); + void *p; + + if (size == -1) { + die("Error getting size of EA: %s", strerror(errno)); + } + p = _ead_get_value(ead, index); + return newSVpv((char*)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 + +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 + +void * +_ead_get_fea2list(ead) + _ead ead + +int +_ead_get_flags(ead, index) + _ead ead + int index + +char * +_ead_get_name(ead, index) + _ead ead + int index + +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 new file mode 100644 index 0000000000..b1a8e80e77 --- /dev/null +++ b/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/ExtAttr/Makefile.PL b/os2/OS2/ExtAttr/Makefile.PL new file mode 100644 index 0000000000..4e8498f10c --- /dev/null +++ b/os2/OS2/ExtAttr/Makefile.PL @@ -0,0 +1,10 @@ +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 + '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 new file mode 100644 index 0000000000..ec4dc81f99 --- /dev/null +++ b/os2/OS2/ExtAttr/myea.h @@ -0,0 +1,2 @@ +#include <sys/ea.h> +#include <sys/ead.h> diff --git a/os2/OS2/ExtAttr/t/os2_ea.t b/os2/OS2/ExtAttr/t/os2_ea.t new file mode 100644 index 0000000000..c1024193c1 --- /dev/null +++ b/os2/OS2/ExtAttr/t/os2_ea.t @@ -0,0 +1,79 @@ +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): + +system 'cmd', '/c', 'del 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"; + $a{'++'} = '---'; + print "ok 4\n"; + $a{'AAA'} = 'xyz'; + 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' ? print "ok 8\n" : print "not ok 8\n# keys=`@b'\n"; + $a{'++'} 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{'++'}; + $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{'++'}'\n";; + ! exists $a{'++'} ? print "ok 19\n" : print "not ok 19\n";; + ! defined $a{'++'} ? print "ok 20\n" : print "not ok 20\n# ->`$a{'++'}'\n";; +} + +print "ok 21\n"; + diff --git a/os2/OS2/ExtAttr/typemap b/os2/OS2/ExtAttr/typemap new file mode 100644 index 0000000000..a5ff8d63ac --- /dev/null +++ b/os2/OS2/ExtAttr/typemap @@ -0,0 +1,2 @@ +struct _ea * T_PTR +_ead T_PTR diff --git a/os2/OS2/PrfDB/Changes b/os2/OS2/PrfDB/Changes new file mode 100644 index 0000000000..3e8bf3f580 --- /dev/null +++ b/os2/OS2/PrfDB/Changes @@ -0,0 +1,5 @@ +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. diff --git a/os2/OS2/PrfDB/MANIFEST b/os2/OS2/PrfDB/MANIFEST new file mode 100644 index 0000000000..fb96b03c5d --- /dev/null +++ b/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/PrfDB/Makefile.PL b/os2/OS2/PrfDB/Makefile.PL new file mode 100644 index 0000000000..c591c0490c --- /dev/null +++ b/os2/OS2/PrfDB/Makefile.PL @@ -0,0 +1,10 @@ +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 + '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 new file mode 100644 index 0000000000..d404c8b1d3 --- /dev/null +++ b/os2/OS2/PrfDB/PrfDB.pm @@ -0,0 +1,314 @@ +package OS2::PrfDB; + +use strict; +use vars qw($VERSION @ISA @EXPORT); + +require Exporter; +require DynaLoader; + +@ISA = qw(Exporter DynaLoader); +# 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. +@EXPORT = qw( + AnyIni UserIni SystemIni + ); +$VERSION = '0.02'; + +bootstrap 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; +} + +use vars qw{$debug @ISA}; +use Tie::Hash; +@ISA = qw{Tie::Hash}; + +# 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 vars qw{$debug @ISA}; +use Tie::Hash; +@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 extention 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<OS2::PrfDB> and C<OS2::PrfDB::Sub>. 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<Application name>, 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<OS2::Prf>. They are + +=over 14 + +=item C<Open(file)> + +Opens the database, returns an I<integer handle>. + +=item C<Close(hndl)> + +Closes the database given an I<integer handle>. + +=item C<Get(hndl, appname, key)> + +Retrieves data from the database given 2-part-key C<appname> C<key>. +If C<key> is C<undef>, return the "\0" delimited list of C<key>s, +terminated by \0. If C<appname> is C<undef>, returns the list of +possible C<appname>s in the same form. + +=item C<GetLength(hndl, appname, key)> + +Same as above, but returns the length of the value. + +=item C<Set(hndl, appname, key, value [ , length ])> + +Sets the value. If the C<value> is not defined, removes the C<key>. If +the C<key> is not defined, removes the C<appname>. + +=item C<System(val)> + +Return an I<integer handle> associated with the system database. If +C<val> is 1, it is I<User> database, if 2, I<System> database, if +0, handle for "both" of them: the handle works for read from any one, +and for write into I<User> one. + +=item C<Profiles()> + +returns a reference to a list of two strings, giving names of the +I<User> and I<System> databases. + +=item C<SetUser(file)> + +B<(Not tested.)> Sets the profile name of the I<User> 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<OS2::Prf::Hini>: + +=over 14 + +=item C<new(package, file)> + +=item C<new_from_int(package, int_hndl [ , filename ])> + +=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 new file mode 100644 index 0000000000..a5b2c89ca6 --- /dev/null +++ b/os2/OS2/PrfDB/PrfDB.xs @@ -0,0 +1,131 @@ +#define INCL_WINSHELLDATA /* Or use INCL_WIN, INCL_PM, */ + +#ifdef __cplusplus +extern "C" { +#endif +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" +#include <os2.h> +#ifdef __cplusplus +} +#endif + +#define Prf_Open(pszFileName) SaveWinError(PrfOpenProfile(Perl_hab, (pszFileName))) +#define Prf_Close(hini) (!CheckWinError(PrfCloseProfile(hini))) + +SV * +Prf_Get(HINI hini, PSZ app, PSZ key) { + ULONG len; + BOOL rc; + SV *sv; + + if (CheckWinError(PrfQueryProfileSize(hini, app, key, &len))) return &sv_undef; + sv = newSVpv("", 0); + SvGROW(sv, len); + if (CheckWinError(PrfQueryProfileData(hini, app, key, SvPVX(sv), &len)) + || (len == 0 && (app == NULL || key == NULL))) { /* Somewhy needed. */ + SvREFCNT_dec(sv); + return &sv_undef; + } + SvCUR_set(sv, len); + *SvEND(sv) = 0; + return sv; +} + +U32 +Prf_GetLength(HINI hini, PSZ app, PSZ key) { + U32 len; + + if (CheckWinError(PrfQueryProfileSize(hini, app, key, &len))) return -1; + return len; +} + +#define Prf_Set(hini, app, key, s, l) \ + (!(CheckWinError(PrfWriteProfileData(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() +{ + AV *av = newAV(); + SV *rv; + char user[257]; + char system[257]; + PRFPROFILE info = { 257, user, 257, system}; + + if (CheckWinError(PrfQueryProfile(Perl_hab, &info))) return &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(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(PrfQueryProfile(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(PrfReset(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; + +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; + +U32 +Prf_GetLength(hini, app, key) + HINI hini; + PSZ app; + PSZ key; + +HINI +Prf_System(key) + int key; + +SV* +Prf_Profiles() + +BOOL +Prf_SetUser(sv) + SV *sv + +BOOT: + Acquire_hab(); diff --git a/os2/OS2/PrfDB/t/os2_prfdb.t b/os2/OS2/PrfDB/t/os2_prfdb.t new file mode 100644 index 0000000000..4c0883db50 --- /dev/null +++ b/os2/OS2/PrfDB/t/os2_prfdb.t @@ -0,0 +1,185 @@ +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"); + +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"); diff --git a/os2/OS2/PrfDB/typemap b/os2/OS2/PrfDB/typemap new file mode 100644 index 0000000000..0b91f3750a --- /dev/null +++ b/os2/OS2/PrfDB/typemap @@ -0,0 +1,14 @@ +BOOL T_IV +ULONG T_IV +HINI T_IV +HAB T_IV +PSZ T_PVNULL + +############################################################################# +INPUT +T_PVNULL + $var = ( SvOK($arg) ? ($type)SvPV($arg,na) : NULL ) +############################################################################# +OUTPUT +T_PVNULL + sv_setpv((SV*)$arg, $var); diff --git a/os2/OS2/Process/MANIFEST b/os2/OS2/Process/MANIFEST new file mode 100644 index 0000000000..0d90d15fca --- /dev/null +++ b/os2/OS2/Process/MANIFEST @@ -0,0 +1,4 @@ +MANIFEST +Makefile.PL +Process.pm +Process.xs diff --git a/os2/OS2/Process/Makefile.PL b/os2/OS2/Process/Makefile.PL new file mode 100644 index 0000000000..ff4deabef6 --- /dev/null +++ b/os2/OS2/Process/Makefile.PL @@ -0,0 +1,10 @@ +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::Process', + 'VERSION' => '0.1', + 'LIBS' => [''], # e.g., '-lm' + 'DEFINE' => '', # e.g., '-DHAVE_SOMETHING' + 'INC' => '', # e.g., '-I/usr/include/other' +); diff --git a/os2/OS2/Process/Process.pm b/os2/OS2/Process/Process.pm new file mode 100644 index 0000000000..9216bb1e05 --- /dev/null +++ b/os2/OS2/Process/Process.pm @@ -0,0 +1,112 @@ +package OS2::Process; + +require Exporter; +require DynaLoader; +require AutoLoader; + +@ISA = qw(Exporter DynaLoader); +# 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. +@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 +); +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. + + local($constname); + ($constname = $AUTOLOAD) =~ s/.*:://; + $val = constant($constname, @_ ? $_[0] : 0); + if ($! != 0) { + if ($! =~ /Invalid/) { + $AutoLoader::AUTOLOAD = $AUTOLOAD; + goto &AutoLoader::AUTOLOAD; + } + else { + ($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; +} + +bootstrap OS2::Process; + +# Preloaded methods go here. + +# Autoload methods go after __END__, and are processed by the autosplit program. + +1; +__END__ + +=head1 NAME + +OS2::Process - exports constants for system() call on OS2. + +=head1 SYNOPSIS + + use OS2::Process; + $pid = system(P_PM+P_BACKGROUND, "epm.exe"); + +=head1 DESCRIPTION + +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 + +=head1 AUTHOR + +Andreas Kaiser <ak@ananke.s.bawue.de>. + +=head1 SEE ALSO + +C<spawn*>() system calls. + +=cut diff --git a/os2/OS2/Process/Process.xs b/os2/OS2/Process/Process.xs new file mode 100644 index 0000000000..bdb2ece7a0 --- /dev/null +++ b/os2/OS2/Process/Process.xs @@ -0,0 +1,154 @@ +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#include <process.h> + +static int +not_here(s) +char *s; +{ + croak("%s not implemented on this architecture", s); + return -1; +} + +static unsigned long +constant(name, arg) +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 + } + + errno = EINVAL; + return 0; + +not_there: + errno = ENOENT; + return 0; +} + + +MODULE = OS2::Process PACKAGE = OS2::Process + + +unsigned long +constant(name,arg) + char * name + int arg + diff --git a/os2/OS2/REXX/Changes b/os2/OS2/REXX/Changes new file mode 100644 index 0000000000..46b38ef46c --- /dev/null +++ b/os2/OS2/REXX/Changes @@ -0,0 +1,4 @@ +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. diff --git a/os2/OS2/REXX/MANIFEST b/os2/OS2/REXX/MANIFEST new file mode 100644 index 0000000000..4ac81492e4 --- /dev/null +++ b/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/REXX/Makefile.PL b/os2/OS2/REXX/Makefile.PL new file mode 100644 index 0000000000..07f6cc67ea --- /dev/null +++ b/os2/OS2/REXX/Makefile.PL @@ -0,0 +1,7 @@ +use ExtUtils::MakeMaker; + +WriteMakefile( + NAME => 'OS2::REXX', + VERSION => '0.2', + XSPROTOARG => '-noprototypes', +); diff --git a/os2/OS2/REXX/REXX.pm b/os2/OS2/REXX/REXX.pm new file mode 100644 index 0000000000..78e0cf917d --- /dev/null +++ b/os2/OS2/REXX/REXX.pm @@ -0,0 +1,387 @@ +package OS2::REXX; + +use Carp; +require Exporter; +require DynaLoader; +@ISA = qw(Exporter DynaLoader); +# 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); + +sub AUTOLOAD { + $AUTOLOAD =~ /^OS2::REXX::.+::(.+)$/ + or confess("Undefined subroutine &$AUTOLOAD called"); + return undef if $1 eq "DESTROY"; + $_[0]->find($1) + or confess("Can't find entry '$1' to DLL '$_[0]->{File}'"); + goto &$AUTOLOAD; +} + +@libs = split(/;/, $ENV{'PERL5REXX'} || $ENV{'PERLREXX'} || $ENV{'LIBPATH'} || $ENV{'PATH'}); +%dlls = (); + +bootstrap OS2::REXX; + +# Preloaded methods go here. Autoload methods go after __END__, and are +# processed by the autosplit program. + +# Cannot autoload, the autoloader is used for the REXX functions. + +sub load +{ + confess 'Usage: load OS2::REXX <file> [<dirs>]' unless $#_ >= 1; + my ($class, $file, @where) = (@_, @libs); + return $dlls{$file} if $dlls{$file}; + my $handle; + foreach (@where) { + $handle = DynaLoader::dl_load_file("$_/$file.dll"); + last if $handle; + } + return undef unless $handle; + eval "package OS2::REXX::$file; \@ISA = ('OS2::REXX');" + . "sub AUTOLOAD {" + . " \$OS2::REXX::AUTOLOAD = \$AUTOLOAD;" + . " goto &OS2::REXX::AUTOLOAD;" + . "} 1;" or die "eval package $@"; + return $dlls{$file} = bless {Handle => $handle, File => $file, Queue => 'SESSION' }, "OS2::REXX::$file"; +} + +sub find +{ + my $self = shift; + my $file = $self->{File}; + my $handle = $self->{Handle}; + my $prefix = exists($self->{Prefix}) ? $self->{Prefix} : ""; + my $queue = $self->{Queue}; + foreach (@_) { + my $name = "OS2::REXX::${file}::$_"; + next if defined(&$name); + my $addr = DynaLoader::dl_find_symbol($handle, uc $prefix.$_) + || DynaLoader::dl_find_symbol($handle, $prefix.$_) + or return 0; + eval "package OS2::REXX::$file; sub $_". + "{ shift; OS2::REXX::_call('$_', $addr, '$queue', \@_); }". + "1;" + or die "eval sub"; + } + return 1; +} + +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$&\E/; + return bless \$name, OS2::REXX::_SCALAR; +} + +sub TIEARRAY +{ + my ($obj, $name) = @_; + $name =~ s/^[\w!?]+/\U$&\E/; + return bless [$name, 0], OS2::REXX::_ARRAY; +} + +sub TIEHASH +{ + my ($obj, $name) = @_; + $name =~ s/^[\w!?]+/\U$&\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<REXX_call> function. REXX functions which do not use +variables may be usable even without C<REXX_call> 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 or, as last resort, PATH. + +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), and to + + REXX_eval EXPR; + REXX_eval_with EXPR, + subroutine_name_in_REXX => \&Perl_subroutine + +=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" [, ...]]); + +=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<t/rx*.t> for examples. + +=head1 AUTHOR + +Andreas Kaiser ak@ananke.s.bawue.de, with additions by Ilya Zakharevich +ilya@math.ohio-state.edu. + +=cut diff --git a/os2/OS2/REXX/REXX.xs b/os2/OS2/REXX/REXX.xs new file mode 100644 index 0000000000..df7646c42e --- /dev/null +++ b/os2/OS2/REXX/REXX.xs @@ -0,0 +1,484 @@ +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#define INCL_BASE +#define INCL_REXXSAA +#include <os2emx.h> + +#if 0 +#define INCL_REXXSAA +#pragma pack(1) +#define _Packed +#include <rexxsaa.h> +#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(PSZ name, ULONG argc, PRXSTRING argv, PSZ queue, PRXSTRING ret); + +#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; + +static SV* +exec_in_REXX(char *cmd, char * handlerName, RexxFunctionHandler *handler) +{ + HMODULE hRexx, hRexxAPI; + BYTE buf[200]; + LONG APIENTRY (*pRexxStart) (LONG, PRXSTRING, PSZ, PRXSTRING, + PSZ, LONG, PRXSYSEXIT, PSHORT, PRXSTRING); + APIRET APIENTRY (*pRexxRegisterFunctionExe) (PSZ, + RexxFunctionHandler *); + APIRET APIENTRY (*pRexxDeregisterFunction) (PSZ); + RXSTRING args[1]; + RXSTRING inst[2]; + RXSTRING result; + USHORT retcode; + LONG rc; + SV *res; + + if (incompartment) die ("Attempt to reenter into REXX compartment"); + incompartment = 1; + + if (DosLoadModule(buf, sizeof buf, "REXX", &hRexx) + || DosLoadModule(buf, sizeof buf, "REXXAPI", &hRexxAPI) + || DosQueryProcAddr(hRexx, 0, "RexxStart", (PFN *)&pRexxStart) + || DosQueryProcAddr(hRexxAPI, 0, "RexxRegisterFunctionExe", + (PFN *)&pRexxRegisterFunctionExe) + || DosQueryProcAddr(hRexxAPI, 0, "RexxDeregisterFunction", + (PFN *)&pRexxDeregisterFunction)) { + die("REXX not available\n"); + } + + if (handlerName) + pRexxRegisterFunctionExe(handlerName, handler); + + MAKERXSTRING(args[0], NULL, 0); + MAKERXSTRING(inst[0], cmd, strlen(cmd)); + MAKERXSTRING(inst[1], NULL, 0); + MAKERXSTRING(result, NULL, 0); + rc = pRexxStart(0, args, "StartPerl", inst, "Perl", RXSUBROUTINE, NULL, + &retcode, &result); + + incompartment = 0; + pRexxDeregisterFunction("StartPerl"); + DosFreeModule(hRexxAPI); + DosFreeModule(hRexx); + if (!RXNULLSTRING(result)) { + res = newSVpv(RXSTRPTR(result), RXSTRLEN(result)); + DosFreeMem(RXSTRPTR(result)); + } else { + res = NEWSV(729,0); + } + if (rc || SvTRUE(GvSV(errgv))) { + if (SvTRUE(GvSV(errgv))) { + die ("Error inside perl function called from REXX compartment.\n%s", SvPV(GvSV(errgv), na)) ; + } + die ("REXX compartment returned non-zero status %li", rc); + } + + return res; +} + +static SV* exec_cv; + +static ULONG +PERLSTART(PSZ name, ULONG argc, PRXSTRING argv, PSZ queue, PRXSTRING ret) +{ + return PERLCALL(NULL, argc, argv, queue, ret); +} + +#define in_rexx_compartment() exec_in_REXX("return StartPerl()\r\n", \ + "StartPerl", PERLSTART) +#define REXX_call(cv) ( exec_cv = (cv), in_rexx_compartment()) +#define REXX_eval_with(cmd,name,cv) ( exec_cv = (cv), \ + exec_in_REXX(cmd,name,PERLSTART)) +#define REXX_eval(cmd) REXX_eval_with(cmd,NULL,NULL) + +static ULONG +PERLCALL(PSZ name, ULONG argc, PRXSTRING argv, PSZ queue, PRXSTRING ret) +{ + EXCEPTIONREGISTRATIONRECORD xreg = { NULL, _emx_exception }; + int i, rc; + unsigned long len; + char *str; + char **arr; + dSP; + + DosSetExceptionHandler(&xreg); + + ENTER; + SAVETMPS; + PUSHMARK(sp); + +#if 0 + if (!my_perl) { + DosUnsetExceptionHandler(&xreg); + return 1; + } +#endif + + if (name) { + int ac = 0; + char **arr = alloca((argc + 1) * sizeof(char *)); + + for (i = 0; i < argc; ++i) + arr[ac++] = argv[i].strptr; + arr[ac] = NULL; + + rc = perl_call_argv(name, G_SCALAR | G_EVAL, arr); + } else if (exec_cv) { + SV *cv = exec_cv; + + exec_cv = NULL; + rc = perl_call_sv(cv, G_SCALAR | G_EVAL); + } else rc = -1; + + SPAGAIN; + + if (rc == 1 && SvOK(TOPs)) { + str = SvPVx(POPs, len); + if (len > 256) + if (DosAllocMem((PPVOID)&ret->strptr, len, PAG_READ|PAG_WRITE|PAG_COMMIT)) { + DosUnsetExceptionHandler(&xreg); + return 1; + } + memcpy(ret->strptr, str, len); + ret->strlength = len; + } + + PUTBACK ; + FREETMPS ; + LEAVE ; + + if (rc != 1) { + DosUnsetExceptionHandler(&xreg); + return 1; + } + + + DosUnsetExceptionHandler(&xreg); + return 0; +} + +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) +{ + needstrs(8); + needvars(8); + trace = getenv("PERL_REXX_DEBUG"); +} + +static int +not_here(s) +char *s; +{ + croak("%s not implemented on this architecture", s); + return -1; +} + +static int +constant(name, arg) +char *name; +int arg; +{ + errno = EINVAL; + return 0; +} + + +MODULE = OS2::REXX PACKAGE = OS2::REXX + +BOOT: + initialize(); + +int +constant(name,arg) + char * name + int arg + +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); + } + +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'", + var->shvname.strlength, var->shvname.strptr, + var->shvvalue.strlength, var->shvvalue.strptr); + } + if (trace) + fprintf(stderr, "\n"); + vars[n-1].shvnext = NULL; + rc = RexxVariablePool(vars); + if (trace) + fprintf(stderr, " rc=%X\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 = RexxVariablePool(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", + var->shvname.strlength, var->shvname.strptr, + namelen, var->shvvalue.strptr); + if (var->shvret & RXSHV_NEWV || !var->shvvalue.strptr) + PUSHs(&sv_undef); + else + PUSHs(sv_2mortal(newSVpv(var->shvvalue.strptr, + namelen))); + } + } else { + if (trace) + fprintf(stderr, " rc=%X\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 = RexxVariablePool(&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(&sv_undef); + } else if (rc != RXSHV_LVAR) { + die("Error %i when in _next", rc); + } else { + if (trace) + fprintf(stderr, " rc=%X\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 = (RexxVariablePool(vars) & ~RXSHV_NEWV) ? FALSE : TRUE; + } + OUTPUT: + RETVAL + +int +_register(name) + char * name + CODE: + RETVAL = RexxRegisterFunctionExe(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 diff --git a/os2/OS2/REXX/t/rx_cmprt.t b/os2/OS2/REXX/t/rx_cmprt.t new file mode 100644 index 0000000000..a73e43e36e --- /dev/null +++ b/os2/OS2/REXX/t/rx_cmprt.t @@ -0,0 +1,40 @@ +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; + +$| = 1; # Otherwise data from REXX may come first + +print "1..13\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"}; diff --git a/os2/OS2/REXX/t/rx_dllld.t b/os2/OS2/REXX/t/rx_dllld.t new file mode 100644 index 0000000000..317743f3cb --- /dev/null +++ b/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/YDBAUTIL.DLL"; + $found = "$dir/YDBAUTIL.DLL"; + last; +} +$found or die "1..0\n#Cannot find YDBAUTIL.DLL\n"; + +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_objcall.t b/os2/OS2/REXX/t/rx_objcall.t new file mode 100644 index 0000000000..b4f04c308a --- /dev/null +++ b/os2/OS2/REXX/t/rx_objcall.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; + +# +# DLL +# +$ydba = load OS2::REXX "ydbautil" or die "1..0\n# load\n"; +print "1..5\n", "ok 1\n"; + +# +# function +# +@pid = $ydba->RxProcId(); +@pid == 1 ? print "ok 2\n" : print "not ok 2\n"; +@res = split " ", $pid[0]; +print "ok 3\n" if $res[0] == $$; +@pid = $ydba->RxProcId(); +@res = split " ", $pid[0]; +print "ok 4\n" if $res[0] == $$; +print "# @pid\n"; + +eval { $ydba->nixda(); }; +print "ok 5\n" if $@ =~ /^Can't find entry 'nixda\'/; + diff --git a/os2/OS2/REXX/t/rx_sql.test b/os2/OS2/REXX/t/rx_sql.test new file mode 100644 index 0000000000..4f984250a3 --- /dev/null +++ b/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/REXX/t/rx_tiesql.test b/os2/OS2/REXX/t/rx_tiesql.test new file mode 100644 index 0000000000..2947516755 --- /dev/null +++ b/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/REXX/t/rx_tievar.t b/os2/OS2/REXX/t/rx_tievar.t new file mode 100644 index 0000000000..6132e23f80 --- /dev/null +++ b/os2/OS2/REXX/t/rx_tievar.t @@ -0,0 +1,88 @@ +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 "ydbautil" or die "1..0\n# load\n"; + +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 new file mode 100644 index 0000000000..8251051265 --- /dev/null +++ b/os2/OS2/REXX/t/rx_tieydb.t @@ -0,0 +1,31 @@ +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 "ydbautil" or die "1..0\n# load\n"; # from RXU17.ZIP +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 new file mode 100644 index 0000000000..9d4f3b2e56 --- /dev/null +++ b/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/REXX/t/rx_vrexx.t b/os2/OS2/REXX/t/rx_vrexx.t new file mode 100644 index 0000000000..a40749f55f --- /dev/null +++ b/os2/OS2/REXX/t/rx_vrexx.t @@ -0,0 +1,59 @@ +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; + +$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 die "1..0\n#Cannot find $name.DLL\n"; + +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"; +}; |