Front page | perl.perl5.porters |
Postings from October 1999
[PATCH 5.005_62] OS/2 improvements
Thread Next
From:
Ilya Zakharevich
Date:
October 24, 1999 00:14
Subject:
[PATCH 5.005_62] OS/2 improvements
Message ID:
199910240714.DAA12125@monk.mps.ohio-state.edu
This patch adds the following change relevent on non-OS/2:
New macro PERL_SYS_INIT3(argvp, argcp, env)
This macro should be used for embedding Perl (including miniperlmain.c
and perlmain.c ;-) in preference to PERL_SYS_INIT(argvp, argcp). See
the first two chunks down below.
Other changes are OS/2-specific and are listed in the third chunk down below.
Enjoy,
Ilya
diff -pru perl5.005_62/perl.h perl5.005_62.my/perl.h
--- perl5.005_62/perl.h Wed Oct 13 18:36:42 1999
+++ perl5.005_62.my/perl.h Sat Oct 16 01:53:18 1999
@@ -1559,6 +1559,10 @@ typedef union any ANY;
# endif
#endif
+#ifndef PERL_SYS_INIT3
+# define PERL_SYS_INIT3(argvp,argcp,env) PERL_SYS_INIT(argvp,argcp)
+#endif
+
#ifndef MAXPATHLEN
# ifdef PATH_MAX
# ifdef _POSIX_PATH_MAX
diff -pru perl5.005_62/miniperlmain.c perl5.005_62.my/miniperlmain.c
--- perl5.005_62/miniperlmain.c Tue Jul 20 12:18:04 1999
+++ perl5.005_62.my/miniperlmain.c Sat Oct 16 01:54:16 1999
@@ -38,7 +38,7 @@ main(int argc, char **argv, char **env)
#undef PERLVARIC
#endif
- PERL_SYS_INIT(&argc,&argv);
+ PERL_SYS_INIT3(&argc,&argv,env);
if (!PL_do_undump) {
my_perl = perl_alloc();
diff -pru perl5.005_62/os2/Changes perl5.005_62.my/os2/Changes
--- perl5.005_62/os2/Changes Tue Jul 20 12:18:06 1999
+++ perl5.005_62.my/os2/Changes Sun Oct 24 02:57:56 1999
@@ -296,3 +296,29 @@ after 5.005_54:
If the only shell-metachars of a command are ' 2>&1' at the
end of a command, it is executed without calling the external shell.
+
+after 5.005_57:
+ Make UDP sockets return correct caller address (OS2 API bug);
+ Enable TCPIPV4 defines (works with Warp 3 IAK too?!);
+ Force Unix-domain sockets to start with "/socket", convert
+ '/' to '\' in the calls;
+ Make C<system 1, $cmd> to treat $cmd as in C<system $cmd>;
+ Autopatch Configure;
+ Find name and location of g[nu]patch.exe;
+ Autocopy perl????.dll to t/ when testing;
+
+after 5.005_62:
+ Extract a lightweight DLL access module OS2::DLL from OS2::REXX
+ which would not load REXX runtime system;
+ Allow compile with os2.h which loads os2tk.h instead of os2emx.h;
+ Put the version of EMX CRTL into -D define;
+ Use _setsyserror() to store last error of OS/2 API for $^E;
+ New macro PERL_SYS_INIT3(argvp, argcp, env);
+ Make Dynaloader return info on the failing module after failed dl_open();
+ OS2::REXX test were done for interactive testing (were writing
+ "ok" to stderr);
+ system() and friends return -1 on failure (was 0xFF00);
+ Put the full name of executable into $^X
+ (alas, uppercased - but with /);
+ t/io/fs.t was failing on HPFS386;
+ Remove extra ';' from defines for MQ operations.
diff -pru perl5.005_62/hints/os2.sh perl5.005_62.my/hints/os2.sh
--- perl5.005_62/hints/os2.sh Sun Jul 25 21:18:06 1999
+++ perl5.005_62.my/hints/os2.sh Sat Oct 16 03:27:20 1999
@@ -95,6 +95,8 @@ libpth="$libpth $libemx/mt $libemx"
set `emxrev -f emxlibcm`
emxcrtrev=$5
+# indented to not put it into config.sh
+ _defemxcrtrev=-D_EMX_CRT_REV_=$emxcrtrev
so='dll'
@@ -124,8 +126,8 @@ fi
aout_ldflags="$aout_ldflags"
aout_d_fork='define'
-aout_ccflags='-DDOSISH -DPERL_IS_AOUT -DOS2=2 -DEMBED -I.'
-aout_cppflags='-DDOSISH -DPERL_IS_AOUT -DOS2=2 -DEMBED -I.'
+aout_ccflags="-DDOSISH -DPERL_IS_AOUT -DOS2=2 -DEMBED -I. $_defemxcrtrev"
+aout_cppflags="-DDOSISH -DPERL_IS_AOUT -DOS2=2 -DEMBED -I. $_defemxcrtrev"
aout_use_clib='c'
aout_usedl='undef'
aout_archobjs="os2.o dl_os2.o"
@@ -165,9 +167,9 @@ else
# Recursive regmatch may eat 2.5M of stack alone.
ldflags='-Zexe -Zomf -Zmt -Zcrtdll -Zstack 32000'
if [ $emxcrtrev -ge 50 ]; then
- ccflags='-Zomf -Zmt -DDOSISH -DOS2=2 -DEMBED -I.'
+ ccflags="-Zomf -Zmt -DDOSISH -DOS2=2 -DEMBED -I. $_defemxcrtrev"
else
- ccflags='-Zomf -Zmt -DDOSISH -DOS2=2 -DEMBED -I. -DEMX_BAD_SBRK'
+ ccflags="-Zomf -Zmt -DDOSISH -DOS2=2 -DEMBED -I. -DEMX_BAD_SBRK $_defemxcrtrev"
fi
use_clib='c_import'
usedl='define'
diff -pru perl5.005_62/MANIFEST perl5.005_62.my/MANIFEST
--- perl5.005_62/MANIFEST Fri Oct 15 04:53:58 1999
+++ perl5.005_62.my/MANIFEST Sun Oct 24 02:00:36 1999
@@ -954,11 +954,17 @@ os2/OS2/Process/Process.pm system() cons
os2/OS2/Process/Process.xs system() constants in a module
os2/OS2/REXX/Changes DLL access module
os2/OS2/REXX/MANIFEST DLL access module
+os2/OS2/REXX/DLL/Changes DLL access module
+os2/OS2/REXX/DLL/DLL.pm DLL access module
+os2/OS2/REXX/DLL/DLL.xs DLL access module
+os2/OS2/REXX/DLL/MANIFEST DLL access module
+os2/OS2/REXX/DLL/Makefile.PL DLL access module
os2/OS2/REXX/Makefile.PL DLL access module
os2/OS2/REXX/REXX.pm DLL access module
os2/OS2/REXX/REXX.xs DLL access module
os2/OS2/REXX/t/rx_cmprt.t DLL access module
os2/OS2/REXX/t/rx_dllld.t DLL access module
+os2/OS2/REXX/t/rx_emxrv.t DLL access module
os2/OS2/REXX/t/rx_objcall.t DLL access module
os2/OS2/REXX/t/rx_sql.test DLL access module
os2/OS2/REXX/t/rx_tiesql.test DLL access module
diff -pru perl5.005_62/mg.c perl5.005_62.my/mg.c
--- perl5.005_62/mg.c Sun Oct 10 15:07:04 1999
+++ perl5.005_62.my/mg.c Sat Oct 16 03:23:58 1999
@@ -638,7 +638,8 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
int saveerrno = errno;
sv_setnv(sv, (NV)errno);
#ifdef OS2
- if (errno == errno_isOS2) sv_setpv(sv, os2error(Perl_rc));
+ if (errno == errno_isOS2 || errno == errno_isOS2_set)
+ sv_setpv(sv, os2error(Perl_rc));
else
#endif
sv_setpv(sv, errno ? Strerror(errno) : "");
diff -pru perl5.005_62/os2/dl_os2.c perl5.005_62.my/os2/dl_os2.c
--- perl5.005_62/os2/dl_os2.c Tue Jul 20 12:18:06 1999
+++ perl5.005_62.my/os2/dl_os2.c Sat Oct 16 01:03:18 1999
@@ -4,15 +4,16 @@
#include <os2.h>
static ULONG retcode;
+static char fail[300];
void *
dlopen(char *path, int mode)
{
HMODULE handle;
char tmp[260], *beg, *dot;
- char fail[300];
ULONG rc;
+ fail[0] = 0;
if ((rc = DosLoadModule(fail, sizeof fail, path, &handle)) == 0)
return (void *)handle;
@@ -42,6 +43,7 @@ dlsym(void *handle, char *symbol)
ULONG rc, type;
PFN addr;
+ fail[0] = 0;
rc = DosQueryProcAddr((HMODULE)handle, 0, symbol, &addr);
if (rc == 0) {
rc = DosQueryProcType((HMODULE)handle, 0, symbol, &type);
@@ -56,15 +58,31 @@ dlsym(void *handle, char *symbol)
char *
dlerror(void)
{
- static char buf[300];
+ static char buf[700];
ULONG len;
if (retcode == 0)
return NULL;
- if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, retcode, "OSO001.MSG", &len))
- sprintf(buf, "OS/2 system error code %d", retcode);
- else
+ if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, retcode,
+ "OSO001.MSG", &len)) {
+ if (fail[0])
+ sprintf(buf,
+"OS/2 system error code %d, possible problematic module: '%s'",
+ retcode, fail);
+ else
+ sprintf(buf, "OS/2 system error code %d", retcode);
+ } else {
buf[len] = '\0';
+ if (len && buf[len - 1] == '\n')
+ buf[--len] = 0;
+ if (len && buf[len - 1] == '\r')
+ buf[--len] = 0;
+ if (len && buf[len - 1] == '.')
+ buf[--len] = 0;
+ if (fail[0] && len < 300)
+ sprintf(buf + len, ", possible problematic module: '%s'",
+ fail);
+ }
retcode = 0;
return buf;
}
diff -pru perl5.005_62/os2/OS2/REXX/Changes perl5.005_62.my/os2/OS2/REXX/Changes
--- perl5.005_62/os2/OS2/REXX/Changes Tue Jul 20 12:18:06 1999
+++ perl5.005_62.my/os2/OS2/REXX/Changes Sat Oct 16 00:01:42 1999
@@ -2,3 +2,6 @@
After fixpak17 a lot of other places have mismatched lengths
returned in the REXXPool interface.
Also drop does not work on stems any more.
+0.22:
+ A subsystem module OS2::DLL extracted which does not link
+ with REXX runtime library.
diff -pru perl5.005_62/os2/OS2/REXX/DLL/Changes perl5.005_62.my/os2/OS2/REXX/DLL/Changes
--- perl5.005_62/os2/OS2/REXX/DLL/Changes Sun Oct 24 02:11:04 1999
+++ perl5.005_62.my/os2/OS2/REXX/DLL/Changes Fri Oct 15 23:30:48 1999
@@ -0,0 +1,2 @@
+0.01:
+ Split out of OS2::REXX
diff -pru perl5.005_62/os2/OS2/REXX/DLL/DLL.pm perl5.005_62.my/os2/OS2/REXX/DLL/DLL.pm
--- perl5.005_62/os2/OS2/REXX/DLL/DLL.pm Sun Oct 24 02:11:04 1999
+++ perl5.005_62.my/os2/OS2/REXX/DLL/DLL.pm Sun Oct 24 01:23:32 1999
@@ -0,0 +1,136 @@
+package OS2::DLL;
+
+use Carp;
+use DynaLoader;
+
+@ISA = qw(DynaLoader);
+
+sub AUTOLOAD {
+ $AUTOLOAD =~ /^OS2::DLL::.+::(.+)$/
+ or confess("Undefined subroutine &$AUTOLOAD called");
+ return undef if $1 eq "DESTROY";
+ $_[0]->find($1)
+ or confess("Can't find entry '$1' to DLL '$_[0]->{File}': $^E");
+ goto &$AUTOLOAD;
+}
+
+@libs = split(/;/, $ENV{'PERL5REXX'} || $ENV{'PERLREXX'} || $ENV{'LIBPATH'} || $ENV{'PATH'});
+%dlls = ();
+
+# Preloaded methods go here. Autoload methods go after __END__, and are
+# processed by the autosplit program.
+
+# Cannot autoload, the autoloader is used for the REXX functions.
+
+sub load
+{
+ confess 'Usage: load OS2::DLL <file> [<dirs>]' unless $#_ >= 1;
+ my ($class, $file, @where) = (@_, @libs);
+ return $dlls{$file} if $dlls{$file};
+ my $handle;
+ foreach (@where) {
+ $handle = DynaLoader::dl_load_file("$_/$file.dll");
+ last if $handle;
+ }
+ $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
+ return $dlls{$file} =
+ bless {Handle => $handle, File => $file, Queue => 'SESSION' },
+ "OS2::DLL::$file";
+}
+
+sub find
+{
+ my $self = shift;
+ my $file = $self->{File};
+ my $handle = $self->{Handle};
+ my $prefix = exists($self->{Prefix}) ? $self->{Prefix} : "";
+ my $queue = $self->{Queue};
+ foreach (@_) {
+ my $name = "OS2::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', \@_);
+}
+1;
+EOE
+ }
+ return 1;
+}
+
+bootstrap OS2::DLL;
+
+1;
+__END__
+
+=head1 NAME
+
+OS2::DLL - access to DLLs with REXX calling convention.
+
+=head2 NOTE
+
+When you use this module, the REXX variable pool is not available.
+
+See documentation of L<OS2::REXX> module if you need the variable pool.
+
+=head1 SYNOPSIS
+
+ use OS2::DLL;
+ $emx_dll = OS2::DLL->load('emx');
+ $emx_version = $emx_dll->emx_revision();
+
+=head1 DESCRIPTION
+
+=head2 Load REXX DLL
+
+ $dll = load OS2::DLL NAME [, WHERE];
+
+NAME is DLL name, without path and extension.
+
+Directories are searched WHERE first (list of dirs), then environment
+paths PERL5REXX, PERLREXX, PATH or, as last resort, OS/2-ish search
+is performed in default DLL path (without adding paths and extensions).
+
+The DLL is not unloaded when the variable dies.
+
+Returns DLL object reference, or undef on failure.
+
+=head2 Check for functions (optional):
+
+ BOOL = $dll->find(NAME [, NAME [, ...]]);
+
+Returns true if all functions are available.
+
+=head2 Call external REXX function:
+
+ $dll->function(arguments);
+
+Returns the return string if the return code is 0, else undef.
+Dies with error message if the function is not available.
+
+=head1 ENVIRONMENT
+
+If C<PERL_REXX_DEBUG> is set, emits debugging output. Looks for DLLs
+in C<PERL5REXX>, C<PERLREXX>, C<PATH>.
+
+=head1 AUTHOR
+
+Extracted by Ilya Zakharevich ilya@math.ohio-state.edu from L<OS2::REXX>
+written by Andreas Kaiser ak@ananke.s.bawue.de.
+
+=cut
diff -pru perl5.005_62/os2/OS2/REXX/DLL/DLL.xs perl5.005_62.my/os2/OS2/REXX/DLL/DLL.xs
--- perl5.005_62/os2/OS2/REXX/DLL/DLL.xs Sun Oct 24 02:11:04 1999
+++ perl5.005_62.my/os2/OS2/REXX/DLL/DLL.xs Fri Oct 15 23:36:14 1999
@@ -0,0 +1,72 @@
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+#define INCL_BASE
+#define INCL_REXXSAA
+#include <os2emx.h>
+
+static RXSTRING * strs;
+static int nstrs;
+static char * trace;
+
+static void
+needstrs(int n)
+{
+ if (n > nstrs) {
+ if (strs)
+ free(strs);
+ nstrs = 2 * n;
+ strs = malloc(nstrs * sizeof(RXSTRING));
+ }
+}
+
+MODULE = OS2::DLL PACKAGE = OS2::DLL
+
+BOOT:
+ needstrs(8);
+ trace = getenv("PERL_REXX_DEBUG");
+
+SV *
+_call(name, address, queue="SESSION", ...)
+ char * name
+ void * address
+ char * queue
+ CODE:
+ {
+ ULONG rc;
+ int argc, i;
+ RXSTRING result;
+ UCHAR resbuf[256];
+ RexxFunctionHandler *fcn = address;
+ argc = items-3;
+ needstrs(argc);
+ if (trace)
+ fprintf(stderr, "REXXCALL::_call name: '%s' args:", name);
+ for (i = 0; i < argc; ++i) {
+ STRLEN len;
+ char *ptr = SvPV(ST(3+i), len);
+ MAKERXSTRING(strs[i], ptr, len);
+ if (trace)
+ fprintf(stderr, " '%.*s'", len, ptr);
+ }
+ if (!*queue)
+ queue = "SESSION";
+ if (trace)
+ fprintf(stderr, "\n");
+ MAKERXSTRING(result, resbuf, sizeof resbuf);
+ rc = fcn(name, argc, strs, queue, &result);
+ if (trace)
+ fprintf(stderr, " rc=%X, result='%.*s'\n", rc,
+ result.strlength, result.strptr);
+ ST(0) = sv_newmortal();
+ if (rc == 0) {
+ if (result.strptr)
+ sv_setpvn(ST(0), result.strptr, result.strlength);
+ else
+ sv_setpvn(ST(0), "", 0);
+ }
+ if (result.strptr && result.strptr != resbuf)
+ DosFreeMem(result.strptr);
+ }
+
diff -pru perl5.005_62/os2/OS2/REXX/DLL/Makefile.PL perl5.005_62.my/os2/OS2/REXX/DLL/Makefile.PL
--- perl5.005_62/os2/OS2/REXX/DLL/Makefile.PL Sun Oct 24 02:11:04 1999
+++ perl5.005_62.my/os2/OS2/REXX/DLL/Makefile.PL Fri Oct 15 23:37:08 1999
@@ -0,0 +1,9 @@
+use ExtUtils::MakeMaker;
+
+WriteMakefile(
+ NAME => 'OS2::DLL',
+ VERSION => '0.01',
+ MAN3PODS => ' ', # Pods will be built by installman.
+ XSPROTOARG => '-noprototypes',
+ PERL_MALLOC_OK => 1,
+);
diff -pru perl5.005_62/os2/OS2/REXX/DLL/MANIFEST perl5.005_62.my/os2/OS2/REXX/DLL/MANIFEST
--- perl5.005_62/os2/OS2/REXX/DLL/MANIFEST Sun Oct 24 02:11:04 1999
+++ perl5.005_62.my/os2/OS2/REXX/DLL/MANIFEST Fri Oct 15 23:30:24 1999
@@ -0,0 +1,5 @@
+Changes
+MANIFEST
+Makefile.PL
+DLL.pm
+DLL.xs
diff -pru perl5.005_62/os2/OS2/REXX/Makefile.PL perl5.005_62.my/os2/OS2/REXX/Makefile.PL
--- perl5.005_62/os2/OS2/REXX/Makefile.PL Fri Aug 20 10:51:56 1999
+++ perl5.005_62.my/os2/OS2/REXX/Makefile.PL Sat Oct 16 00:00:52 1999
@@ -2,7 +2,7 @@ use ExtUtils::MakeMaker;
WriteMakefile(
NAME => 'OS2::REXX',
- VERSION => '0.21',
+ VERSION => '0.22',
MAN3PODS => ' ', # Pods will be built by installman.
XSPROTOARG => '-noprototypes',
PERL_MALLOC_OK => 1,
diff -pru perl5.005_62/os2/OS2/REXX/REXX.pm perl5.005_62.my/os2/OS2/REXX/REXX.pm
--- perl5.005_62/os2/OS2/REXX/REXX.pm Tue Jul 20 12:18:06 1999
+++ perl5.005_62.my/os2/OS2/REXX/REXX.pm Sat Oct 16 00:47:10 1999
@@ -3,6 +3,8 @@ package OS2::REXX;
use Carp;
require Exporter;
require DynaLoader;
+require OS2::DLL;
+
@ISA = qw(Exporter DynaLoader);
# Items to export into callers namespace by default
# (move infrequently used names to @EXPORT_OK below)
@@ -10,66 +12,18 @@ require DynaLoader;
# Other items we are prepared to export if requested
@EXPORT_OK = qw(drop);
-sub AUTOLOAD {
- $AUTOLOAD =~ /^OS2::REXX::.+::(.+)$/
- or confess("Undefined subroutine &$AUTOLOAD called");
- return undef if $1 eq "DESTROY";
- $_[0]->find($1)
- or confess("Can't find entry '$1' to DLL '$_[0]->{File}'");
- goto &$AUTOLOAD;
-}
+# We cannot just put OS2::DLL in @ISA, since some scripts would use
+# function interface, not method interface...
-@libs = split(/;/, $ENV{'PERL5REXX'} || $ENV{'PERLREXX'} || $ENV{'LIBPATH'} || $ENV{'PATH'});
-%dlls = ();
+*_call = \&OS2::DLL::_call;
+*load = \&OS2::DLL::load;
+*find = \&OS2::DLL::find;
bootstrap OS2::REXX;
# Preloaded methods go here. Autoload methods go after __END__, and are
# processed by the autosplit program.
-# Cannot autoload, the autoloader is used for the REXX functions.
-
-sub load
-{
- confess 'Usage: load OS2::REXX <file> [<dirs>]' unless $#_ >= 1;
- my ($class, $file, @where) = (@_, @libs);
- return $dlls{$file} if $dlls{$file};
- my $handle;
- foreach (@where) {
- $handle = DynaLoader::dl_load_file("$_/$file.dll");
- last if $handle;
- }
- $handle = DynaLoader::dl_load_file($file) unless $handle;
- return undef unless $handle;
- eval "package OS2::REXX::$file; \@ISA = ('OS2::REXX');"
- . "sub AUTOLOAD {"
- . " \$OS2::REXX::AUTOLOAD = \$AUTOLOAD;"
- . " goto &OS2::REXX::AUTOLOAD;"
- . "} 1;" or die "eval package $@";
- return $dlls{$file} = bless {Handle => $handle, File => $file, Queue => 'SESSION' }, "OS2::REXX::$file";
-}
-
-sub find
-{
- my $self = shift;
- my $file = $self->{File};
- my $handle = $self->{Handle};
- my $prefix = exists($self->{Prefix}) ? $self->{Prefix} : "";
- my $queue = $self->{Queue};
- foreach (@_) {
- my $name = "OS2::REXX::${file}::$_";
- next if defined(&$name);
- my $addr = DynaLoader::dl_find_symbol($handle, uc $prefix.$_)
- || DynaLoader::dl_find_symbol($handle, $prefix.$_)
- or return 0;
- eval "package OS2::REXX::$file; sub $_".
- "{ shift; OS2::REXX::_call('$_', $addr, '$queue', \@_); }".
- "1;"
- or die "eval sub";
- }
- return 1;
-}
-
sub prefix
{
my $self = shift;
@@ -385,5 +339,9 @@ See C<t/rx*.t> for examples.
Andreas Kaiser ak@ananke.s.bawue.de, with additions by Ilya Zakharevich
ilya@math.ohio-state.edu.
+
+=head1 SEE ALSO
+
+L<OS2::DLL>.
=cut
diff -pru perl5.005_62/os2/OS2/REXX/REXX.xs perl5.005_62.my/os2/OS2/REXX/REXX.xs
--- perl5.005_62/os2/OS2/REXX/REXX.xs Tue Jul 20 12:18:06 1999
+++ perl5.005_62.my/os2/OS2/REXX/REXX.xs Fri Oct 15 23:59:42 1999
@@ -236,49 +236,6 @@ constant(name,arg)
char * name
int arg
-SV *
-_call(name, address, queue="SESSION", ...)
- char * name
- void * address
- char * queue
- CODE:
- {
- ULONG rc;
- int argc, i;
- RXSTRING result;
- UCHAR resbuf[256];
- RexxFunctionHandler *fcn = address;
- argc = items-3;
- needstrs(argc);
- if (trace)
- fprintf(stderr, "REXXCALL::_call name: '%s' args:", name);
- for (i = 0; i < argc; ++i) {
- STRLEN len;
- char *ptr = SvPV(ST(3+i), len);
- MAKERXSTRING(strs[i], ptr, len);
- if (trace)
- fprintf(stderr, " '%.*s'", len, ptr);
- }
- if (!*queue)
- queue = "SESSION";
- if (trace)
- fprintf(stderr, "\n");
- MAKERXSTRING(result, resbuf, sizeof resbuf);
- rc = fcn(name, argc, strs, queue, &result);
- if (trace)
- fprintf(stderr, " rc=%X, result='%.*s'\n", rc,
- result.strlength, result.strptr);
- ST(0) = sv_newmortal();
- if (rc == 0) {
- if (result.strptr)
- sv_setpvn(ST(0), result.strptr, result.strlength);
- else
- sv_setpvn(ST(0), "", 0);
- }
- if (result.strptr && result.strptr != resbuf)
- DosFreeMem(result.strptr);
- }
-
int
_set(name,value,...)
char * name
diff -pru perl5.005_62/os2/OS2/REXX/t/rx_dllld.t perl5.005_62.my/os2/OS2/REXX/t/rx_dllld.t
--- perl5.005_62/os2/OS2/REXX/t/rx_dllld.t Tue Jul 20 12:18:06 1999
+++ perl5.005_62.my/os2/OS2/REXX/t/rx_dllld.t Sun Oct 24 01:16:08 1999
@@ -16,7 +16,7 @@ foreach $dir (split(';', $path)) {
$found = "$dir/YDBAUTIL.DLL";
last;
}
-$found or die "1..0\n#Cannot find YDBAUTIL.DLL\n";
+$found or print "1..0 # skipped: cannot find YDBAUTIL.DLL\n" and exit;
print "1..5\n";
diff -pru perl5.005_62/os2/OS2/REXX/t/rx_emxrv.t perl5.005_62.my/os2/OS2/REXX/t/rx_emxrv.t
--- perl5.005_62/os2/OS2/REXX/t/rx_emxrv.t Sun Oct 24 02:11:04 1999
+++ perl5.005_62.my/os2/OS2/REXX/t/rx_emxrv.t Sun Oct 24 01:28:18 1999
@@ -0,0 +1,24 @@
+BEGIN {
+ chdir 't' if -d 't/lib';
+ @INC = '../lib' if -d 'lib';
+ require Config; import Config;
+ if (-d 'lib' and $Config{'extensions'} !~ /\bOS2(::|\/)REXX\b/) {
+ print "1..0\n";
+ exit 0;
+ }
+}
+
+print "1..5\n";
+
+require OS2::DLL;
+print "ok 1\n";
+$emx_dll = OS2::DLL->load('emx');
+print "ok 2\n";
+$emx_version = $emx_dll->emx_revision();
+print "ok 3\n";
+$emx_version >= 40 or print "not "; # We cannot work with old EMXs
+print "ok 4\n";
+
+$reason = '';
+$emx_version >= 99 and $reason = ' # skipped: version of EMX 100 or more'; # Be safe
+print "ok 5$reason\n";
diff -pru perl5.005_62/os2/OS2/REXX/t/rx_objcall.t perl5.005_62.my/os2/OS2/REXX/t/rx_objcall.t
--- perl5.005_62/os2/OS2/REXX/t/rx_objcall.t Tue Jul 20 12:18:06 1999
+++ perl5.005_62.my/os2/OS2/REXX/t/rx_objcall.t Sun Oct 24 01:16:40 1999
@@ -13,7 +13,8 @@ use OS2::REXX;
#
# DLL
#
-$ydba = load OS2::REXX "ydbautil" or die "1..0\n# load\n";
+$ydba = load OS2::REXX "ydbautil"
+ or print "1..0 # skipped: cannot find YDBAUTIL.DLL\n" and exit;
print "1..5\n", "ok 1\n";
#
diff -pru perl5.005_62/os2/OS2/REXX/t/rx_tievar.t perl5.005_62.my/os2/OS2/REXX/t/rx_tievar.t
--- perl5.005_62/os2/OS2/REXX/t/rx_tievar.t Tue Jul 20 12:18:06 1999
+++ perl5.005_62.my/os2/OS2/REXX/t/rx_tievar.t Sun Oct 24 01:17:20 1999
@@ -13,7 +13,8 @@ use OS2::REXX;
#
# DLL
#
-load OS2::REXX "ydbautil" or die "1..0\n# load\n";
+load OS2::REXX "ydbautil"
+ or print "1..0 # skipped: cannot find YDBAUTIL.DLL\n" and exit;
print "1..19\n";
diff -pru perl5.005_62/os2/OS2/REXX/t/rx_tieydb.t perl5.005_62.my/os2/OS2/REXX/t/rx_tieydb.t
--- perl5.005_62/os2/OS2/REXX/t/rx_tieydb.t Tue Jul 20 12:18:06 1999
+++ perl5.005_62.my/os2/OS2/REXX/t/rx_tieydb.t Sun Oct 24 01:17:46 1999
@@ -9,7 +9,9 @@ BEGIN {
}
use OS2::REXX;
-$rx = load OS2::REXX "ydbautil" or die "1..0\n# load\n"; # from RXU17.ZIP
+$rx = load OS2::REXX "ydbautil" # from RXU17.ZIP
+ or print "1..0 # skipped: cannot find YDBAUTIL.DLL\n" and exit;
+
print "1..7\n", "ok 1\n";
$rx->prefix("Rx"); # implicit function prefix
diff -pru perl5.005_62/os2/OS2/REXX/t/rx_vrexx.t perl5.005_62.my/os2/OS2/REXX/t/rx_vrexx.t
--- perl5.005_62/os2/OS2/REXX/t/rx_vrexx.t Tue Jul 20 12:18:06 1999
+++ perl5.005_62.my/os2/OS2/REXX/t/rx_vrexx.t Sun Oct 24 01:18:56 1999
@@ -18,7 +18,7 @@ foreach $dir (split(';', $path)) {
print "# found at `$found'\n";
last;
}
-$found or die "1..0\n#Cannot find $name.DLL\n";
+$found or print "1..0 # skipped: cannot find $name.DLL\n" and exit;
print "1..10\n";
diff -pru perl5.005_62/os2/os2.c perl5.005_62.my/os2/os2.c
--- perl5.005_62/os2/os2.c Tue Jul 20 12:18:06 1999
+++ perl5.005_62.my/os2/os2.c Sat Oct 23 22:27:36 1999
@@ -3,6 +3,10 @@
#define INCL_DOSFILEMGR
#define INCL_DOSMEMMGR
#define INCL_DOSERRORS
+/* These 3 are needed for compile if os2.h includes os2tk.h, not os2emx.h */
+#define INCL_DOSPROCESS
+#define SPU_DISABLESUPPRESSION 0
+#define SPU_ENABLESUPPRESSION 1
#include <os2.h>
#include <sys/uflags.h>
@@ -802,7 +806,7 @@ U32 addflag;
PL_Argv[0], Strerror(errno));
if (rc < 0 && (execf != EXECF_SPAWN_NOWAIT)
&& ((trueflag & 0xFF) == P_WAIT))
- rc = 255 << 8; /* Emulate the fork(). */
+ rc = -1;
finish:
if (new_stderr != -1) { /* How can we use error codes? */
@@ -907,7 +911,8 @@ do_spawn3(char *cmd, int execf, int flag
Perl_warner(aTHX_ WARN_EXEC, "Can't %s \"%s\": %s",
(execf == EXECF_SPAWN ? "spawn" : "exec"),
shell, Strerror(errno));
- if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */
+ if (rc < 0)
+ rc = -1;
}
if (news)
Safefree(news);
@@ -1356,18 +1361,37 @@ os2error(int rc)
return NULL;
if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, rc, "OSO001.MSG", &len))
sprintf(buf, "OS/2 system error code %d=0x%x", rc, rc);
- else
+ else {
buf[len] = '\0';
- if (len > 0 && buf[len - 1] == '\n')
- buf[len - 1] = '\0';
- if (len > 1 && buf[len - 2] == '\r')
- buf[len - 2] = '\0';
- if (len > 2 && buf[len - 3] == '.')
- buf[len - 3] = '\0';
+ if (len && buf[len - 1] == '\n')
+ buf[--len] = 0;
+ if (len && buf[len - 1] == '\r')
+ buf[--len] = 0;
+ if (len && buf[len - 1] == '.')
+ buf[--len] = 0;
+ }
return buf;
}
char *
+os2_execname(void)
+{
+ char buf[300], *p;
+
+ if (_execname(buf, sizeof buf) != 0)
+ return PL_origargv[0];
+ p = buf;
+ while (*p) {
+ if (*p == '\\')
+ *p = '/';
+ p++;
+ }
+ p = savepv(buf);
+ SAVEFREEPV(p);
+ return p;
+}
+
+char *
perllib_mangle(char *s, unsigned int l)
{
static char *newp, *oldp;
@@ -2067,7 +2091,7 @@ Perl_OS2_init(char **env)
settmppath();
OS2_Perl_data.xs_init = &Xs_OS2_init;
_uflags (_UF_SBRK_MODEL, _UF_SBRK_ARBITRARY);
- if (environ == NULL) {
+ if (environ == NULL && env) {
environ = env;
}
if ( (shell = getenv("PERL_SH_DRIVE")) ) {
diff -pru perl5.005_62/os2/os2ish.h perl5.005_62.my/os2/os2ish.h
--- perl5.005_62/os2/os2ish.h Tue Jul 20 12:18:06 1999
+++ perl5.005_62.my/os2/os2ish.h Sun Oct 24 00:27:02 1999
@@ -183,16 +183,26 @@ void Perl_OS2_init(char **);
/* XXX This code hideously puts env inside: */
-#ifdef __EMX__
-# define PERL_SYS_INIT(argcp, argvp) STMT_START { \
+#ifdef PERL_CORE
+# define PERL_SYS_INIT3(argcp, argvp, env) STMT_START { \
_response(argcp, argvp); \
_wildcard(argcp, argvp); \
Perl_OS2_init(env); } STMT_END
-#else /* Compiling embedded Perl with non-EMX compiler */
# define PERL_SYS_INIT(argcp, argvp) STMT_START { \
+ _response(argcp, argvp); \
+ _wildcard(argcp, argvp); \
+ Perl_OS2_init(NULL); } STMT_END
+#else /* Compiling embedded Perl or Perl extension */
+# define PERL_SYS_INIT3(argcp, argvp, env) STMT_START { \
Perl_OS2_init(env); } STMT_END
+# define PERL_SYS_INIT(argcp, argvp) STMT_START { \
+ Perl_OS2_init(NULL); } STMT_END
+#endif
+
+#ifndef __EMX__
# define PERL_CALLCONV _System
#endif
+
#define PERL_SYS_TERM() MALLOC_TERM
/* #define PERL_SYS_TERM() STMT_START { \
@@ -318,6 +328,7 @@ extern OS2_Perl_data_t OS2_Perl_data;
#define Perl_rc (OS2_Perl_data.rc)
#define Perl_severity (OS2_Perl_data.severity)
#define errno_isOS2 12345678
+#define errno_isOS2_set 12345679
#define OS2_Perl_flags (OS2_Perl_data.flags)
#define Perl_HAB_set_f 1
#define Perl_HAB_set (OS2_Perl_flags & Perl_HAB_set_f)
@@ -339,6 +350,7 @@ void Perl_Deregister_MQ(int serve);
int Perl_Serve_Messages(int force);
/* Cannot prototype with I32 at this point. */
int Perl_Process_Messages(int force, long *cntp);
+char *os2_execname(void);
struct _QMSG;
struct PMWIN_entries_t {
@@ -356,23 +368,29 @@ struct PMWIN_entries_t {
extern struct PMWIN_entries_t PMWIN_entries;
void init_PMWIN_entries(void);
-#define perl_hmq_GET(serve) Perl_Register_MQ(serve);
-#define perl_hmq_UNSET(serve) Perl_Deregister_MQ(serve);
+#define perl_hmq_GET(serve) Perl_Register_MQ(serve)
+#define perl_hmq_UNSET(serve) Perl_Deregister_MQ(serve)
#define OS2_XS_init() (*OS2_Perl_data.xs_init)()
+
+#if _EMX_CRT_REV_ >= 60
+# define os2_setsyserrno(rc) (Perl_rc = rc, errno = errno_isOS2_set, \
+ _setsyserrno(rc))
+#else
+# define os2_setsyserrno(rc) (Perl_rc = rc, errno = errno_isOS2)
+#endif
+
/* The expressions below return true on error. */
/* INCL_DOSERRORS needed. rc should be declared outside. */
#define CheckOSError(expr) (!(rc = (expr)) ? 0 : (FillOSError(rc), 1))
/* INCL_WINERRORS needed. */
#define SaveWinError(expr) ((expr) ? : (FillWinError, 0))
#define CheckWinError(expr) ((expr) ? 0: (FillWinError, 1))
-#define FillOSError(rc) (Perl_rc = rc, \
- errno = errno_isOS2, \
+#define FillOSError(rc) (os2_setsyserrno(rc), \
Perl_severity = SEVERITY_ERROR)
-#define FillWinError (Perl_rc = WinGetLastError(Perl_hab), \
- errno = errno_isOS2, \
- Perl_severity = ERRORIDSEV(Perl_rc), \
- Perl_rc = ERRORIDERROR(Perl_rc))
+#define FillWinError (Perl_severity = ERRORIDSEV(Perl_rc), \
+ Perl_rc = ERRORIDERROR(Perl_rc)), \
+ os2_setsyserrno(Perl_rc)
#define STATIC_FILE_LENGTH 127
@@ -392,7 +410,7 @@ char *os2error(int rc);
#define QSS_FILE 8 /* Buggy until fixpack18 */
#define QSS_SHARED 16
-#ifdef _OS2EMX_H
+#ifdef _OS2_H
APIRET APIENTRY Dos32QuerySysState(ULONG func,ULONG arg1,ULONG pid,
ULONG _res_,PVOID buf,ULONG bufsz);
@@ -550,5 +568,5 @@ typedef struct {
PQTOPLEVEL get_sysinfo(ULONG pid, ULONG flags);
-#endif /* _OS2EMX_H */
+#endif /* _OS2_H */
diff -pru perl5.005_62/perl.c perl5.005_62.my/perl.c
--- perl5.005_62/perl.c Thu Oct 14 12:35:12 1999
+++ perl5.005_62.my/perl.c Sat Oct 16 01:42:52 1999
@@ -2691,7 +2691,11 @@ S_init_postdump_symbols(pTHX_ register i
magicname("0", "0", 1);
}
if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
+#ifdef OS2
+ sv_setpv(GvSV(tmpgv), os2_execname());
+#else
sv_setpv(GvSV(tmpgv),PL_origargv[0]);
+#endif
if (PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
GvMULTI_on(PL_argvgv);
(void)gv_AVadd(PL_argvgv);
diff -pru perl5.005_62/t/io/fs.t perl5.005_62.my/t/io/fs.t
--- perl5.005_62/t/io/fs.t Sat Sep 4 15:02:00 1999
+++ perl5.005_62.my/t/io/fs.t Sun Oct 24 02:50:30 1999
@@ -147,12 +147,16 @@ else {
print FH "helloworld\n";
truncate FH, 5;
}
- if ($^O eq 'dos') {
+ if ($^O eq 'dos'
+ # Not needed on HPFS, but needed on HPFS386 ?!
+ or $^O eq 'os2') {
close (FH); open (FH, ">>Iofs.tmp") or die "Can't reopen Iofs.tmp";
}
if (-s "Iofs.tmp" == 5) {print "ok 25\n"} else {print "not ok 25\n"}
truncate FH, 0;
- if ($^O eq 'dos') {
+ if ($^O eq 'dos'
+ # Not needed on HPFS, but needed on HPFS386 ?!
+ or $^O eq 'os2') {
close (FH); open (FH, ">>Iofs.tmp") or die "Can't reopen Iofs.tmp";
}
if (-z "Iofs.tmp") {print "ok 26\n"} else {print "not ok 26\n"}
diff -pru perl5.005_62/t/op/magic.t perl5.005_62.my/t/op/magic.t
--- perl5.005_62/t/op/magic.t Tue Jul 20 12:18:14 1999
+++ perl5.005_62.my/t/op/magic.t Sun Oct 24 01:04:12 1999
@@ -22,6 +22,7 @@ sub ok {
$Is_MSWin32 = $^O eq 'MSWin32';
$Is_VMS = $^O eq 'VMS';
$Is_Dos = $^O eq 'dos';
+$Is_os2 = $^O eq 'os2';
$Is_Cygwin = $^O =~ /cygwin/;
$PERL = ($Is_MSWin32 ? '.\perl' : './perl');
@@ -117,6 +118,9 @@ ok 18, $$ > 0, $$;
chomp($wd = `pwd`);
$wd =~ s#/t$##;
}
+ elsif($Is_os2) {
+ $wd = Cwd::sys_cwd();
+ }
else {
$wd = '.';
}
@@ -142,6 +146,9 @@ __END__
:endofperl
EOT
}
+ elsif ($Is_os2) {
+ $script = "./show-shebang";
+ }
if ($^O eq 'os390' or $^O eq 'posix-bc' or $^O eq 'vmesa') { # no shebang
$headmaybe = <<EOH ;
eval 'exec ./perl -S \$0 \${1+"\$\@"}'
@@ -158,15 +165,15 @@ EOF
ok 21, close(SCRIPT), $!;
ok 22, chmod(0755, $script), $!;
$_ = `$script`;
- s/\.exe//i if $Is_Dos or $Is_Cygwin;
+ s/\.exe//i if $Is_Dos or $Is_Cygwin or $Is_os2;
s{\bminiperl\b}{perl}; # so that test doesn't fail with miniperl
s{is perl}{is $perl}; # for systems where $^X is only a basename
s{\\}{/}g;
- ok 23, ($Is_MSWin32 ? uc($_) eq uc($s1) : $_ eq $s1), ":$_:!=:$s1:";
+ ok 23, (($Is_MSWin32 || $Is_os2) ? uc($_) eq uc($s1) : $_ eq $s1), " :$_:!=:$s1:";
$_ = `$perl $script`;
- s/\.exe//i if $Is_Dos;
+ s/\.exe//i if $Is_Dos or $Is_os2;
s{\\}{/}g;
- ok 24, ($Is_MSWin32 ? uc($_) eq uc($s1) : $_ eq $s1), ":$_:!=:$s1: after `$perl $script`";
+ ok 24, (($Is_MSWin32 || $Is_os2) ? uc($_) eq uc($s1) : $_ eq $s1), " :$_:!=:$s1: after `$perl $script`";
ok 25, unlink($script), $!;
}
@@ -211,8 +218,8 @@ if ($Is_MSWin32) {
ok 35, (scalar(keys(%ENV)) == 0);
}
else {
- ok "32 # skipped",1;
- ok "33 # skipped",1;
- ok "34 # skipped",1;
- ok "35 # skipped",1;
+ ok "32 # skipped: not MSWin",1;
+ ok "33 # skipped: not MSWin",1;
+ ok "34 # skipped: not MSWin",1;
+ ok "35 # skipped: not MSWin",1;
}
Thread Next
-
[PATCH 5.005_62] OS/2 improvements
by Ilya Zakharevich