Integrate:

author Jarkko Hietaniemi <jhi@iki.fi>

Sun, 15 Jun 2003 17:57:06 +0000 (17:57 +0000)

committer Jarkko Hietaniemi <jhi@iki.fi>

Sun, 15 Jun 2003 17:57:06 +0000 (17:57 +0000)
author Jarkko Hietaniemi <jhi@iki.fi>
Sun, 15 Jun 2003 17:57:06 +0000 (17:57 +0000)
committer Jarkko Hietaniemi <jhi@iki.fi>
Sun, 15 Jun 2003 17:57:06 +0000 (17:57 +0000)
diff --git a/MANIFEST b/MANIFEST

index 4f1d898..64adbce 100644 (file)
--- 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/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"
  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/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
  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/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/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
  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 (file)
--- a/doio.c
+++ b/doio.c
@@ -1395,11 +1395,13 @@ Perl_my_lstat(pTHX)
      return PL_laststatval;
  }
  
      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);
  }
  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,
  
  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 (executable)
--- 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:
  
  # 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`"
  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 (file)
--- a/ext/Time/HiRes/Makefile.PL
+++ b/ext/Time/HiRes/Makefile.PL
@@ -14,6 +14,8 @@ my $DEFINE;
  my $LIBS;
  my $XSOPT;
  
  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;
  }
  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
          {
          }
          else
          {
+           my $tmp_exe = "$tmp$ld_exeext";
             printf "cccmd = $cccmd\n" if $VERBOSE;
             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 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) {
      }
  
      if ($DEFINE) {
diff --git a/handy.h b/handy.h

index 6936c20..9f0fb3c 100644 (file)
--- 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 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)
  #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 (file)
--- a/hints/freebsd.sh
+++ b/hints/freebsd.sh
@@ -92,10 +92,17 @@ case "$osvers" in
         d_setegid='undef'
         d_seteuid='undef'
         ;;
         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
  *)     usevfork='true'
         case "$usemymalloc" in
-           "") usemymalloc='n'
-               ;;
+       "") usemymalloc='y'
+           ;;
         esac
         libswanted=`echo $libswanted | sed 's/ malloc / /'`
         ;;
         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?
  
         # Even with the malloc mutexes the Perl malloc does not
         # seem to be threadsafe in FreeBSD?
-       usemymalloc=n
+       usemymalloc=y
  
  esac
  EOCBU
  
  esac
  EOCBU
diff --git a/hints/os2.sh b/hints/os2.sh

index b2f962d..a3fc0b6 100644 (file)
--- 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_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 '
  
  # 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 (file)
--- 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;
         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
  }
  
  # EXPORT_LIST
diff --git a/lib/FileCache.t b/lib/FileCache.t

deleted file mode 100755 (executable)

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 <foo> 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 (file)

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 (file)

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 (file)

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 (file)

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 <foo> 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 (file)

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 (file)
--- a/lib/bytes.t
+++ b/lib/bytes.t
@@ -1,32 +1,34 @@
  BEGIN {
      chdir 't' if -d 't';
      @INC = '../lib';
  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;
  
  {
      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;
  
  {
      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 {
      } 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 (file)
--- 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<no utf8;>.
  
  =head2 Utility functions
  
  
  =head2 Utility functions
  
-The following functions are defined in the C<utf8::> package by the perl core.
+The following functions are defined in the C<utf8::> package by the
+Perl core.  You do not need to say C<use utf8> 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);
  
  
  =over 4
  
  =item * $num_octets = utf8::upgrade($string);
  
-Converts (in-place) internal representation of string to Perl's internal
-I<UTF-X> form.  Returns the number of octets necessary to represent
-the string as I<UTF-X>.  Can be used to make sure that the
+Converts (in-place) internal representation of string to Perl's
+internal I<UTF-X> form.  Returns the number of octets necessary to
+represent the string as I<UTF-X>.  Can be used to make sure that the
  UTF-8 flag is on, so that C<\w> or C<lc()> work as expected on strings
  UTF-8 flag is on, so that C<\w> or C<lc()> 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])
  
  
  =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
  =item * utf8::encode($string)
  
  Converts (in-place) I<$string> from logical characters to octet
-sequence representing it in Perl's I<UTF-X> 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<UTF-X> 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<UTF-X> encoding
  
  =item * $flag = utf8::decode($string)
  
  Attempts to convert I<$string> in-place from Perl's I<UTF-X> 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)
  
  
  =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<or> 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
  
  
  =back
  
@@ -128,9 +136,9 @@ functions C<sv_utf8_upgrade>, C<sv_utf8_downgrade>, C<sv_utf8_encode>,
  and C<sv_utf8_decode>, which are wrapped by the Perl functions
  C<utf8::upgrade>, C<utf8::downgrade>, C<utf8::encode> and
  C<utf8::decode>.  Note that in the Perl 5.8.0 implementation the
  and C<sv_utf8_decode>, which are wrapped by the Perl functions
  C<utf8::upgrade>, C<utf8::downgrade>, C<utf8::encode> and
  C<utf8::decode>.  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<require utf8>
-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<require utf8> statement-- this may change in future releases.
  
  =head1 BUGS
  
  
  =head1 BUGS
  
diff --git a/lib/utf8.t b/lib/utf8.t

index 223bb1d..33cd596 100644 (file)
--- 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
  
  {
      # 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]");};
  }
      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..1e8878f 100644 (file)
--- a/makedef.pl
+++ b/makedef.pl
@@ -389,6 +389,8 @@ elsif ($PLATFORM eq 'os2') {
                     my_getpwent
                     my_setpwent
                     my_endpwent
                     my_getpwent
                     my_setpwent
                     my_endpwent
+                   fork_with_resources
+                   croak_with_os2error
                     setgrent
                     endgrent
                     getgrent
                     setgrent
                     endgrent
                     getgrent
diff --git a/os2/OS2/Process/Makefile.PL b/os2/OS2/Process/Makefile.PL

index 6a59d1f..c24af0c 100644 (file)
--- 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:
        '--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"),
             '-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 (file)
--- 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
         ChildWindows
         out_codepage
         out_codepage_set
+       process_codepage_set
         in_codepage
         in_codepage_set
         cursor
         in_codepage
         in_codepage_set
         cursor
@@ -124,6 +125,45 @@ our @EXPORT = qw(
          SetWindowPtr
          SetWindowULong
          SetWindowUShort
          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
  
         get_title
         set_title
@@ -178,7 +218,7 @@ sub import {
    my $ini = @_;
    @_ = ($class,
         map {
    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;
  }
         } @_);
    goto &Exporter::import if @_ > 1 or $ini == 0;
  }
@@ -335,6 +375,117 @@ sub ChildWindows (;$) {
    @kids;
  }
  
    @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#<number>', 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;
  # 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<screen_set($buffer)>
  
  
  =item C<screen_set($buffer)>
  
-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
  
  
  =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.
  
  sets text of the titlebar and task switch menu of the current process' window
  via direct manipulation of the windows' texts.
  
-=item C<SwitchToProgram($sw_entry)>
+=item C<SwitchToProgram([$sw_entry])>
  
  
-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
  
  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<Ctrl-Esc> list.
  To show an application, use either one of
  
         WinShowWindow( $hwnd, 1 );
  To show an application, use either one of
  
         WinShowWindow( $hwnd, 1 );
-       SetFocus( $hwnd );
+       FocusWindow_set( $hwnd );
         SwitchToProgram($switch_handle);
  
         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<FocusWindow_set_keep_Zorder($hwnd)>
+
+same as FocusWindow_set(), but preserves the Z-order of windows.
  
  =item C<ActiveWindow([$parentHwnd])>
  
  
  =item C<ActiveWindow([$parentHwnd])>
  
@@ -1013,6 +1184,16 @@ item list when beginning is reached.
  
  =back
  
  
  =back
  
+=item DesktopWindow()
+
+gets the actual window handle of the PM desktop; most APIs accept the
+pseudo-handle C<HWND_DESKTOP> 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<Win*>-class APIs which may
  =item ResetWinError()
  
  Resets $^E.  One may need to call it before the C<Win*>-class APIs which may
@@ -1031,6 +1212,77 @@ This function is normally not needed.  Not exported by default.
  
  =back
  
  
  =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<CF_TEXT>).
+
+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<CF_TEXT>).
+
+=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.
  =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
  
         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
  
  
    >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 (file)
--- 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_WININPUT
  #define INCL_VIO
  #define INCL_KBD
+#define INCL_WINCLIPBOARD
+#define INCL_WINATOM
  #include <os2.h>
  
  #include "EXTERN.h"
  #include <os2.h>
  
  #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 (!(_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"); 
         }
         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;
      }
      
      return apptype;
@@ -260,7 +264,7 @@ DeclFuncByORD(ULONG, XmyWinSwitchToProgram,  ORD_WinSwitchToProgram,
  #define myWinSwitchToProgram(hsw) (!CheckOSError(XmyWinSwitchToProgram(hsw)))
  
  
  #define myWinSwitchToProgram(hsw) (!CheckOSError(XmyWinSwitchToProgram(hsw)))
  
  
-
+/* These function croak if the return value is 0. */
  DeclWinFunc_CACHE(HWND, QueryWindow, (HWND hwnd, LONG cmd), (hwnd, cmd))
  DeclWinFunc_CACHE(BOOL, QueryWindowPos, (HWND hwnd, PSWP pswp),
                   (hwnd, pswp))
  DeclWinFunc_CACHE(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(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),
  
  /* 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 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)
  
  int
  WindowText_set(HWND hwnd, char* text)
@@ -355,7 +419,7 @@ myQueryWindowText(HWND hwnd)
      }
      sv = newSVpvn("", 0);
      SvGROW(sv, l + 1);
      }
      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()");
      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));
  }
  
      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)))
          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)))
          swentryp->hswitch = hSwitch;
          if (CheckOSError(myWinQuerySwitchEntry(hSwitch, &swentryp->swctl)))
-            croak("WinQuerySwitchEntry err %ld", rc);
+            croak_with_os2error("WinQuerySwitchEntry");
  }
  
  static void
  }
  
  static void
@@ -433,6 +506,103 @@ fill_swentry_default(SWENTRY *swentryp)
         fill_swentry(swentryp, NULLHANDLE, getpid());
  }
  
         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);
  
  /* static ULONG (* APIENTRY16 pDosSmSetTitle)(ULONG, PSZ); */
  ULONG _THUNK_FUNCTION(DosSmSetTitle)(ULONG, PSZ);
  
@@ -508,7 +678,7 @@ set_title2(char *s)
  #endif
  
  SV *
  #endif
  
  SV *
-process_swentry(unsigned long pid, unsigned long hwnd)
+process_swentry(unsigned long pid, HWND hwnd)
  {
      SWENTRY swentry;
  
  {
      SWENTRY swentry;
  
@@ -660,7 +830,7 @@ cursor(int *sp, int *ep, int *wp, int *ap)
      VIO_FROM_VIOB;
  
      if (CheckOSError(VioGetCurType( vio, 0 )))
      VIO_FROM_VIOB;
  
      if (CheckOSError(VioGetCurType( vio, 0 )))
-       croak("VioGetCurType() error");
+       croak_with_os2error("VioGetCurType() error");
  
      *sp = vio->yStart;
      *ep = vio->cEnd;
  
      *sp = vio->yStart;
      *ep = vio->cEnd;
@@ -706,7 +876,7 @@ bufsize(void)
  
      vio->cb = sizeof(*vio);
      if (CheckOSError(VioGetMode( vio, 0 )))
  
      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);
  #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 )))
      ULONG cps[4], cp, rc;
  
      if (CheckOSError(DosQueryCp( sizeof(cps), cps, &cp )))
-       croak("DosQueryCp() error");
+       croak_with_os2error("DosQueryCp()");
      return cp;
  }
  
      return cp;
  }
  
@@ -776,7 +946,7 @@ out_codepage()
      USHORT cp, rc;
  
      if (CheckOSError(VioGetCp( 0, &cp, 0 )))
      USHORT cp, rc;
  
      if (CheckOSError(VioGetCp( 0, &cp, 0 )))
-       croak("VioGetCp() error");
+       croak_with_os2error("VioGetCp()");
      return cp;
  }
  
      return cp;
  }
  
@@ -794,7 +964,7 @@ in_codepage()
      USHORT cp, rc;
  
      if (CheckOSError(KbdGetCp( 0, &cp, 0 )))
      USHORT cp, rc;
  
      if (CheckOSError(KbdGetCp( 0, &cp, 0 )))
-       croak("KbdGetCp() error");
+       croak_with_os2error("KbdGetCp()");
      return cp;
  }
  
      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 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
  MODULE = OS2::Process          PACKAGE = OS2::Process
  
  PROTOTYPES: ENABLE
@@ -904,7 +1077,7 @@ sesmgr_title_set(s)
      char *s
  
  SV *
      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
    PROTOTYPE: DISABLE
  
  int
@@ -917,27 +1090,27 @@ void
  ResetWinError()
  
  int
  ResetWinError()
  
  int
-WindowText_set(unsigned long hwndFrame, char *title)
+WindowText_set(HWND hwndFrame, char *title)
  
  bool
  
  bool
-FocusWindow_set(unsigned long hwndFocus, unsigned long hwndDesktop = HWND_DESKTOP)
+FocusWindow_set(HWND hwndFocus, HWND hwndDesktop = HWND_DESKTOP)
  
  bool
  
  bool
-ShowWindow(unsigned long hwnd, bool fShow = TRUE)
+ShowWindow(HWND hwnd, bool fShow = TRUE)
  
  bool
  
  bool
-EnableWindow(unsigned long hwnd, bool fEnable = TRUE)
+EnableWindow(HWND hwnd, bool fEnable = TRUE)
  
  bool
  
  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
      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
    PROTOTYPE: DISABLE
  
  unsigned long
-BeginEnumWindows(unsigned long hwnd)
+BeginEnumWindows(HWND hwnd)
  
  bool
  EndEnumWindows(unsigned long henum)
  
  bool
  EndEnumWindows(unsigned long henum)
@@ -946,56 +1119,60 @@ unsigned long
  GetNextWindow(unsigned long henum)
  
  bool
  GetNextWindow(unsigned long henum)
  
  bool
-IsWindowVisible(unsigned long hwnd)
+IsWindowVisible(HWND hwnd)
  
  bool
  
  bool
-IsWindowEnabled(unsigned long hwnd)
+IsWindowEnabled(HWND hwnd)
  
  bool
  
  bool
-IsWindowShowing(unsigned long hwnd)
+IsWindowShowing(HWND hwnd)
  
  unsigned long
  
  unsigned long
-QueryWindow(unsigned long hwnd, long cmd)
+QueryWindow(HWND hwnd, long cmd)
  
  unsigned long
  
  unsigned long
-IsChild(unsigned long hwnd, unsigned long hwndParent)
+IsChild(HWND hwnd, HWND hwndParent)
  
  unsigned long
  
  unsigned long
-WindowFromId(unsigned long hwndParent, unsigned long id)
+WindowFromId(HWND hwndParent, unsigned long id)
  
  unsigned long
  
  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
  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
     C_ARGS: hwndDlg, hwnd, code
  
  bool
-EnableWindowUpdate(unsigned long hwnd, bool fEnable = TRUE)
+EnableWindowUpdate(HWND hwnd, bool fEnable = TRUE)
  
  bool
  
  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
  
  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
      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
  
  bool
-SetWindowUShort(unsigned long hwnd, long index, unsigned short i)
+SetWindowUShort(HWND hwnd, long index, unsigned short i)
  
  bool
  
  bool
-IsWindow(unsigned long hwnd, unsigned long hab = Acquire_hab())
+IsWindow(HWND hwnd, HAB hab = Acquire_hab())
      C_ARGS: hab, hwnd
  
  BOOL
      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);
  
      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()
  
  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))
  
  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 *
  MODULE = OS2::Process          PACKAGE = OS2::Process  PREFIX = myQuery
  
  SV *
-myQueryWindowText(unsigned long hwnd)
+myQueryWindowText(HWND hwnd)
  
  SV *
  
  SV *
-myQueryClassName(unsigned long hwnd)
+myQueryClassName(HWND hwnd)
  
  MODULE = OS2::Process          PACKAGE = OS2::Process  PREFIX = Query
  
  unsigned long
  
  MODULE = OS2::Process          PACKAGE = OS2::Process  PREFIX = Query
  
  unsigned long
-QueryFocusWindow(unsigned long hwndDesktop = HWND_DESKTOP)
+QueryFocusWindow(HWND hwndDesktop = HWND_DESKTOP)
  
  long
  
  long
-QueryWindowTextLength(unsigned long hwnd)
+QueryWindowTextLength(HWND hwnd)
  
  SV *
  
  SV *
-QueryWindowSWP(unsigned long hwnd)
+QueryWindowSWP(HWND hwnd)
  
  unsigned long
  
  unsigned long
-QueryWindowULong(unsigned long hwnd, long index)
+QueryWindowULong(HWND hwnd, long index)
  
  unsigned short
  
  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
  
  unsigned long
-QueryActiveWindow(unsigned long hwnd = HWND_DESKTOP)
+CreateAtomTable(unsigned long initial = 0, unsigned long buckets = 0)
  
  unsigned long
  
  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
  
  MODULE = OS2::Process          PACKAGE = OS2::Process  PREFIX = myWinQuery
  
  unsigned long
-myWinQueryWindowPtr(unsigned long hwnd, long index)
+myWinQueryWindowPtr(HWND hwnd, long index)
  
  NO_OUTPUT BOOL
  
  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))
     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
  
  MODULE = OS2::Process          PACKAGE = OS2::Process  PREFIX = myWin
  
  int
-myWinSwitchToProgram(unsigned long hsw)
+myWinSwitchToProgram(HSWITCH hsw = switch_of(NULLHANDLE, getpid()))
      PREINIT:
         ULONG rc;
  
      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
  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)
  
  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
  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 (file)
--- 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;
  
  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.
  
  @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( <file> [<dirs>] )' 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 <file> [<dirs>]' 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) {
         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;
         }
         $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 <<EOE or die "eval package $@";
-package OS2::DLL::$file; \@ISA = qw($packs);
-sub AUTOLOAD {
-  \$OS2::DLL::AUTOLOAD = \$AUTOLOAD;
-  goto &OS2::DLL::AUTOLOAD;
-}
-1;
-EOE
+       my @packs = $INC{'OS2/REXX.pm'} ? qw(OS2::DLL::dll OS2::REXX) : 'OS2::DLL::dll';
+       my $p = "OS2::DLL::dll::$file";
+       @{"$p\::ISA"} = @packs;
+       *{"$p\::AUTOLOAD"} = \&OS2::DLL::dll::AUTOLOAD;
         return $dlls{$file} = 
         return $dlls{$file} = 
-         bless {Handle => $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( <file> [<dirs>] )' unless @_ >= 2;
+  $new_dll->(1, @_);
  }
  
  }
  
-sub find
-{
+sub module {
+  confess 'Usage: OS2::DLL->module( <file> [<dirs>] )' unless @_ >= 2;
+  $new_dll->(0, @_);
+}
+
+sub load {
+  confess 'Usage: load OS2::DLL <file> [<dirs>]' 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};
         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 <<EOE or die "eval sub";
-package OS2::DLL::$file;
-sub $_ {
-  shift;
-  OS2::DLL::_call('$_', $addr, '$queue', \@_);
+       my $name = shift;
+       $prefix = '' if $name =~ /^#\d+/;       # loading by ordinal
+       my $addr = (DynaLoader::dl_find_symbol($handle, uc $prefix.$name)
+                   || DynaLoader::dl_find_symbol($handle, $prefix.$name));
+       return sub {
+         OS2::DLL::_call($name, $addr, $queue, @_);
+       } if $addr;
+       my $err = DynaLoader::dl_error();
+       $err =~ s/\s+at\s+\S+\s+line\s+\S+\s*\z//;
+       croak "Can't find symbol `$name' in DLL `$file': $err";
  }
  }
-1;
-EOE
+
+sub find
+{
+       my $self   = shift;
+       my $file   = $self->{File};
+       my $p      = ref $self;
+       foreach (@_) {
+               my $f = eval {$self->wrapper_REXX($_)} or return 0;
+               ${"${p}::"}{$_} = sub { shift; $f->(@_) };
         }
         return 1;
  }
         }
         return 1;
  }
@@ -102,45 +120,124 @@ See documentation of L<OS2::REXX> module if you need the variable pool.
  =head1 SYNOPSIS
  
         use OS2::DLL;
  =head1 SYNOPSIS
  
         use OS2::DLL;
-       $emx_dll = OS2::DLL->load('emx');
+       $emx_dll = OS2::DLL->module('emx');
         $emx_version = $emx_dll->emx_revision();
         $emx_version = $emx_dll->emx_revision();
+       $func_emx_version = $emx_dll->wrapper_REXX('#128'); # emx_revision
+       $emx_version = $func_emx_version->();
  
  =head1 DESCRIPTION
  
  
  =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<DynaLoader::dl_error()>).
+       $dll = OS2::DLL->new( NAME [, WHERE] );
  
  
-=head2 Create a REXX DLL handle
+Same as L<C<module>|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<C<load>|Load REXX DLL>, but croaks with a meaningful message on
-failure.
+       $dll = load OS2::DLL NAME [, WHERE];
+
+Same as L<C<new>|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<DynaLoader::dl_error()>) (provided for backward
+compatibility).
  
  =head2 Check for functions (optional):
  
         BOOL = $dll->find(NAME [, NAME [, ...]]);
  
  
  =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<OS2::REXX>), 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<regparm(3)> function:
+
+ $res = call20_rp3( $pointer, $arg0, $arg1, ...);
+
+=item Same for packed arguments and C<regparm(3)> 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<Dos*> API - and rare C<Win*> 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<Win*> 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<Win*> 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<Win*> 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
  
  
  =head1 ENVIRONMENT
  
@@ -149,7 +246,7 @@ in C<PERL5REXX>, C<PERLREXX>, C<PATH>.
  
  =head1 AUTHOR
  
  
  =head1 AUTHOR
  
-Extracted by Ilya Zakharevich ilya@math.ohio-state.edu from L<OS2::REXX>
+Extracted by Ilya Zakharevich perl-module-OS2-DLL@ilyaz.org from L<OS2::REXX>
  written by Andreas Kaiser ak@ananke.s.bawue.de.
  
  =cut
  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 (file)
--- 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");
  
  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
  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 (file)
--- 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";
  
  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";
  $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 (file)
--- 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 "# @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 (file)
--- a/os2/OS2/PrfDB/typemap
+++ b/os2/OS2/typemap
@@ -1,14 +1,28 @@
  BOOL                   T_IV
  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
  PSZ                    T_PVNULL
+PCSZ                   T_PVNULLC
  
  #############################################################################
  INPUT
  T_PVNULL
         $var = ( SvOK($arg) ? ($type)SvPV($arg,PL_na) : NULL )
  
  #############################################################################
  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);
  #############################################################################
  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 (file)
--- a/os2/dl_os2.c
+++ b/os2/dl_os2.c
@@ -4,10 +4,15 @@
  
  #define INCL_BASE
  #include <os2.h>
  
  #define INCL_BASE
  #include <os2.h>
+#include <float.h>
+#include <stdlib.h>
  
  static ULONG retcode;
  static char fail[300];
  
  
  static ULONG retcode;
  static char fail[300];
  
+static ULONG dllHandle;
+static int handle_found;
+static int handle_loaded;
  #ifdef PERL_CORE
  
  #include "EXTERN.h"
  #ifdef PERL_CORE
  
  #include "EXTERN.h"
@@ -19,6 +24,57 @@ char *os2error(int rc);
  
  #endif
  
  
  #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)
  {
  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;
         char tmp[260];
         const char *beg, *dot;
         ULONG rc;
+       unsigned fpflag = _control87(0,0);
  
         fail[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)
         if ((rc = DosLoadModule(fail, sizeof fail, (char*)path, &handle)) == 0)
-               return (void *)handle;
+               goto ret;
  
         retcode = rc;
  
  
         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)
                 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)
  {
  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 = 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;
         }
         retcode = rc;
         return NULL;
@@ -82,12 +169,15 @@ dlerror(void)
  
         if (retcode == 0)
                 return NULL;
  
         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);
         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;
             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 (file)
--- a/os2/os2.c
+++ b/os2/os2.c
@@ -3,6 +3,8 @@
  #define INCL_DOSFILEMGR
  #define INCL_DOSMEMMGR
  #define INCL_DOSERRORS
  #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
  /* 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"
  
  #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 *);
  #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,
  };
      pthreads_st_norun,
      pthreads_st_exited_waited,
  };
-const char *pthreads_states[] = {
+const char * const pthreads_states[] = {
      "uninit",
      "running",
      "exited",
      "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)) {
  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];
  }
    }
    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;
  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)
  
  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))
      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))
      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);
      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);
  
  
  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 {
  /* 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;
      const char *entryname;
      int entrypoint;
-} loadOrdinals[ORD_NENTRIES] = { 
+} loadOrdinals[] = {
    {&doscalls_handle, NULL, 874},       /* DosQueryExtLibpath */
    {&doscalls_handle, NULL, 873},       /* DosSetExtLibpath */
    {&doscalls_handle, NULL, 460},       /* DosVerifyPidTid */
    {&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 */
    {&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)
  {
  HMODULE
  loadModule(const char *modname, int fail)
  {
@@ -444,16 +632,69 @@ loadModule(const char *modname, int fail)
      return h;
  }
  
      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)
  {
  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 (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);
             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,
         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 */
  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);
  #define QSS_INI_BUFFER 1024
  
  ULONG (*pDosVerifyPidTid) (PID pid, TID tid);
-static int pidtid_lookup;
  
  PQTOPLEVEL
  get_sysinfo(ULONG pid, ULONG flags)
  
  PQTOPLEVEL
  get_sysinfo(ULONG pid, ULONG flags)
@@ -616,13 +856,7 @@ getpriority(int which /* ignored */, int pid)
  /*****************************************************************************/
  /* spawn */
  
  /*****************************************************************************/
  /* 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)
  
  static Signal_t
  spawn_sighandler(int sig)
@@ -690,22 +924,6 @@ enum execf_t {
    EXECF_SYNC
  };
  
    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)
  {
  static ULONG
  file_type(char *path)
  {
@@ -730,8 +948,6 @@ file_type(char *path)
      return apptype;
  }
  
      return apptype;
  }
  
-static ULONG os2_mytype;
-
  /* Spawn/exec a program, revert to shell if needed. */
  /* global PL_Argv[] contains arguments. */
  
  /* 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;
  {
         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", };
             = { "/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;
         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 (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? */
  
        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. */ 
             ) /* 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;
           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];
             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) {
  
                 if (l + 5 <= sizeof tbuf) {
-                   strcpy(tbuf, tmps);
+                   strcpy(tbuf, real_name);
                     strcpy(tbuf + l, ".exe");
                     type = file_type(tbuf);
                     if (type >= -3)
                     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: 
             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;
                 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);
                 }
                         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;
                 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);
                 }
                         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
         }
  
  #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)
  #else
         if (execf == EXECF_TRUEEXEC)
-           rc = execvp(tmps,PL_Argv);
+           rc = execvp(real_name,PL_Argv);
         else if (execf == EXECF_EXEC)
         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)
         else if (execf == EXECF_SPAWN_NOWAIT)
-           rc = spawnvp(flag,tmps,PL_Argv);
+           rc = spawnvp(flag,real_name,PL_Argv);
          else if (execf == EXECF_SYNC)
          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, 
          else                           /* EXECF_SPAWN, EXECF_SPAWN_BYFLAG */
             rc = result(aTHX_ trueflag, 
-                       spawnvp(flag,tmps,PL_Argv));
+                       spawnvp(flag,real_name,PL_Argv));
  #endif 
  #endif 
-       if (rc < 0 && pass == 1
-           && (tmps == PL_Argv[0])) { /* Cannot transfer `really' via shell. */
+       if (rc < 0 && pass == 1) {
               do_script:
               do_script:
-           {
+         if (real_name == PL_Argv[0]) {
             int err = errno;
  
             if (err == ENOENT || err == ENOEXEC) {
             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 */
                         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 */
                                 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:
                     }
                     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;
                              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;
                   doshell_args:
                     {
                         char **a = PL_Argv;
-                       char *exec_args[2];
+                       const char *exec_args[2];
  
                         if (force_shell 
                             || (!buf[0] && file)) { /* File without magic */
  
                         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--;
                         }
                                                    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;
                         /* 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;
             }
                 /* 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], '/');
           }
         } 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"),
             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;
         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;
  }
  
      return rc;
  }
  
-/* Array spawn.  */
+/* Array spawn/exec.  */
  int
  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;
  {
      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;
  
         }
         *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_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;
  }
  
      } 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)
  {
  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;
  
      memset(st, 0, sizeof *st);
      st->st_mode = S_IFCHR|0666;
+    MUTEX_LOCK(&perlos2_state_mutex);
      st->st_ino = (ino-- & 0x7FFF);
      st->st_ino = (ino-- & 0x7FFF);
+    MUTEX_UNLOCK(&perlos2_state_mutex);
      st->st_nlink = 1;
      return 0;
  }
      st->st_nlink = 1;
      return 0;
  }
@@ -1529,7 +1780,7 @@ sys_alloc(int size) {
  
  /* tmp path */
  
  
  /* tmp path */
  
-char *tmppath = TMPPATH1;
+const char *tmppath = TMPPATH1;
  
  void
  settmppath()
  
  void
  settmppath()
@@ -1538,6 +1789,7 @@ settmppath()
      int len;
  
      if (!p) p = getenv("TEMP");
      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);
      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;
         char *  dst = (char *)SvPV(ST(1),n_a);
         U32     flag;
         int     RETVAL, rc;
+       dXSTARG;
  
         if (items < 3)
             flag = 0;
  
         if (items < 3)
             flag = 0;
@@ -1570,8 +1823,7 @@ XS(XS_File__Copy_syscopy)
         }
  
         RETVAL = !CheckOSError(DosCopy(src, dst, flag));
         }
  
         RETVAL = !CheckOSError(DosCopy(src, dst, flag));
-       ST(0) = sv_newmortal();
-       sv_setiv(ST(0), (IV)RETVAL);
+       XSprePUSH; PUSHi((IV)RETVAL);
      }
      XSRETURN(1);
  }
      }
      XSRETURN(1);
  }
@@ -1583,7 +1835,6 @@ XS(XS_File__Copy_syscopy)
  char *
  mod2fname(pTHX_ SV *sv)
  {
  char *
  mod2fname(pTHX_ SV *sv)
  {
-    static char fname[9];
      int pos = 6, len, avlen;
      unsigned int sum = 0;
      char *s;
      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;
      {
         SV *    sv = ST(0);
         char *  RETVAL;
+       dXSTARG;
  
         RETVAL = mod2fname(aTHX_ sv);
  
         RETVAL = mod2fname(aTHX_ sv);
-       ST(0) = sv_newmortal();
-       sv_setpv((SV*)ST(0), RETVAL);
+       sv_setpv(TARG, RETVAL);
+       XSprePUSH; PUSHTARG;
      }
      XSRETURN(1);
  }
      }
      XSRETURN(1);
  }
@@ -1652,7 +1904,6 @@ char *
  os2error(int rc)
  {
         dTHX;
  os2error(int rc)
  {
         dTHX;
-       static char buf[300];
         ULONG len;
         char *s;
         int number = SvTRUE(get_sv("OS2::nsyserror", TRUE));
         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) {
         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
         } 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)) {
                           rc, "OSO001.MSG", &len)) {
+           char *name = "";
+
             if (!number) {
             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')
         } 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;
                         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);
         }
                     && 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
  }
  
  void
@@ -1741,12 +2012,17 @@ os2_execname(pTHX)
  char *
  perllib_mangle(char *s, unsigned int l)
  {
  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) {
      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;
             
         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");
             }
             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++;
             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");
      }
      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 
  }
  
  unsigned long 
@@ -1793,6 +2069,31 @@ Perl_hab_GET()                   /* Needed if perl.h cannot be included */
      return perl_hab_GET();
  }
  
      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)
  {
  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_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);
         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++;
      } 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;
  }
  
      return Perl_hmq;
  }
  
@@ -1873,24 +2172,31 @@ Perl_Process_Messages(int force, I32 *cntp)
  void
  Perl_Deregister_MQ(int serve)
  {
  void
  Perl_Deregister_MQ(int serve)
  {
-    PPIB pib;
-    PTIB tib;
-
-    if (serve)
+    if (serve & REGISTERMQ_WILL_SERVE)
         Perl_hmq_servers--;
         Perl_hmq_servers--;
+
      if (--Perl_hmq_refcnt <= 0) {
      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;
         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. */
         /* 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",
         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] == ':' \
  }
  
  #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)))
  
  #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;
  XS(XS_OS2_Error)
  {
      dXSARGS;
@@ -1919,7 +2223,7 @@ XS(XS_OS2_Error)
         unsigned long rc;
  
         if (CheckOSError(DosError(a)))
         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);
         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);
  }
  
      XSRETURN(1);
  }
  
-static signed char DOS_suppression_state = -1;    
-
  XS(XS_OS2_Errors2Drive)
  {
      dXSARGS;
  XS(XS_OS2_Errors2Drive)
  {
      dXSARGS;
@@ -1949,7 +2251,8 @@ XS(XS_OS2_Errors2Drive)
                                             ? SPU_ENABLESUPPRESSION 
                                             : SPU_DISABLESUPPRESSION),
                                            drive)))
                                             ? 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);
         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);
  }
  
      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",
    "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",
    "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)
  };
  
  XS(XS_OS2_SysInfo)
@@ -1994,25 +2652,67 @@ XS(XS_OS2_SysInfo)
      if (items != 0)
         Perl_croak_nocontext("Usage: 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            */
         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))))
                                          (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++;
         }
             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)
  }
  
  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;
         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))))
         
         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];
         c = 'a' - 1 + si[0];
-       sv_setpvn(ST(0), &c, 1);
+       sv_setpvn(TARG, &c, 1);
+       XSprePUSH; PUSHTARG;
      }
      XSRETURN(1);
  }
  
      }
      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;
  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);
      {
         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);
  }
      }
      XSRETURN(1);
  }
@@ -2071,9 +2790,9 @@ XS(XS_OS2_Serve_Messages)
      {
         bool  force = SvOK(ST(0));
         unsigned long   cnt = Perl_Serve_Messages(force);
      {
         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);
  }
      }
      XSRETURN(1);
  }
@@ -2086,6 +2805,7 @@ XS(XS_OS2_Process_Messages)
      {
         bool  force = SvOK(ST(0));
         unsigned long   cnt;
      {
         bool  force = SvOK(ST(0));
         unsigned long   cnt;
+       dXSTARG;
  
         if (items == 2) {
             I32 cntr;
  
         if (items == 2) {
             I32 cntr;
@@ -2100,8 +2820,7 @@ XS(XS_OS2_Process_Messages)
         } else {
             cnt =  Perl_Process_Messages(force, NULL);
          }
         } else {
             cnt =  Perl_Process_Messages(force, NULL);
          }
-       ST(0) = sv_newmortal();
-       sv_setiv(ST(0), cnt);
+       XSprePUSH; PUSHi((IV)cnt);
      }
      XSRETURN(1);
  }
      }
      XSRETURN(1);
  }
@@ -2113,10 +2832,11 @@ XS(XS_Cwd_current_drive)
         Perl_croak_nocontext("Usage: Cwd::current_drive()");
      {
         char    RETVAL;
         Perl_croak_nocontext("Usage: Cwd::current_drive()");
      {
         char    RETVAL;
+       dXSTARG;
  
         RETVAL = current_drive();
  
         RETVAL = current_drive();
-       ST(0) = sv_newmortal();
-       sv_setpvn(ST(0), (char *)&RETVAL, 1);
+       sv_setpvn(TARG, (char *)&RETVAL, 1);
+       XSprePUSH; PUSHTARG;
      }
      XSRETURN(1);
  }
      }
      XSRETURN(1);
  }
@@ -2214,9 +2934,11 @@ XS(XS_Cwd_sys_cwd)
      {
         char p[MAXPATHLEN];
         char *  RETVAL;
      {
         char p[MAXPATHLEN];
         char *  RETVAL;
+
+       /* Can't use TARG, since tainting behaves differently */
         RETVAL = _getcwd2(p, MAXPATHLEN);
         ST(0) = sv_newmortal();
         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
  #ifndef INCOMPLETE_TAINTS
         SvTAINTED_on(ST(0));
  #endif
@@ -2392,6 +3114,7 @@ XS(XS_Cwd_extLibpath)
         char    to[1024];
         U32     rc;
         char *  RETVAL;
         char    to[1024];
         U32     rc;
         char *  RETVAL;
+       dXSTARG;
  
         if (items < 1)
             type = 0;
  
         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");
         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);
  }
      }
      XSRETURN(1);
  }
@@ -2445,7 +3168,8 @@ DeclOSFuncByORD(APIRET, _DosQueryModFromEIP,ORD_DosQueryModFromEIP,
                         ULONG * Offset, ULONG Address),
                         (hmod, obj, BufLen, Buf, Offset, Address))
  
                         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)
  
  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;
      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... */
         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) {
          && 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 (!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);
         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);
  }
  
      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
  
  #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;
         unsigned        new = (unsigned)SvIV(ST(0));
         unsigned        mask = (unsigned)SvIV(ST(1));
         unsigned        RETVAL;
+       dXSTARG;
  
         RETVAL = _control87(new, mask);
  
         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);
  }
  
      }
      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;
  XS(XS_OS2_get_control87)
  {
      dXSARGS;
@@ -2537,10 +3383,10 @@ XS(XS_OS2_get_control87)
         Perl_croak(aTHX_ "Usage: OS2::get_control87()");
      {
         unsigned        RETVAL;
         Perl_croak(aTHX_ "Usage: OS2::get_control87()");
      {
         unsigned        RETVAL;
+       dXSTARG;
  
         RETVAL = get_control87();
  
         RETVAL = get_control87();
-       ST(0) = sv_newmortal();
-       sv_setiv(ST(0), (IV)RETVAL);
+       XSprePUSH; PUSHi((IV)RETVAL);
      }
      XSRETURN(1);
  }
      }
      XSRETURN(1);
  }
@@ -2555,6 +3401,7 @@ XS(XS_OS2_set_control87)
         unsigned        new;
         unsigned        mask;
         unsigned        RETVAL;
         unsigned        new;
         unsigned        mask;
         unsigned        RETVAL;
+       dXSTARG;
  
         if (items < 1)
             new = MCW_EM;
  
         if (items < 1)
             new = MCW_EM;
@@ -2569,8 +3416,29 @@ XS(XS_OS2_set_control87)
         }
  
         RETVAL = set_control87(new, mask);
         }
  
         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);
  }
      }
      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);
          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);
          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::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
         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;
  }
  
      return 0;
  }
  
-OS2_Perl_data_t OS2_Perl_data;
-
  extern void _emx_init(void*);
  
  static void jmp_out_of_atexit(void);
  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 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 */
  
      /* 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"
                 "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 {
  }
  
  struct layout_table_t {
@@ -2680,7 +3557,7 @@ struct layout_table_t {
  
  static ULONG
  my_os_version() {
  
  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 */
  
      /* 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"
                 "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
  }
  
  static void
@@ -2703,7 +3580,6 @@ force_init_emx_runtime(EXCEPTIONREGISTRATIONRECORD *preg, ULONG flags)
      void *oldstackend, *oldstack;
      PPIB pib;
      PTIB tib;
      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;
      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;
  
      } *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);
      layout_table.flags   = 0x02000002; /* flags: application, OMF */
  
      DosGetInfoBlocks(&tib, &pib);
@@ -2794,9 +3670,6 @@ force_init_emx_runtime(EXCEPTIONREGISTRATIONRECORD *preg, ULONG flags)
         exit(56);
  }
  
         exit(56);
  }
  
-jmp_buf at_exit_buf;
-int longjmp_at_exit;
-
  static void
  jmp_out_of_atexit(void)
  {
  static void
  jmp_out_of_atexit(void)
  {
@@ -2806,8 +3679,6 @@ jmp_out_of_atexit(void)
  
  extern void _CRT_term(void);
  
  
  extern void _CRT_term(void);
  
-int emx_runtime_secondary;
-
  void
  Perl_OS2_term(void **p, int exitstatus, int flags)
  {
  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 */
  
  
  extern ULONG __os_version();           /* See system.doc */
  
-static int emx_wasnt_initialized;
-
  void
  check_emx_runtime(char **env, EXCEPTIONREGISTRATIONRECORD *preg)
  {
  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
  
      /*  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 */
  
      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().  */
      /*  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;
         *ep = NULL;
      }
      _environ = _org_environ = env;
+    emx_init_done = 1;
+    if (hmtx_emx_init)
+       DosReleaseMutexSem(hmtx_emx_init);
  }
  
  #define ENTRY_POINT 0x10000
  }
  
  #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);
      }
  #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? */
  #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);
  }
      /* 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;
    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)
      char *s = getenv("USE_PERL_FLOCK");
      if (s)
-       use_my = atoi(s);
+       use_my_flock = atoi(s);
      else 
      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? */
      return flock(handle, o);   /* Delegate to EMX. */
    
                                          /* is this a file? */
@@ -3175,9 +4094,6 @@ my_flock(int handle, int o)
    return 0;
  }
  
    return 0;
  }
  
-static int pwent_cnt;
-static int _my_pwent = -1;
-
  static int
  use_my_pwent(void)
  {
  static int
  use_my_pwent(void)
  {
@@ -3224,8 +4140,6 @@ my_getpwent (void)
    return getpwuid(0);
  }
  
    return getpwuid(0);
  }
  
-static int grent_cnt;
-
  void
  setgrent(void)
  {
  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 *
  passw_wrap(struct passwd *p)
  {
-    static struct passwd pw;
      char *s;
  
      if (!p || (p->pw_passwd && *p->pw_passwd)) /* Not a dangerous password */
      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)
  {
  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);
  }
  
    return gcvt (value, digits, buffer);
  }
  
@@ -3293,14 +4221,66 @@ int fork_with_resources()
    dTHX;
    void *ctx = PERL_GET_CONTEXT;
  #endif
    dTHX;
    void *ctx = PERL_GET_CONTEXT;
  #endif
-
+  unsigned fpflag = _control87(0,0);
    int rc = fork();
  
    int rc = fork();
  
-#if (defined(USE_5005THREADS) || defined(USE_ITHREADS)) && !defined(USE_SLOW_THREAD_SPECIFIC)
    if (rc == 0) {                       /* child */
    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 */
      ALLOC_THREAD_KEY;                  /* Acquire the thread-local memory */
      PERL_SET_CONTEXT(ctx);             /* Reinit the thread-local memory */
-  }
  #endif
  #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;
  }
    return rc;
  }
+
diff --git a/os2/os2ish.h b/os2/os2ish.h

index c0eb40f..bb8420e 100644 (file)
--- a/os2/os2ish.h
+++ b/os2/os2ish.h
@@ -299,7 +299,7 @@ void *sys_alloc(int size);
  #endif
  
  #define TMPPATH1 "plXXXXXX"
  #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);
  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);
  
  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);
  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 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
  /*
   * 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        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;
  } 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_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);
  
  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_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
  };
  
      ORD_NENTRIES
  };
  
@@ -676,6 +741,21 @@ char *perllib_mangle(char *, unsigned int);
  
  #define fork   fork_with_resources
  
  
  #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;
  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);
  
  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);
  #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
  #endif
  
  #ifndef LOG_DAEMON
diff --git a/os2/perlrexx.cmd b/os2/perlrexx.cmd

new file mode 100644 (file)

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 (file)
--- 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;
      char *s;
      SV *sv;
      GV* tmpgv;
+#ifdef NEED_ENVIRON_DUP_FOR_MODIFY
      char **dup_env_base = 0;
      int dup_env_count = 0;
      char **dup_env_base = 0;
      int dup_env_count = 0;
+#endif
  
      PL_toptarget = NEWSV(0,0);
      sv_upgrade(PL_toptarget, SVt_PVFM);
  
      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 (file)
--- 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<encoding>).
  
  to 255 (inclusive) are by default not encoded in Unicode for backward
  compatibility reasons (but see L<encoding>).
  
+If NUMBER is omitted, uses C<$_>.
+
  For the reverse, use L</ord>.
  For the reverse, use L</ord>.
-See L<perlunicode> and L<encoding> for more about Unicode.
  
  
-If NUMBER is omitted, uses C<$_>.
+Note that under the C<bytes> pragma the NUMBER is masked to
+the low eight bits.
+
+See L<perlunicode> and L<encoding> for more about Unicode.
  
  =item chroot FILENAME
  
  
  =item chroot FILENAME
  
@@ -2431,11 +2435,15 @@ If EXPR is omitted, uses C<$_>.
  
  =item length
  
  
  =item length
  
-Returns the length in characters of the value of EXPR.  If EXPR is
+Returns the length in I<characters> 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<scalar @array> and C<scalar keys %hash> respectively.
  
  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<scalar @array> and C<scalar keys %hash> respectively.
  
+Note the I<characters>: 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<do { use bytes; length(EXPR) }>, see L<bytes>.
+
  =item link OLDFILE,NEWFILE
  
  Creates a new filename linked to the old filename.  Returns true for
  =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
  
  
  =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///
  
  
  =item s///
  
diff --git a/pod/perlunicode.pod b/pod/perlunicode.pod

index 4508de7..91bb0f8 100644 (file)
--- 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.
               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.
          [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}]]
  
  
      [{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.
  
  
  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</"User-Defined Character Properties">.
  
  =item *
  [b] See L</"User-Defined Character Properties">.
  
  =item *
diff --git a/pod/perluniintro.pod b/pod/perluniintro.pod

index feee902..c20e05c 100644 (file)
--- 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<PV>.  See also later in this document
  
  That shows the UTF8 flag in FLAGS and both the UTF-8 bytes
  and Unicode characters in C<PV>.  See also later in this document
-the discussion about the C<is_utf8> function of the C<Encode> module.
+the discussion about the C<utf8::is_utf8()> function.
  
  =back
  
  
  =back
  
@@ -625,8 +625,7 @@ didn't get the transparency of Unicode quite right.
  
  Okay, if you insist:
  
  
  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
  
  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 (file)
--- 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;
      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) {
         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);
         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 (file)
--- 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';
         }
              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",
             (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 (file)
--- 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);
  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);
  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("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);
      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);
  }
  
      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)
  {
  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)
  }
  
  XS(XS_utf8_encode)
diff --git a/utils/h2xs.PL b/utils/h2xs.PL

index 7ec7dea..ffc343e 100644 (file)
--- a/utils/h2xs.PL
+++ b/utils/h2xs.PL
@@ -879,8 +879,9 @@ if( @path_h ){
          close(CH);
        }
        else {
          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 $/; <CH> };
          close CH;
          no warnings 'uninitialized';
          my $src = do { local $/; <CH> };
          close CH;
          no warnings 'uninitialized';
author	Jarkko Hietaniemi <jhi@iki.fi>
	Sun, 15 Jun 2003 17:57:06 +0000 (17:57 +0000)
committer	Jarkko Hietaniemi <jhi@iki.fi>
	Sun, 15 Jun 2003 17:57:06 +0000 (17:57 +0000)
MANIFEST		patch \| blob \| blame \| history
doio.c		patch \| blob \| blame \| history
emacs/ptags		patch \| blob \| blame \| history
ext/Time/HiRes/Makefile.PL		patch \| blob \| blame \| history
handy.h		patch \| blob \| blame \| history
hints/freebsd.sh		patch \| blob \| blame \| history
hints/os2.sh		patch \| blob \| blame \| history
lib/ExtUtils/t/MM_OS2.t		patch \| blob \| blame \| history
lib/FileCache.t	[deleted file]	patch \| blob \| blame \| history
lib/FileCache/t/01open.t	[new file with mode: 0644]	patch \| blob
lib/FileCache/t/02maxopen.t	[new file with mode: 0644]	patch \| blob
lib/FileCache/t/03append.t	[new file with mode: 0644]	patch \| blob
lib/FileCache/t/04twoarg.t	[new file with mode: 0644]	patch \| blob
lib/FileCache/t/05override.t	[new file with mode: 0644]	patch \| blob
lib/bytes.t		patch \| blob \| blame \| history
lib/utf8.pm		patch \| blob \| blame \| history
lib/utf8.t		patch \| blob \| blame \| history
makedef.pl		patch \| blob \| blame \| history
os2/OS2/Process/Makefile.PL		patch \| blob \| blame \| history
os2/OS2/Process/Process.pm		patch \| blob \| blame \| history
os2/OS2/Process/Process.xs		patch \| blob \| blame \| history
os2/OS2/REXX/DLL/DLL.pm		patch \| blob \| blame \| history
os2/OS2/REXX/DLL/DLL.xs		patch \| blob \| blame \| history
os2/OS2/REXX/t/rx_emxrv.t		patch \| blob \| blame \| history
os2/OS2/REXX/t/rx_objcall.t		patch \| blob \| blame \| history
os2/OS2/typemap	[moved from os2/OS2/PrfDB/typemap with 54% similarity]	patch \| blob \| blame \| history
os2/dl_os2.c		patch \| blob \| blame \| history
os2/os2.c		patch \| blob \| blame \| history
os2/os2ish.h		patch \| blob \| blame \| history
os2/perlrexx.cmd	[new file with mode: 0644]	patch \| blob
perl.c		patch \| blob \| blame \| history
pod/perlfunc.pod		patch \| blob \| blame \| history
pod/perlunicode.pod		patch \| blob \| blame \| history
pod/perluniintro.pod		patch \| blob \| blame \| history
pp_sys.c		patch \| blob \| blame \| history
sv.c		patch \| blob \| blame \| history
universal.c		patch \| blob \| blame \| history
utils/h2xs.PL		patch \| blob \| blame \| history