Change 13805 by jhi@alpha on 2001/12/19 15:04:03
Subject: [PATCH @13746] OS/2 build
From: Ilya Zakharevich <[EMAIL PROTECTED]>
Date: Wed, 19 Dec 2001 02:45:41 -0500
Message-ID: <[EMAIL PROTECTED]>
(skipped the t/TEST change)
Affected files ...
.... //depot/perl/lib/English.t#4 edit
.... //depot/perl/lib/ExtUtils/t/Embed.t#2 edit
.... //depot/perl/lib/File/stat.t#5 edit
.... //depot/perl/lib/Shell.t#4 edit
.... //depot/perl/os2/Makefile.SHs#29 edit
.... //depot/perl/os2/OS2/REXX/DLL/Makefile.PL#3 edit
.... //depot/perl/os2/os2.c#56 edit
.... //depot/perl/os2/perlrexx.c#4 edit
.... //depot/perl/t/op/alarm.t#3 edit
.... //depot/perl/util.c#305 edit
Differences ...
==== //depot/perl/lib/English.t#4 (xtext) ====
Index: perl/lib/English.t
--- perl/lib/English.t.~1~ Wed Dec 19 08:15:05 2001
+++ perl/lib/English.t Wed Dec 19 08:15:05 2001
@@ -85,7 +85,7 @@
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
==== //depot/perl/lib/ExtUtils/t/Embed.t#2 (text) ====
Index: perl/lib/ExtUtils/t/Embed.t
--- perl/lib/ExtUtils/t/Embed.t.~1~ Wed Dec 19 08:15:05 2001
+++ perl/lib/ExtUtils/t/Embed.t Wed Dec 19 08:15:05 2001
@@ -16,7 +16,9 @@
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 @@
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 @@
$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';
==== //depot/perl/lib/File/stat.t#5 (text) ====
Index: perl/lib/File/stat.t
--- perl/lib/File/stat.t.~1~ Wed Dec 19 08:15:05 2001
+++ perl/lib/File/stat.t Wed Dec 19 08:15:05 2001
@@ -30,7 +30,7 @@
# 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" );
}
==== //depot/perl/lib/Shell.t#4 (text) ====
Index: perl/lib/Shell.t
--- perl/lib/Shell.t.~1~ Wed Dec 19 08:15:05 2001
+++ perl/lib/Shell.t Wed Dec 19 08:15:05 2001
@@ -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 @@
$tmpfile++;
}
-END { -f $tmpfile && unlink $tmpfile };
+END { -f $tmpfile && (open STDERR, '>&SAVERR' and unlink $tmpfile) };
@@ -28,7 +33,8 @@
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; #
==== //depot/perl/os2/Makefile.SHs#29 (text) ====
Index: perl/os2/Makefile.SHs
--- perl/os2/Makefile.SHs.~1~ Wed Dec 19 08:15:05 2001
+++ perl/os2/Makefile.SHs Wed Dec 19 08:15:05 2001
@@ -57,8 +57,9 @@
$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 @@
$(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 @@
# 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 @@
@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!
==== //depot/perl/os2/OS2/REXX/DLL/Makefile.PL#3 (text) ====
Index: perl/os2/OS2/REXX/DLL/Makefile.PL
--- perl/os2/OS2/REXX/DLL/Makefile.PL.~1~ Wed Dec 19 08:15:05 2001
+++ perl/os2/OS2/REXX/DLL/Makefile.PL Wed Dec 19 08:15:05 2001
@@ -2,7 +2,7 @@
WriteMakefile(
NAME => 'OS2::DLL',
- VERSION => '0.01',
+ VERSION_FROM => 'DLL.pm',
MAN3PODS => {}, # Pods will be built by installman.
XSPROTOARG => '-noprototypes',
PERL_MALLOC_OK => 1,
==== //depot/perl/os2/os2.c#56 (text) ====
Index: perl/os2/os2.c
--- perl/os2/os2.c.~1~ Wed Dec 19 08:15:05 2001
+++ perl/os2/os2.c Wed Dec 19 08:15:05 2001
@@ -618,14 +618,14 @@
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;
==== //depot/perl/os2/perlrexx.c#4 (text) ====
Index: perl/os2/perlrexx.c
--- perl/os2/perlrexx.c.~1~ Wed Dec 19 08:15:05 2001
+++ perl/os2/perlrexx.c Wed Dec 19 08:15:05 2001
@@ -320,234 +320,3 @@
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;
- }
-}
==== //depot/perl/t/op/alarm.t#3 (text) ====
Index: perl/t/op/alarm.t
--- perl/t/op/alarm.t.~1~ Wed Dec 19 08:15:05 2001
+++ perl/t/op/alarm.t Wed Dec 19 08:15:05 2001
@@ -29,7 +29,7 @@
# 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 @@
# 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' );
==== //depot/perl/util.c#305 (text) ====
Index: perl/util.c
--- perl/util.c.~1~ Wed Dec 19 08:15:05 2001
+++ perl/util.c Wed Dec 19 08:15:05 2001
@@ -2459,9 +2459,11 @@
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 @@
}
}
#endif
+ finish:
if (result < 0 && errno == EINTR) {
PERL_ASYNC_CHECK();
}
End of Patch.
