From: Ilya Zakharevich Date: Sun, 24 Oct 1999 03:24:28 +0000 (-0400) Subject: Re: [PATCH 5.005_62] OS/2 improvements X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=ed344e4f516e393bcdfd181ec61ffbb056bebd56;p=p5sagit%2Fp5-mst-13.2.git Re: [PATCH 5.005_62] OS/2 improvements Message-Id: <199910240724.DAA12230@monk.mps.ohio-state.edu> p4raw-id: //depot/perl@4432 --- diff --git a/MANIFEST b/MANIFEST index 2ad8ec2..de3c0f7 100644 --- a/MANIFEST +++ b/MANIFEST @@ -954,11 +954,17 @@ os2/OS2/Process/Process.pm system() constants in a module 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 --git a/hints/os2.sh b/hints/os2.sh index 0167a0a..1d9df36 100644 --- a/hints/os2.sh +++ b/hints/os2.sh @@ -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 --git a/mg.c b/mg.c index b08cee3..09be2f7 100644 --- a/mg.c +++ b/mg.c @@ -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 --git a/miniperlmain.c b/miniperlmain.c index f7b24f4..fb5cf1a 100644 --- a/miniperlmain.c +++ b/miniperlmain.c @@ -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 --git a/os2/Changes b/os2/Changes index 910ec46..e56b708 100644 --- a/os2/Changes +++ b/os2/Changes @@ -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 to treat $cmd as in C; + 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, envp); + 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 --git a/os2/OS2/REXX/Changes b/os2/OS2/REXX/Changes index 46b38ef..7c19710 100644 --- a/os2/OS2/REXX/Changes +++ b/os2/OS2/REXX/Changes @@ -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 --git a/os2/OS2/REXX/DLL/Changes b/os2/OS2/REXX/DLL/Changes new file mode 100644 index 0000000..874f7fa --- /dev/null +++ b/os2/OS2/REXX/DLL/Changes @@ -0,0 +1,2 @@ +0.01: + Split out of OS2::REXX diff --git a/os2/OS2/REXX/DLL/DLL.pm b/os2/OS2/REXX/DLL/DLL.pm new file mode 100644 index 0000000..7e54371 --- /dev/null +++ b/os2/OS2/REXX/DLL/DLL.pm @@ -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 []' 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 < $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 < 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 is set, emits debugging output. Looks for DLLs +in C, C, C. + +=head1 AUTHOR + +Extracted by Ilya Zakharevich ilya@math.ohio-state.edu from L +written by Andreas Kaiser ak@ananke.s.bawue.de. + +=cut diff --git a/os2/OS2/REXX/DLL/DLL.xs b/os2/OS2/REXX/DLL/DLL.xs new file mode 100644 index 0000000..c8e7c58 --- /dev/null +++ b/os2/OS2/REXX/DLL/DLL.xs @@ -0,0 +1,72 @@ +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#define INCL_BASE +#define INCL_REXXSAA +#include + +static RXSTRING * strs; +static int nstrs; +static char * trace; + +static void +needstrs(int n) +{ + if (n > nstrs) { + if (strs) + free(strs); + nstrs = 2 * n; + strs = malloc(nstrs * sizeof(RXSTRING)); + } +} + +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 --git a/os2/OS2/REXX/DLL/MANIFEST b/os2/OS2/REXX/DLL/MANIFEST new file mode 100644 index 0000000..d7ad9b6 --- /dev/null +++ b/os2/OS2/REXX/DLL/MANIFEST @@ -0,0 +1,5 @@ +Changes +MANIFEST +Makefile.PL +DLL.pm +DLL.xs diff --git a/os2/OS2/REXX/DLL/Makefile.PL b/os2/OS2/REXX/DLL/Makefile.PL new file mode 100644 index 0000000..fe2403d --- /dev/null +++ b/os2/OS2/REXX/DLL/Makefile.PL @@ -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 --git a/os2/OS2/REXX/Makefile.PL b/os2/OS2/REXX/Makefile.PL index 5eda5a3..6648b2c 100644 --- a/os2/OS2/REXX/Makefile.PL +++ b/os2/OS2/REXX/Makefile.PL @@ -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 --git a/os2/OS2/REXX/REXX.pm b/os2/OS2/REXX/REXX.pm index 4580ede..5c6dfd2 100644 --- a/os2/OS2/REXX/REXX.pm +++ b/os2/OS2/REXX/REXX.pm @@ -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 []' 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; @@ -386,4 +340,8 @@ See C for examples. Andreas Kaiser ak@ananke.s.bawue.de, with additions by Ilya Zakharevich ilya@math.ohio-state.edu. +=head1 SEE ALSO + +L. + =cut diff --git a/os2/OS2/REXX/REXX.xs b/os2/OS2/REXX/REXX.xs index 9f23714..8a8e5f2 100644 --- a/os2/OS2/REXX/REXX.xs +++ b/os2/OS2/REXX/REXX.xs @@ -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 --git a/os2/OS2/REXX/t/rx_dllld.t b/os2/OS2/REXX/t/rx_dllld.t index 9d81bf3..15362d7 100644 --- a/os2/OS2/REXX/t/rx_dllld.t +++ b/os2/OS2/REXX/t/rx_dllld.t @@ -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 --git a/os2/OS2/REXX/t/rx_emxrv.t b/os2/OS2/REXX/t/rx_emxrv.t new file mode 100644 index 0000000..d51e1b0 --- /dev/null +++ b/os2/OS2/REXX/t/rx_emxrv.t @@ -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 --git a/os2/OS2/REXX/t/rx_objcall.t b/os2/OS2/REXX/t/rx_objcall.t index cb3c52a..8bdf905 100644 --- a/os2/OS2/REXX/t/rx_objcall.t +++ b/os2/OS2/REXX/t/rx_objcall.t @@ -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 --git a/os2/OS2/REXX/t/rx_tievar.t b/os2/OS2/REXX/t/rx_tievar.t index 77f90c2..5f43f4e 100644 --- a/os2/OS2/REXX/t/rx_tievar.t +++ b/os2/OS2/REXX/t/rx_tievar.t @@ -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 --git a/os2/OS2/REXX/t/rx_tieydb.t b/os2/OS2/REXX/t/rx_tieydb.t index 30a2daf..1653a20 100644 --- a/os2/OS2/REXX/t/rx_tieydb.t +++ b/os2/OS2/REXX/t/rx_tieydb.t @@ -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 --git a/os2/OS2/REXX/t/rx_vrexx.t b/os2/OS2/REXX/t/rx_vrexx.t index 04ca663..b0621f4 100644 --- a/os2/OS2/REXX/t/rx_vrexx.t +++ b/os2/OS2/REXX/t/rx_vrexx.t @@ -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 --git a/os2/dl_os2.c b/os2/dl_os2.c index 19f36f6..4a9688c 100644 --- a/os2/dl_os2.c +++ b/os2/dl_os2.c @@ -4,15 +4,16 @@ #include 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 --git a/os2/os2.c b/os2/os2.c index 7c23200..8a17ae7 100644 --- a/os2/os2.c +++ b/os2/os2.c @@ -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 #include @@ -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 --git a/os2/os2ish.h b/os2/os2ish.h index 6993dfc..23b1096 100644 --- a/os2/os2ish.h +++ b/os2/os2ish.h @@ -183,16 +183,26 @@ void Perl_OS2_init(char **); /* XXX This code hideously puts env inside: */ -#ifdef __EMX__ +#ifdef PERL_CORE +# define PERL_SYS_INIT3(argcp, argvp, envp) STMT_START { \ + _response(argcp, argvp); \ + _wildcard(argcp, argvp); \ + Perl_OS2_init(*envp); } STMT_END # define PERL_SYS_INIT(argcp, argvp) STMT_START { \ _response(argcp, argvp); \ _wildcard(argcp, argvp); \ - Perl_OS2_init(env); } STMT_END -#else /* Compiling embedded Perl with non-EMX compiler */ + Perl_OS2_init(NULL); } STMT_END +#else /* Compiling embedded Perl or Perl extension */ +# define PERL_SYS_INIT3(argcp, argvp, envp) STMT_START { \ + Perl_OS2_init(*envp); } STMT_END # define PERL_SYS_INIT(argcp, argvp) STMT_START { \ - Perl_OS2_init(env); } STMT_END + 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 --git a/perl.c b/perl.c index 23ece0f..d5b6d43 100644 --- a/perl.c +++ b/perl.c @@ -2726,7 +2726,11 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register 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 --git a/perl.h b/perl.h index eb88c39..046e044 100644 --- a/perl.h +++ b/perl.h @@ -1560,6 +1560,10 @@ typedef union any ANY; # endif #endif +#ifndef PERL_SYS_INIT3 +# define PERL_SYS_INIT3(argvp,argcp,envp) PERL_SYS_INIT(argvp,argcp) +#endif + #ifndef MAXPATHLEN # ifdef PATH_MAX # ifdef _POSIX_PATH_MAX diff --git a/t/io/fs.t b/t/io/fs.t index 087021b..3192970 100755 --- a/t/io/fs.t +++ b/t/io/fs.t @@ -147,12 +147,18 @@ 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 --git a/t/op/magic.t b/t/op/magic.t index 31765e2..fe55521 100755 --- a/t/op/magic.t +++ b/t/op/magic.t @@ -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 = <