From 18729d3e27f8d8545469c3e23a69b10dc409a88f Mon Sep 17 00:00:00 2001 From: Jarkko Hietaniemi Date: Sun, 15 Jun 2003 17:57:06 +0000 Subject: [PATCH] Integrate: [ 19775] test.pl-ify and add a couple of tests. [ 19776] Slight tweaks on the length() and chr() entries, passing-by rewrapping on the rmdir entry. [ 19778] Exercise the utf8:: "internal" functions. [ 19779] Subject: [PATCH: sv.c] strchr() running amok in sv_vcatpvfn() From: "Marcus Holland-Moritz" Date: Sat, 14 Jun 2003 12:51:31 +0200 Message-ID: <041901c33262$eac8ae30$f248eed9@R2D2> (choosing the safe alternative) [ 19781] Followup on #19779: make the helper function static, and rename it for paranoia reasons. [ 19782] Mention the Unicode::Regex::Set module. [ 19783] The FileCache 1.03 tests from belg4mit. [ 19785] Most often unused variables. [ 19786] Subject: Re: [PATCH: sv.c] strchr() running amok in sv_vcatpvfn() From: "Marcus Holland-Moritz" Date: Sun, 15 Jun 2003 10:48:40 +0200 Message-ID: <004a01c3331a$ec001320$3445eed9@R2D2> [ 19787] Unused variable. [ 19788] Reindent a section of the file. [ 19789] Subject: [PATCH 5.8.1 @19774] OS2 patches From: Ilya Zakharevich Date: Sat, 14 Jun 2003 17:49:57 -0700 Message-ID: <20030615004956.GA28272@math.berkeley.edu> [ 19790] Start using Perl malloc in FreeBSD since the system malloc is reaaally slooow for Perl. Subject: FreeBSD 5.1 vs. -Uusemymalloc From: Dan Kogai Date: Mon, 16 Jun 2003 01:48:49 +0900 Message-Id: <3CE9B94D-9F51-11D7-AF50-000393AE4244@dan.co.jp> p4raw-link: @19790 on //depot/perl: c23d2014b1a223f2595b3a2dcd8277fab2a0bb38 p4raw-link: @19789 on //depot/perl: 622913ab81739f4a9419ed541a122ff2495c8ab1 p4raw-link: @19788 on //depot/perl: 41be1fbddbbc49a5c34acad74f2905b11dd0ced0 p4raw-link: @19787 on //depot/perl: 89d7df92a07b0e2b75f1879743e6589850f05d22 p4raw-link: @19786 on //depot/perl: 94330da298089e668ae1ded0e8f984462f3f70b3 p4raw-link: @19785 on //depot/perl: 8bdbb4723ae10faa8f5ebfec78d78879f0c6b8e1 p4raw-link: @19783 on //depot/perl: 1673d79ec73dea09f6ee503fbe23e5c7945eba82 p4raw-link: @19782 on //depot/perl: 5ca1ac52233afde3fa5135257b2e37cba75b1c11 p4raw-link: @19781 on //depot/perl: 953cdb4a8c192dad24419e2faad15e31948e48a6 p4raw-link: @19779 on //depot/perl: bc3e8b6e7257ce0b7af7dcd5f3c2ff55a3b60ae3 p4raw-link: @19778 on //depot/perl: 6e37fd2a54b1a286397ea047abb89aad1f47cd8d p4raw-link: @19776 on //depot/perl: 974da8e5aded27d81bcf7d5c0c5998c377065269 p4raw-link: @19775 on //depot/perl: 1ae0ae1779f56be3f5008214f23d0e0a7f3dce42 p4raw-id: //depot/maint-5.8/perl@19791 p4raw-integrated: from //depot/perl@19783 'edit in' MANIFEST (@19672..) p4raw-integrated: from //depot/perl@19781 'ignore' embed.h (@19670..) p4raw-integrated: from //depot/perl@19777 'edit in' universal.c (@19277..) p4raw-branched: from //depot/perl@19774 'branch in' lib/FileCache/t/01open.t lib/FileCache/t/02maxopen.t lib/FileCache/t/03append.t lib/FileCache/t/04twoarg.t lib/FileCache/t/05override.t os2/OS2/typemap os2/perlrexx.cmd p4raw-deleted: from //depot/perl@19774 'delete in' os2/OS2/PrfDB/typemap (@1578..) lib/FileCache.t (@16065..) p4raw-integrated: from //depot/perl@19774 'copy in' os2/OS2/REXX/DLL/DLL.xs os2/OS2/REXX/t/rx_emxrv.t (@4432..) os2/OS2/REXX/t/rx_objcall.t (@6149..) emacs/ptags (@11803..) lib/bytes.t (@13299..) os2/OS2/Process/Makefile.PL os2/OS2/Process/Process.pm os2/OS2/Process/Process.xs (@14705..) lib/utf8.pm (@17286..) hints/os2.sh (@18283..) hints/freebsd.sh (@18846..) lib/utf8.t (@19097..) lib/ExtUtils/t/MM_OS2.t (@19099..) os2/OS2/REXX/DLL/DLL.pm os2/dl_os2.c os2/os2.c (@19120..) pod/perluniintro.pod (@19148..) handy.h (@19368..) pod/perlunicode.pod (@19433..) ext/Time/HiRes/Makefile.PL (@19449..) doio.c (@19552..) utils/h2xs.PL (@19589..) 'edit in' embed.fnc sv.c (@19781..) 'ignore' proto.h (@19781..) 'merge in' os2/os2ish.h (@19120..) makedef.pl (@19484..) pp_sys.c (@19751..) perl.c (@19756..) pod/perlfunc.pod (@19773..) --- MANIFEST | 9 +- doio.c | 2 + emacs/ptags | 2 +- ext/Time/HiRes/Makefile.PL | 12 +- handy.h | 2 + hints/freebsd.sh | 13 +- hints/os2.sh | 2 + lib/ExtUtils/t/MM_OS2.t | 4 +- lib/FileCache.t | 91 --- lib/FileCache/t/01open.t | 26 + lib/FileCache/t/02maxopen.t | 36 ++ lib/FileCache/t/03append.t | 47 ++ lib/FileCache/t/04twoarg.t | 24 + lib/FileCache/t/05override.t | 21 + lib/bytes.t | 30 +- lib/utf8.pm | 52 +- lib/utf8.t | 79 ++- makedef.pl | 2 + os2/OS2/Process/Makefile.PL | 2 +- os2/OS2/Process/Process.pm | 276 ++++++++- os2/OS2/Process/Process.xs | 400 ++++++++++-- os2/OS2/REXX/DLL/DLL.pm | 239 ++++--- os2/OS2/REXX/DLL/DLL.xs | 100 +++ os2/OS2/REXX/t/rx_emxrv.t | 39 +- os2/OS2/REXX/t/rx_objcall.t | 7 +- os2/OS2/{PrfDB => }/typemap | 20 +- os2/dl_os2.c | 102 ++- os2/os2.c | 1402 +++++++++++++++++++++++++++++++++++------- os2/os2ish.h | 86 ++- os2/perlrexx.cmd | 68 ++ perl.c | 2 + pod/perlfunc.pod | 20 +- pod/perlunicode.pod | 7 +- pod/perluniintro.pod | 5 +- pp_sys.c | 4 +- sv.c | 4 +- universal.c | 49 +- utils/h2xs.PL | 5 +- 38 files changed, 2763 insertions(+), 528 deletions(-) delete mode 100755 lib/FileCache.t create mode 100644 lib/FileCache/t/01open.t create mode 100644 lib/FileCache/t/02maxopen.t create mode 100644 lib/FileCache/t/03append.t create mode 100644 lib/FileCache/t/04twoarg.t create mode 100644 lib/FileCache/t/05override.t rename os2/OS2/{PrfDB => }/typemap (54%) create mode 100644 os2/perlrexx.cmd diff --git a/MANIFEST b/MANIFEST index 4f1d898..64adbce 100644 --- a/MANIFEST +++ b/MANIFEST @@ -1191,7 +1191,11 @@ lib/File/Temp/t/posix.t See if File::Temp works lib/File/Temp/t/security.t See if File::Temp works lib/File/Temp/t/tempfile.t See if File::Temp works lib/FileCache.pm Keep more files open than the system permits -lib/FileCache.t See if FileCache works +lib/FileCache/t/01open.t See if FileCache works +lib/FileCache/t/02maxopen.t See if FileCache works +lib/FileCache/t/03append.t See if FileCache works +lib/FileCache/t/04twoarg.t See if FileCache works +lib/FileCache/t/05override.t See if FileCache works lib/FileHandle.pm Backward-compatible front end to IO extension lib/FileHandle.t See if FileHandle works lib/filetest.pm For "use filetest" @@ -2179,7 +2183,6 @@ os2/OS2/PrfDB/MANIFEST System database access module os2/OS2/PrfDB/PrfDB.pm System database access module os2/OS2/PrfDB/PrfDB.xs System database access module os2/OS2/PrfDB/t/os2_prfdb.t System database access module -os2/OS2/PrfDB/typemap System database access module os2/OS2/Process/Makefile.PL system() constants in a module os2/OS2/Process/MANIFEST system() constants in a module os2/OS2/Process/Process.pm system() constants in a module @@ -2207,12 +2210,14 @@ os2/OS2/REXX/t/rx_tievar.t DLL access module os2/OS2/REXX/t/rx_tieydb.t DLL access module os2/OS2/REXX/t/rx_varset.t DLL access module os2/OS2/REXX/t/rx_vrexx.t DLL access module +os2/OS2/typemap Common typemap for OS/2 types os2/os2add.sym Overriding symbols to export os2/os2ish.h Header for OS/2 os2/os2thread.h pthread-like typedefs os2/os2_base.t Additional tests for builtin methods os2/perl2cmd.pl Corrects installed binaries under OS/2 os2/perlrexx.c Support perl interpreter embedded in REXX +os2/perlrexx.cmd Test perl interpreter embedded in REXX pad.c Scratchpad functions pad.h Scratchpad headers patchlevel.h The current patch level of perl diff --git a/doio.c b/doio.c index 1135a62..fd5b809 100644 --- a/doio.c +++ b/doio.c @@ -1395,11 +1395,13 @@ Perl_my_lstat(pTHX) return PL_laststatval; } +#ifndef OS2 bool Perl_do_aexec(pTHX_ SV *really, register SV **mark, register SV **sp) { return do_aexec5(really, mark, sp, 0, 0); } +#endif bool Perl_do_aexec5(pTHX_ SV *really, register SV **mark, register SV **sp, diff --git a/emacs/ptags b/emacs/ptags index 5551201..3294ed9 100755 --- a/emacs/ptags +++ b/emacs/ptags @@ -21,7 +21,7 @@ if test ! -z "$OS2_SHELL"; then alias find=gnufind; fi # Move autogenerated less-informative files to the end: # Hard to do embed.h and embedvar.h in one sweep: -topfiles="`echo ' ' *.y *.c *.h ' ' | sed 's/ / /g' | sed 's/ embedvar\.h\|embed\.h\|perlapi\.h\|\(globals\|perlapi\)\.c / /g'`" +topfiles="`echo ' ' *.y *.c *.h ' ' | sed 's/ / /g' | sed 's/ embedvar\.h\|embed\.h\|perlapi\.h\|os2ish\.h\|\(globals\|perlapi\| os2\)\.c / /g'`" subdirs="`find ./* -maxdepth 0 -type d`" subdirfiles="`find $subdirs -name '*.[cy]' -print | sort`" subdirfiles1="`find $subdirs -name '*.[hH]' -print | sort`" diff --git a/ext/Time/HiRes/Makefile.PL b/ext/Time/HiRes/Makefile.PL index dfcbce3..8343307 100644 --- a/ext/Time/HiRes/Makefile.PL +++ b/ext/Time/HiRes/Makefile.PL @@ -14,6 +14,8 @@ my $DEFINE; my $LIBS; my $XSOPT; +my $ld_exeext = ($^O eq 'os2' and $Config{ldflags} =~ /-Zexe\b/) ? '.exe' : ''; + unless($ENV{PERL_CORE}) { $ENV{PERL_CORE} = 1 if grep { $_ eq 'PERL_CORE=1' } @ARGV; } @@ -139,10 +141,11 @@ sub try_compile_and_link { } else { + my $tmp_exe = "$tmp$ld_exeext"; printf "cccmd = $cccmd\n" if $VERBOSE; - system($cccmd); - $ok = -s $tmp && -x _; - unlink("$tmp.c", $tmp); + my $res = system($cccmd); + $ok = defined($res) && $res==0 && -s $tmp_exe && -x _; + unlink("$tmp.c", $tmp_exe); } } @@ -367,7 +370,8 @@ EOD print "You can mix subsecond sleeps with signals.\n"; } else { print "NOT found.\n"; - print "You cannot mix subsecond sleeps with signals.\n"; + my $nt = ($^O eq 'os2' ? '' : 'not'); + print "You can$nt mix subsecond sleeps with signals.\n"; } if ($DEFINE) { diff --git a/handy.h b/handy.h index 6936c20..9f0fb3c 100644 --- a/handy.h +++ b/handy.h @@ -619,6 +619,8 @@ hopefully catches attempts to access uninitialized memory. #define StructCopy(s,d,t) Copy(s,d,1,t) #endif +#define C_ARRAY_LENGTH(a) (sizeof(a)/sizeof((a)[0])) + #ifdef NEED_VA_COPY # ifdef va_copy # define Perl_va_copy(s, d) va_copy(d, s) diff --git a/hints/freebsd.sh b/hints/freebsd.sh index 937df2a..5818097 100644 --- a/hints/freebsd.sh +++ b/hints/freebsd.sh @@ -92,10 +92,17 @@ case "$osvers" in d_setegid='undef' d_seteuid='undef' ;; +4.*) # In FreeBSD 4 and 5 the system malloc is performance-wise + # VERY bad for Perl-- we are talking of differences of not + # one, but TWO magnitudes. + usemymalloc=y + ;; +5.*) usemymalloc=y + ;; *) usevfork='true' case "$usemymalloc" in - "") usemymalloc='n' - ;; + "") usemymalloc='y' + ;; esac libswanted=`echo $libswanted | sed 's/ malloc / /'` ;; @@ -250,7 +257,7 @@ EOM # Even with the malloc mutexes the Perl malloc does not # seem to be threadsafe in FreeBSD? - usemymalloc=n + usemymalloc=y esac EOCBU diff --git a/hints/os2.sh b/hints/os2.sh index b2f962d..a3fc0b6 100644 --- a/hints/os2.sh +++ b/hints/os2.sh @@ -271,6 +271,8 @@ d_strtoll='define' d_strtoull='define' d_getprior='define' d_setprior='define' +d_usleep='define' +d_usleepproto='define' # The next two are commented. pdksh handles #!, extproc gives no path part. # sharpbang='extproc ' diff --git a/lib/ExtUtils/t/MM_OS2.t b/lib/ExtUtils/t/MM_OS2.t index caf662e..ae3b79e 100644 --- a/lib/ExtUtils/t/MM_OS2.t +++ b/lib/ExtUtils/t/MM_OS2.t @@ -263,8 +263,8 @@ is( $mm->{PERL_ARCHIVE}, '$(PERL_INC)/libperl$(LIB_EXT)', 'PERL_ARCHIVE' ); isnt( $mm->{PERL_ARCHIVE_AFTER}, '', 'PERL_ARCHIVE_AFTER should be empty without $is_aout set' ); $aout = 1; - is( $mm->{PERL_ARCHIVE_AFTER}, '', - '... and blank string if it is set' ); + is( $mm->{PERL_ARCHIVE_AFTER}, '$(PERL_INC)/libperl_override$(LIB_EXT)', + '... and `$(PERL_INC)/libperl_override$(LIB_EXT)\' if it is set' ); } # EXPORT_LIST diff --git a/lib/FileCache.t b/lib/FileCache.t deleted file mode 100755 index 1d91d21..0000000 --- a/lib/FileCache.t +++ /dev/null @@ -1,91 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -print "1..5\n"; - -use FileCache maxopen=>2; -my @files = qw(foo bar baz quux); - -{# Test 1: that we can open files - for my $path ( @files ){ - cacheout $path; - print $path "$path 1\n"; - } - print "not " unless scalar map({ -f } @files) == 4; - print "ok 1\n"; -} - - -{# Test 2: that we actually adhere to maxopen - my @cat; - for my $path ( @files ){ - print $path "$path 2\n"; - close($path); - open($path, $path); - <$path>; - push @cat, <$path>; - close($path); - } - print "not " if (grep {/foo|bar/} @cat) && ! (grep {/baz|quux/} @cat); - print "ok 2\n" ; -} - -{# Test 3: that we open for append on second viewing - my @cat; - for my $path ( @files ){ - cacheout $path; - print $path "$path 3\n"; - } - for my $path ( @files ){ - open($path, $path); - push @cat, do{ local $/; <$path>}; - close($path); - } - print "not " unless scalar map({ /3$/ } @cat) == 4; - print "ok 3\n"; -} - - -{# Test 4: that 2 arg format works - cacheout '+<', "foo"; - print foo "foo 2\n"; - close foo; - cacheout '<', "foo"; - print "not " unless eq "foo 2\n"; - print "ok 4\n"; - close(foo); -} - -{# Test 5: that close is overridden properly - cacheout local $_ = "Foo_Bar"; - print $_ "Hello World\n"; - close($_); - open($_, "+>$_"); - print $_ "$_\n"; - seek($_, 0, 0); - print "not " unless <$_> eq "$_\n"; - print "ok 5\n"; - close($_); -} - -q( -{# Test close override - package Bob; - use FileCache; - cacheout local $_ = "Foo_Bar"; - print $_ "Hello World\n"; - close($_); - open($_, "+>$_"); - print $_ "$_\n"; - seek($_, 0, 0); - print "not " unless <$_> eq "$_\n"; - print "ok 5\n"; - close($_); -} -); - -1 while unlink @files, "Foo_Bar"; diff --git a/lib/FileCache/t/01open.t b/lib/FileCache/t/01open.t new file mode 100644 index 0000000..d516aea --- /dev/null +++ b/lib/FileCache/t/01open.t @@ -0,0 +1,26 @@ +#!./perl +use FileCache; +use vars qw(@files); +BEGIN { + @files = qw(foo bar baz quux Foo'Bar); + chdir 't' if -d 't'; + + #For tests within the perl distribution + @INC = '../lib' if -d '../lib'; + END; +} +END{ + unlink @files; +} + + +print "1..1\n"; + +{# Test 1: that we can open files + for my $path ( @files ){ + cacheout $path; + print $path "$path 1\n"; + } + print "not " unless scalar map({ -f } @files) == scalar @files; + print "ok 1\n"; +} diff --git a/lib/FileCache/t/02maxopen.t b/lib/FileCache/t/02maxopen.t new file mode 100644 index 0000000..6b3b4c8 --- /dev/null +++ b/lib/FileCache/t/02maxopen.t @@ -0,0 +1,36 @@ +#!./perl +use FileCache maxopen=>2; +use Test; +use vars qw(@files); +BEGIN { + @files = qw(foo bar baz quux); + chdir 't' if -d 't'; + + #For tests within the perl distribution + @INC = '../lib' if -d '../lib'; + END; + plan tests=>5; +} +END{ + unlink @files; +} + +{# Test 2: that we actually adhere to maxopen + for my $path ( @files ){ + cacheout $path; + print $path "$path 1\n"; + } + + my @cat; + for my $path ( @files ){ + ok(fileno($path) || $path =~ /^(?:foo|bar)$/); + next unless fileno($path); + print $path "$path 2\n"; + close($path); + open($path, $path); + <$path>; + push @cat, <$path>; + close($path); + } + ok( grep(/^(?:baz|quux) 2$/, @cat) == 2 ); +} diff --git a/lib/FileCache/t/03append.t b/lib/FileCache/t/03append.t new file mode 100644 index 0000000..5a08a1e --- /dev/null +++ b/lib/FileCache/t/03append.t @@ -0,0 +1,47 @@ +#!./perl +use FileCache maxopen=>2; +use vars qw(@files); +BEGIN { + @files = qw(foo bar baz quux Foo'Bar); + chdir 't' if -d 't'; + + #For tests within the perl distribution + @INC = '../lib' if -d '../lib'; + END; +} +END{ + unlink @files; +} + +print "1..2\n"; + +{# Test 3: that we open for append on second viewing + my @cat; + for my $path ( @files ){ + cacheout $path; + print $path "$path 3\n"; + } + for my $path ( @files ){ + cacheout $path; + print $path "$path 33\n"; + } + for my $path ( @files ){ + open($path, '<', $path); + push @cat, do{ local $/; <$path>}; + close($path); + } + print 'not ' unless scalar grep(/\b3$/m, @cat) == scalar @files; + print "ok 1\n"; + @cat = (); + for my $path ( @files ){ + cacheout $path; + print $path "$path 333\n"; + } + for my $path ( @files ){ + open($path, '<', $path); + push @cat, do{ local $/; <$path>}; + close($path); + } + print 'not ' unless scalar grep(/\b33$/m, @cat) == scalar @files; + print "ok 2\n"; +} diff --git a/lib/FileCache/t/04twoarg.t b/lib/FileCache/t/04twoarg.t new file mode 100644 index 0000000..a2a70be --- /dev/null +++ b/lib/FileCache/t/04twoarg.t @@ -0,0 +1,24 @@ +#!./perl +BEGIN { + use FileCache; + chdir 't' if -d 't'; + + #For tests within the perl distribution + @INC = '../lib' if -d '../lib'; + END; +} +END{ + unlink('foo'); +} + +print "1..1\n"; + +{# Test 4: that 2 arg format works, and that we cycle on mode change + cacheout '>', "foo"; + print foo "foo 4\n"; + cacheout '+>', "foo"; + print foo "foo 44\n"; + seek(foo, 0, 0); + print 'not ' unless eq "foo 44\n"; + print "ok 1\n"; +} diff --git a/lib/FileCache/t/05override.t b/lib/FileCache/t/05override.t new file mode 100644 index 0000000..6fdf873 --- /dev/null +++ b/lib/FileCache/t/05override.t @@ -0,0 +1,21 @@ +#!./perl +BEGIN { + use FileCache; + chdir 't' if -d 't'; + + #For tests within the perl distribution + @INC = '../lib' if -d '../lib'; + END; +} +END{ + unlink("Foo'Bar"); +} +print "1..1\n"; + +{# Test 5: that close is overridden properly within the caller + cacheout local $_ = "Foo'Bar"; + print $_ "Hello World\n"; + close($_); + print 'not ' if fileno($_); + print "ok 1\n"; +} diff --git a/lib/bytes.t b/lib/bytes.t index dda2b87..28043ca 100644 --- a/lib/bytes.t +++ b/lib/bytes.t @@ -1,32 +1,34 @@ BEGIN { chdir 't' if -d 't'; @INC = '../lib'; + require './test.pl'; } -print "1..6\n"; +plan tests => 9; -my $a = chr(0x0100); +my $a = chr(0x100); -print ord($a) == 0x100 ? "ok 1\n" : "not ok 1\n"; -print length($a) == 1 ? "ok 2\n" : "not ok 2\n"; +is(ord($a), 0x100, "ord sanity check"); +is(length($a), 1, "length sanity check"); +is(bytes::length($a), 2, "bytes::length sanity check"); { use bytes; - my $b = chr(0x0100); - print ord($b) == 0 ? "ok 3\n" : "not ok 3\n"; + my $b = chr(0x100); # affected by 'use bytes' + is(ord($b), 0, "chr truncates under use bytes"); + is(length($b), 1, "length truncated under use bytes"); + is(bytes::length($b), 1, "bytes::length truncated under use bytes"); } -my $c = chr(0x0100); - -print ord($c) == 0x100 ? "ok 4\n" : "not ok 4\n"; +my $c = chr(0x100); { use bytes; - if (ord('A') == 193) { - print ord($c) == 0x8c ? "ok 5\n" : "not ok 5\n"; + if (ord('A') == 193) { # EBCDIC? + is(ord($c), 0x8c, "ord under use bytes looks at the 1st byte"); } else { - print ord($c) == 0xc4 ? "ok 5\n" : "not ok 5\n"; + is(ord($c), 0xc4, "ord under use bytes looks at the 1st byte"); } - print length($c) == 2 ? "ok 6\n" : "not ok 6\n"; + is(length($c), 2, "length under use bytes looks at bytes"); + is(bytes::length($c), 2, "bytes::length under use bytes looks at bytes"); } - diff --git a/lib/utf8.pm b/lib/utf8.pm index 5a37aec..0c8a991 100644 --- a/lib/utf8.pm +++ b/lib/utf8.pm @@ -72,20 +72,22 @@ utf8 until the end the block (or file, if at top level) by C. =head2 Utility functions -The following functions are defined in the C package by the perl core. +The following functions are defined in the C package by the +Perl core. You do not need to say C to use these and in fact +you should not unless you really want to have UTF-8 source code. =over 4 =item * $num_octets = utf8::upgrade($string); -Converts (in-place) internal representation of string to Perl's internal -I form. Returns the number of octets necessary to represent -the string as I. Can be used to make sure that the +Converts (in-place) internal representation of string to Perl's +internal I form. Returns the number of octets necessary to +represent the string as I. Can be used to make sure that the UTF-8 flag is on, so that C<\w> or C work as expected on strings -containing characters in the range 0x80-0xFF. Note that this should -not be used to convert -a legacy byte encoding to Unicode: use Encode for that. Affected -by the encoding pragma. +containing characters in the range 0x80-0xFF (oon ASCII and +derivatives). Note that this should not be used to convert a legacy +byte encoding to Unicode: use Encode for that. Affected by the +encoding pragma. =item * utf8::downgrade($string[, FAIL_OK]) @@ -101,24 +103,30 @@ pragma. =item * utf8::encode($string) Converts (in-place) I<$string> from logical characters to octet -sequence representing it in Perl's I encoding. Same as -Encode::encode_utf8(). Note that this should not be used to convert -a legacy byte encoding to Unicode: use Encode for that. +sequence representing it in Perl's I encoding. Returns +nothing. Same as Encode::encode_utf8(). Note that this should not be +used to convert a legacy byte encoding to Unicode: use Encode for +that. =item * $flag = utf8::decode($string) Attempts to convert I<$string> in-place from Perl's I encoding -into logical characters. Same as Encode::decode_utf8(). Note that this -should not be used to convert Unicode back to a legacy byte encoding: -use Encode for that. +into logical characters. Returns nothing. Same as Encode::decode_utf8(). +Note that this should not be used to convert Unicode back to a legacy +byte encoding: use Encode for that. + +=item * $flag = utf8::is_utf8(STRING) + +Test whether STRING is in UTF-8. Same as Encode::is_utf8(). =item * $flag = utf8::valid(STRING) -[INTERNAL] Test whether STRING is in a consistent state. Will return -true if string is held as bytes, or is well-formed UTF-8 and has the -UTF-8 flag on. Main reason for this routine is to allow Perl's -testsuite to check that operations have left strings in a consistent -state. +[INTERNAL] Test whether STRING is in a consistent state regarding +UTF-8. Will return true is well-formed UTF-8 and has the UTF-8 flag +on B if string is held as bytes (both these states are 'consistent'). +Main reason for this routine is to allow Perl's testsuite to check +that operations have left strings in a consistent state. You most +probably want to use utf8::is_utf8() instead. =back @@ -128,9 +136,9 @@ functions C, C, C, and C, which are wrapped by the Perl functions C, C, C and C. Note that in the Perl 5.8.0 implementation the -functions utf8::valid, utf8::encode, utf8::decode, utf8::upgrade, -and utf8::downgrade are always available, without a C -statement-- this may change in future releases. +functions utf8::is_utf8, utf8::valid, utf8::encode, utf8::decode, +utf8::upgrade, and utf8::downgrade are always available, without a +C statement-- this may change in future releases. =head1 BUGS diff --git a/lib/utf8.t b/lib/utf8.t index 223bb1d..33cd596 100644 --- a/lib/utf8.t +++ b/lib/utf8.t @@ -37,7 +37,7 @@ no utf8; # Ironic, no? # # -plan tests => 99; +plan tests => 143; { # bug id 20001009.001 @@ -332,3 +332,80 @@ SKIP: { eval qq{is(q \xc3\xbc test \xc3\xbc, qq\xc2\xb7 test \xc2\xb7, "utf8 quote delimiters [perl #16823]");}; } + +# Test the "internals". + +{ + my $a = "A"; + my $b = chr(0x0FF); + my $c = chr(0x100); + + ok( utf8::valid($a), "utf8::valid basic"); + ok( utf8::valid($b), "utf8::valid beyond"); + ok( utf8::valid($c), "utf8::valid unicode"); + + ok(!utf8::is_utf8($a), "!utf8::is_utf8 basic"); + ok(!utf8::is_utf8($b), "!utf8::is_utf8 beyond"); + ok( utf8::is_utf8($c), "utf8::is_utf8 unicode"); + + is(utf8::upgrade($a), 1, "utf8::upgrade basic"); + is(utf8::upgrade($b), 2, "utf8::upgrade beyond"); + is(utf8::upgrade($c), 2, "utf8::upgrade unicode"); + + is($a, "A", "basic"); + is($b, "\xFF", "beyond"); + is($c, "\x{100}", "unicode"); + + ok( utf8::valid($a), "utf8::valid basic"); + ok( utf8::valid($b), "utf8::valid beyond"); + ok( utf8::valid($c), "utf8::valid unicode"); + + ok( utf8::is_utf8($a), "utf8::is_utf8 basic"); + ok( utf8::is_utf8($b), "utf8::is_utf8 beyond"); + ok( utf8::is_utf8($c), "utf8::is_utf8 unicode"); + + is(utf8::downgrade($a), 1, "utf8::downgrade basic"); + is(utf8::downgrade($b), 1, "utf8::downgrade beyond"); + + is($a, "A", "basic"); + is($b, "\xFF", "beyond"); + + ok( utf8::valid($a), "utf8::valid basic"); + ok( utf8::valid($b), "utf8::valid beyond"); + + ok(!utf8::is_utf8($a), "!utf8::is_utf8 basic"); + ok(!utf8::is_utf8($b), "!utf8::is_utf8 beyond"); + + utf8::encode($a); + utf8::encode($b); + utf8::encode($c); + + is($a, "A", "basic"); + is(length($b), 2, "beyond length"); + is(length($c), 2, "unicode length"); + + ok(utf8::valid($a), "utf8::valid basic"); + ok(utf8::valid($b), "utf8::valid beyond"); + ok(utf8::valid($c), "utf8::valid unicode"); + + # encode() clears the UTF-8 flag (unlike upgrade()). + ok(!utf8::is_utf8($a), "!utf8::is_utf8 basic"); + ok(!utf8::is_utf8($b), "!utf8::is_utf8 beyond"); + ok(!utf8::is_utf8($c), "!utf8::is_utf8 unicode"); + + utf8::decode($a); + utf8::decode($b); + utf8::decode($c); + + is($a, "A", "basic"); + is($b, "\xFF", "beyond"); + is($c, "\x{100}", "unicode"); + + ok(utf8::valid($a), "!utf8::valid basic"); + ok(utf8::valid($b), "!utf8::valid beyond"); + ok(utf8::valid($c), " utf8::valid unicode"); + + ok(!utf8::is_utf8($a), "!utf8::is_utf8 basic"); + ok( utf8::is_utf8($b), " utf8::is_utf8 beyond"); # $b stays in UTF-8. + ok( utf8::is_utf8($c), " utf8::is_utf8 unicode"); +} diff --git a/makedef.pl b/makedef.pl index b718633..1e8878fe 100644 --- a/makedef.pl +++ b/makedef.pl @@ -389,6 +389,8 @@ elsif ($PLATFORM eq 'os2') { my_getpwent my_setpwent my_endpwent + fork_with_resources + croak_with_os2error setgrent endgrent getgrent diff --git a/os2/OS2/Process/Makefile.PL b/os2/OS2/Process/Makefile.PL index 6a59d1f..c24af0c 100644 --- a/os2/OS2/Process/Makefile.PL +++ b/os2/OS2/Process/Makefile.PL @@ -32,7 +32,7 @@ sub create_constants { '--skip-strict', '--skip-warnings', # likewise '--skip-ppport', # will not work without dynaloading. # Most useful for OS2::Process: - '-M^(HWND|WM|SC|SWP|WC|PROG|QW|EDI|WS|QWS|QWP|QWL|FF|FI|LS|FS|FCF|BS|MS|TBM|CF|CFI|FID)_', + '-M^(HWND|WM|SC|SWP|WC|PROG|QW|EDI|WS|QWS|QWP|QWL|FF|FI|LS|FS|FCF|BS|MS|TBM|CF|CFI|FID|MB|MBID|CF|CFI|SPTR)_', '-F', '-DINCL_NLS -DINCL_BASE -DINCL_PM', # Define more symbols 'os2emx.h' # EMX version of OS/2 API and warn("Can't build module with contants, falling back to no constants"), diff --git a/os2/OS2/Process/Process.pm b/os2/OS2/Process/Process.pm index 29e4d9b..956e8fd 100644 --- a/os2/OS2/Process/Process.pm +++ b/os2/OS2/Process/Process.pm @@ -101,6 +101,7 @@ our @EXPORT = qw( ChildWindows out_codepage out_codepage_set + process_codepage_set in_codepage in_codepage_set cursor @@ -124,6 +125,45 @@ our @EXPORT = qw( SetWindowPtr SetWindowULong SetWindowUShort + TopLevel + FocusWindow_set_keep_Zorder + + ActiveDesktopPathname + InvalidateRect + CreateFrameControl + ClipbrdFmtInfo + ClipbrdOwner + ClipbrdViewer + ClipbrdData + OpenClipbrd + CloseClipbrd + ClipbrdData_set + ClipbrdOwner_set + ClipbrdViewer_set + EnumClipbrdFmts + EmptyClipbrd + AddAtom + FindAtom + DeleteAtom + AtomUsage + AtomName + AtomLength + SystemAtomTable + CreateAtomTable + DestroyAtomTable + + _ClipbrdData_set + ClipbrdText + ClipbrdText_set + + _MessageBox + MessageBox + _MessageBox2 + MessageBox2 + LoadPointer + SysPointer + Alarm + FlashWindow get_title set_title @@ -178,7 +218,7 @@ sub import { my $ini = @_; @_ = ($class, map { - /^(HWND|WM|SC|SWP|WC|PROG|QW|EDI|WS|QWS|QWP|QWL|FF|FI|LS|FS|FCF|BS|MS|TBM|CF|CFI|FID)_/ ? const_import($_) : $_ + /^(HWND|WM|SC|SWP|WC|PROG|QW|EDI|WS|QWS|QWP|QWL|FF|FI|LS|FS|FCF|BS|MS|TBM|CF|CFI|FID|MB|MBID|CF|CFI|SPTR)_/ ? const_import($_) : $_ } @_); goto &Exporter::import if @_ > 1 or $ini == 0; } @@ -335,6 +375,117 @@ sub ChildWindows (;$) { @kids; } +sub TopLevel ($) { + my $d = DesktopWindow; + my $w = shift; + while (1) { + my $p = QueryWindow $w, 5; # QW_PARENT; + return $w if not $p or $p == $d; + $w = $p; + } +} + +sub FocusWindow_set_keep_Zorder ($) { + my $w = shift; + my $t = TopLevel $w; + my $b = hWindowPos($t)->{behind}; # we are behind this + EnableWindowUpdate($t, 0); + FocusWindow_set($w); +# sleep 1; # Make flicker stronger when present + hWindowPos_set {behind => $b}, $t; + EnableWindowUpdate($t, 1); +} + +sub ClipbrdText (@) { + my $morph = OS2::localMorphPM->new(0); + OpenClipbrd(); + my $txt = unpack 'p', pack 'L', ClipbrdData @_; + CloseClipbrd(); + $txt; +} + +sub ClipbrdText_set ($;$) { + my $morph = OS2::localMorphPM->new(0); + OpenClipbrd(); + EmptyClipbrd(); # It may contain other types + my ($txt, $no_convert_nl) = (shift, shift); + ClipbrdData_set($txt, !$no_convert_nl, @_); + CloseClipbrd(); +} + +sub MessageBox ($;$$$$$) { + my $morph = OS2::localMorphPM->new(0); + die "MessageBox needs text" unless @_; + push @_ , ($0 eq '-e' ? "Perl one-liner's message" : "$0 message") if @_ == 1; + &_MessageBox; +} + +my %pointers; + +sub get_pointer ($;$$) { + my $id = $_[0]; + return $pointers{$id} if exists $pointers{$id}; + $pointers{$id} = &SysPointer; +} + +# $button needs to be of the form 'String', ['String'] or ['String', flag]. +# If ['String'], it is assumed the default button; same for 'String' if $only +# is set. +sub process_MB2 ($$;$) { + die "process_MB2() needs 2 arguments, got '@_'" unless @_ == 2 or @_ == 3; + my ($button, $ret, $only) = @_; + # default is BS_PUSHBUTTON, add BS_DEFAULT if $only is set + $button = [$button, $only ? 0x400 : 0] unless ref $button eq 'ARRAY'; + push @$button, 0x400 if @$button == 1; # BS_PUSHBUTTON|BS_DEFAULT + die "Button needs to be of the form 'String', ['String'] or ['String', flag]" + unless @$button == 2; + pack "Z71 x L l", $button->[0], $ret, $button->[1]; # name, retval, flag +} + +# If one button, make it the default one even if it is of 'String' => val form. +# If icon is of the form 'SP#', load this via SysPointer. +sub process_MB2_INFO ($;$$$) { + my $l = 0; + my $out; + die "process_MB2_INFO() needs 1..4 arguments" unless @_ and @_ < 5; + my $buttons = shift; + die "Buttons array should consist of pairs" if @$buttons % 2; + + push @_, 0 unless @_; # Icon id (pointer) + # Box flags (MB_MOVABLE and MB_INFORMATION or MB_CUSTOMICON) + push @_, ($_[0] ? 0x4080 : 0x4030) unless @_ > 1; + push @_, 0 unless @_ > 2; # Notify window + + my ($icon, $style, $notify) = (shift, shift, shift); + $icon = get_pointer $1 if $icon =~ /^SP#(\d+)\z/; + $out = pack "L L L L", # icon, #buttons, style, notify, buttons + $icon, @$buttons/2, $style, $notify; + $out .= join '', + map process_MB2($buttons->[2*$_], $buttons->[2*$_+1], @$buttons == 2), + 0..@$buttons/2-1; + pack('L', length(pack 'L', 0) + length $out) . $out; +} + +# MessageBox2 'Try this', OS2::Process::process_MB2_INFO([['Dismiss', 0] => 0x1000], OS2::Process::get_pointer(22),0x4080,0), 'me', 1, 0, 0 +# or the shortcut +# MessageBox2 'Try this', [[['Dismiss', 0] => 0x1000], 'SP#22'], 'me' +# 0x80 means MB_CUSTOMICON (does not focus?!). This focuses: +# MessageBox2 'Try this', [[['Dismiss',0x400] => 0x1000], 0, 0x4030,0] +# 0x400 means BS_DEFAULT. This is the same as the shortcut +# MessageBox2 'Try this', [[Dismiss => 0x1000]] +sub MessageBox2 ($;$$$$$) { + my $morph = OS2::localMorphPM->new(0); + die "MessageBox needs text" unless @_; + push @_ , [[Dismiss => 0x1000], # Name, retval (BS_PUSHBUTTON|BS_DEFAULT) + #0, # get_pointer(11), # SPTR_ICONINFORMATION + #0x4030, # MB_MOVEABLE | MB_INFORMATION + #0, # Notify window; was 1==HWND_DESKTOP + ] if @_ == 1; + push @_ , ($0 eq '-e' ? "Perl one-liner's message" : "$0's message") if @_ == 2; + $_[1] = &process_MB2_INFO(@{$_[1]}) if ref($_[1]) eq 'ARRAY'; + &_MessageBox2; +} + # backward compatibility *set_title = \&Title_set; *get_title = \&Title; @@ -551,7 +702,19 @@ gets a buffer with characters and attributes of the screen. =item C -restores the screen given the result of screen(). +restores the screen given the result of screen(). E.g., if the file +C<$file> contains the sceen contents, then + + open IN, $file or die; + binmode IN; + read IN, $in, -s IN; + $s = screen; + $in .= qq(\0) x (length($s) - length $in); + substr($in, length $s) = ''; + screen_set $in; + +will restore the screen content even if the height of the window +changed (if the width changed, more manipulation is needed). =back @@ -705,9 +868,9 @@ titlebar of the current window. sets text of the titlebar and task switch menu of the current process' window via direct manipulation of the windows' texts. -=item C +=item C -switch to session given by a switch list handle. +switch to session given by a switch list handle (defaults to the entry of our process). Use of this function causes another window (and its related windows) of a PM session to appear on the front of the screen, or a switch to @@ -824,10 +987,18 @@ to use. E.g, the first entry in program_entries() is the C list. To show an application, use either one of WinShowWindow( $hwnd, 1 ); - SetFocus( $hwnd ); + FocusWindow_set( $hwnd ); SwitchToProgram($switch_handle); -(Which work with alternative focus-to-front policies?) Requires (morphing to) PM. +(Which work with alternative focus-to-front policies?) Requires +(morphing to) PM. + +Switching focus to currently-unfocused window moves the window to the +front in Z-order; use FocusWindow_set_keep_Zorder() to avoid this. + +=item C + +same as FocusWindow_set(), but preserves the Z-order of windows. =item C @@ -1013,6 +1184,16 @@ item list when beginning is reached. =back +=item DesktopWindow() + +gets the actual window handle of the PM desktop; most APIs accept the +pseudo-handle C 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 @@ -1031,6 +1212,77 @@ This function is normally not needed. Not exported by default. =back +=head2 Control of the PM data + +=over + +=item ActiveDesktopPathname() + +gets the path of the directory which corresponds to Desktop. + +=item ClipbrdText() + +gets the content of the clipboard. An optional argument is the format +of the data in the clipboard (defaults to C). + +Note that the usual convention is to have clipboard data with +C<"\r\n"> as line separators. + +=item ClipbrdText_set($txt) + +sets the text content of the clipboard. Unless the optional argument +is TRUE, will convert newlines to C<"\r\n">. Another optional +argument is the format of the data in the clipboard (defaults to +C). + +=item InvalidateRect + +=item CreateFrameControl + +=item ClipbrdFmtInfo + +=item ClipbrdOwner + +=item ClipbrdViewer + +=item ClipbrdData + +=item OpenClipbrd + +=item CloseClipbrd + +=item ClipbrdData_set + +=item ClipbrdOwner_set + +=item ClipbrdViewer_set + +=item EnumClipbrdFmts + +=item EmptyClipbrd + +=item AddAtom + +=item FindAtom + +=item DeleteAtom + +=item AtomUsage + +=item AtomName + +=item AtomLength + +=item SystemAtomTable + +=item CreateAtomTable + +=item DestroyAtomTable + +Low-level methods to access clipboard and the atom table(s). + +=back + =head1 OS2::localMorphPM class This class morphs the process to PM for the duration of the given scope. @@ -1072,12 +1324,14 @@ Add tests for: scrsize scrsize_set -Document: -Query/SetWindowULong/Short/Ptr, SetWindowBits. +Document and test: Query/SetWindowULong/Short/Ptr, SetWindowBits. +InvalidateRect, CreateFrameControl, ClipbrdFmtInfo ClipbrdOwner +ClipbrdViewer ClipbrdData OpenClipbrd CloseClipbrd ClipbrdData_set +ClipbrdOwner_set ClipbrdViewer_set EnumClipbrdFmts EmptyClipbrd +AddAtom FindAtom DeleteAtom AtomUsage AtomName AtomLength +SystemAtomTable CreateAtomTable DestroyAtomTable -Implement InvalidateRect, -CreateFrameControl. ClipbrdFmtInfo, ClipbrdData, OpenClipbrd, CloseClipbrd, -ClipbrdData_set, EnumClipbrdFmt, EmptyClipbrd. SOMETHINGFROMMR. +Implement SOMETHINGFROMMR. >But I wish to change the default button if the user enters some diff --git a/os2/OS2/Process/Process.xs b/os2/OS2/Process/Process.xs index 1e75951..97e5d2f 100644 --- a/os2/OS2/Process/Process.xs +++ b/os2/OS2/Process/Process.xs @@ -7,6 +7,8 @@ #define INCL_WININPUT #define INCL_VIO #define INCL_KBD +#define INCL_WINCLIPBOARD +#define INCL_WINATOM #include #include "EXTERN.h" @@ -234,12 +236,14 @@ file_type(char *path) if (!(_emx_env & 0x200)) croak("file_type not implemented on DOS"); /* not OS/2. */ if (CheckOSError(DosQueryAppType(path, &apptype))) { +#if 0 if (rc == ERROR_INVALID_EXE_SIGNATURE) croak("Invalid EXE signature"); else if (rc == ERROR_EXE_MARKED_INVALID) { croak("EXE marked invalid"); } - croak("DosQueryAppType err %ld", rc); +#endif + croak_with_os2error("DosQueryAppType"); } return apptype; @@ -260,7 +264,7 @@ DeclFuncByORD(ULONG, XmyWinSwitchToProgram, ORD_WinSwitchToProgram, #define myWinSwitchToProgram(hsw) (!CheckOSError(XmyWinSwitchToProgram(hsw))) - +/* These function croak if the return value is 0. */ DeclWinFunc_CACHE(HWND, QueryWindow, (HWND hwnd, LONG cmd), (hwnd, cmd)) DeclWinFunc_CACHE(BOOL, QueryWindowPos, (HWND hwnd, PSWP pswp), (hwnd, pswp)) @@ -300,6 +304,63 @@ DeclWinFunc_CACHE(HWND, EnumDlgItem, (HWND hwndDlg, HWND hwnd, ULONG code), DeclWinFunc_CACHE(HWND, QueryDesktopWindow, (HAB hab, HDC hdc), (hab, hdc)); DeclWinFunc_CACHE(BOOL, SetActiveWindow, (HWND hwndDesktop, HWND hwnd), (hwndDesktop, hwnd)); +DeclWinFunc_CACHE(BOOL, QueryActiveDesktopPathname, (PSZ pszPathName, ULONG ulSize), + (pszPathName, ulSize)); +DeclWinFunc_CACHE(BOOL, InvalidateRect, + (HWND hwnd, /*RECTL*/ char *prcl, BOOL fIncludeChildren), + (hwnd, prcl, fIncludeChildren)); +DeclWinFunc_CACHE(BOOL, CreateFrameControls, + (HWND hwndFrame, /*PFRAMECDATA*/ char* pfcdata, PCSZ pszTitle), + (hwndFrame, pfcdata, pszTitle)); +DeclWinFunc_CACHE(BOOL, OpenClipbrd, (HAB hab), (hab)); +DeclWinFunc_CACHE(BOOL, EmptyClipbrd, (HAB hab), (hab)); +DeclWinFunc_CACHE(BOOL, CloseClipbrd, (HAB hab), (hab)); +DeclWinFunc_CACHE(HWND, QueryClipbrdViewer, (HAB hab), (hab)); +DeclWinFunc_CACHE(HWND, QueryClipbrdOwner, (HAB hab), (hab)); +DeclWinFunc_CACHE(BOOL, QueryClipbrdFmtInfo, (HAB hab, ULONG fmt, PULONG prgfFmtInfo), (hab, fmt, prgfFmtInfo)); +DeclWinFunc_CACHE(ULONG, QueryClipbrdData, (HAB hab, ULONG fmt), (hab, fmt)); +DeclWinFunc_CACHE(HWND, SetClipbrdViewer, (HAB hab, HWND hwnd), (hab, hwnd)); +DeclWinFunc_CACHE(HWND, SetClipbrdOwner, (HAB hab, HWND hwnd), (hab, hwnd)); +DeclWinFunc_CACHE(ULONG, EnumClipbrdFmts, (HAB hab, ULONG fmt), (hab, fmt)); +DeclWinFunc_CACHE(ATOM, AddAtom, (HATOMTBL hAtomTbl, PCSZ pszAtomName), + (hAtomTbl, pszAtomName)); +DeclWinFunc_CACHE(ATOM, FindAtom, (HATOMTBL hAtomTbl, PCSZ pszAtomName), + (hAtomTbl, pszAtomName)); +DeclWinFunc_CACHE(ATOM, DeleteAtom, (HATOMTBL hAtomTbl, PCSZ pszAtomName), + (hAtomTbl, pszAtomName)); +DeclWinFunc_CACHE(ULONG, QueryAtomUsage, (HATOMTBL hAtomTbl, ATOM atom), + (hAtomTbl, atom)); +DeclWinFunc_CACHE(ULONG, QueryAtomLength, (HATOMTBL hAtomTbl, ATOM atom), + (hAtomTbl, atom)); +DeclWinFunc_CACHE(ULONG, QueryAtomName, + (HATOMTBL hAtomTbl, ATOM atom, PSZ pchBuffer, ULONG cchBufferMax), + (hAtomTbl, atom, pchBuffer, cchBufferMax)); +DeclWinFunc_CACHE(HATOMTBL, QuerySystemAtomTable, (VOID), ()); +DeclWinFunc_CACHE(HATOMTBL, CreateAtomTable, (ULONG initial, ULONG buckets), + (initial, buckets)); +DeclWinFunc_CACHE(HATOMTBL, DestroyAtomTable, (HATOMTBL hAtomTbl), (hAtomTbl)); +DeclWinFunc_CACHE(ULONG, MessageBox, (HWND hwndParent, HWND hwndOwner, PCSZ pszText, PCSZ pszCaption, ULONG idWindow, ULONG flStyle), (hwndParent, hwndOwner, pszText, pszCaption, idWindow, flStyle)); +DeclWinFunc_CACHE(ULONG, MessageBox2, + (HWND hwndParent, HWND hwndOwner, PCSZ pszText, + PCSZ pszCaption, ULONG idWindow, PMB2INFO pmb2info), + (hwndParent, hwndOwner, pszText, pszCaption, idWindow, pmb2info)); +DeclWinFunc_CACHE(HPOINTER, LoadPointer, + (HWND hwndDesktop, HMODULE hmod, ULONG idres), + (hwndDesktop, hmod, idres)); +DeclWinFunc_CACHE(HPOINTER, QuerySysPointer, + (HWND hwndDesktop, LONG lId, BOOL fCopy), + (hwndDesktop, lId, fCopy)); +DeclWinFunc_CACHE(BOOL, Alarm, (HWND hwndDesktop, ULONG rgfType), (hwndDesktop, rgfType)); +DeclWinFunc_CACHE(BOOL, FlashWindow, (HWND hwndFrame, BOOL fFlash), (hwndFrame, fFlash)); + + +/* These functions do not croak on error */ +DeclWinFunc_CACHE_survive(BOOL, SetClipbrdData, + (HAB hab, ULONG ulData, ULONG fmt, ULONG rgfFmtInfo), + (hab, ulData, fmt, rgfFmtInfo)); + +#define get_InvalidateRect InvalidateRect +#define get_CreateFrameControls CreateFrameControls /* These functions may return 0 on success; check $^E/Perl_rc on res==0: */ DeclWinFunc_CACHE_resetError(PVOID, QueryWindowPtr, (HWND hwnd, LONG index), @@ -334,6 +395,9 @@ HWND (*pWinWindowFromPoint)(HWND hwnd, __const__ POINTL *pptl, BOOL fChildren); #define WindowPos_set(hwnd, x, y, fl, cx, cy, hwndInsertBehind) \ SetWindowPos(hwnd, hwndInsertBehind, x, y, cx, cy, fl) #define myWinQueryWindowPtr(hwnd, i) ((ULONG)QueryWindowPtr(hwnd, i)) +#define _ClipbrdData_set SetClipbrdData +#define ClipbrdOwner_set SetClipbrdOwner +#define ClipbrdViewer_set SetClipbrdViewer int WindowText_set(HWND hwnd, char* text) @@ -355,7 +419,7 @@ myQueryWindowText(HWND hwnd) } sv = newSVpvn("", 0); SvGROW(sv, l + 1); - len = WinQueryWindowText(hwnd, l + 1, SvPV_force(sv, n_a)); + len = QueryWindowText(hwnd, l + 1, SvPV_force(sv, n_a)); if (len != l) { Safefree(sv); croak("WinQueryWindowText() uncompatible with WinQueryWindowTextLength()"); @@ -411,20 +475,29 @@ WindowFromPoint(long x, long y, HWND hwnd, BOOL fChildren) return SaveWinError(pWinWindowFromPoint(hwnd, &ppl, fChildren)); } -static void -fill_swentry(SWENTRY *swentryp, HWND hwnd, PID pid) +static HSWITCH +switch_of(HWND hwnd, PID pid) { - int rc; HSWITCH hSwitch; if (!(_emx_env & 0x200)) croak("switch_entry not implemented on DOS"); /* not OS/2. */ if (CheckWinError(hSwitch = myWinQuerySwitchHandle(hwnd, pid))) - croak("WinQuerySwitchHandle: %s", os2error(Perl_rc)); + croak_with_os2error("WinQuerySwitchHandle"); + return hSwitch; +} + + +static void +fill_swentry(SWENTRY *swentryp, HWND hwnd, PID pid) +{ + int rc; + HSWITCH hSwitch = switch_of(hwnd, pid); + swentryp->hswitch = hSwitch; if (CheckOSError(myWinQuerySwitchEntry(hSwitch, &swentryp->swctl))) - croak("WinQuerySwitchEntry err %ld", rc); + croak_with_os2error("WinQuerySwitchEntry"); } static void @@ -433,6 +506,103 @@ fill_swentry_default(SWENTRY *swentryp) fill_swentry(swentryp, NULLHANDLE, getpid()); } +static SV* +myWinQueryActiveDesktopPathname() +{ + SV *buf = newSVpv("",0); + STRLEN n_a; + + SvGROW(buf, MAXPATHLEN); + QueryActiveDesktopPathname(SvPV(buf,n_a), MAXPATHLEN); + SvCUR_set(buf, strlen(SvPV(buf, n_a))); + return buf; +} + +SV * +myWinQueryAtomName(ATOM atom, HATOMTBL hAtomTbl) +{ + ULONG len = QueryAtomLength(hAtomTbl, atom); + SV *sv = newSVpvn("",0); + STRLEN n_a; + + SvGROW(sv, len + 1); + QueryAtomName(hAtomTbl, atom, SvPV(sv, n_a), len); + SvCUR_set(sv, len); + *SvEND(sv) = 0; + return sv; +} + +#define myWinQueryClipbrdFmtInfo QueryClipbrdFmtInfo + +/* Put data into shared memory, then call SetClipbrdData */ +void +ClipbrdData_set(SV *sv, int convert_nl, unsigned long fmt, unsigned long rgfFmtInfo, HAB hab) +{ + STRLEN len; + char *buf = SvPV_force(sv, len); + char *pByte = 0, *s = buf, c; + ULONG nls = 0, rc; + + if (convert_nl) { + while ((c = *s++)) { + if (c == '\r' && *s == '\n') + s++; + else if (c == '\n') + nls++; + } + } + + if (CheckOSError(DosAllocSharedMem((PPVOID)&pByte, 0, len + nls + 1, + PAG_WRITE | PAG_COMMIT | OBJ_GIVEABLE | OBJ_GETTABLE))) + croak_with_os2error("ClipbrdData_set: DosAllocSharedMem error"); + + if (!nls) + memcpy(pByte, buf, len + 1); + else { + char *t = pByte, *e = buf + len; + + while (buf < e) { + c = *t++ = *buf++; + if (c == '\n' && (t == pByte + 1 || t[-2] != '\r')) + t[-1] = '\r', *t++ = '\n'; + } + } + + if (!SetClipbrdData(hab, (ULONG)pByte, fmt, rgfFmtInfo)) { + DosFreeMem((PPVOID)&pByte); + croak_with_os2error("ClipbrdData_set: WinSetClipbrdData error"); + } +} + +#if 0 + +ULONG +myWinMessageBox(HWND hwndParent, HWND hwndOwner, PCSZ pszText, PCSZ pszCaption, ULONG idWindow, ULONG flStyle) +{ + ULONG rc = MessageBox(hwndParent, hwndOwner, pszText, pszCaption, + idWindow, flStyle); + + if (rc == MBID_ERROR) + rc = 0; + if (CheckWinError(rc)) + croak_with_os2error("MessageBox"); + return rc; +} + +ULONG +myWinMessageBox2(HWND hwndParent, HWND hwndOwner, PCSZ pszText, + PCSZ pszCaption, ULONG idWindow, PMB2INFO pmb2info) +{ + ULONG rc = MessageBox2(hwndParent, hwndOwner, pszText, pszCaption, idWindow, pmb2info); + + if (rc == MBID_ERROR) + rc = 0; + if (CheckWinError(rc)) + croak_with_os2error("MessageBox2"); + return rc; +} +#endif + /* static ULONG (* APIENTRY16 pDosSmSetTitle)(ULONG, PSZ); */ ULONG _THUNK_FUNCTION(DosSmSetTitle)(ULONG, PSZ); @@ -508,7 +678,7 @@ set_title2(char *s) #endif SV * -process_swentry(unsigned long pid, unsigned long hwnd) +process_swentry(unsigned long pid, HWND hwnd) { SWENTRY swentry; @@ -660,7 +830,7 @@ cursor(int *sp, int *ep, int *wp, int *ap) VIO_FROM_VIOB; if (CheckOSError(VioGetCurType( vio, 0 ))) - croak("VioGetCurType() error"); + croak_with_os2error("VioGetCurType() error"); *sp = vio->yStart; *ep = vio->cEnd; @@ -706,7 +876,7 @@ bufsize(void) vio->cb = sizeof(*vio); if (CheckOSError(VioGetMode( vio, 0 ))) - croak("Can't get size of buffer for screen"); + croak_with_os2error("Can't get size of buffer for screen"); #if 0 /* buf=323552247, full=1118455, partial=0 */ croak("Lengths: buf=%d, full=%d, partial=%d",vio->buf_length,vio->full_length,vio->partial_length); return newSVpvn((char*)vio->buf_addr, vio->full_length); @@ -766,7 +936,7 @@ process_codepages() ULONG cps[4], cp, rc; if (CheckOSError(DosQueryCp( sizeof(cps), cps, &cp ))) - croak("DosQueryCp() error"); + croak_with_os2error("DosQueryCp()"); return cp; } @@ -776,7 +946,7 @@ out_codepage() USHORT cp, rc; if (CheckOSError(VioGetCp( 0, &cp, 0 ))) - croak("VioGetCp() error"); + croak_with_os2error("VioGetCp()"); return cp; } @@ -794,7 +964,7 @@ in_codepage() USHORT cp, rc; if (CheckOSError(KbdGetCp( 0, &cp, 0 ))) - croak("KbdGetCp() error"); + croak_with_os2error("KbdGetCp()"); return cp; } @@ -853,6 +1023,9 @@ sidOf(int pid) #define ulMPFROMSH2CH(s, c1, c2) ((unsigned long)MPFROMSH2CH(s, c1, c2)) #define ulMPFROMLONG(x) ((unsigned long)MPFROMLONG(x)) +#define _MessageBox MessageBox +#define _MessageBox2 MessageBox2 + MODULE = OS2::Process PACKAGE = OS2::Process PROTOTYPES: ENABLE @@ -904,7 +1077,7 @@ sesmgr_title_set(s) char *s SV * -process_swentry(unsigned long pid = getpid(), unsigned long hwnd = NULLHANDLE); +process_swentry(unsigned long pid = getpid(), HWND hwnd = NULLHANDLE); PROTOTYPE: DISABLE int @@ -917,27 +1090,27 @@ void ResetWinError() int -WindowText_set(unsigned long hwndFrame, char *title) +WindowText_set(HWND hwndFrame, char *title) bool -FocusWindow_set(unsigned long hwndFocus, unsigned long hwndDesktop = HWND_DESKTOP) +FocusWindow_set(HWND hwndFocus, HWND hwndDesktop = HWND_DESKTOP) bool -ShowWindow(unsigned long hwnd, bool fShow = TRUE) +ShowWindow(HWND hwnd, bool fShow = TRUE) bool -EnableWindow(unsigned long hwnd, bool fEnable = TRUE) +EnableWindow(HWND hwnd, bool fEnable = TRUE) bool -PostMsg(unsigned long hwnd, unsigned long msg, unsigned long mp1 = 0, unsigned long mp2 = 0) +PostMsg(HWND hwnd, unsigned long msg, unsigned long mp1 = 0, unsigned long mp2 = 0) C_ARGS: hwnd, msg, (MPARAM)mp1, (MPARAM)mp2 bool -WindowPos_set(unsigned long hwnd, long x, long y, unsigned long fl = SWP_MOVE, long cx = 0, long cy = 0, unsigned long hwndInsertBehind = HWND_TOP) +WindowPos_set(HWND hwnd, long x, long y, unsigned long fl = SWP_MOVE, long cx = 0, long cy = 0, HWND hwndInsertBehind = HWND_TOP) PROTOTYPE: DISABLE unsigned long -BeginEnumWindows(unsigned long hwnd) +BeginEnumWindows(HWND hwnd) bool EndEnumWindows(unsigned long henum) @@ -946,56 +1119,60 @@ unsigned long GetNextWindow(unsigned long henum) bool -IsWindowVisible(unsigned long hwnd) +IsWindowVisible(HWND hwnd) bool -IsWindowEnabled(unsigned long hwnd) +IsWindowEnabled(HWND hwnd) bool -IsWindowShowing(unsigned long hwnd) +IsWindowShowing(HWND hwnd) unsigned long -QueryWindow(unsigned long hwnd, long cmd) +QueryWindow(HWND hwnd, long cmd) unsigned long -IsChild(unsigned long hwnd, unsigned long hwndParent) +IsChild(HWND hwnd, HWND hwndParent) unsigned long -WindowFromId(unsigned long hwndParent, unsigned long id) +WindowFromId(HWND hwndParent, unsigned long id) unsigned long -WindowFromPoint(long x, long y, unsigned long hwnd = HWND_DESKTOP, bool fChildren = TRUE) +WindowFromPoint(long x, long y, HWND hwnd = HWND_DESKTOP, bool fChildren = TRUE) PROTOTYPE: DISABLE unsigned long -EnumDlgItem(unsigned long hwndDlg, unsigned long code, unsigned long hwnd = NULLHANDLE) +EnumDlgItem(HWND hwndDlg, unsigned long code, HWND hwnd = NULLHANDLE) C_ARGS: hwndDlg, hwnd, code bool -EnableWindowUpdate(unsigned long hwnd, bool fEnable = TRUE) +EnableWindowUpdate(HWND hwnd, bool fEnable = TRUE) bool -SetWindowBits(unsigned long hwnd, long index, unsigned long flData, unsigned long flMask) +SetWindowBits(HWND hwnd, long index, unsigned long flData, unsigned long flMask) bool -SetWindowPtr(unsigned long hwnd, long index, unsigned long p) +SetWindowPtr(HWND hwnd, long index, unsigned long p) C_ARGS: hwnd, index, (PVOID)p bool -SetWindowULong(unsigned long hwnd, long index, unsigned long i) +SetWindowULong(HWND hwnd, long index, unsigned long i) bool -SetWindowUShort(unsigned long hwnd, long index, unsigned short i) +SetWindowUShort(HWND hwnd, long index, unsigned short i) bool -IsWindow(unsigned long hwnd, unsigned long hab = Acquire_hab()) +IsWindow(HWND hwnd, HAB hab = Acquire_hab()) C_ARGS: hab, hwnd BOOL -ActiveWindow_set(unsigned long hwnd, unsigned long hwndDesktop = HWND_DESKTOP) +ActiveWindow_set(HWND hwnd, HWND hwndDesktop = HWND_DESKTOP) CODE: RETVAL = SetActiveWindow(hwndDesktop, hwnd); +unsigned long +LoadPointer(unsigned long idres, unsigned long hmod = 0, HWND hwndDesktop = HWND_DESKTOP) + C_ARGS: hwndDesktop, hmod, idres + int out_codepage() @@ -1039,56 +1216,173 @@ cursor(OUTLIST int stp, OUTLIST int ep, OUTLIST int wp, OUTLIST int ap) bool cursor_set(int s, int e, int w = cursor__(0), int a = cursor__(1)) +NO_OUTPUT bool +_ClipbrdData_set(unsigned long ulData, unsigned long fmt = CF_TEXT, unsigned long rgfFmtInfo = ((fmt == CF_TEXT || fmt == CF_DSPTEXT) ? CFI_POINTER : CFI_HANDLE), HAB hab = perl_hab_GET()) + PROTOTYPE: DISABLE + C_ARGS: hab, ulData, fmt, rgfFmtInfo + POSTCALL: + if (CheckWinError(RETVAL)) + croak_with_os2error("_ClipbrdData_set() error"); + +void +ClipbrdData_set(SV *text, int convert_nl = 1, unsigned long fmt = CF_TEXT, unsigned long rgfFmtInfo = ((fmt == CF_TEXT || fmt == CF_DSPTEXT) ? CFI_POINTER : CFI_HANDLE), HAB hab = perl_hab_GET()) + PROTOTYPE: DISABLE + +void +ClipbrdOwner_set(HWND hwnd, HAB hab = perl_hab_GET()) + C_ARGS: hab, hwnd + +void +ClipbrdViewer_set(HWND hwnd, HAB hab = perl_hab_GET()) + C_ARGS: hab, hwnd + +unsigned long +EnumClipbrdFmts(unsigned long fmt = 0, HAB hab = perl_hab_GET()) + C_ARGS: hab, fmt + +unsigned long +AddAtom(char *pszAtomName, HATOMTBL hAtomTbl = QuerySystemAtomTable()) + C_ARGS: hAtomTbl, pszAtomName + +unsigned long +FindAtom(char *pszAtomName, HATOMTBL hAtomTbl = QuerySystemAtomTable()) + C_ARGS: hAtomTbl, pszAtomName + +unsigned long +DeleteAtom(char *pszAtomName, HATOMTBL hAtomTbl = QuerySystemAtomTable()) + C_ARGS: hAtomTbl, pszAtomName + +void +Alarm(unsigned long rgfType = WA_ERROR, HWND hwndDesktop = HWND_DESKTOP) + C_ARGS: hwndDesktop, rgfType + +void +FlashWindow(HWND hwndFrame, bool fFlash) + MODULE = OS2::Process PACKAGE = OS2::Process PREFIX = myQuery SV * -myQueryWindowText(unsigned long hwnd) +myQueryWindowText(HWND hwnd) SV * -myQueryClassName(unsigned long hwnd) +myQueryClassName(HWND hwnd) MODULE = OS2::Process PACKAGE = OS2::Process PREFIX = Query unsigned long -QueryFocusWindow(unsigned long hwndDesktop = HWND_DESKTOP) +QueryFocusWindow(HWND hwndDesktop = HWND_DESKTOP) long -QueryWindowTextLength(unsigned long hwnd) +QueryWindowTextLength(HWND hwnd) SV * -QueryWindowSWP(unsigned long hwnd) +QueryWindowSWP(HWND hwnd) unsigned long -QueryWindowULong(unsigned long hwnd, long index) +QueryWindowULong(HWND hwnd, long index) unsigned short -QueryWindowUShort(unsigned long hwnd, long index) +QueryWindowUShort(HWND hwnd, long index) + +unsigned long +QueryActiveWindow(HWND hwnd = HWND_DESKTOP) + +unsigned long +QueryDesktopWindow(HAB hab = Acquire_hab(), unsigned long hdc = NULLHANDLE) + +unsigned long +QueryClipbrdData(unsigned long fmt = CF_TEXT, HAB hab = perl_hab_GET()) + C_ARGS: hab, fmt + PROTOTYPE: DISABLE + +unsigned long +QueryClipbrdViewer(HAB hab = perl_hab_GET()) + +unsigned long +QueryClipbrdOwner(HAB hab = perl_hab_GET()) + +void +CloseClipbrd(HAB hab = perl_hab_GET()) + +void +EmptyClipbrd(HAB hab = perl_hab_GET()) + +bool +OpenClipbrd(HAB hab = perl_hab_GET()) + +unsigned long +QueryAtomUsage(ATOM atom, HATOMTBL hAtomTbl = QuerySystemAtomTable()) + C_ARGS: hAtomTbl, atom + +unsigned long +QueryAtomLength(ATOM atom, HATOMTBL hAtomTbl = QuerySystemAtomTable()) + C_ARGS: hAtomTbl, atom + +unsigned long +QuerySystemAtomTable() + +unsigned long +QuerySysPointer(long lId, bool fCopy = 1, HWND hwndDesktop = HWND_DESKTOP) + C_ARGS: hwndDesktop, lId, fCopy unsigned long -QueryActiveWindow(unsigned long hwnd = HWND_DESKTOP) +CreateAtomTable(unsigned long initial = 0, unsigned long buckets = 0) unsigned long -QueryDesktopWindow(unsigned long hab = Acquire_hab(), unsigned long hdc = NULLHANDLE) +DestroyAtomTable(HATOMTBL hAtomTbl) + MODULE = OS2::Process PACKAGE = OS2::Process PREFIX = myWinQuery unsigned long -myWinQueryWindowPtr(unsigned long hwnd, long index) +myWinQueryWindowPtr(HWND hwnd, long index) NO_OUTPUT BOOL -myWinQueryWindowProcess(unsigned long hwnd, OUTLIST unsigned long pid, OUTLIST unsigned long tid) +myWinQueryWindowProcess(HWND hwnd, OUTLIST unsigned long pid, OUTLIST unsigned long tid) PROTOTYPE: $ POSTCALL: if (CheckWinError(RETVAL)) - croak("WindowProcess() error"); + croak_with_os2error("WindowProcess() error"); + +SV * +myWinQueryActiveDesktopPathname() + +void +myWinQueryClipbrdFmtInfo(OUTLIST unsigned long prgfFmtInfo, unsigned long fmt = CF_TEXT, HAB hab = perl_hab_GET()) + C_ARGS: hab, fmt, &prgfFmtInfo + +SV * +myWinQueryAtomName(ATOM atom, HATOMTBL hAtomTbl = QuerySystemAtomTable()) MODULE = OS2::Process PACKAGE = OS2::Process PREFIX = myWin int -myWinSwitchToProgram(unsigned long hsw) +myWinSwitchToProgram(HSWITCH hsw = switch_of(NULLHANDLE, getpid())) PREINIT: ULONG rc; +#if 0 + +unsigned long +myWinMessageBox(unsigned long pszText, char* pszCaption = "Perl script error", unsigned long flStyle = MB_CANCEL | MB_ICONHAND, HWND hwndParent = HWND_DESKTOP, HWND hwndOwner = HWND_DESKTOP, unsigned long idWindow = 0) + C_ARGS: hwndParent, hwndOwner, pszText, pszCaption, idWindow, flStyle + +#endif + +unsigned long +_MessageBox(char* pszText, char* pszCaption = "Perl script error", unsigned long flStyle = MB_CANCEL | MB_INFORMATION | MB_MOVEABLE, HWND hwndParent = HWND_DESKTOP, HWND hwndOwner = NULLHANDLE, unsigned long idWindow = 0) + C_ARGS: hwndParent, hwndOwner, pszText, pszCaption, idWindow, flStyle + POSTCALL: + if (RETVAL == MBID_ERROR) + RETVAL = 0; + +unsigned long +_MessageBox2(char *pszText, char* pmb2info, char *pszCaption, HWND hwndParent = HWND_DESKTOP, HWND hwndOwner = NULLHANDLE, unsigned long idWindow = 0) + C_ARGS: hwndParent, hwndOwner, pszText, pszCaption, idWindow, (PMB2INFO)pmb2info + POSTCALL: + if (RETVAL == MBID_ERROR) + RETVAL = 0; + MODULE = OS2::Process PACKAGE = OS2::Process PREFIX = myWinQuery MODULE = OS2::Process PACKAGE = OS2::Process PREFIX = get @@ -1109,6 +1403,12 @@ getscrsize(OUTLIST int wp, OUTLIST int hp) bool scrsize_set(int w_or_h, int h = -9999) +void +get_InvalidateRect(HWND hwnd, char *prcl, bool fIncludeChildren) + +void +get_CreateFrameControls(HWND hwndFrame, char *pfcdata, char* pszTitle) + MODULE = OS2::Process PACKAGE = OS2::Process PREFIX = ul unsigned long diff --git a/os2/OS2/REXX/DLL/DLL.pm b/os2/OS2/REXX/DLL/DLL.pm index 09e3e37..f6660d6 100644 --- a/os2/OS2/REXX/DLL/DLL.pm +++ b/os2/OS2/REXX/DLL/DLL.pm @@ -5,38 +5,16 @@ our $VERSION = '1.00'; use Carp; use XSLoader; -sub AUTOLOAD { - $AUTOLOAD =~ /^OS2::DLL::.+::(.+)$/ - or confess("Undefined subroutine &$AUTOLOAD called"); - return undef if $1 eq "DESTROY"; - $_[0]->find($1) - or confess("Can't find entry '$1' to DLL '$_[0]->{File}': $^E"); - goto &$AUTOLOAD; -} - @libs = split(/;/, $ENV{'PERL5REXX'} || $ENV{'PERLREXX'} || $ENV{'LIBPATH'} || $ENV{'PATH'}); %dlls = (); # Preloaded methods go here. Autoload methods go after __END__, and are # processed by the autosplit program. -# Cannot autoload, the autoloader is used for the REXX functions. +# Cannot be autoload, the autoloader is used for the REXX functions. -sub new { - confess 'Usage: OS2::DLL->new( [] )' unless @_ >= 2; - my ($class, $file) = (shift, shift); - my $handle; - $handle = $class->load($file, @_) and return $handle; - my $path = @_ ? " from '@_'" : ''; - my $err = DynaLoader::dl_error(); - $err =~ s/\s+at\s+\S+\s+line\s+\S+\s*\z//; - croak "Can't load '$file'$path: $err"; -} - -sub load -{ - confess 'Usage: load OS2::DLL []' unless $#_ >= 1; - my ($class, $file, @where) = (@_, @libs); +my $load_with_dirs = sub { + my ($class, $file, @where) = (@_); return $dlls{$file} if $dlls{$file}; my $handle; foreach (@where) { @@ -45,41 +23,81 @@ sub load } $handle = DynaLoader::dl_load_file($file) unless $handle; return undef unless $handle; - my $packs = $INC{'OS2/REXX.pm'} ? 'OS2::DLL OS2::REXX' : 'OS2::DLL'; - eval < $handle, File => $file, Queue => 'SESSION' }, - "OS2::DLL::$file"; + bless {Handle => $handle, File => $file, Queue => 'SESSION' }, $p; +}; + +my $new_dll = sub { + my ($dirs, $class, $file) = (shift, shift, shift); + my $handle; + push @_, @libs if $dirs; + $handle = $load_with_dirs->($class, $file, @_) + and return $handle; + my $path = @_ ? " from '@_'" : ''; + my $err = DynaLoader::dl_error(); + $err =~ s/\s+at\s+\S+\s+line\s+\S+\s*\z//; + croak "Can't load '$file'$path: $err"; +}; + +sub new { + confess 'Usage: OS2::DLL->new( [] )' unless @_ >= 2; + $new_dll->(1, @_); } -sub find -{ +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); +} + +package OS2::DLL::dll; +use Carp; +@ISA = 'OS2::DLL'; + +sub AUTOLOAD { + $AUTOLOAD =~ /^OS2::DLL::dll::.+::(.+)$/ + or confess("Undefined subroutine &$AUTOLOAD called"); + return undef if $1 eq "DESTROY"; + die "AUTOLOAD loop" if $1 eq "AUTOLOAD"; + $_[0]->find($1) or confess($@); + goto &$AUTOLOAD; +} + +sub wrapper_REXX { + confess 'Usage: $dllhandle->wrapper_REXX($func_name)' unless @_ == 2; my $self = shift; my $file = $self->{File}; my $handle = $self->{Handle}; my $prefix = exists($self->{Prefix}) ? $self->{Prefix} : ""; my $queue = $self->{Queue}; - foreach (@_) { - my $name = "OS2::DLL::${file}::$_"; - next if defined(&$name); - my $addr = DynaLoader::dl_find_symbol($handle, uc $prefix.$_) - || DynaLoader::dl_find_symbol($handle, $prefix.$_) - or return 0; - eval <{File}; + my $p = ref $self; + foreach (@_) { + my $f = eval {$self->wrapper_REXX($_)} or return 0; + ${"${p}::"}{$_} = sub { shift; $f->(@_) }; } return 1; } @@ -102,45 +120,124 @@ See documentation of L module if you need the variable pool. =head1 SYNOPSIS use OS2::DLL; - $emx_dll = OS2::DLL->load('emx'); + $emx_dll = OS2::DLL->module('emx'); $emx_version = $emx_dll->emx_revision(); + $func_emx_version = $emx_dll->wrapper_REXX('#128'); # emx_revision + $emx_version = $func_emx_version->(); =head1 DESCRIPTION -=head2 Load REXX DLL +=head2 Create a DLL handle - $dll = load OS2::DLL NAME [, WHERE]; + $dll = OS2::DLL->module( NAME [, WHERE] ); -NAME is DLL name, without path and extension. +Loads an OS/2 module NAME, looking in directories WHERE (adding the +extension F<.dll>), if the DLL is not found there, loads in the usual OS/2 way +(via LIBPATH and other settings). Croaks with a verbose report on failure. -Directories are searched WHERE first (list of dirs), then environment -paths PERL5REXX, PERLREXX, PATH or, as last resort, OS/2-ish search -is performed in default DLL path (without adding paths and extensions). +The DLL is not unloaded when the return value is destroyed. -The DLL is not unloaded when the variable dies. +=head2 Create a DLL handle (looking in some strange locations) -Returns DLL object reference, or undef on failure (in this case one can -get the reason via C). + $dll = OS2::DLL->new( NAME [, WHERE] ); -=head2 Create a REXX DLL handle +Same as L|Create a DLL handle>, but in addition to WHERE, looks +in environment paths PERL5REXX, PERLREXX, PATH (provided for backward +compatibility). - $dll = OS2::DLL->new( NAME [, WHERE] ); +=head2 Loads DLL by name -Same as L|Load REXX DLL>, but croaks with a meaningful message on -failure. + $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. +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 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() -=head2 Call external REXX function: + $res = call20_Win_0OK_survive( $pointer, $arg0, $arg1, ...); + if ($res == 0 and $^E) { # Do error processing here + } - $dll->function(arguments); +[Good for some of C API.] -Returns the return string if the return code is 0, else undef. -Dies with error message if the function is not available. +=back =head1 ENVIRONMENT @@ -149,7 +246,7 @@ in C, C, C. =head1 AUTHOR -Extracted by Ilya Zakharevich ilya@math.ohio-state.edu from L +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 index c8e7c58..90b14ea 100644 --- a/os2/OS2/REXX/DLL/DLL.xs +++ b/os2/OS2/REXX/DLL/DLL.xs @@ -21,12 +21,112 @@ needstrs(int n) } } +typedef ULONG (*fptr_UL_20)(ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG); +typedef __attribute__((regparm(3))) ULONG (*fptr_UL_20_rp3)(ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG, ULONG); + +static inline unsigned long +call20_p(unsigned long fp, char* str) +{ + ULONG *argv = (ULONG*)str; + fptr_UL_20 f = (fptr_UL_20)fp; + + return f(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5], argv[6], argv[7], argv[8], argv[9], argv[10], argv[11], argv[12], argv[13], argv[14], argv[15], argv[16], argv[17], argv[18], argv[19]); +} + +static inline unsigned long +call20(unsigned long fp, unsigned long arg0, unsigned long arg1, unsigned long arg2, unsigned long arg3, unsigned long arg4, unsigned long arg5, unsigned long arg6, unsigned long arg7, unsigned long arg8, unsigned long arg9, unsigned long arg10, unsigned long arg11, unsigned long arg12, unsigned long arg13, unsigned long arg14, unsigned long arg15, unsigned long arg16, unsigned long arg17, unsigned long arg18, unsigned long arg19) +{ + fptr_UL_20 f = (fptr_UL_20)fp; + + return f(arg0, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8, arg9, arg10, arg11, arg12, arg13, arg14, arg15, arg16, arg17, arg18, arg19); +} + +static inline unsigned long +call20_rp3_p(unsigned long fp, char* str) +{ + ULONG *argv = (ULONG*)str; + fptr_UL_20_rp3 f = (fptr_UL_20_rp3)fp; + + return f(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5], argv[6], argv[7], argv[8], argv[9], argv[10], argv[11], argv[12], argv[13], argv[14], argv[15], argv[16], argv[17], argv[18], argv[19]); +} + +static inline unsigned long +call20_rp3(unsigned long fp, unsigned long arg0, unsigned long arg1, unsigned long arg2, unsigned long arg3, unsigned long arg4, unsigned long arg5, unsigned long arg6, unsigned long arg7, unsigned long arg8, unsigned long arg9, unsigned long arg10, unsigned long arg11, unsigned long arg12, unsigned long arg13, unsigned long arg14, unsigned long arg15, unsigned long arg16, unsigned long arg17, unsigned long arg18, unsigned long arg19) +{ + fptr_UL_20_rp3 f = (fptr_UL_20_rp3)fp; + + return f(arg0, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8, arg9, arg10, arg11, arg12, arg13, arg14, arg15, arg16, arg17, arg18, arg19); +} + +static inline void +call20_Dos(char *msg, unsigned long fp, unsigned long arg0, unsigned long arg1, unsigned long arg2, unsigned long arg3, unsigned long arg4, unsigned long arg5, unsigned long arg6, unsigned long arg7, unsigned long arg8, unsigned long arg9, unsigned long arg10, unsigned long arg11, unsigned long arg12, unsigned long arg13, unsigned long arg14, unsigned long arg15, unsigned long arg16, unsigned long arg17, unsigned long arg18, unsigned long arg19) +{ + fptr_UL_20 f = (fptr_UL_20)fp; + ULONG rc; + + if (CheckOSError(f(arg0, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8, arg9, arg10, arg11, arg12, arg13, arg14, arg15, arg16, arg17, arg18, arg19))) + croak_with_os2error(msg); +} + +static inline unsigned long +call20_Win(char *msg, unsigned long fp, unsigned long arg0, unsigned long arg1, unsigned long arg2, unsigned long arg3, unsigned long arg4, unsigned long arg5, unsigned long arg6, unsigned long arg7, unsigned long arg8, unsigned long arg9, unsigned long arg10, unsigned long arg11, unsigned long arg12, unsigned long arg13, unsigned long arg14, unsigned long arg15, unsigned long arg16, unsigned long arg17, unsigned long arg18, unsigned long arg19) +{ + fptr_UL_20 f = (fptr_UL_20)fp; + + if (CheckWinError(f(arg0, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8, arg9, arg10, arg11, arg12, arg13, arg14, arg15, arg16, arg17, arg18, arg19))) + croak_with_os2error(msg); +} + +static inline unsigned long +call20_Win_0OK(char *msg, unsigned long fp, unsigned long arg0, unsigned long arg1, unsigned long arg2, unsigned long arg3, unsigned long arg4, unsigned long arg5, unsigned long arg6, unsigned long arg7, unsigned long arg8, unsigned long arg9, unsigned long arg10, unsigned long arg11, unsigned long arg12, unsigned long arg13, unsigned long arg14, unsigned long arg15, unsigned long arg16, unsigned long arg17, unsigned long arg18, unsigned long arg19) +{ + fptr_UL_20 f = (fptr_UL_20)fp; + + ResetWinError(); + return SaveCroakWinError(f(arg0, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8, arg9, arg10, arg11, arg12, arg13, arg14, arg15, arg16, arg17, arg18, arg19), + 1 /* Die on error */, /* No prefix */, msg); +} + +static inline unsigned long +call20_Win_0OK_survive(unsigned long fp, unsigned long arg0, unsigned long arg1, unsigned long arg2, unsigned long arg3, unsigned long arg4, unsigned long arg5, unsigned long arg6, unsigned long arg7, unsigned long arg8, unsigned long arg9, unsigned long arg10, unsigned long arg11, unsigned long arg12, unsigned long arg13, unsigned long arg14, unsigned long arg15, unsigned long arg16, unsigned long arg17, unsigned long arg18, unsigned long arg19) +{ + fptr_UL_20 f = (fptr_UL_20)fp; + + ResetWinError(); + return SaveCroakWinError(f(arg0, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8, arg9, arg10, arg11, arg12, arg13, arg14, arg15, arg16, arg17, arg18, arg19), + 0 /* No die on error */, /* No prefix */, "N/A"); +} + MODULE = OS2::DLL PACKAGE = OS2::DLL BOOT: needstrs(8); trace = getenv("PERL_REXX_DEBUG"); +unsigned long +call20_p(unsigned long fp, char* argv) + +unsigned long +call20(unsigned long fp, unsigned long arg0 = 0, unsigned long arg1 = 0, unsigned long arg2 = 0, unsigned long arg3 = 0, unsigned long arg4 = 0, unsigned long arg5 = 0, unsigned long arg6 = 0, unsigned long arg7 = 0, unsigned long arg8 = 0, unsigned long arg9 = 0, unsigned long arg10 = 0, unsigned long arg11 = 0, unsigned long arg12 = 0, unsigned long arg13 = 0, unsigned long arg14 = 0, unsigned long arg15 = 0, unsigned long arg16 = 0, unsigned long arg17 = 0, unsigned long arg18 = 0, unsigned long arg19 = 0) + +void +call20_Dos(char* msg, unsigned long fp, unsigned long arg0 = 0, unsigned long arg1 = 0, unsigned long arg2 = 0, unsigned long arg3 = 0, unsigned long arg4 = 0, unsigned long arg5 = 0, unsigned long arg6 = 0, unsigned long arg7 = 0, unsigned long arg8 = 0, unsigned long arg9 = 0, unsigned long arg10 = 0, unsigned long arg11 = 0, unsigned long arg12 = 0, unsigned long arg13 = 0, unsigned long arg14 = 0, unsigned long arg15 = 0, unsigned long arg16 = 0, unsigned long arg17 = 0, unsigned long arg18 = 0, unsigned long arg19 = 0) + +unsigned long +call20_Win(char *msg, unsigned long fp, unsigned long arg0 = 0, unsigned long arg1 = 0, unsigned long arg2 = 0, unsigned long arg3 = 0, unsigned long arg4 = 0, unsigned long arg5 = 0, unsigned long arg6 = 0, unsigned long arg7 = 0, unsigned long arg8 = 0, unsigned long arg9 = 0, unsigned long arg10 = 0, unsigned long arg11 = 0, unsigned long arg12 = 0, unsigned long arg13 = 0, unsigned long arg14 = 0, unsigned long arg15 = 0, unsigned long arg16 = 0, unsigned long arg17 = 0, unsigned long arg18 = 0, unsigned long arg19 = 0) + +unsigned long +call20_Win_0OK(char *msg, unsigned long fp, unsigned long arg0 = 0, unsigned long arg1 = 0, unsigned long arg2 = 0, unsigned long arg3 = 0, unsigned long arg4 = 0, unsigned long arg5 = 0, unsigned long arg6 = 0, unsigned long arg7 = 0, unsigned long arg8 = 0, unsigned long arg9 = 0, unsigned long arg10 = 0, unsigned long arg11 = 0, unsigned long arg12 = 0, unsigned long arg13 = 0, unsigned long arg14 = 0, unsigned long arg15 = 0, unsigned long arg16 = 0, unsigned long arg17 = 0, unsigned long arg18 = 0, unsigned long arg19 = 0) + +unsigned long +call20_Win_0OK_survive(unsigned long fp, unsigned long arg0 = 0, unsigned long arg1 = 0, unsigned long arg2 = 0, unsigned long arg3 = 0, unsigned long arg4 = 0, unsigned long arg5 = 0, unsigned long arg6 = 0, unsigned long arg7 = 0, unsigned long arg8 = 0, unsigned long arg9 = 0, unsigned long arg10 = 0, unsigned long arg11 = 0, unsigned long arg12 = 0, unsigned long arg13 = 0, unsigned long arg14 = 0, unsigned long arg15 = 0, unsigned long arg16 = 0, unsigned long arg17 = 0, unsigned long arg18 = 0, unsigned long arg19 = 0) + +unsigned long +call20_rp3_p(unsigned long fp, char* argv) + +unsigned long +call20_rp3(unsigned long fp, unsigned long arg0 = 0, unsigned long arg1 = 0, unsigned long arg2 = 0, unsigned long arg3 = 0, unsigned long arg4 = 0, unsigned long arg5 = 0, unsigned long arg6 = 0, unsigned long arg7 = 0, unsigned long arg8 = 0, unsigned long arg9 = 0, unsigned long arg10 = 0, unsigned long arg11 = 0, unsigned long arg12 = 0, unsigned long arg13 = 0, unsigned long arg14 = 0, unsigned long arg15 = 0, unsigned long arg16 = 0, unsigned long arg17 = 0, unsigned long arg18 = 0, unsigned long arg19 = 0) + SV * _call(name, address, queue="SESSION", ...) char * name diff --git a/os2/OS2/REXX/t/rx_emxrv.t b/os2/OS2/REXX/t/rx_emxrv.t index d51e1b0..5df8c32 100644 --- a/os2/OS2/REXX/t/rx_emxrv.t +++ b/os2/OS2/REXX/t/rx_emxrv.t @@ -8,7 +8,7 @@ BEGIN { } } -print "1..5\n"; +print "1..20\n"; require OS2::DLL; print "ok 1\n"; @@ -22,3 +22,40 @@ print "ok 4\n"; $reason = ''; $emx_version >= 99 and $reason = ' # skipped: version of EMX 100 or more'; # Be safe print "ok 5$reason\n"; + +$emx_fullname = OS2::DLLname 0x202, $emx_dll->{Handle}; # Handle ==> fullname +print "ok 6\n"; +$emx_dll1 = OS2::DLL->module($emx_fullname); +print "ok 7\n"; +$emx_dll->{Handle} == $emx_dll1->{Handle} or print "not "; +print "ok 8\n"; + +$emx_version1 = $emx_dll1->emx_revision(); +print "ok 9\n"; +$emx_version1 eq $emx_version or print "not "; +print "ok 10\n"; + +$emx_revision = $emx_dll->wrapper_REXX('emx_revision'); +print "ok 11\n"; +$emx_version2 = $emx_revision->(); +print "ok 12\n"; +$emx_version2 eq $emx_version or print "not "; +print "ok 13\n"; + +$emx_revision1 = $emx_dll1->wrapper_REXX('#128'); +print "ok 14\n"; +$emx_version3 = $emx_revision1->(); +print "ok 15\n"; +$emx_version3 eq $emx_version or print "not "; +print "ok 16\n"; + +($emx_fullname1 = $emx_fullname) =~ s,/,\\,g; +$emx_dll2 = OS2::DLL->new($emx_fullname1); +print "ok 17\n"; +$emx_dll->{Handle} == $emx_dll2->{Handle} or print "not "; +print "ok 18\n"; + +$emx_version4 = $emx_dll2->emx_revision(); +print "ok 19\n"; +$emx_version4 eq $emx_version or print "not "; +print "ok 20\n"; diff --git a/os2/OS2/REXX/t/rx_objcall.t b/os2/OS2/REXX/t/rx_objcall.t index b115475..0ec67b1 100644 --- a/os2/OS2/REXX/t/rx_objcall.t +++ b/os2/OS2/REXX/t/rx_objcall.t @@ -30,4 +30,9 @@ print "ok 4\n" if $res[0] == $$; print "# @pid\n"; eval { $rxu->nixda(); }; -print "ok 5\n" if $@ =~ /^Can't find entry 'nixda\'/; +my $err = $@; +if ($err) { + $err =~ s/\n/\n#\t/g; + print "# \$\@ = '$err'\n"; +} +print "ok 5\n" if $@ =~ /^Can't find symbol `nixda\'/; diff --git a/os2/OS2/PrfDB/typemap b/os2/OS2/typemap similarity index 54% rename from os2/OS2/PrfDB/typemap rename to os2/OS2/typemap index eb2722b..b6f0e07 100644 --- a/os2/OS2/PrfDB/typemap +++ b/os2/OS2/typemap @@ -1,14 +1,28 @@ BOOL T_IV -ULONG T_IV -HINI T_IV -HAB T_IV +ULONG T_UV +HINI T_UV +HAB T_UV +HWND T_UV +ATOM T_UV +HATOMTBL T_UV +HSWITCH T_UV +ULONG T_UV +USHORT T_UV +LONG T_IV +SHORT T_IV + PSZ T_PVNULL +PCSZ T_PVNULLC ############################################################################# INPUT T_PVNULL $var = ( SvOK($arg) ? ($type)SvPV($arg,PL_na) : NULL ) +T_PVNULLC + $var = ( SvOK($arg) ? ($type)SvPV($arg,PL_na) : NULL ) ############################################################################# OUTPUT T_PVNULL sv_setpv((SV*)$arg, $var); +T_PVNULLC + NOTIMPLEMENTED diff --git a/os2/dl_os2.c b/os2/dl_os2.c index b698451..76fa9dc 100644 --- a/os2/dl_os2.c +++ b/os2/dl_os2.c @@ -4,10 +4,15 @@ #define INCL_BASE #include +#include +#include static ULONG retcode; static char fail[300]; +static ULONG dllHandle; +static int handle_found; +static int handle_loaded; #ifdef PERL_CORE #include "EXTERN.h" @@ -19,6 +24,57 @@ char *os2error(int rc); #endif +#ifdef DLOPEN_INITTERM +unsigned long _DLL_InitTerm(unsigned long modHandle, unsigned long flag) +{ + switch (flag) { + case 0: /* INIT */ + /* Save handle */ + dllHandle = modHandle; + handle_found = 1; + return TRUE; + + case 1: /* TERM */ + handle_found = 0; + dllHandle = (unsigned long)NULLHANDLE; + return TRUE; + } + + return FALSE; +} + +#endif + +HMODULE +find_myself(void) +{ + + static APIRET APIENTRY (*pDosQueryModFromEIP) (HMODULE * hmod, ULONG * obj, ULONG BufLen, PCHAR Buf, + ULONG * Offset, ULONG Address); + HMODULE doscalls_h, mod; + static int failed; + ULONG obj, offset, rc; + char buf[260]; + + if (failed) + return 0; + failed = 1; + doscalls_h = (HMODULE)dlopen("DOSCALLS",0); + if (!doscalls_h) + return 0; +/* {&doscalls_handle, NULL, 360}, */ /* DosQueryModFromEIP */ + rc = DosQueryProcAddr(doscalls_h, 360, 0, (PFN*)&pDosQueryModFromEIP); + if (rc) + return 0; + rc = pDosQueryModFromEIP(&mod, &obj, sizeof(buf), buf, &offset, (ULONG)dlopen); + if (rc) + return 0; + failed = 0; + handle_found = 1; + dllHandle = mod; + return mod; +} + void * dlopen(const char *path, int mode) { @@ -26,10 +82,36 @@ dlopen(const char *path, int mode) char tmp[260]; const char *beg, *dot; ULONG rc; + unsigned fpflag = _control87(0,0); fail[0] = 0; + if (!path) { /* Our own handle. */ + if (handle_found || find_myself()) { + char dllname[260]; + + if (handle_loaded) + return (void*)dllHandle; + rc = DosQueryModuleName(dllHandle, sizeof(dllname), dllname); + if (rc) { + strcpy(fail, "can't find my DLL name by the handle"); + retcode = rc; + return 0; + } + rc = DosLoadModule(fail, sizeof fail, dllname, &handle); + if (rc) { + strcpy(fail, "can't load my own DLL"); + retcode = rc; + return 0; + } + handle_loaded = 1; + goto ret; + } + retcode = ERROR_MOD_NOT_FOUND; + strcpy(fail, "can't load from myself: compiled without -DDLOPEN_INITTERM"); + return 0; + } if ((rc = DosLoadModule(fail, sizeof fail, (char*)path, &handle)) == 0) - return (void *)handle; + goto ret; retcode = rc; @@ -49,12 +131,17 @@ dlopen(const char *path, int mode) memmove(tmp, path, n); memmove(tmp+n, dot, strlen(dot)+1); if (DosLoadModule(fail, sizeof fail, tmp, &handle) == 0) - return (void *)handle; + goto ret; } + handle = 0; - return NULL; + ret: + _control87(fpflag, MCW_EM); /* Some modules reset FP flags on load */ + return (void *)handle; } +#define ERROR_WRONG_PROCTYPE 0xffffffff + void * dlsym(void *handle, const char *symbol) { @@ -67,7 +154,7 @@ dlsym(void *handle, const char *symbol) rc = DosQueryProcType((HMODULE)handle, 0, symbol, &type); if (rc == 0 && type == PT_32BIT) return (void *)addr; - rc = ERROR_CALL_NOT_IMPLEMENTED; + rc = ERROR_WRONG_PROCTYPE; } retcode = rc; return NULL; @@ -82,12 +169,15 @@ dlerror(void) if (retcode == 0) return NULL; - err = os2error(retcode); + if (retcode == ERROR_WRONG_PROCTYPE) + err = "Wrong procedure type"; + else + err = os2error(retcode); len = strlen(err); if (len > sizeof(buf) - 1) len = sizeof(buf) - 1; strncpy(buf, err, len+1); - if (fail[0] && len < 300) + if (fail[0] && len + strlen(fail) < sizeof(buf) - 100) sprintf(buf + len, ", possible problematic module: '%s'", fail); retcode = 0; return buf; diff --git a/os2/os2.c b/os2/os2.c index 0490449..bf8891b 100644 --- a/os2/os2.c +++ b/os2/os2.c @@ -3,6 +3,8 @@ #define INCL_DOSFILEMGR #define INCL_DOSMEMMGR #define INCL_DOSERRORS +#define INCL_WINERRORS +#define INCL_WINSYS /* These 3 are needed for compile if os2.h includes os2tk.h, not os2emx.h */ #define INCL_DOSPROCESS #define SPU_DISABLESUPPRESSION 0 @@ -30,6 +32,173 @@ #include "EXTERN.h" #include "perl.h" +void +croak_with_os2error(char *s) +{ + Perl_croak_nocontext("%s: %s", s, os2error(Perl_rc)); +} + +struct PMWIN_entries_t PMWIN_entries; + +/*****************************************************************************/ +/* 2.1 would not resolve symbols on demand, and has no ExtLIBPATH. */ + +struct dll_handle_t { + const char *modname; + HMODULE handle; + int requires_pm; +}; + +static struct dll_handle_t dll_handles[] = { + {"doscalls", 0, 0}, + {"tcp32dll", 0, 0}, + {"pmwin", 0, 1}, + {"rexx", 0, 0}, + {"rexxapi", 0, 0}, + {"sesmgr", 0, 0}, + {"pmshapi", 0, 1}, + {"pmwp", 0, 1}, + {"pmgpi", 0, 1}, + {NULL, 0}, +}; + +enum dll_handle_e { + dll_handle_doscalls, + dll_handle_tcp32dll, + dll_handle_pmwin, + dll_handle_rexx, + dll_handle_rexxapi, + dll_handle_sesmgr, + dll_handle_pmshapi, + dll_handle_pmwp, + dll_handle_pmgpi, + dll_handle_LAST, +}; + +#define doscalls_handle (dll_handles[dll_handle_doscalls]) +#define tcp_handle (dll_handles[dll_handle_tcp32dll]) +#define pmwin_handle (dll_handles[dll_handle_pmwin]) +#define rexx_handle (dll_handles[dll_handle_rexx]) +#define rexxapi_handle (dll_handles[dll_handle_rexxapi]) +#define sesmgr_handle (dll_handles[dll_handle_sesmgr]) +#define pmshapi_handle (dll_handles[dll_handle_pmshapi]) +#define pmwp_handle (dll_handles[dll_handle_pmwp]) +#define pmgpi_handle (dll_handles[dll_handle_pmgpi]) + +/* The following local-scope data is not yet included: + fargs.140 // const => OK + ino.165 // locked - and the access is almost cosmetic + layout_table.260 // startup only, locked + osv_res.257 // startup only, locked + old_esp.254 // startup only, locked + priors // const ==> OK + use_my_flock.283 // locked + emx_init_done.268 // locked + dll_handles // locked + hmtx_emx_init.267 // THIS is the lock for startup + perlos2_state_mutex // THIS is the lock for all the rest +BAD: + perlos2_state // see below +*/ +/* The following global-scope data is not yet included: + OS2_Perl_data + pthreads_states // const now? + start_thread_mutex + thread_join_count // protected + thread_join_data // protected + tmppath + + pDosVerifyPidTid + + Perl_OS2_init3() - should it be protected? +*/ +OS2_Perl_data_t OS2_Perl_data; + +static struct perlos2_state_t { + int po2__my_pwent; /* = -1; */ + int po2_DOS_harderr_state; /* = -1; */ + signed char po2_DOS_suppression_state; /* = -1; */ + PFN po2_ExtFCN[ORD_NENTRIES]; /* Labeled by ord ORD_*. */ +/* struct PMWIN_entries_t po2_PMWIN_entries; */ + + int po2_emx_wasnt_initialized; + + char po2_fname[9]; + int po2_rmq_cnt; + + int po2_grent_cnt; + + char *po2_newp; + char *po2_oldp; + int po2_newl; + int po2_oldl; + int po2_notfound; + char po2_mangle_ret[STATIC_FILE_LENGTH+1]; + ULONG po2_os2_dll_fake; + ULONG po2_os2_mytype; + ULONG po2_os2_mytype_ini; + int po2_pidtid_lookup; + struct passwd po2_pw; + + int po2_pwent_cnt; + char po2_pthreads_state_buf[80]; + char po2_os2error_buf[300]; +/* There is no big sense to make it thread-specific, since signals + are delivered to thread 1 only. XXXX Maybe make it into an array? */ + int po2_spawn_pid; + int po2_spawn_killed; + + jmp_buf po2_at_exit_buf; + int po2_longjmp_at_exit; + int po2_emx_runtime_init; /* If 1, we need to manually init it */ + int po2_emx_exception_init; /* If 1, we need to manually set it */ + int po2_emx_runtime_secondary; + +} perlos2_state = { + -1, /* po2__my_pwent */ + -1, /* po2_DOS_harderr_state */ + -1, /* po2_DOS_suppression_state */ +}; + +#define Perl_po2() (&perlos2_state) + +#define ExtFCN (Perl_po2()->po2_ExtFCN) +/* #define PMWIN_entries (Perl_po2()->po2_PMWIN_entries) */ +#define emx_wasnt_initialized (Perl_po2()->po2_emx_wasnt_initialized) +#define fname (Perl_po2()->po2_fname) +#define rmq_cnt (Perl_po2()->po2_rmq_cnt) +#define grent_cnt (Perl_po2()->po2_grent_cnt) +#define newp (Perl_po2()->po2_newp) +#define oldp (Perl_po2()->po2_oldp) +#define newl (Perl_po2()->po2_newl) +#define oldl (Perl_po2()->po2_oldl) +#define notfound (Perl_po2()->po2_notfound) +#define mangle_ret (Perl_po2()->po2_mangle_ret) +#define os2_dll_fake (Perl_po2()->po2_os2_dll_fake) +#define os2_mytype (Perl_po2()->po2_os2_mytype) +#define os2_mytype_ini (Perl_po2()->po2_os2_mytype_ini) +#define pidtid_lookup (Perl_po2()->po2_pidtid_lookup) +#define pw (Perl_po2()->po2_pw) +#define pwent_cnt (Perl_po2()->po2_pwent_cnt) +#define _my_pwent (Perl_po2()->po2__my_pwent) +#define pthreads_state_buf (Perl_po2()->po2_pthreads_state_buf) +#define os2error_buf (Perl_po2()->po2_os2error_buf) +/* There is no big sense to make it thread-specific, since signals + are delivered to thread 1 only. XXXX Maybe make it into an array? */ +#define spawn_pid (Perl_po2()->po2_spawn_pid) +#define spawn_killed (Perl_po2()->po2_spawn_killed) +#define DOS_harderr_state (Perl_po2()->po2_DOS_harderr_state) +#define DOS_suppression_state (Perl_po2()->po2_DOS_suppression_state) + +#define at_exit_buf (Perl_po2()->po2_at_exit_buf) +#define longjmp_at_exit (Perl_po2()->po2_longjmp_at_exit) +#define emx_runtime_init (Perl_po2()->po2_emx_runtime_init) +#define emx_exception_init (Perl_po2()->po2_emx_exception_init) +#define emx_runtime_secondary (Perl_po2()->po2_emx_runtime_secondary) + +const Perl_PFN * const pExtFCN = (Perl_po2()->po2_ExtFCN); + + #if defined(USE_5005THREADS) || defined(USE_ITHREADS) typedef void (*emx_startroutine)(void *); @@ -44,7 +213,7 @@ enum pthreads_state { pthreads_st_norun, pthreads_st_exited_waited, }; -const char *pthreads_states[] = { +const char * const pthreads_states[] = { "uninit", "running", "exited", @@ -60,10 +229,9 @@ static const char* pthreads_state_string(enum pthreads_state state) { if (state < 0 || state >= sizeof(pthreads_states)/sizeof(*pthreads_states)) { - static char buf[80]; - - snprintf(buf, sizeof(buf), "unknown thread state %d", (int)state); - return buf; + snprintf(pthreads_state_buf, sizeof(pthreads_state_buf), + "unknown thread state %d", (int)state); + return pthreads_state_buf; } return pthreads_states[state]; } @@ -77,6 +245,8 @@ typedef struct { thread_join_t *thread_join_data; int thread_join_count; perl_mutex start_thread_mutex; +static perl_mutex perlos2_state_mutex; + int pthread_join(perl_os_thread tid, void **status) @@ -304,11 +474,11 @@ os2_cond_wait(perl_cond *c, perl_mutex *m) int rc; STRLEN n_a; if ((rc = DosResetEventSem(*c,&n_a)) && (rc != ERROR_ALREADY_RESET)) - Perl_croak_nocontext("panic: COND_WAIT-reset: rc=%i", rc); + Perl_rc = rc, croak_with_os2error("panic: COND_WAIT-reset"); if (m) MUTEX_UNLOCK(m); if (CheckOSError(DosWaitEventSem(*c,SEM_INDEFINITE_WAIT)) && (rc != ERROR_INTERRUPT)) - Perl_croak_nocontext("panic: COND_WAIT: rc=%i", rc); + croak_with_os2error("panic: COND_WAIT"); if (rc == ERROR_INTERRUPT) errno = EINTR; if (m) MUTEX_LOCK(m); @@ -318,28 +488,12 @@ os2_cond_wait(perl_cond *c, perl_mutex *m) static int exe_is_aout(void); -/*****************************************************************************/ -/* 2.1 would not resolve symbols on demand, and has no ExtLIBPATH. */ -#define C_ARR_LEN(sym) (sizeof(sym)/sizeof(*sym)) - -struct dll_handle { - const char *modname; - HMODULE handle; -}; -static struct dll_handle doscalls_handle = {"doscalls", 0}; -static struct dll_handle tcp_handle = {"tcp32dll", 0}; -static struct dll_handle pmwin_handle = {"pmwin", 0}; -static struct dll_handle rexx_handle = {"rexx", 0}; -static struct dll_handle rexxapi_handle = {"rexxapi", 0}; -static struct dll_handle sesmgr_handle = {"sesmgr", 0}; -static struct dll_handle pmshapi_handle = {"pmshapi", 0}; - /* This should match enum entries_ordinals defined in os2ish.h. */ static const struct { - struct dll_handle *dll; + struct dll_handle_t *dll; const char *entryname; int entrypoint; -} loadOrdinals[ORD_NENTRIES] = { +} loadOrdinals[] = { {&doscalls_handle, NULL, 874}, /* DosQueryExtLibpath */ {&doscalls_handle, NULL, 873}, /* DosSetExtLibpath */ {&doscalls_handle, NULL, 460}, /* DosVerifyPidTid */ @@ -427,12 +581,46 @@ static const struct { {&pmwin_handle, NULL, 813}, /* WinQueryDesktopWindow */ {&pmwin_handle, NULL, 851}, /* WinSetActiveWindow */ {&doscalls_handle, NULL, 360}, /* DosQueryModFromEIP */ + {&doscalls_handle, NULL, 582}, /* Dos32QueryHeaderInfo */ + {&doscalls_handle, NULL, 362}, /* DosTmrQueryFreq */ + {&doscalls_handle, NULL, 363}, /* DosTmrQueryTime */ + {&pmwp_handle, NULL, 262}, /* WinQueryActiveDesktopPathname */ + {&pmwin_handle, NULL, 765}, /* WinInvalidateRect */ + {&pmwin_handle, NULL, 906}, /* WinCreateFrameControl */ + {&pmwin_handle, NULL, 807}, /* WinQueryClipbrdFmtInfo */ + {&pmwin_handle, NULL, 808}, /* WinQueryClipbrdOwner */ + {&pmwin_handle, NULL, 809}, /* WinQueryClipbrdViewer */ + {&pmwin_handle, NULL, 806}, /* WinQueryClipbrdData */ + {&pmwin_handle, NULL, 793}, /* WinOpenClipbrd */ + {&pmwin_handle, NULL, 707}, /* WinCloseClipbrd */ + {&pmwin_handle, NULL, 854}, /* WinSetClipbrdData */ + {&pmwin_handle, NULL, 855}, /* WinSetClipbrdOwner */ + {&pmwin_handle, NULL, 856}, /* WinSetClipbrdViewer */ + {&pmwin_handle, NULL, 739}, /* WinEnumClipbrdFmts */ + {&pmwin_handle, NULL, 733}, /* WinEmptyClipbrd */ + {&pmwin_handle, NULL, 700}, /* WinAddAtom */ + {&pmwin_handle, NULL, 744}, /* WinFindAtom */ + {&pmwin_handle, NULL, 721}, /* WinDeleteAtom */ + {&pmwin_handle, NULL, 803}, /* WinQueryAtomUsage */ + {&pmwin_handle, NULL, 802}, /* WinQueryAtomName */ + {&pmwin_handle, NULL, 801}, /* WinQueryAtomLength */ + {&pmwin_handle, NULL, 830}, /* WinQuerySystemAtomTable */ + {&pmwin_handle, NULL, 714}, /* WinCreateAtomTable */ + {&pmwin_handle, NULL, 724}, /* WinDestroyAtomTable */ + {&pmwin_handle, NULL, 794}, /* WinOpenWindowDC */ + {&pmgpi_handle, NULL, 610}, /* DevOpenDC */ + {&pmgpi_handle, NULL, 606}, /* DevQueryCaps */ + {&pmgpi_handle, NULL, 604}, /* DevCloseDC */ + {&pmwin_handle, NULL, 789}, /* WinMessageBox */ + {&pmwin_handle, NULL, 1015}, /* WinMessageBox2 */ + {&pmwin_handle, NULL, 829}, /* WinQuerySysValue */ + {&pmwin_handle, NULL, 873}, /* WinSetSysValue */ + {&pmwin_handle, NULL, 701}, /* WinAlarm */ + {&pmwin_handle, NULL, 745}, /* WinFlashWindow */ + {&pmwin_handle, NULL, 780}, /* WinLoadPointer */ + {&pmwin_handle, NULL, 828}, /* WinQuerySysPointer */ }; -static PFN ExtFCN[C_ARR_LEN(loadOrdinals)]; /* Labeled by ord ORD_*. */ -const Perl_PFN * const pExtFCN = ExtFCN; -struct PMWIN_entries_t PMWIN_entries; - HMODULE loadModule(const char *modname, int fail) { @@ -444,16 +632,69 @@ loadModule(const char *modname, int fail) return h; } +/* const char* const ptypes[] = { "FS", "DOS", "VIO", "PM", "DETACH" }; */ + +static int +my_type() +{ + int rc; + TIB *tib; + PIB *pib; + + if (!(_emx_env & 0x200)) return 1; /* not OS/2. */ + if (CheckOSError(DosGetInfoBlocks(&tib, &pib))) + return -1; + + return (pib->pib_ultype); +} + +static void +my_type_set(int type) +{ + int rc; + TIB *tib; + PIB *pib; + + if (!(_emx_env & 0x200)) + Perl_croak_nocontext("Can't set type on DOS"); /* not OS/2. */ + if (CheckOSError(DosGetInfoBlocks(&tib, &pib))) + croak_with_os2error("Error getting info blocks"); + pib->pib_ultype = type; +} + PFN loadByOrdinal(enum entries_ordinals ord, int fail) { + if (sizeof(loadOrdinals)/sizeof(loadOrdinals[0]) != ORD_NENTRIES) + Perl_croak_nocontext( + "Wrong size of loadOrdinals array: expected %d, actual %d", + sizeof(loadOrdinals)/sizeof(loadOrdinals[0]), ORD_NENTRIES); if (ExtFCN[ord] == NULL) { PFN fcn = (PFN)-1; APIRET rc; - if (!loadOrdinals[ord].dll->handle) + if (!loadOrdinals[ord].dll->handle) { + if (loadOrdinals[ord].dll->requires_pm && my_type() < 2) { /* FS */ + char *s = getenv("PERL_ASIF_PM"); + + if (!s || !atoi(s)) { + /* The module will not function well without PM. + The usual way to detect PM is the existence of the mutex + \SEM32\PMDRAG.SEM. */ + HMTX hMtx = 0; + + if (CheckOSError(DosOpenMutexSem("\\SEM32\\PMDRAG.SEM", + &hMtx))) + Perl_croak_nocontext("Looks like we have no PM; will not load DLL %s without $ENV{PERL_ASIF_PM}", + loadOrdinals[ord].dll->modname); + DosCloseMutexSem(hMtx); + } + } + MUTEX_LOCK(&perlos2_state_mutex); loadOrdinals[ord].dll->handle = loadModule(loadOrdinals[ord].dll->modname, fail); + MUTEX_UNLOCK(&perlos2_state_mutex); + } if (!loadOrdinals[ord].dll->handle) return 0; /* Possible with FAIL==0 only */ if (CheckOSError(DosQueryProcAddr(loadOrdinals[ord].dll->handle, @@ -504,12 +745,11 @@ DeclVoidFuncByORD(endprotoent, ORD_ENDPROTOENT, (void), ()) DeclVoidFuncByORD(endservent, ORD_ENDSERVENT, (void), ()) /* priorities */ -static signed char priors[] = {0, 1, 3, 2}; /* Last two interchanged, - self inverse. */ +static const signed char priors[] = {0, 1, 3, 2}; /* Last two interchanged, + self inverse. */ #define QSS_INI_BUFFER 1024 ULONG (*pDosVerifyPidTid) (PID pid, TID tid); -static int pidtid_lookup; PQTOPLEVEL get_sysinfo(ULONG pid, ULONG flags) @@ -616,13 +856,7 @@ getpriority(int which /* ignored */, int pid) /*****************************************************************************/ /* spawn */ -int emx_runtime_init; /* If 1, we need to manually init it */ -int emx_exception_init; /* If 1, we need to manually set it */ -/* There is no big sense to make it thread-specific, since signals - are delivered to thread 1 only. XXXX Maybe make it into an array? */ -static int spawn_pid; -static int spawn_killed; static Signal_t spawn_sighandler(int sig) @@ -690,22 +924,6 @@ enum execf_t { EXECF_SYNC }; -/* const char* const ptypes[] = { "FS", "DOS", "VIO", "PM", "DETACH" }; */ - -static int -my_type() -{ - int rc; - TIB *tib; - PIB *pib; - - if (!(_emx_env & 0x200)) return 1; /* not OS/2. */ - if (CheckOSError(DosGetInfoBlocks(&tib, &pib))) - return -1; - - return (pib->pib_ultype); -} - static ULONG file_type(char *path) { @@ -730,8 +948,6 @@ file_type(char *path) return apptype; } -static ULONG os2_mytype; - /* Spawn/exec a program, revert to shell if needed. */ /* global PL_Argv[] contains arguments. */ @@ -745,11 +961,11 @@ do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag) { int trueflag = flag; int rc, pass = 1; - char *tmps; - char *args[4]; - static char * fargs[4] + char *real_name; + char const * args[4]; + static const char * const fargs[4] = { "/bin/sh", "-c", "\"$@\"", "spawn-via-shell", }; - char **argsp = fargs; + const char * const *argsp = fargs; int nargs = 4; int force_shell; int new_stderr = -1, nostderr = 0; @@ -760,24 +976,26 @@ do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag) if (flag == P_WAIT) flag = P_NOWAIT; + if (really && !*(real_name = SvPV(really, n_a))) + really = Nullsv; retry: if (strEQ(PL_Argv[0],"/bin/sh")) PL_Argv[0] = PL_sh_path; /* We should check PERL_SH* and PERLLIB_* as well? */ - if (!really || !*(tmps = SvPV(really, n_a))) - tmps = PL_Argv[0]; - if (tmps[0] != '/' && tmps[0] != '\\' - && !(tmps[0] && tmps[1] == ':' - && (tmps[2] == '/' || tmps[2] != '\\')) + if (!really || pass >= 2) + real_name = PL_Argv[0]; + if (real_name[0] != '/' && real_name[0] != '\\' + && !(real_name[0] && real_name[1] == ':' + && (real_name[2] == '/' || real_name[2] != '\\')) ) /* will spawnvp use PATH? */ TAINT_ENV(); /* testing IFS here is overkill, probably */ reread: force_shell = 0; if (_emx_env & 0x200) { /* OS/2. */ - int type = file_type(tmps); + int type = file_type(real_name); type_again: if (type == -1) { /* Not found */ errno = ENOENT; @@ -792,10 +1010,10 @@ do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag) else if (type == -3) { /* Is a directory? */ /* Special-case this */ char tbuf[512]; - int l = strlen(tmps); + int l = strlen(real_name); if (l + 5 <= sizeof tbuf) { - strcpy(tbuf, tmps); + strcpy(tbuf, real_name); strcpy(tbuf + l, ".exe"); type = file_type(tbuf); if (type >= -3) @@ -809,11 +1027,11 @@ do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag) switch (type & 7) { /* Ignore WINDOWCOMPAT and FAPI, start them the same type we are. */ case FAPPTYP_WINDOWAPI: - { + { /* Apparently, kids are started basing on startup type, not the morphed type */ if (os2_mytype != 3) { /* not PM */ if (flag == P_NOWAIT) flag = P_PM; - else if ((flag & 7) != P_PM && (flag & 7) != P_SESSION) + else if ((flag & 7) != P_PM && (flag & 7) != P_SESSION && ckWARN(WARN_EXEC)) Perl_warner(aTHX_ packWARN(WARN_EXEC), "Starting PM process with flag=%d, mytype=%d", flag, os2_mytype); } @@ -824,7 +1042,7 @@ do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag) if (os2_mytype != 0) { /* not full screen */ if (flag == P_NOWAIT) flag = P_SESSION; - else if ((flag & 7) != P_SESSION) + else if ((flag & 7) != P_SESSION && ckWARN(WARN_EXEC)) Perl_warner(aTHX_ packWARN(WARN_EXEC), "Starting Full Screen process with flag=%d, mytype=%d", flag, os2_mytype); } @@ -859,24 +1077,23 @@ do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag) } #if 0 - rc = result(aTHX_ trueflag, spawnvp(flag,tmps,PL_Argv)); + rc = result(aTHX_ trueflag, spawnvp(flag,real_name,PL_Argv)); #else if (execf == EXECF_TRUEEXEC) - rc = execvp(tmps,PL_Argv); + rc = execvp(real_name,PL_Argv); else if (execf == EXECF_EXEC) - rc = spawnvp(trueflag | P_OVERLAY,tmps,PL_Argv); + rc = spawnvp(trueflag | P_OVERLAY,real_name,PL_Argv); else if (execf == EXECF_SPAWN_NOWAIT) - rc = spawnvp(flag,tmps,PL_Argv); + rc = spawnvp(flag,real_name,PL_Argv); else if (execf == EXECF_SYNC) - rc = spawnvp(trueflag,tmps,PL_Argv); + rc = spawnvp(trueflag,real_name,PL_Argv); else /* EXECF_SPAWN, EXECF_SPAWN_BYFLAG */ rc = result(aTHX_ trueflag, - spawnvp(flag,tmps,PL_Argv)); + spawnvp(flag,real_name,PL_Argv)); #endif - if (rc < 0 && pass == 1 - && (tmps == PL_Argv[0])) { /* Cannot transfer `really' via shell. */ + if (rc < 0 && pass == 1) { do_script: - { + if (real_name == PL_Argv[0]) { int err = errno; if (err == ENOENT || err == ENOEXEC) { @@ -912,7 +1129,7 @@ do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag) scr = SvPV(scrsv, n_a); /* Reload */ if (PerlLIO_stat(scr,&PL_statbuf) >= 0 && !S_ISDIR(PL_statbuf.st_mode)) { /* Found */ - tmps = scr; + real_name = scr; pass++; goto reread; } else { /* Restore */ @@ -922,7 +1139,8 @@ do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag) } if (PerlIO_close(file) != 0) { /* Failure */ panic_file: - Perl_warner(aTHX_ packWARN(WARN_EXEC), "Error reading \"%s\": %s", + if (ckWARN(WARN_EXEC)) + Perl_warner(aTHX_ packWARN(WARN_EXEC), "Error reading \"%s\": %s", scr, Strerror(errno)); buf = ""; /* Not #! */ goto doshell_args; @@ -975,7 +1193,7 @@ do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag) doshell_args: { char **a = PL_Argv; - char *exec_args[2]; + const char *exec_args[2]; if (force_shell || (!buf[0] && file)) { /* File without magic */ @@ -1046,8 +1264,8 @@ do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag) long enough. */ a--; } - while (--nargs >= 0) - PL_Argv[nargs] = argsp[nargs]; + while (--nargs >= 0) /* XXXX Discard const... */ + PL_Argv[nargs] = (char*)argsp[nargs]; /* Enable pathless exec if #! (as pdksh). */ pass = (buf[0] == '#' ? 2 : 3); goto retry; @@ -1056,6 +1274,20 @@ do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag) /* Not found: restore errno */ errno = err; } + } else if (errno == ENOEXEC) { /* Cannot transfer `real_name' via shell. */ + if (rc < 0 && ckWARN(WARN_EXEC)) + Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s script `%s' with ARGV[0] being `%s'", + ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC) + ? "spawn" : "exec"), + real_name, PL_Argv[0]); + goto warned; + } else if (errno == ENOENT) { /* Cannot transfer `real_name' via shell. */ + if (rc < 0 && ckWARN(WARN_EXEC)) + Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s `%s' with ARGV[0] being `%s' (looking for executables only, not found)", + ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC) + ? "spawn" : "exec"), + real_name, PL_Argv[0]); + goto warned; } } else if (rc < 0 && pass == 2 && errno == ENOENT) { /* File not found */ char *no_dir = strrchr(PL_Argv[0], '/'); @@ -1072,7 +1304,8 @@ do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag) Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s\n", ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC) ? "spawn" : "exec"), - PL_Argv[0], Strerror(errno)); + real_name, Strerror(errno)); + warned: if (rc < 0 && (execf != EXECF_SPAWN_NOWAIT) && ((trueflag & 0xFF) == P_WAIT)) rc = -1; @@ -1215,9 +1448,9 @@ do_spawn3(pTHX_ char *cmd, int execf, int flag) return rc; } -/* Array spawn. */ +/* Array spawn/exec. */ int -os2_do_aspawn(pTHX_ SV *really, register void **vmark, register void **vsp) +os2_aspawn4(pTHX_ SV *really, register SV **vmark, register SV **vsp, int execing) { register SV **mark = (SV **)vmark; register SV **sp = (SV **)vsp; @@ -1245,16 +1478,32 @@ os2_do_aspawn(pTHX_ SV *really, register void **vmark, register void **vsp) } *a = Nullch; - if (flag_set && (a == PL_Argv + 1)) { /* One arg? */ + if ( flag_set && (a == PL_Argv + 1) + && !really && !execing ) { /* One arg? */ rc = do_spawn3(aTHX_ a[-1], EXECF_SPAWN_BYFLAG, flag); } else - rc = do_spawn_ve(aTHX_ really, flag, EXECF_SPAWN, NULL, 0); + rc = do_spawn_ve(aTHX_ really, flag, + (execing ? EXECF_EXEC : EXECF_SPAWN), NULL, 0); } else rc = -1; do_execfree(); return rc; } +/* Array spawn. */ +int +os2_do_aspawn(pTHX_ SV *really, register SV **vmark, register SV **vsp) +{ + return os2_aspawn4(aTHX_ really, vmark, vsp, 0); +} + +/* Array exec. */ +bool +Perl_do_aexec(pTHX_ SV* really, SV** vmark, SV** vsp) +{ + return os2_aspawn4(aTHX_ really, vmark, vsp, 1); +} + int os2_do_spawn(pTHX_ char *cmd) { @@ -1460,7 +1709,9 @@ os2_stat(const char *name, struct stat *st) memset(st, 0, sizeof *st); st->st_mode = S_IFCHR|0666; + MUTEX_LOCK(&perlos2_state_mutex); st->st_ino = (ino-- & 0x7FFF); + MUTEX_UNLOCK(&perlos2_state_mutex); st->st_nlink = 1; return 0; } @@ -1529,7 +1780,7 @@ sys_alloc(int size) { /* tmp path */ -char *tmppath = TMPPATH1; +const char *tmppath = TMPPATH1; void settmppath() @@ -1538,6 +1789,7 @@ settmppath() int len; if (!p) p = getenv("TEMP"); + if (!p) p = getenv("TMPDIR"); if (!p) return; len = strlen(p); tpath = (char *)malloc(len + strlen(TMPPATH1) + 2); @@ -1562,6 +1814,7 @@ XS(XS_File__Copy_syscopy) char * dst = (char *)SvPV(ST(1),n_a); U32 flag; int RETVAL, rc; + dXSTARG; if (items < 3) flag = 0; @@ -1570,8 +1823,7 @@ XS(XS_File__Copy_syscopy) } RETVAL = !CheckOSError(DosCopy(src, dst, flag)); - ST(0) = sv_newmortal(); - sv_setiv(ST(0), (IV)RETVAL); + XSprePUSH; PUSHi((IV)RETVAL); } XSRETURN(1); } @@ -1583,7 +1835,6 @@ XS(XS_File__Copy_syscopy) char * mod2fname(pTHX_ SV *sv) { - static char fname[9]; int pos = 6, len, avlen; unsigned int sum = 0; char *s; @@ -1640,10 +1891,11 @@ XS(XS_DynaLoader_mod2fname) { SV * sv = ST(0); char * RETVAL; + dXSTARG; RETVAL = mod2fname(aTHX_ sv); - ST(0) = sv_newmortal(); - sv_setpv((SV*)ST(0), RETVAL); + sv_setpv(TARG, RETVAL); + XSprePUSH; PUSHTARG; } XSRETURN(1); } @@ -1652,7 +1904,6 @@ char * os2error(int rc) { dTHX; - static char buf[300]; ULONG len; char *s; int number = SvTRUE(get_sv("OS2::nsyserror", TRUE)); @@ -1661,17 +1912,37 @@ os2error(int rc) if (rc == 0) return ""; if (number) { - sprintf(buf, "SYS%04d=%#x: ", rc, rc); - s = buf + strlen(buf); + sprintf(os2error_buf, "SYS%04d=%#x: ", rc, rc); + s = os2error_buf + strlen(os2error_buf); } else - s = buf; - if (DosGetMessage(NULL, 0, s, sizeof(buf) - 1 - (s-buf), + s = os2error_buf; + if (DosGetMessage(NULL, 0, s, sizeof(os2error_buf) - 1 - (s-os2error_buf), rc, "OSO001.MSG", &len)) { + char *name = ""; + if (!number) { - sprintf(buf, "SYS%04d=%#x: ", rc, rc); - s = buf + strlen(buf); + sprintf(os2error_buf, "SYS%04d=%#x: ", rc, rc); + s = os2error_buf + strlen(os2error_buf); } - sprintf(s, "[No description found in OSO001.MSG]"); + switch (rc) { + case PMERR_INVALID_HWND: + name = "PMERR_INVALID_HWND"; + break; + case PMERR_INVALID_HMQ: + name = "PMERR_INVALID_HMQ"; + break; + case PMERR_CALL_FROM_WRONG_THREAD: + name = "PMERR_CALL_FROM_WRONG_THREAD"; + break; + case PMERR_NO_MSG_QUEUE: + name = "PMERR_NO_MSG_QUEUE"; + break; + case PMERR_NOT_IN_A_PM_SESSION: + name = "PMERR_NOT_IN_A_PM_SESSION"; + break; + } + sprintf(s, "%s%s[No description found in OSO001.MSG]", + name, (*name ? "=" : "")); } else { s[len] = '\0'; if (len && s[len - 1] == '\n') @@ -1680,12 +1951,12 @@ os2error(int rc) s[--len] = 0; if (len && s[len - 1] == '.') s[--len] = 0; - if (len >= 10 && number && strnEQ(s, buf, 7) + if (len >= 10 && number && strnEQ(s, os2error_buf, 7) && s[7] == ':' && s[8] == ' ') /* Some messages start with SYSdddd:, some not */ Move(s + 9, s, (len -= 9) + 1, char); } - return buf; + return os2error_buf; } void @@ -1741,12 +2012,17 @@ os2_execname(pTHX) char * perllib_mangle(char *s, unsigned int l) { - static char *newp, *oldp; - static int newl, oldl, notfound; - static char ret[STATIC_FILE_LENGTH+1]; - if (!newp && !notfound) { - newp = getenv("PERLLIB_PREFIX"); + newp = getenv("PERLLIB_" STRINGIFY(PERL_REVISION) + STRINGIFY(PERL_VERSION) STRINGIFY(PERL_SUBVERSION) + "_PREFIX"); + if (!newp) + newp = getenv("PERLLIB_" STRINGIFY(PERL_REVISION) + STRINGIFY(PERL_VERSION) "_PREFIX"); + if (!newp) + newp = getenv("PERLLIB_" STRINGIFY(PERL_REVISION) "_PREFIX"); + if (!newp) + newp = getenv("PERLLIB_PREFIX"); if (newp) { char *s; @@ -1761,8 +2037,8 @@ perllib_mangle(char *s, unsigned int l) if (newl == 0 || oldl == 0) { Perl_croak_nocontext("Malformed PERLLIB_PREFIX"); } - strcpy(ret, newp); - s = ret; + strcpy(mangle_ret, newp); + s = mangle_ret; while (*s) { if (*s == '\\') *s = '/'; s++; @@ -1783,8 +2059,8 @@ perllib_mangle(char *s, unsigned int l) if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH) { Perl_croak_nocontext("Malformed PERLLIB_PREFIX"); } - strcpy(ret + newl, s + oldl); - return ret; + strcpy(mangle_ret + newl, s + oldl); + return mangle_ret; } unsigned long @@ -1793,6 +2069,31 @@ Perl_hab_GET() /* Needed if perl.h cannot be included */ return perl_hab_GET(); } +static void +Create_HMQ(int serve, char *message) /* Assumes morphing */ +{ + unsigned fpflag = _control87(0,0); + + init_PMWIN_entries(); + /* 64 messages if before OS/2 3.0, ignored otherwise */ + Perl_hmq = (*PMWIN_entries.CreateMsgQueue)(perl_hab_GET(), 64); + if (!Perl_hmq) { + dTHX; + + SAVEINT(rmq_cnt); /* Allow catch()ing. */ + if (rmq_cnt++) + _exit(188); /* Panic can try to create a window. */ + CroakWinError(1, message ? message : "Cannot create a message queue"); + } + if (serve != -1) + (*PMWIN_entries.CancelShutdown)(Perl_hmq, !serve); + /* We may have loaded some modules */ + _control87(fpflag, MCW_EM); /* Some modules reset FP flags on (un)load */ +} + +#define REGISTERMQ_WILL_SERVE 1 +#define REGISTERMQ_IMEDIATE_UNMORPH 2 + HMQ Perl_Register_MQ(int serve) { @@ -1802,24 +2103,20 @@ Perl_Register_MQ(int serve) Perl_hmq_refcnt = 0; /* Be extra safe */ DosGetInfoBlocks(&tib, &pib); - Perl_os2_initial_mode = pib->pib_ultype; - /* Try morphing into a PM application. */ - if (pib->pib_ultype != 3) /* 2 is VIO */ - pib->pib_ultype = 3; /* 3 is PM */ - init_PMWIN_entries(); - /* 64 messages if before OS/2 3.0, ignored otherwise */ - Perl_hmq = (*PMWIN_entries.CreateMsgQueue)(perl_hab_GET(), 64); - if (!Perl_hmq) { - dTHX; - static int cnt; - - SAVEINT(cnt); /* Allow catch()ing. */ - if (cnt++) - _exit(188); /* Panic can try to create a window. */ - Perl_croak_nocontext("Cannot create a message queue, or morph to a PM application"); + if (!Perl_morph_refcnt) { + Perl_os2_initial_mode = pib->pib_ultype; + /* Try morphing into a PM application. */ + if (pib->pib_ultype != 3) /* 2 is VIO */ + pib->pib_ultype = 3; /* 3 is PM */ + } + Create_HMQ(-1, /* We do CancelShutdown ourselves */ + "Cannot create a message queue, or morph to a PM application"); + if ((serve & REGISTERMQ_IMEDIATE_UNMORPH)) { + if (!Perl_morph_refcnt && Perl_os2_initial_mode != 3) + pib->pib_ultype = Perl_os2_initial_mode; } } - if (serve) { + if (serve & REGISTERMQ_WILL_SERVE) { if ( Perl_hmq_servers <= 0 /* Safe to inform us on shutdown, */ && Perl_hmq_refcnt > 0 ) /* this was switched off before... */ (*PMWIN_entries.CancelShutdown)(Perl_hmq, 0); @@ -1827,6 +2124,8 @@ Perl_Register_MQ(int serve) } else if (!Perl_hmq_servers) /* Do not inform us on shutdown */ (*PMWIN_entries.CancelShutdown)(Perl_hmq, 1); Perl_hmq_refcnt++; + if (!(serve & REGISTERMQ_IMEDIATE_UNMORPH)) + Perl_morph_refcnt++; return Perl_hmq; } @@ -1873,24 +2172,31 @@ Perl_Process_Messages(int force, I32 *cntp) void Perl_Deregister_MQ(int serve) { - PPIB pib; - PTIB tib; - - if (serve) + if (serve & REGISTERMQ_WILL_SERVE) Perl_hmq_servers--; + if (--Perl_hmq_refcnt <= 0) { + unsigned fpflag = _control87(0,0); + init_PMWIN_entries(); /* To be extra safe */ (*PMWIN_entries.DestroyMsgQueue)(Perl_hmq); Perl_hmq = 0; + /* We may have (un)loaded some modules */ + _control87(fpflag, MCW_EM); /* Some modules reset FP flags on (un)load */ + } else if ((serve & REGISTERMQ_WILL_SERVE) && Perl_hmq_servers <= 0) + (*PMWIN_entries.CancelShutdown)(Perl_hmq, 1); /* Last server exited */ + if (!(serve & REGISTERMQ_IMEDIATE_UNMORPH) && (--Perl_morph_refcnt <= 0)) { /* Try morphing back from a PM application. */ + PPIB pib; + PTIB tib; + DosGetInfoBlocks(&tib, &pib); if (pib->pib_ultype == 3) /* 3 is PM */ pib->pib_ultype = Perl_os2_initial_mode; else Perl_warn_nocontext("Unexpected program mode %d when morphing back from PM", - pib->pib_ultype); - } else if (serve && Perl_hmq_servers <= 0) /* Last server exited */ - (*PMWIN_entries.CancelShutdown)(Perl_hmq, 1); + pib->pib_ultype); + } } #define sys_is_absolute(path) ( isALPHA((path)[0]) && (path)[1] == ':' \ @@ -1903,8 +2209,6 @@ Perl_Deregister_MQ(int serve) #define sys_chdir(p) (chdir(p) == 0) #define change_drive(d) (_chdrive(d), (current_drive() == toupper(d))) -static int DOS_harderr_state = -1; - XS(XS_OS2_Error) { dXSARGS; @@ -1919,7 +2223,7 @@ XS(XS_OS2_Error) unsigned long rc; if (CheckOSError(DosError(a))) - Perl_croak_nocontext("DosError(%d) failed", a); + Perl_croak_nocontext("DosError(%d) failed: %s", a, os2error(Perl_rc)); ST(0) = sv_newmortal(); if (DOS_harderr_state >= 0) sv_setiv(ST(0), DOS_harderr_state); @@ -1928,8 +2232,6 @@ XS(XS_OS2_Error) XSRETURN(1); } -static signed char DOS_suppression_state = -1; - XS(XS_OS2_Errors2Drive) { dXSARGS; @@ -1949,7 +2251,8 @@ XS(XS_OS2_Errors2Drive) ? SPU_ENABLESUPPRESSION : SPU_DISABLESUPPRESSION), drive))) - Perl_croak_nocontext("DosSuppressPopUps(%c) failed", drive); + Perl_croak_nocontext("DosSuppressPopUps(%c) failed: %s", drive, + os2error(Perl_rc)); ST(0) = sv_newmortal(); if (DOS_suppression_state > 0) sv_setpvn(ST(0), &DOS_suppression_state, 1); @@ -1960,7 +2263,356 @@ XS(XS_OS2_Errors2Drive) XSRETURN(1); } -static const char * const si_fields[QSV_MAX] = { +ULONG (*pDosTmrQueryFreq) (PULONG); +ULONG (*pDosTmrQueryTime) (unsigned long long *); + +XS(XS_OS2_Timer) +{ + dXSARGS; + static ULONG freq; + unsigned long long count; + ULONG rc; + + if (items != 0) + Perl_croak_nocontext("Usage: OS2::Timer()"); + if (!freq) { + *(PFN*)&pDosTmrQueryFreq = loadByOrdinal(ORD_DosTmrQueryFreq, 0); + *(PFN*)&pDosTmrQueryTime = loadByOrdinal(ORD_DosTmrQueryTime, 0); + MUTEX_LOCK(&perlos2_state_mutex); + if (!freq) + if (CheckOSError(pDosTmrQueryFreq(&freq))) + croak_with_os2error("DosTmrQueryFreq"); + MUTEX_UNLOCK(&perlos2_state_mutex); + } + if (CheckOSError(pDosTmrQueryTime(&count))) + croak_with_os2error("DosTmrQueryTime"); + { + dXSTARG; + + XSprePUSH; PUSHn(((NV)count)/freq); + } + XSRETURN(1); +} + +static const char * const dc_fields[] = { + "FAMILY", + "IO_CAPS", + "TECHNOLOGY", + "DRIVER_VERSION", + "WIDTH", + "HEIGHT", + "WIDTH_IN_CHARS", + "HEIGHT_IN_CHARS", + "HORIZONTAL_RESOLUTION", + "VERTICAL_RESOLUTION", + "CHAR_WIDTH", + "CHAR_HEIGHT", + "SMALL_CHAR_WIDTH", + "SMALL_CHAR_HEIGHT", + "COLORS", + "COLOR_PLANES", + "COLOR_BITCOUNT", + "COLOR_TABLE_SUPPORT", + "MOUSE_BUTTONS", + "FOREGROUND_MIX_SUPPORT", + "BACKGROUND_MIX_SUPPORT", + "VIO_LOADABLE_FONTS", + "WINDOW_BYTE_ALIGNMENT", + "BITMAP_FORMATS", + "RASTER_CAPS", + "MARKER_HEIGHT", + "MARKER_WIDTH", + "DEVICE_FONTS", + "GRAPHICS_SUBSET", + "GRAPHICS_VERSION", + "GRAPHICS_VECTOR_SUBSET", + "DEVICE_WINDOWING", + "ADDITIONAL_GRAPHICS", + "PHYS_COLORS", + "COLOR_INDEX", + "GRAPHICS_CHAR_WIDTH", + "GRAPHICS_CHAR_HEIGHT", + "HORIZONTAL_FONT_RES", + "VERTICAL_FONT_RES", + "DEVICE_FONT_SIM", + "LINEWIDTH_THICK", + "DEVICE_POLYSET_POINTS", +}; + +enum { + DevCap_dc, DevCap_hwnd +}; + +HDC (*pWinOpenWindowDC) (HWND hwnd); +HMF (*pDevCloseDC) (HDC hdc); +HDC (*pDevOpenDC) (HAB hab, LONG lType, PCSZ pszToken, LONG lCount, + PDEVOPENDATA pdopData, HDC hdcComp); +BOOL (*pDevQueryCaps) (HDC hdc, LONG lStart, LONG lCount, PLONG alArray); + + +XS(XS_OS2_DevCap) +{ + dXSARGS; + if (items > 2) + Perl_croak_nocontext("Usage: OS2::DevCap()"); + { + /* Device Capabilities Data Buffer (10 extra w.r.t. Warp 4.5) */ + LONG si[CAPS_DEVICE_POLYSET_POINTS - CAPS_FAMILY + 1]; + int i = 0, j = 0, how = DevCap_dc; + HDC hScreenDC; + DEVOPENSTRUC doStruc= {0L, (PSZ)"DISPLAY", NULL, 0L, 0L, 0L, 0L, 0L, 0L}; + ULONG rc1 = NO_ERROR; + HWND hwnd; + static volatile int devcap_loaded; + + if (!devcap_loaded) { + *(PFN*)&pWinOpenWindowDC = loadByOrdinal(ORD_WinOpenWindowDC, 0); + *(PFN*)&pDevOpenDC = loadByOrdinal(ORD_DevOpenDC, 0); + *(PFN*)&pDevCloseDC = loadByOrdinal(ORD_DevCloseDC, 0); + *(PFN*)&pDevQueryCaps = loadByOrdinal(ORD_DevQueryCaps, 0); + devcap_loaded = 1; + } + + if (items >= 2) + how = SvIV(ST(1)); + if (!items) { /* Get device contents from PM */ + hScreenDC = pDevOpenDC(perl_hab_GET(), OD_MEMORY, (PSZ)"*", 0, + (PDEVOPENDATA)&doStruc, NULLHANDLE); + if (CheckWinError(hScreenDC)) + croak_with_os2error("DevOpenDC() failed"); + } else if (how == DevCap_dc) + hScreenDC = (HDC)SvIV(ST(0)); + else { /* DevCap_hwnd */ + if (!Perl_hmq) + Perl_croak(aTHX_ "Getting a window's device context without a message queue would lock PM"); + hwnd = (HWND)SvIV(ST(0)); + hScreenDC = pWinOpenWindowDC(hwnd); /* No need to DevCloseDC() */ + if (CheckWinError(hScreenDC)) + croak_with_os2error("WinOpenWindowDC() failed"); + } + if (CheckWinError(pDevQueryCaps(hScreenDC, + CAPS_FAMILY, /* W3 documented caps */ + CAPS_DEVICE_POLYSET_POINTS + - CAPS_FAMILY + 1, + si))) + rc1 = Perl_rc; + if (!items && CheckWinError(pDevCloseDC(hScreenDC))) + Perl_warn_nocontext("DevCloseDC() failed: %s", os2error(Perl_rc)); + if (rc1) + Perl_rc = rc1, croak_with_os2error("DevQueryCaps() failed"); + EXTEND(SP,2*(CAPS_DEVICE_POLYSET_POINTS - CAPS_FAMILY + 1)); + while (i < CAPS_DEVICE_POLYSET_POINTS - CAPS_FAMILY + 1) { + ST(j) = sv_newmortal(); + sv_setpv(ST(j++), dc_fields[i]); + ST(j) = sv_newmortal(); + sv_setiv(ST(j++), si[i]); + i++; + } + } + XSRETURN(2 * (CAPS_DEVICE_POLYSET_POINTS - CAPS_FAMILY + 1)); +} + +LONG (*pWinQuerySysValue) (HWND hwndDesktop, LONG iSysValue); +BOOL (*pWinSetSysValue) (HWND hwndDesktop, LONG iSysValue, LONG lValue); + +const char * const sv_keys[] = { + "SWAPBUTTON", + "DBLCLKTIME", + "CXDBLCLK", + "CYDBLCLK", + "CXSIZEBORDER", + "CYSIZEBORDER", + "ALARM", + "7", + "8", + "CURSORRATE", + "FIRSTSCROLLRATE", + "SCROLLRATE", + "NUMBEREDLISTS", + "WARNINGFREQ", + "NOTEFREQ", + "ERRORFREQ", + "WARNINGDURATION", + "NOTEDURATION", + "ERRORDURATION", + "19", + "CXSCREEN", + "CYSCREEN", + "CXVSCROLL", + "CYHSCROLL", + "CYVSCROLLARROW", + "CXHSCROLLARROW", + "CXBORDER", + "CYBORDER", + "CXDLGFRAME", + "CYDLGFRAME", + "CYTITLEBAR", + "CYVSLIDER", + "CXHSLIDER", + "CXMINMAXBUTTON", + "CYMINMAXBUTTON", + "CYMENU", + "CXFULLSCREEN", + "CYFULLSCREEN", + "CXICON", + "CYICON", + "CXPOINTER", + "CYPOINTER", + "DEBUG", + "CPOINTERBUTTONS", + "POINTERLEVEL", + "CURSORLEVEL", + "TRACKRECTLEVEL", + "CTIMERS", + "MOUSEPRESENT", + "CXALIGN", + "CYALIGN", + "DESKTOPWORKAREAYTOP", + "DESKTOPWORKAREAYBOTTOM", + "DESKTOPWORKAREAXRIGHT", + "DESKTOPWORKAREAXLEFT", + "55", + "NOTRESERVED", + "EXTRAKEYBEEP", + "SETLIGHTS", + "INSERTMODE", + "60", + "61", + "62", + "63", + "MENUROLLDOWNDELAY", + "MENUROLLUPDELAY", + "ALTMNEMONIC", + "TASKLISTMOUSEACCESS", + "CXICONTEXTWIDTH", + "CICONTEXTLINES", + "CHORDTIME", + "CXCHORD", + "CYCHORD", + "CXMOTIONSTART", + "CYMOTIONSTART", + "BEGINDRAG", + "ENDDRAG", + "SINGLESELECT", + "OPEN", + "CONTEXTMENU", + "CONTEXTHELP", + "TEXTEDIT", + "BEGINSELECT", + "ENDSELECT", + "BEGINDRAGKB", + "ENDDRAGKB", + "SELECTKB", + "OPENKB", + "CONTEXTMENUKB", + "CONTEXTHELPKB", + "TEXTEDITKB", + "BEGINSELECTKB", + "ENDSELECTKB", + "ANIMATION", + "ANIMATIONSPEED", + "MONOICONS", + "KBDALTERED", + "PRINTSCREEN", /* 97, the last one on one of the DDK header */ + "LOCKSTARTINPUT", + "DYNAMICDRAG", + "100", + "101", + "102", + "103", + "104", + "105", + "106", + "107", +/* "CSYSVALUES",*/ + /* In recent DDK the limit is 108 */ +}; + +XS(XS_OS2_SysValues) +{ + dXSARGS; + if (items > 2) + Perl_croak_nocontext("Usage: OS2::SysValues(which = -1, hwndDesktop = HWND_DESKTOP)"); + { + int i = 0, j = 0, which = -1; + HWND hwnd = HWND_DESKTOP; + static volatile int sv_loaded; + LONG RETVAL; + + if (!sv_loaded) { + *(PFN*)&pWinQuerySysValue = loadByOrdinal(ORD_WinQuerySysValue, 0); + sv_loaded = 1; + } + + if (items == 2) + hwnd = (HWND)SvIV(ST(1)); + if (items >= 1) + which = (int)SvIV(ST(0)); + if (which == -1) { + EXTEND(SP,2*C_ARRAY_LENGTH(sv_keys)); + while (i < C_ARRAY_LENGTH(sv_keys)) { + ResetWinError(); + RETVAL = pWinQuerySysValue(hwnd, i); + if ( !RETVAL + && !(sv_keys[i][0] >= '0' && sv_keys[i][0] <= '9' + && i <= SV_PRINTSCREEN) ) { + FillWinError; + if (Perl_rc) { + if (i > SV_PRINTSCREEN) + break; /* May be not present on older systems */ + croak_with_os2error("SysValues():"); + } + + } + ST(j) = sv_newmortal(); + sv_setpv(ST(j++), sv_keys[i]); + ST(j) = sv_newmortal(); + sv_setiv(ST(j++), RETVAL); + i++; + } + XSRETURN(2 * i); + } else { + dXSTARG; + + ResetWinError(); + RETVAL = pWinQuerySysValue(hwnd, which); + if (!RETVAL) { + FillWinError; + if (Perl_rc) + croak_with_os2error("SysValues():"); + } + XSprePUSH; PUSHi((IV)RETVAL); + } + } +} + +XS(XS_OS2_SysValues_set) +{ + dXSARGS; + if (items < 2 || items > 3) + Perl_croak_nocontext("Usage: OS2::SysValues_set(which, val, hwndDesktop = HWND_DESKTOP)"); + { + int which = (int)SvIV(ST(0)); + LONG val = (LONG)SvIV(ST(1)); + HWND hwnd = HWND_DESKTOP; + static volatile int svs_loaded; + + if (!svs_loaded) { + *(PFN*)&pWinSetSysValue = loadByOrdinal(ORD_WinSetSysValue, 0); + svs_loaded = 1; + } + + if (items == 3) + hwnd = (HWND)SvIV(ST(2)); + if (CheckWinError(pWinSetSysValue(hwnd, which, val))) + croak_with_os2error("SysValues_set()"); + } + XSRETURN_EMPTY; +} + +#define QSV_MAX_WARP3 QSV_MAX_COMP_LENGTH + +static const char * const si_fields[] = { "MAX_PATH_LENGTH", "MAX_TEXT_SESSIONS", "MAX_PM_SESSIONS", @@ -1985,7 +2637,13 @@ static const char * const si_fields[QSV_MAX] = { "TIMER_INTERVAL", "MAX_COMP_LENGTH", "FOREGROUND_FS_SESSION", - "FOREGROUND_PROCESS" + "FOREGROUND_PROCESS", /* Warp 3 toolkit defines up to this */ + "NUMPROCESSORS", + "MAXHPRMEM", + "MAXHSHMEM", + "MAXPROCESSES", + "VIRTUALADDRESSLIMIT", + "INT10ENABLED", /* From $TOOLKIT-ddk\DDK\video\rel\os2c\include\base\os2\bsedos.h */ }; XS(XS_OS2_SysInfo) @@ -1994,25 +2652,67 @@ XS(XS_OS2_SysInfo) if (items != 0) Perl_croak_nocontext("Usage: OS2::SysInfo()"); { - ULONG si[QSV_MAX] = {0}; /* System Information Data Buffer */ + /* System Information Data Buffer (10 extra w.r.t. Warp 4.5) */ + ULONG si[C_ARRAY_LENGTH(si_fields) + 10]; APIRET rc = NO_ERROR; /* Return code */ - int i = 0, j = 0; + int i = 0, j = 0, last = QSV_MAX_WARP3; - if (CheckOSError(DosQuerySysInfo(1L, /* Request all available system */ - QSV_MAX, /* information */ + if (CheckOSError(DosQuerySysInfo(1L, /* Request documented system */ + last, /* info for Warp 3 */ (PVOID)si, sizeof(si)))) - Perl_croak_nocontext("DosQuerySysInfo() failed"); - EXTEND(SP,2*QSV_MAX); - while (i < QSV_MAX) { + croak_with_os2error("DosQuerySysInfo() failed"); + while (last++ <= C_ARRAY_LENGTH(si)) { + if (CheckOSError(DosQuerySysInfo(last, last, /* One entry only */ + (PVOID)(si+last-1), + sizeof(*si)))) { + if (Perl_rc != ERROR_INVALID_PARAMETER) + croak_with_os2error("DosQuerySysInfo() failed"); + break; + } + } + last--; + EXTEND(SP,2*last); + while (i < last) { ST(j) = sv_newmortal(); sv_setpv(ST(j++), si_fields[i]); ST(j) = sv_newmortal(); sv_setiv(ST(j++), si[i]); i++; } + XSRETURN(2 * last); } - XSRETURN(2 * QSV_MAX); +} + +XS(XS_OS2_SysInfoFor) +{ + dXSARGS; + int count = (items == 2 ? (int)SvIV(ST(1)) : 1); + + if (items < 1 || items > 2) + Perl_croak_nocontext("Usage: OS2::SysInfoFor(id[,count])"); + { + /* System Information Data Buffer (10 extra w.r.t. Warp 4.5) */ + ULONG si[C_ARRAY_LENGTH(si_fields) + 10]; + APIRET rc = NO_ERROR; /* Return code */ + int i = 0; + int start = (int)SvIV(ST(0)); + + if (count > C_ARRAY_LENGTH(si) || count <= 0) + Perl_croak(aTHX_ "unexpected count %d for OS2::SysInfoFor()", count); + if (CheckOSError(DosQuerySysInfo(start, + start + count - 1, + (PVOID)si, + sizeof(si)))) + croak_with_os2error("DosQuerySysInfo() failed"); + EXTEND(SP,count); + while (i < count) { + ST(i) = sv_newmortal(); + sv_setiv(ST(i), si[i]); + i++; + } + } + XSRETURN(count); } XS(XS_OS2_BootDrive) @@ -2024,17 +2724,36 @@ XS(XS_OS2_BootDrive) ULONG si[1] = {0}; /* System Information Data Buffer */ APIRET rc = NO_ERROR; /* Return code */ char c; + dXSTARG; if (CheckOSError(DosQuerySysInfo(QSV_BOOT_DRIVE, QSV_BOOT_DRIVE, (PVOID)si, sizeof(si)))) - Perl_croak_nocontext("DosQuerySysInfo() failed"); - ST(0) = sv_newmortal(); + croak_with_os2error("DosQuerySysInfo() failed"); c = 'a' - 1 + si[0]; - sv_setpvn(ST(0), &c, 1); + sv_setpvn(TARG, &c, 1); + XSprePUSH; PUSHTARG; } XSRETURN(1); } +XS(XS_OS2_Beep) +{ + dXSARGS; + if (items > 2) /* Defaults as for WinAlarm(ERROR) */ + Perl_croak_nocontext("Usage: OS2::Beep(freq = 440, ms = 100)"); + { + ULONG freq = (items > 0 ? (ULONG)SvUV(ST(0)) : 440); + ULONG ms = (items > 1 ? (ULONG)SvUV(ST(1)) : 100); + ULONG rc; + + if (CheckOSError(DosBeep(freq, ms))) + croak_with_os2error("SysValues_set()"); + } + XSRETURN_EMPTY; +} + + + XS(XS_OS2_MorphPM) { dXSARGS; @@ -2043,9 +2762,9 @@ XS(XS_OS2_MorphPM) { bool serve = SvOK(ST(0)); unsigned long pmq = perl_hmq_GET(serve); + dXSTARG; - ST(0) = sv_newmortal(); - sv_setiv(ST(0), pmq); + XSprePUSH; PUSHi((IV)pmq); } XSRETURN(1); } @@ -2071,9 +2790,9 @@ XS(XS_OS2_Serve_Messages) { bool force = SvOK(ST(0)); unsigned long cnt = Perl_Serve_Messages(force); + dXSTARG; - ST(0) = sv_newmortal(); - sv_setiv(ST(0), cnt); + XSprePUSH; PUSHi((IV)cnt); } XSRETURN(1); } @@ -2086,6 +2805,7 @@ XS(XS_OS2_Process_Messages) { bool force = SvOK(ST(0)); unsigned long cnt; + dXSTARG; if (items == 2) { I32 cntr; @@ -2100,8 +2820,7 @@ XS(XS_OS2_Process_Messages) } else { cnt = Perl_Process_Messages(force, NULL); } - ST(0) = sv_newmortal(); - sv_setiv(ST(0), cnt); + XSprePUSH; PUSHi((IV)cnt); } XSRETURN(1); } @@ -2113,10 +2832,11 @@ XS(XS_Cwd_current_drive) Perl_croak_nocontext("Usage: Cwd::current_drive()"); { char RETVAL; + dXSTARG; RETVAL = current_drive(); - ST(0) = sv_newmortal(); - sv_setpvn(ST(0), (char *)&RETVAL, 1); + sv_setpvn(TARG, (char *)&RETVAL, 1); + XSprePUSH; PUSHTARG; } XSRETURN(1); } @@ -2214,9 +2934,11 @@ XS(XS_Cwd_sys_cwd) { char p[MAXPATHLEN]; char * RETVAL; + + /* Can't use TARG, since tainting behaves differently */ RETVAL = _getcwd2(p, MAXPATHLEN); ST(0) = sv_newmortal(); - sv_setpv((SV*)ST(0), RETVAL); + sv_setpv(ST(0), RETVAL); #ifndef INCOMPLETE_TAINTS SvTAINTED_on(ST(0)); #endif @@ -2392,6 +3114,7 @@ XS(XS_Cwd_extLibpath) char to[1024]; U32 rc; char * RETVAL; + dXSTARG; if (items < 1) type = 0; @@ -2403,8 +3126,8 @@ XS(XS_Cwd_extLibpath) RETVAL = extLibpath(to, type); if (RETVAL && RETVAL[0] == 1 && RETVAL[1] == 0) Perl_croak_nocontext("panic Cwd::extLibpath parameter"); - ST(0) = sv_newmortal(); - sv_setpv((SV*)ST(0), RETVAL); + sv_setpv(TARG, RETVAL); + XSprePUSH; PUSHTARG; } XSRETURN(1); } @@ -2445,7 +3168,8 @@ DeclOSFuncByORD(APIRET, _DosQueryModFromEIP,ORD_DosQueryModFromEIP, ULONG * Offset, ULONG Address), (hmod, obj, BufLen, Buf, Offset, Address)) -enum module_name_how { mod_name_handle, mod_name_shortname, mod_name_full}; +enum module_name_how { mod_name_handle, mod_name_shortname, mod_name_full, + mod_name_C_function = 0x100, mod_name_HMODULE = 0x200}; static SV* module_name_at(void *pp, enum module_name_how how) @@ -2454,14 +3178,19 @@ module_name_at(void *pp, enum module_name_how how) char buf[MAXPATHLEN]; char *p = buf; HMODULE mod; - ULONG obj, offset, rc; - - if (!_DosQueryModFromEIP(&mod, &obj, sizeof(buf), buf, &offset, (ULONG)pp)) + ULONG obj, offset, rc, addr = (ULONG)pp; + + if (how & mod_name_HMODULE) { + if ((how & ~mod_name_HMODULE) == mod_name_shortname) + Perl_croak(aTHX_ "Can't get short module name from a handle"); + mod = (HMODULE)pp; + how &= ~mod_name_HMODULE; + } else if (!_DosQueryModFromEIP(&mod, &obj, sizeof(buf), buf, &offset, addr)) return &PL_sv_undef; if (how == mod_name_handle) return newSVuv(mod); /* Full name... */ - if ( how == mod_name_full + if ( how != mod_name_shortname && CheckOSError(DosQueryModuleName(mod, sizeof(buf), buf)) ) return &PL_sv_undef; while (*p) { @@ -2478,6 +3207,10 @@ module_name_of_cv(SV *cv, enum module_name_how how) if (!cv || !SvROK(cv) || SvTYPE(SvRV(cv)) != SVt_PVCV || !CvXSUB(SvRV(cv))) { dTHX; + if (how & mod_name_C_function) + return module_name_at((void*)SvIV(cv), how & ~mod_name_C_function); + else if (how & mod_name_HMODULE) + return module_name_at((void*)SvIV(cv), how); Perl_croak(aTHX_ "Not an XSUB reference"); } return module_name_at(CvXSUB(SvRV(cv)), how); @@ -2510,6 +3243,70 @@ XS(XS_OS2_DLLname) XSRETURN(1); } +DeclOSFuncByORD(INT, _Dos32QueryHeaderInfo, ORD_Dos32QueryHeaderInfo, + (ULONG r1, ULONG r2, PVOID buf, ULONG szbuf, ULONG fnum), + (r1, r2, buf, szbuf, fnum)) + +XS(XS_OS2__headerInfo) +{ + dXSARGS; + if (items > 4 || items < 2) + Perl_croak(aTHX_ "Usage: OS2::_headerInfo(req,size[,handle,[offset]])"); + { + ULONG req = (ULONG)SvIV(ST(0)); + STRLEN size = (STRLEN)SvIV(ST(1)), n_a; + ULONG handle = (items >= 3 ? (ULONG)SvIV(ST(2)) : 0); + ULONG offset = (items >= 4 ? (ULONG)SvIV(ST(3)) : 0); + + if (size <= 0) + Perl_croak(aTHX_ "OS2::_headerInfo(): unexpected size: %d", (int)size); + ST(0) = newSVpvn("",0); + SvGROW(ST(0), size + 1); + sv_2mortal(ST(0)); + + if (!_Dos32QueryHeaderInfo(handle, offset, SvPV(ST(0), n_a), size, req)) + Perl_croak(aTHX_ "OS2::_headerInfo(%ld,%ld,%ld,%ld) error: %s", + req, size, handle, offset, os2error(Perl_rc)); + SvCUR_set(ST(0), size); + *SvEND(ST(0)) = 0; + } + XSRETURN(1); +} + +#define DQHI_QUERYLIBPATHSIZE 4 +#define DQHI_QUERYLIBPATH 5 + +XS(XS_OS2_libPath) +{ + dXSARGS; + if (items != 0) + Perl_croak(aTHX_ "Usage: OS2::libPath()"); + { + ULONG size; + STRLEN n_a; + + if (!_Dos32QueryHeaderInfo(0, 0, &size, sizeof(size), + DQHI_QUERYLIBPATHSIZE)) + Perl_croak(aTHX_ "OS2::_headerInfo(%ld,%ld,%ld,%ld) error: %s", + DQHI_QUERYLIBPATHSIZE, sizeof(size), 0, 0, + os2error(Perl_rc)); + ST(0) = newSVpvn("",0); + SvGROW(ST(0), size + 1); + sv_2mortal(ST(0)); + + /* We should be careful: apparently, this entry point does not + pay attention to the size argument, so may overwrite + unrelated data! */ + if (!_Dos32QueryHeaderInfo(0, 0, SvPV(ST(0), n_a), size, + DQHI_QUERYLIBPATH)) + Perl_croak(aTHX_ "OS2::_headerInfo(%ld,%ld,%ld,%ld) error: %s", + DQHI_QUERYLIBPATH, size, 0, 0, os2error(Perl_rc)); + SvCUR_set(ST(0), size); + *SvEND(ST(0)) = 0; + } + XSRETURN(1); +} + #define get_control87() _control87(0,0) #define set_control87 _control87 @@ -2522,14 +3319,63 @@ XS(XS_OS2__control87) unsigned new = (unsigned)SvIV(ST(0)); unsigned mask = (unsigned)SvIV(ST(1)); unsigned RETVAL; + dXSTARG; RETVAL = _control87(new, mask); - ST(0) = sv_newmortal(); - sv_setiv(ST(0), (IV)RETVAL); + XSprePUSH; PUSHi((IV)RETVAL); + } + XSRETURN(1); +} + +XS(XS_OS2_mytype) +{ + dXSARGS; + int which = 0; + + if (items < 0 || items > 1) + Perl_croak(aTHX_ "Usage: OS2::mytype([which])"); + if (items == 1) + which = (int)SvIV(ST(0)); + { + unsigned RETVAL; + dXSTARG; + + switch (which) { + case 0: + RETVAL = os2_mytype; /* Reset after fork */ + break; + case 1: + RETVAL = os2_mytype_ini; /* Before any fork */ + break; + case 2: + RETVAL = Perl_os2_initial_mode; /* Before first morphing */ + break; + case 3: + RETVAL = my_type(); /* Morphed type */ + break; + default: + Perl_croak(aTHX_ "OS2::mytype(which): unknown which=%d", which); + } + XSprePUSH; PUSHi((IV)RETVAL); } XSRETURN(1); } + +XS(XS_OS2_mytype_set) +{ + dXSARGS; + int type; + + if (items == 1) + type = (int)SvIV(ST(0)); + else + Perl_croak(aTHX_ "Usage: OS2::mytype_set(type)"); + my_type_set(type); + XSRETURN_EMPTY; +} + + XS(XS_OS2_get_control87) { dXSARGS; @@ -2537,10 +3383,10 @@ XS(XS_OS2_get_control87) Perl_croak(aTHX_ "Usage: OS2::get_control87()"); { unsigned RETVAL; + dXSTARG; RETVAL = get_control87(); - ST(0) = sv_newmortal(); - sv_setiv(ST(0), (IV)RETVAL); + XSprePUSH; PUSHi((IV)RETVAL); } XSRETURN(1); } @@ -2555,6 +3401,7 @@ XS(XS_OS2_set_control87) unsigned new; unsigned mask; unsigned RETVAL; + dXSTARG; if (items < 1) new = MCW_EM; @@ -2569,8 +3416,29 @@ XS(XS_OS2_set_control87) } RETVAL = set_control87(new, mask); - ST(0) = sv_newmortal(); - sv_setiv(ST(0), (IV)RETVAL); + XSprePUSH; PUSHi((IV)RETVAL); + } + XSRETURN(1); +} + +XS(XS_OS2_incrMaxFHandles) /* DosSetRelMaxFH */ +{ + dXSARGS; + if (items < 0 || items > 1) + Perl_croak(aTHX_ "Usage: OS2::incrMaxFHandles(delta = 0)"); + { + LONG delta; + ULONG RETVAL, rc; + dXSTARG; + + if (items < 1) + delta = 0; + else + delta = (LONG)SvIV(ST(0)); + + if (CheckOSError(DosSetRelMaxFH(&delta, &RETVAL))) + croak_with_os2error("OS2::incrMaxFHandles(): DosSetRelMaxFH() error"); + XSprePUSH; PUSHu((UV)RETVAL); } XSRETURN(1); } @@ -2590,6 +3458,8 @@ Xs_OS2_init(pTHX) newXS("OS2::Error", XS_OS2_Error, file); newXS("OS2::Errors2Drive", XS_OS2_Errors2Drive, file); newXS("OS2::SysInfo", XS_OS2_SysInfo, file); + newXSproto("OS2::DevCap", XS_OS2_DevCap, file, ";$$"); + newXSproto("OS2::SysInfoFor", XS_OS2_SysInfoFor, file, "$;$"); newXS("OS2::BootDrive", XS_OS2_BootDrive, file); newXS("OS2::MorphPM", XS_OS2_MorphPM, file); newXS("OS2::UnMorphPM", XS_OS2_UnMorphPM, file); @@ -2608,6 +3478,15 @@ Xs_OS2_init(pTHX) newXSproto("OS2::get_control87", XS_OS2_get_control87, file, ""); newXSproto("OS2::set_control87", XS_OS2_set_control87, file, ";$$"); newXSproto("OS2::DLLname", XS_OS2_DLLname, file, ";$$"); + newXSproto("OS2::mytype", XS_OS2_mytype, file, ";$"); + newXSproto("OS2::mytype_set", XS_OS2_mytype_set, file, "$"); + newXSproto("OS2::_headerInfo", XS_OS2__headerInfo, file, "$$;$$"); + newXSproto("OS2::libPath", XS_OS2_libPath, file, ""); + newXSproto("OS2::Timer", XS_OS2_Timer, file, ""); + newXSproto("OS2::incrMaxFHandles", XS_OS2_incrMaxFHandles, file, ";$"); + newXSproto("OS2::SysValues", XS_OS2_SysValues, file, ";$$"); + newXSproto("OS2::SysValues_set", XS_OS2_SysValues_set, file, "$$;$"); + newXSproto("OS2::Beep", XS_OS2_Beep, file, ";$$"); gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV); GvMULTI_on(gv); #ifdef PERL_IS_AOUT @@ -2634,8 +3513,6 @@ Xs_OS2_init(pTHX) return 0; } -OS2_Perl_data_t OS2_Perl_data; - extern void _emx_init(void*); static void jmp_out_of_atexit(void); @@ -2645,7 +3522,7 @@ static void jmp_out_of_atexit(void); static void my_emx_init(void *layout) { - static volatile void *p = 0; /* Cannot be on stack! */ + static volatile void *old_esp = 0; /* Cannot be on stack! */ /* Can't just call emx_init(), since it moves the stack pointer */ /* It also busts a lot of registers, so be extra careful */ @@ -2656,7 +3533,7 @@ my_emx_init(void *layout) { "call __emx_init\n" "movl %1, %%esp\n" "popa\n" - "popf\n" : : "r" (layout), "m" (p) ); + "popf\n" : : "r" (layout), "m" (old_esp) ); } struct layout_table_t { @@ -2680,7 +3557,7 @@ struct layout_table_t { static ULONG my_os_version() { - static ULONG res; /* Cannot be on stack! */ + static ULONG osv_res; /* Cannot be on stack! */ /* Can't just call __os_version(), since it does not follow C calling convention: it busts a lot of registers, so be extra careful */ @@ -2689,9 +3566,9 @@ my_os_version() { "call ___os_version\n" "movl %%eax, %0\n" "popa\n" - "popf\n" : "=m" (res) ); + "popf\n" : "=m" (osv_res) ); - return res; + return osv_res; } static void @@ -2703,7 +3580,6 @@ force_init_emx_runtime(EXCEPTIONREGISTRATIONRECORD *preg, ULONG flags) void *oldstackend, *oldstack; PPIB pib; PTIB tib; - static ULONG os2_dll; ULONG rc, error = 0, out; char buf[512]; static struct layout_table_t layout_table; @@ -2714,7 +3590,7 @@ force_init_emx_runtime(EXCEPTIONREGISTRATIONRECORD *preg, ULONG flags) } *newstack; char *s; - layout_table.os2_dll = (ULONG)&os2_dll; + layout_table.os2_dll = (ULONG)&os2_dll_fake; layout_table.flags = 0x02000002; /* flags: application, OMF */ DosGetInfoBlocks(&tib, &pib); @@ -2794,9 +3670,6 @@ force_init_emx_runtime(EXCEPTIONREGISTRATIONRECORD *preg, ULONG flags) exit(56); } -jmp_buf at_exit_buf; -int longjmp_at_exit; - static void jmp_out_of_atexit(void) { @@ -2806,8 +3679,6 @@ jmp_out_of_atexit(void) extern void _CRT_term(void); -int emx_runtime_secondary; - void Perl_OS2_term(void **p, int exitstatus, int flags) { @@ -2847,12 +3718,12 @@ Perl_OS2_term(void **p, int exitstatus, int flags) extern ULONG __os_version(); /* See system.doc */ -static int emx_wasnt_initialized; - void check_emx_runtime(char **env, EXCEPTIONREGISTRATIONRECORD *preg) { - ULONG v_crt, v_emx; + ULONG v_crt, v_emx, count = 0, rc, rc1, maybe_inited = 0; + static HMTX hmtx_emx_init = NULLHANDLE; + static int emx_init_done = 0; /* If _environ is not set, this code sits in a DLL which uses a CRT DLL which not compatible with the executable's @@ -2861,6 +3732,44 @@ check_emx_runtime(char **env, EXCEPTIONREGISTRATIONRECORD *preg) if (_environ != NULL) return; /* Properly initialized */ + /* It is not DOS, so we may use OS/2 API now */ + /* Some data we manipulate is static; protect ourselves from + calling the same API from a different thread. */ + DosEnterMustComplete(&count); + + rc1 = DosEnterCritSec(); + if (!hmtx_emx_init) + rc = DosCreateMutexSem(NULL, &hmtx_emx_init, 0, TRUE); /*Create owned*/ + else + maybe_inited = 1; + + if (rc != NO_ERROR) + hmtx_emx_init = NULLHANDLE; + + if (rc1 == NO_ERROR) + DosExitCritSec(); + DosExitMustComplete(&count); + + while (maybe_inited) { /* Other thread did or is doing the same now */ + if (emx_init_done) + return; + rc = DosRequestMutexSem(hmtx_emx_init, + (ULONG) SEM_INDEFINITE_WAIT); /* Timeout (none) */ + if (rc == ERROR_INTERRUPT) + continue; + if (rc != NO_ERROR) { + char buf[80]; + ULONG out; + + sprintf(buf, + "panic: EMX backdoor init: DosRequestMutexSem error: %lu=%#lx\n", rc, rc); + DosWrite(2, buf, strlen(buf), &out); + return; + } + DosReleaseMutexSem(hmtx_emx_init); + return; + } + /* If the executable does not use EMX.DLL, EMX.DLL is not completely initialized either. Uninitialized EMX.DLL returns 0 in the low nibble of __os_version(). */ @@ -2913,6 +3822,9 @@ check_emx_runtime(char **env, EXCEPTIONREGISTRATIONRECORD *preg) *ep = NULL; } _environ = _org_environ = env; + emx_init_done = 1; + if (hmtx_emx_init) + DosReleaseMutexSem(hmtx_emx_init); } #define ENTRY_POINT 0x10000 @@ -2973,8 +3885,11 @@ Perl_OS2_init3(char **env, void **preg, int flags) } #if defined(USE_5005THREADS) || defined(USE_ITHREADS) MUTEX_INIT(&start_thread_mutex); + MUTEX_INIT(&perlos2_state_mutex); #endif os2_mytype = my_type(); /* Do it before morphing. Needed? */ + os2_mytype_ini = os2_mytype; + Perl_os2_initial_mode = -1; /* Uninit */ /* Some DLLs reset FP flags on load. We may have been linked with them */ _control87(MCW_EM, MCW_EM); } @@ -3072,16 +3987,20 @@ my_flock(int handle, int o) ULONG timeout, handle_type, flag_word; APIRET rc; int blocking, shared; - static int use_my = -1; + static int use_my_flock = -1; - if (use_my == -1) { + if (use_my_flock == -1) { + MUTEX_LOCK(&perlos2_state_mutex); + if (use_my_flock == -1) { char *s = getenv("USE_PERL_FLOCK"); if (s) - use_my = atoi(s); + use_my_flock = atoi(s); else - use_my = 1; + use_my_flock = 1; + } + MUTEX_UNLOCK(&perlos2_state_mutex); } - if (!(_emx_env & 0x200) || !use_my) + if (!(_emx_env & 0x200) || !use_my_flock) return flock(handle, o); /* Delegate to EMX. */ /* is this a file? */ @@ -3175,9 +4094,6 @@ my_flock(int handle, int o) return 0; } -static int pwent_cnt; -static int _my_pwent = -1; - static int use_my_pwent(void) { @@ -3224,8 +4140,6 @@ my_getpwent (void) return getpwuid(0); } -static int grent_cnt; - void setgrent(void) { @@ -3254,7 +4168,6 @@ static const char pw_p[] = "Jf0Wb/BzMFvk7K7lrzK"; static struct passwd * passw_wrap(struct passwd *p) { - static struct passwd pw; char *s; if (!p || (p->pw_passwd && *p->pw_passwd)) /* Not a dangerous password */ @@ -3283,6 +4196,21 @@ my_getpwnam (__const__ char *n) char * gcvt_os2 (double value, int digits, char *buffer) { + double absv = value > 0 ? value : -value; + /* EMX implementation is lousy between 0.1 and 0.0001 (uses exponents below + 0.1), 1-digit stuff is ok below 0.001; multi-digit below 0.0001. */ + int buggy; + + absv *= 10000; + buggy = (absv < 1000 && (absv >= 10 || (absv > 1 && floor(absv) != absv))); + + if (buggy) { + char pat[12]; + + sprintf(pat, "%%.%dg", digits); + sprintf(buffer, pat, value); + return buffer; + } return gcvt (value, digits, buffer); } @@ -3293,14 +4221,66 @@ int fork_with_resources() dTHX; void *ctx = PERL_GET_CONTEXT; #endif - + unsigned fpflag = _control87(0,0); int rc = fork(); -#if (defined(USE_5005THREADS) || defined(USE_ITHREADS)) && !defined(USE_SLOW_THREAD_SPECIFIC) if (rc == 0) { /* child */ +#if (defined(USE_5005THREADS) || defined(USE_ITHREADS)) && !defined(USE_SLOW_THREAD_SPECIFIC) ALLOC_THREAD_KEY; /* Acquire the thread-local memory */ PERL_SET_CONTEXT(ctx); /* Reinit the thread-local memory */ - } #endif + + { /* Reload loaded-on-demand DLLs */ + struct dll_handle_t *dlls = dll_handles; + + while (dlls->modname) { + char dllname[260], fail[260]; + ULONG rc; + + if (!dlls->handle) { /* Was not loaded */ + dlls++; + continue; + } + /* It was loaded in the parent. We need to reload it. */ + + rc = DosQueryModuleName(dlls->handle, sizeof(dllname), dllname); + if (rc) { + Perl_warn_nocontext("Can't find DLL name for the module `%s' by the handle %d, rc=%lu=%#lx", + dlls->modname, (int)dlls->handle, rc, rc); + dlls++; + continue; + } + rc = DosLoadModule(fail, sizeof fail, dllname, &dlls->handle); + if (rc) + Perl_warn_nocontext("Can't load DLL `%s', possible problematic module `%s'", + dllname, fail); + dlls++; + } + } + + { /* Support message queue etc. */ + os2_mytype = my_type(); + /* Apparently, subprocesses (in particular, fork()) do not + inherit the morphed state, so os2_mytype is the same as + os2_mytype_ini. */ + + if (Perl_os2_initial_mode != -1 + && Perl_os2_initial_mode != os2_mytype) { + /* XXXX ??? */ + } + } + if (Perl_HAB_set) + (void)_obtain_Perl_HAB; + if (Perl_hmq_refcnt) { + if (my_type() != 3) + my_type_set(3); + Create_HMQ(Perl_hmq_servers != 0, + "Cannot create a message queue on fork"); + } + + /* We may have loaded some modules */ + _control87(fpflag, MCW_EM); /* Some modules reset FP flags on (un)load */ + } return rc; } + diff --git a/os2/os2ish.h b/os2/os2ish.h index c0eb40f..bb8420e 100644 --- a/os2/os2ish.h +++ b/os2/os2ish.h @@ -299,7 +299,7 @@ void *sys_alloc(int size); #endif #define TMPPATH1 "plXXXXXX" -extern char *tmppath; +extern const char *tmppath; PerlIO *my_syspopen(pTHX_ char *cmd, char *mode); /* Cannot prototype with I32 at this point. */ int my_syspclose(PerlIO *f); @@ -312,6 +312,28 @@ void my_setpwent (void); void my_endpwent (void); char *gcvt_os2(double value, int digits, char *buffer); +#define MAX_SLEEP (((1<30) / (1000/4))-1) /* 1<32 msec */ + +static __inline__ unsigned +my_sleep(unsigned sec) +{ + int remain; + while (sec > MAX_SLEEP) { + sec -= MAX_SLEEP; + remain = sleep(MAX_SLEEP); + if (remain) + return remain + sec; + } + return sleep(sec); +} + +#define sleep my_sleep + +#ifndef INCL_DOS +unsigned long DosSleep(unsigned long); +unsigned long DosAllocThreadLocalMemory (unsigned long cb, unsigned long **p); +#endif + struct group *getgrent (void); void setgrent (void); void endgrent (void); @@ -330,6 +352,9 @@ struct passwd *my_getpwnam (__const__ char *); #define strtoll _strtoll #define strtoull _strtoull +#define usleep(usec) ((void)_sleep2(((usec)+500)/1000)) + + /* * fwrite1() should be a routine with the same calling sequence as fwrite(), * but which outputs all of the bytes requested as a single stream (unlike @@ -440,6 +465,7 @@ typedef struct OS2_Perl_data { unsigned long phmq_refcnt; unsigned long phmq_servers; unsigned long initial_mode; /* VIO etc. mode we were started in */ + unsigned long morph_refcnt; } OS2_Perl_data_t; extern OS2_Perl_data_t OS2_Perl_data; @@ -463,6 +489,7 @@ extern OS2_Perl_data_t OS2_Perl_data; #define Perl_hmq_refcnt (OS2_Perl_data.phmq_refcnt) #define Perl_hmq_servers (OS2_Perl_data.phmq_servers) #define Perl_os2_initial_mode (OS2_Perl_data.initial_mode) +#define Perl_morph_refcnt (OS2_Perl_data.morph_refcnt) unsigned long Perl_hab_GET(); unsigned long Perl_Register_MQ(int serve); @@ -615,6 +642,44 @@ enum entries_ordinals { ORD_WinQueryDesktopWindow, ORD_WinSetActiveWindow, ORD_DosQueryModFromEIP, + ORD_Dos32QueryHeaderInfo, + ORD_DosTmrQueryFreq, + ORD_DosTmrQueryTime, + ORD_WinQueryActiveDesktopPathname, + ORD_WinInvalidateRect, + ORD_WinCreateFrameControls, + ORD_WinQueryClipbrdFmtInfo, + ORD_WinQueryClipbrdOwner, + ORD_WinQueryClipbrdViewer, + ORD_WinQueryClipbrdData, + ORD_WinOpenClipbrd, + ORD_WinCloseClipbrd, + ORD_WinSetClipbrdData, + ORD_WinSetClipbrdOwner, + ORD_WinSetClipbrdViewer, + ORD_WinEnumClipbrdFmts, + ORD_WinEmptyClipbrd, + ORD_WinAddAtom, + ORD_WinFindAtom, + ORD_WinDeleteAtom, + ORD_WinQueryAtomUsage, + ORD_WinQueryAtomName, + ORD_WinQueryAtomLength, + ORD_WinQuerySystemAtomTable, + ORD_WinCreateAtomTable, + ORD_WinDestroyAtomTable, + ORD_WinOpenWindowDC, + ORD_DevOpenDC, + ORD_DevQueryCaps, + ORD_DevCloseDC, + ORD_WinMessageBox, + ORD_WinMessageBox2, + ORD_WinQuerySysValue, + ORD_WinSetSysValue, + ORD_WinAlarm, + ORD_WinFlashWindow, + ORD_WinLoadPointer, + ORD_WinQuerySysPointer, ORD_NENTRIES }; @@ -676,6 +741,21 @@ char *perllib_mangle(char *, unsigned int); #define fork fork_with_resources +static __inline__ int +my_select(int nfds, fd_set *readfds, fd_set *writefds, fd_set *exceptfds, struct timeval *timeout) +{ + if (nfds == 0 && timeout && (_emx_env & 0x200)) { + if (DosSleep(1000 * timeout->tv_sec + (timeout->tv_usec + 500)/1000) == 0) + return 0; + errno = EINTR; + return -1; + } + return select(nfds, readfds, writefds, exceptfds, timeout); +} + +#define select my_select + + typedef int (*Perl_PFN)(); Perl_PFN loadByOrdinal(enum entries_ordinals ord, int fail); extern const Perl_PFN * const pExtFCN; @@ -685,9 +765,11 @@ int fork_with_resources(); int setpriority(int which, int pid, int val); int getpriority(int which /* ignored */, int pid); +void croak_with_os2error(char *s) __attribute__((noreturn)); + #ifdef PERL_CORE int os2_do_spawn(pTHX_ char *cmd); -int os2_do_aspawn(pTHX_ SV *really, void **vmark, void **vsp); +int os2_do_aspawn(pTHX_ SV *really, SV **vmark, SV **vsp); #endif #ifndef LOG_DAEMON diff --git a/os2/perlrexx.cmd b/os2/perlrexx.cmd new file mode 100644 index 0000000..5a32d85 --- /dev/null +++ b/os2/perlrexx.cmd @@ -0,0 +1,68 @@ +/* Test PERLREXX.DLL */ +/* Example: + perlrexx.cmd BEGIN {push @INC, 'lib'} use OS2::REXX; REXX_eval "address cmd\n'copyy'"; + */ + +call RxFuncAdd 'SysLoadFuncs', 'RexxUtil', 'SysLoadFuncs' +call SysLoadFuncs + +parse arg args +retval = runperl(args) +say 'retval = "'retval'"' +exit 0 + +addperl: procedure + parse arg perlf + pathname='perlrexx' + r = RxFuncAdd(perlf, pathname, perlf) + say "RxFuncAdd("perlf","pathname") -> "r + return + +runperl1: procedure + parse arg perlarg + call addperl('PERL') + call addperl('PERLTERM') + call addperl('PERLEXIT') + call addperl('PERLEVAL') + call addperl('PERLLASTERROR') + signal on syntax name runperl_error +/* signal on error name runperl_error + signal on failure name runperl_error */ + say "doing PERLEVAL("perlarg")" + tmp = PERLEVAL(perlarg) + say "PERLEVAL -> '"tmp"'" + signal off syntax + call RxFuncDrop 'PERL' + call RxFuncDrop 'PERLLASTERROR' + call RxFuncDrop 'PERLTERM' + call RxFuncDrop 'PERLEVAL' + call PERLEXIT + call RxFuncDrop 'PERLEXIT' + return pathname ': PERLEVAL('perlarg') =' tmp + +runperl: procedure + parse arg perlarg + pathname='perlrexx' + r = RxFuncAdd("PerlExportAll", pathname, "PERLEXPORTALL") + say "RxFuncAdd("'PerlExportAll'","pathname") -> "r + r = PerlExportAll() + say "PerlExportAll() -> "r + signal on syntax name runperl_error +/* signal on error name runperl_error + signal on failure name runperl_error */ + say "doing PERLEVAL("perlarg")" + tmp = PERLEVAL(perlarg) + say "PERLEVAL -> '"tmp"'" + address evalperl perlarg + say "Did address evalperl "perlarg + signal off syntax + r = PerlDropAllExit() + /* The following line is not reached... Why? */ + say "PerlDropAllExit() -> "r + return pathname ': PERLEVAL('perlarg') =' tmp + + +runperl_error: + return pathname ': REXX->Perl interface not available; rc="'rc'", .rs="'.rs'", errstr="'errortext(rc)'", perlerr="'PERLLASTERROR()'"' + +/* return pathname ': REXX->Perl interface not available; rc="'rc'", .rs="'.rs'", errstr="'errortext(rc)'", perlerr="???"' */ diff --git a/perl.c b/perl.c index a194634..989d1e3 100644 --- a/perl.c +++ b/perl.c @@ -3632,8 +3632,10 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char *s; SV *sv; GV* tmpgv; +#ifdef NEED_ENVIRON_DUP_FOR_MODIFY char **dup_env_base = 0; int dup_env_count = 0; +#endif PL_toptarget = NEWSV(0,0); sv_upgrade(PL_toptarget, SVt_PVFM); diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod index 11fecf6..436d5a8 100644 --- a/pod/perlfunc.pod +++ b/pod/perlfunc.pod @@ -732,10 +732,14 @@ chr(0x263a) is a Unicode smiley face. Note that characters from 127 to 255 (inclusive) are by default not encoded in Unicode for backward compatibility reasons (but see L). +If NUMBER is omitted, uses C<$_>. + For the reverse, use L. -See L and L for more about Unicode. -If NUMBER is omitted, uses C<$_>. +Note that under the C pragma the NUMBER is masked to +the low eight bits. + +See L and L for more about Unicode. =item chroot FILENAME @@ -2431,11 +2435,15 @@ If EXPR is omitted, uses C<$_>. =item length -Returns the length in characters of the value of EXPR. If EXPR is +Returns the length in I of the value of EXPR. If EXPR is omitted, returns length of C<$_>. Note that this cannot be used on an entire array or hash to find out how many elements these have. For that, use C and C respectively. +Note the I: if the EXPR is in Unicode, you will get the +number of characters, not the number of bytes. To get the length +in bytes, use C, see L. + =item link OLDFILE,NEWFILE Creates a new filename linked to the old filename. Returns true for @@ -4201,9 +4209,9 @@ last occurrence at or before that position. =item rmdir -Deletes the directory specified by FILENAME if that directory is empty. If it -succeeds it returns true, otherwise it returns false and sets C<$!> (errno). If -FILENAME is omitted, uses C<$_>. +Deletes the directory specified by FILENAME if that directory is +empty. If it succeeds it returns true, otherwise it returns false and +sets C<$!> (errno). If FILENAME is omitted, uses C<$_>. =item s/// diff --git a/pod/perlunicode.pod b/pod/perlunicode.pod index 4508de7..91bb0f8 100644 --- a/pod/perlunicode.pod +++ b/pod/perlunicode.pod @@ -780,13 +780,13 @@ Level 1 - Basic Unicode Support capital letters with certain modifiers: the Full case-folding decomposes the letter, while the Simple case-folding would map it to a single character. - [ 9] see UTR#13 Unicode Newline Guidelines + [ 9] see UTR #13 Unicode Newline Guidelines [10] should do ^ and $ also on \x{85}, \x{2028} and \x{2029} (should also affect <>, $., and script line numbers) (the \x{85}, \x{2028} and \x{2029} do match \s) [a] You can mimic class subtraction using lookahead. -For example, what TR18 might write as +For example, what UTR #18 might write as [{Greek}-[{UNASSIGNED}]] @@ -801,6 +801,9 @@ But in this particular example, you probably really want which will match assigned characters known to be part of the Greek script. +Also see the Unicode::Regex::Set module, it does implement the full +UTR #18 grouping, intersection, union, and removal (subtraction) syntax. + [b] See L. =item * diff --git a/pod/perluniintro.pod b/pod/perluniintro.pod index feee902..c20e05c 100644 --- a/pod/perluniintro.pod +++ b/pod/perluniintro.pod @@ -504,7 +504,7 @@ Yet another way would be to use the Devel::Peek module: That shows the UTF8 flag in FLAGS and both the UTF-8 bytes and Unicode characters in C. See also later in this document -the discussion about the C function of the C module. +the discussion about the C function. =back @@ -625,8 +625,7 @@ didn't get the transparency of Unicode quite right. Okay, if you insist: - use Encode 'is_utf8'; - print is_utf8($string) ? 1 : 0, "\n"; + print utf8::is_utf8($string) ? 1 : 0, "\n"; But note that this doesn't mean that any of the characters in the string are necessary UTF-8 encoded, or that any of the characters have diff --git a/pp_sys.c b/pp_sys.c index 57820b4..995f23d 100644 --- a/pp_sys.c +++ b/pp_sys.c @@ -4144,14 +4144,14 @@ PP(pp_system) result = 0; if (PL_op->op_flags & OPf_STACKED) { SV *really = *++MARK; -# ifdef WIN32 +# if defined(WIN32) || defined(OS2) value = (I32)do_aspawn(really, MARK, SP); # else value = (I32)do_aspawn(really, (void **)MARK, (void **)SP); # endif } else if (SP - MARK != 1) { -# ifdef WIN32 +# if defined(WIN32) || defined(OS2) value = (I32)do_aspawn(Nullsv, MARK, SP); # else value = (I32)do_aspawn(Nullsv, (void **)MARK, (void **)SP); diff --git a/sv.c b/sv.c index e8dfe45..c0d03cb 100644 --- a/sv.c +++ b/sv.c @@ -9036,7 +9036,9 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV p = SvEND(sv); *p = '\0'; } - if (left && ckWARN(WARN_PRINTF) && strchr(eptr, '\n') && + /* Use memchr() instead of strchr(), as eptr is not guaranteed */ + /* to point to a null-terminated string. */ + if (left && ckWARN(WARN_PRINTF) && memchr(eptr, '\n', elen) && (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) Perl_warner(aTHX_ packWARN(WARN_PRINTF), "Newline in left-justified string for %sprintf", diff --git a/universal.c b/universal.c index 1c48999..1ce9121 100644 --- a/universal.c +++ b/universal.c @@ -165,6 +165,7 @@ Perl_sv_derived_from(pTHX_ SV *sv, const char *name) void XS_UNIVERSAL_isa(pTHX_ CV *cv); void XS_UNIVERSAL_can(pTHX_ CV *cv); void XS_UNIVERSAL_VERSION(pTHX_ CV *cv); +XS(XS_utf8_is_utf8); XS(XS_utf8_valid); XS(XS_utf8_encode); XS(XS_utf8_decode); @@ -185,6 +186,7 @@ Perl_boot_core_UNIVERSAL(pTHX) newXS("UNIVERSAL::isa", XS_UNIVERSAL_isa, file); newXS("UNIVERSAL::can", XS_UNIVERSAL_can, file); newXS("UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, file); + newXS("utf8::is_utf8", XS_utf8_is_utf8, file); newXS("utf8::valid", XS_utf8_valid, file); newXS("utf8::encode", XS_utf8_encode, file); newXS("utf8::decode", XS_utf8_decode, file); @@ -364,23 +366,40 @@ finish: XSRETURN(1); } +XS(XS_utf8_is_utf8) +{ + dXSARGS; + if (items != 1) + Perl_croak(aTHX_ "Usage: utf8::is_utf8(sv)"); + { + SV * sv = ST(0); + { + if (SvUTF8(sv)) + XSRETURN_YES; + else + XSRETURN_NO; + } + } + XSRETURN_EMPTY; +} + XS(XS_utf8_valid) { - dXSARGS; - if (items != 1) - Perl_croak(aTHX_ "Usage: utf8::valid(sv)"); - { - SV * sv = ST(0); - { - STRLEN len; - char *s = SvPV(sv,len); - if (!SvUTF8(sv) || is_utf8_string((U8*)s,len)) - XSRETURN_YES; - else - XSRETURN_NO; - } - } - XSRETURN_EMPTY; + dXSARGS; + if (items != 1) + Perl_croak(aTHX_ "Usage: utf8::valid(sv)"); + { + SV * sv = ST(0); + { + STRLEN len; + char *s = SvPV(sv,len); + if (!SvUTF8(sv) || is_utf8_string((U8*)s,len)) + XSRETURN_YES; + else + XSRETURN_NO; + } + } + XSRETURN_EMPTY; } XS(XS_utf8_encode) diff --git a/utils/h2xs.PL b/utils/h2xs.PL index 7ec7dea..ffc343e 100644 --- a/utils/h2xs.PL +++ b/utils/h2xs.PL @@ -879,8 +879,9 @@ if( @path_h ){ close(CH); } else { - use Fcntl qw/SEEK_SET/; - seek CH, 0, SEEK_SET; + # Work from miniperl too - on "normal" systems + my $SEEK_SET = eval 'use Fcntl qw/SEEK_SET/; SEEK_SET' or 0; + seek CH, 0, $SEEK_SET; my $src = do { local $/; }; close CH; no warnings 'uninitialized'; -- 1.8.3.1