diff options
| -rwxr-xr-x | lib/English.t | 2 | ||||
| -rw-r--r-- | lib/ExtUtils/t/Embed.t | 7 | ||||
| -rw-r--r-- | lib/File/stat.t | 2 | ||||
| -rw-r--r-- | lib/Shell.t | 10 | ||||
| -rw-r--r-- | os2/Makefile.SHs | 11 | ||||
| -rw-r--r-- | os2/OS2/REXX/DLL/Makefile.PL | 2 | ||||
| -rw-r--r-- | os2/os2.c | 10 | ||||
| -rw-r--r-- | os2/perlrexx.c | 231 | ||||
| -rw-r--r-- | t/op/alarm.t | 4 | ||||
| -rw-r--r-- | util.c | 3 |
10 files changed, 35 insertions, 247 deletions
diff --git a/lib/English.t b/lib/English.t index 745d42ee2a..6e11dcc686 100755 --- a/lib/English.t +++ b/lib/English.t @@ -85,7 +85,7 @@ is( $PERL_VERSION, $^V, '$PERL_VERSION' ); is( $DEBUGGING, $^D, '$DEBUGGING' ); is( $WARNING, 0, '$WARNING' ); -like( $EXECUTABLE_NAME, qr/perl/, '$EXECUTABLE_NAME' ); +like( $EXECUTABLE_NAME, qr/perl/i, '$EXECUTABLE_NAME' ); is( $OSNAME, $Config{osname}, '$OSNAME' ); # may be non-portable diff --git a/lib/ExtUtils/t/Embed.t b/lib/ExtUtils/t/Embed.t index 24b6a17362..1f23909cb5 100644 --- a/lib/ExtUtils/t/Embed.t +++ b/lib/ExtUtils/t/Embed.t @@ -16,7 +16,9 @@ $| = 1; print "1..9\n"; my $cc = $Config{'cc'}; my $cl = ($^O eq 'MSWin32' && $cc eq 'cl'); -my $exe = 'embed_test' . $Config{'exe_ext'}; +my $skip_exe = $^O eq 'os2' && $Config{ldflags} =~ /(?<!\S)-Zexe\b/; +my $exe = 'embed_test'; +$exe .= $Config{'exe_ext'} unless $skip_exe; # Linker will auto-append it my $obj = 'embed_test' . $Config{'obj_ext'}; my $inc = File::Spec->updir; my $lib = File::Spec->updir; @@ -70,6 +72,8 @@ if ($^O eq 'VMS') { local $SIG{__WARN__} = sub { warn $_[0] unless $_[0] =~ /No library found for -lperl/ }; + push(@cmd, '-Zlinker', '/PM:VIO') # Otherwise puts a warning to STDOUT! + if $^O eq 'os2' and $Config{ldflags} =~ /(?<!\S)-Zomf\b/; push(@cmd,ldopts()); } @@ -118,6 +122,7 @@ print "# embed_test = $embed_test\n"; $status = system($embed_test); print (($status? 'not ':'')."ok 9 # $status\n"); unlink($exe,"embed_test.c",$obj); +unlink("$exe$Config{exe_ext}") if $skip_exe; unlink("embed_test.map","embed_test.lis") if $^O eq 'VMS'; unlink(glob("./libperl*.dll")) if $^O eq 'cygwin'; unlink("../libperl.a") if $^O eq 'cygwin'; diff --git a/lib/File/stat.t b/lib/File/stat.t index 8215f45d87..0487b8b51a 100644 --- a/lib/File/stat.t +++ b/lib/File/stat.t @@ -30,7 +30,7 @@ is( $stat->dev, $stat[0], "device number in position 0" ); # On OS/2 (fake) ino is not constant, it is incremented each time SKIP: { - skip(1, 'inode number is not constant on OS/2') if $^O eq 'os2'; + skip('inode number is not constant on OS/2', 1) if $^O eq 'os2'; is( $stat->ino, $stat[1], "inode number in position 1" ); } diff --git a/lib/Shell.t b/lib/Shell.t index 837f6aca88..b2d3d67aa0 100644 --- a/lib/Shell.t +++ b/lib/Shell.t @@ -1,5 +1,10 @@ #!./perl +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + use Test::More tests => 4; BEGIN { use_ok('Shell'); } @@ -19,7 +24,7 @@ while ( -f $tmpfile ) $tmpfile++; } -END { -f $tmpfile && unlink $tmpfile }; +END { -f $tmpfile && (open STDERR, '>&SAVERR' and unlink $tmpfile) }; @@ -28,7 +33,8 @@ open(STDERR, ">$tmpfile"); xXx(); # Ok someone could have a program called this :( -ok( !(-s $tmpfile) ,'$Shell::capture_stderr'); +# On os2 the warning is on by default... +ok( ($^O eq 'os2' xor !(-s $tmpfile)) ,'$Shell::capture_stderr'); $Shell::capture_stderr = 0; # diff --git a/os2/Makefile.SHs b/os2/Makefile.SHs index 2f697ed76e..9c44823a21 100644 --- a/os2/Makefile.SHs +++ b/os2/Makefile.SHs @@ -57,8 +57,9 @@ AOUT_EXTRA_LIBS = $aout_extra_libs $spitshell >>Makefile <<'!NO!SUBS!' $(LIBPERL): perl.imp $(PERL_DLL) perl5.def libperl_override.lib emximp -o $(LIBPERL) perl.imp + cp $(LIBPERL) perl.lib -libperl_override.imp: os2/os2add.sym +libperl_override.imp: os2/os2add.sym miniperl ./miniperl -wnle 'print "$$_\t$(PERL_DLL_BASE)\t$$_\t?"' os2/os2add.sym > tmp.imp echo 'strdup $(PERL_DLL_BASE) Perl_strdup ?' >> tmp.imp echo 'putenv $(PERL_DLL_BASE) Perl_putenv ?' >> tmp.imp @@ -198,6 +199,7 @@ $(DYNALOADER_OBJ) : $(DYNALOADER) $(AOUT_LIBPERL) : $(aout_obj) perl$(AOUT_OBJ_EXT) rm -f $@ $(AOUT_AR) rcu $@ perl$(AOUT_OBJ_EXT) $(aout_obj) + cp $@ perl.a .c$(AOUT_OBJ_EXT): $(AOUT_CCCMD) $(PLDLFLAGS) -c $*.c @@ -219,7 +221,10 @@ miniperl_: $& miniperlmain$(AOUT_OBJ_EXT) $(AOUT_LIBPERL) opmini$(AOUT_OBJ_EXT) # Forking statically loaded perl -perl_$(EXE_EXT) perl_: $& aout_perlmain$(AOUT_OBJ_EXT) $(AOUT_LIBPERL) $(AOUT_DYNALOADER) $(aout_static_ext) ext.libs +# Need a miniperl_ dependency, since $(AOUT_DYNALOADER) is build via implicit +# rules, thus would not rebuild miniperl_ via an explicit rule + +perl_$(EXE_EXT) perl_: $& miniperl_ aout_perlmain$(AOUT_OBJ_EXT) $(AOUT_LIBPERL) $(AOUT_DYNALOADER) $(aout_static_ext) ext.libs $(CC) $(AOUT_CLDFLAGS) $(CCDLFLAGS) -o perl_ aout_perlmain$(AOUT_OBJ_EXT) $(AOUT_DYNALOADER) $(aout_static_ext) $(AOUT_LIBPERL) `cat ext.libs` $(libs) # Remove -Zcrtdll @@ -448,7 +453,7 @@ lib/auto/*/%.a : ext/%/Makefile.aout @cd ext/$(basename $(notdir $@)) ; make -f Makefile.aout config || echo "\$(MAKE) config failed, continuing anyway..." cd ext/$(basename $(notdir $@)) ; make -f Makefile.aout LINKTYPE=static CCCDLFLAGS= -ext/%/Makefile.aout : miniperl_ \$(_preplibrary) \$(AOUT_EXTENSIONS_FORCE) +ext/%/Makefile.aout : miniperl_ $(_preplibrary) $(AOUT_EXTENSIONS_FORCE) cd $(dir $@) ; ../../miniperl_ -I ../../lib Makefile.PL FIRST_MAKEFILE=Makefile.aout INSTALLDIRS=perl !NO!SUBS! diff --git a/os2/OS2/REXX/DLL/Makefile.PL b/os2/OS2/REXX/DLL/Makefile.PL index fb91688ce7..6756402c2f 100644 --- a/os2/OS2/REXX/DLL/Makefile.PL +++ b/os2/OS2/REXX/DLL/Makefile.PL @@ -2,7 +2,7 @@ use ExtUtils::MakeMaker; WriteMakefile( NAME => 'OS2::DLL', - VERSION => '0.01', + VERSION_FROM => 'DLL.pm', MAN3PODS => {}, # Pods will be built by installman. XSPROTOARG => '-noprototypes', PERL_MALLOC_OK => 1, @@ -618,14 +618,14 @@ do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag) if (strEQ(PL_Argv[0],"/bin/sh")) PL_Argv[0] = PL_sh_path; - if (PL_Argv[0][0] != '/' && PL_Argv[0][0] != '\\' - && !(PL_Argv[0][0] && PL_Argv[0][1] == ':' - && (PL_Argv[0][2] == '/' || PL_Argv[0][2] != '\\')) - ) /* will spawnvp use PATH? */ - TAINT_ENV(); /* testing IFS here is overkill, probably */ /* 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] != '\\')) + ) /* will spawnvp use PATH? */ + TAINT_ENV(); /* testing IFS here is overkill, probably */ reread: force_shell = 0; diff --git a/os2/perlrexx.c b/os2/perlrexx.c index 5706b18969..fbeb493e95 100644 --- a/os2/perlrexx.c +++ b/os2/perlrexx.c @@ -320,234 +320,3 @@ PERLDROPALLEXIT(PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PR retstr->strlength = 0; return 0; } -#define INCL_DOSPROCESS -#define INCL_DOSSEMAPHORES -#define INCL_DOSMODULEMGR -#define INCL_DOSMISC -#define INCL_DOSEXCEPTIONS -#define INCL_DOSERRORS -#define INCL_REXXSAA -#include <os2.h> - -/* - * "The Road goes ever on and on, down from the door where it began." - */ - -#ifdef OEMVS -#ifdef MYMALLOC -/* sbrk is limited to first heap segement so make it big */ -#pragma runopts(HEAP(8M,500K,ANYWHERE,KEEP,8K,4K) STACK(,,ANY,) ALL31(ON)) -#else -#pragma runopts(HEAP(2M,500K,ANYWHERE,KEEP,8K,4K) STACK(,,ANY,) ALL31(ON)) -#endif -#endif - - -#include "EXTERN.h" -#include "perl.h" - -static void xs_init (pTHX); -static PerlInterpreter *my_perl; - -#if defined (__MINT__) || defined (atarist) -/* The Atari operating system doesn't have a dynamic stack. The - stack size is determined from this value. */ -long _stksize = 64 * 1024; -#endif - -/* Register any extra external extensions */ - -/* Do not delete this line--writemain depends on it */ -EXTERN_C void boot_DynaLoader (pTHX_ CV* cv); - -static void -xs_init(pTHX) -{ - char *file = __FILE__; - dXSUB_SYS; - newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file); -} - -int perlos2_is_inited; - -static void -init_perlos2(void) -{ -/* static char *env[1] = {NULL}; */ - - Perl_OS2_init3(0, 0, 0); -} - -static int -init_perl(int doparse) -{ - int exitstatus; - char *argv[3] = {"perl_in_REXX", "-e", ""}; - - if (!perlos2_is_inited) { - perlos2_is_inited = 1; - init_perlos2(); - } - if (my_perl) - return 1; - if (!PL_do_undump) { - my_perl = perl_alloc(); - if (!my_perl) - return 0; - perl_construct(my_perl); - PL_perl_destruct_level = 1; - } - if (!doparse) - return 1; - exitstatus = perl_parse(my_perl, xs_init, 3, argv, (char **)NULL); - return !exitstatus; -} - -/* The REXX-callable entrypoints ... */ - -ULONG PERL (PCSZ name, LONG rargc, const RXSTRING *rargv, - PCSZ queuename, PRXSTRING retstr) -{ - int exitstatus; - char buf[256]; - char *argv[3] = {"perl_from_REXX", "-e", buf}; - ULONG ret; - - if (rargc != 1) { - sprintf(retstr->strptr, "one argument expected, got %ld", rargc); - retstr->strlength = strlen (retstr->strptr); - return 1; - } - if (rargv[0].strlength >= sizeof(buf)) { - sprintf(retstr->strptr, - "length of the argument %ld exceeds the maximum %ld", - rargv[0].strlength, (long)sizeof(buf) - 1); - retstr->strlength = strlen (retstr->strptr); - return 1; - } - - if (!init_perl(0)) - return 1; - - memcpy(buf, rargv[0].strptr, rargv[0].strlength); - buf[rargv[0].strlength] = 0; - - exitstatus = perl_parse(my_perl, xs_init, 3, argv, (char **)NULL); - if (!exitstatus) { - exitstatus = perl_run(my_perl); - } - - perl_destruct(my_perl); - perl_free(my_perl); - my_perl = 0; - - if (exitstatus) - ret = 1; - else { - ret = 0; - sprintf(retstr->strptr, "%s", "ok"); - retstr->strlength = strlen (retstr->strptr); - } - PERL_SYS_TERM1(0); - return ret; -} - -ULONG PERLEXIT (PCSZ name, LONG rargc, const RXSTRING *rargv, - PCSZ queuename, PRXSTRING retstr) -{ - if (rargc != 0) { - sprintf(retstr->strptr, "no arguments expected, got %ld", rargc); - retstr->strlength = strlen (retstr->strptr); - return 1; - } - PERL_SYS_TERM1(0); - return 0; -} - -ULONG PERLTERM (PCSZ name, LONG rargc, const RXSTRING *rargv, - PCSZ queuename, PRXSTRING retstr) -{ - if (rargc != 0) { - sprintf(retstr->strptr, "no arguments expected, got %ld", rargc); - retstr->strlength = strlen (retstr->strptr); - return 1; - } - if (!my_perl) { - sprintf(retstr->strptr, "no perl interpreter present"); - retstr->strlength = strlen (retstr->strptr); - return 1; - } - perl_destruct(my_perl); - perl_free(my_perl); - my_perl = 0; - - sprintf(retstr->strptr, "%s", "ok"); - retstr->strlength = strlen (retstr->strptr); - return 0; -} - - -ULONG PERLINIT (PCSZ name, LONG rargc, const RXSTRING *rargv, - PCSZ queuename, PRXSTRING retstr) -{ - if (rargc != 0) { - sprintf(retstr->strptr, "no argument expected, got %ld", rargc); - retstr->strlength = strlen (retstr->strptr); - return 1; - } - if (!init_perl(1)) - return 1; - - sprintf(retstr->strptr, "%s", "ok"); - retstr->strlength = strlen (retstr->strptr); - return 0; -} - -ULONG PERLEVAL (PCSZ name, LONG rargc, const RXSTRING *rargv, - PCSZ queuename, PRXSTRING retstr) -{ - SV *res, *in; - STRLEN len; - char *str; - - if (rargc != 1) { - sprintf(retstr->strptr, "one argument expected, got %ld", rargc); - retstr->strlength = strlen (retstr->strptr); - return 1; - } - - if (!init_perl(1)) - return 1; - - { - dSP; - int ret; - - ENTER; - SAVETMPS; - - PUSHMARK(SP); - in = sv_2mortal(newSVpvn(rargv[0].strptr, rargv[0].strlength)); - eval_sv(in, G_SCALAR); - SPAGAIN; - res = POPs; - PUTBACK; - - ret = 0; - if (SvTRUE(ERRSV) || !SvOK(res)) - ret = 1; - str = SvPV(res, len); - if (len <= 256 /* Default buffer is 256-char long */ - || !DosAllocMem((PPVOID)&retstr->strptr, len, - PAG_READ|PAG_WRITE|PAG_COMMIT)) { - memcpy(retstr->strptr, str, len); - retstr->strlength = len; - } else - ret = 1; - - FREETMPS; - LEAVE; - - return ret; - } -} diff --git a/t/op/alarm.t b/t/op/alarm.t index 12c8c264c4..907c385264 100644 --- a/t/op/alarm.t +++ b/t/op/alarm.t @@ -29,7 +29,7 @@ my $diff = time - $start_time; # alarm time might be one second less than you said. is( $@, "ALARM!\n", 'alarm w/$SIG{ALRM} vs inf loop' ); -ok( $diff == 3 || $diff == 2, ' right time' ); +ok( abs($diff - 3) <= 1, " right time" ); my $start_time = time; @@ -44,4 +44,4 @@ $diff = time - $start_time; # alarm time might be one second less than you said. is( $@, "ALARM!\n", 'alarm w/$SIG{ALRM} vs system()' ); -ok( $diff == 3 || $diff == 2, ' right time' ); +ok( abs($diff - 3) <= 1, ' right time' ); @@ -2459,9 +2459,11 @@ Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags) goto hard_way; # endif result = PerlProc_waitpid(pid,statusp,flags); + goto finish; #endif #if !defined(HAS_WAITPID) && defined(HAS_WAIT4) result = wait4((pid==-1)?0:pid,statusp,flags,Null(struct rusage *)); + goto finish; #endif #if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME) hard_way: @@ -2476,6 +2478,7 @@ Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags) } } #endif + finish: if (result < 0 && errno == EINTR) { PERL_ASYNC_CHECK(); } |