diff options
author | Ilya Zakharevich <ilya@math.berkeley.edu> | 2003-10-29 06:00:18 -0800 |
---|---|---|
committer | Nicholas Clark <nick@ccl4.org> | 2003-11-02 18:22:16 +0000 |
commit | 59ad941d06909cf9027c5fb10edca7d68fc7149b (patch) | |
tree | 31cbe92fcf6d4df0a555139b93ead70dafd6824d | |
parent | df500c58e3444bfdd2437855ea268d802281b50e (diff) | |
download | perl-59ad941d06909cf9027c5fb10edca7d68fc7149b.tar.gz |
OS/2 build
Message-ID: <20031029220017.GA26384@math.berkeley.edu>
p4raw-id: //depot/perl@21620
-rw-r--r-- | ext/DynaLoader/DynaLoader_pm.PL | 9 | ||||
-rw-r--r-- | makedef.pl | 7 | ||||
-rw-r--r-- | os2/Makefile.SHs | 94 | ||||
-rw-r--r-- | os2/OS2/REXX/REXX.xs | 6 | ||||
-rw-r--r-- | os2/os2.c | 167 | ||||
-rw-r--r-- | os2/os2_base.t | 15 | ||||
-rw-r--r-- | os2/os2ish.h | 2 | ||||
-rw-r--r-- | os2/perl2cmd.pl | 19 | ||||
-rw-r--r-- | perlio.c | 4 |
9 files changed, 274 insertions, 49 deletions
diff --git a/ext/DynaLoader/DynaLoader_pm.PL b/ext/DynaLoader/DynaLoader_pm.PL index 8a3e6e1e73..8dfb5d436c 100644 --- a/ext/DynaLoader/DynaLoader_pm.PL +++ b/ext/DynaLoader/DynaLoader_pm.PL @@ -229,6 +229,15 @@ sub bootstrap { " dynamic loading or has the $module module statically linked into it.)\n") unless defined(&dl_load_file); +EOT + +print OUT <<'EOT' if $^O eq 'os2'; + # Can dynaload, but cannot dynaload Perl modules... + die 'Dynaloaded Perl modules are not available in this build of Perl' if $OS2::is_static; + +EOT + +print OUT <<'EOT'; my @modparts = split(/::/,$module); my $modfname = $modparts[-1]; diff --git a/makedef.pl b/makedef.pl index 6c6bafeeb3..3db62ab7eb 100644 --- a/makedef.pl +++ b/makedef.pl @@ -377,6 +377,8 @@ elsif ($PLATFORM eq 'os2') { dlsym dlerror dlclose + dup2 + dup my_tmpfile my_tmpnam my_flock @@ -1340,7 +1342,10 @@ foreach my $symbol (sort keys %export) { } if ($PLATFORM eq 'os2') { - print "; LAST_ORDINAL=$sym_ord\n"; + print <<EOP; + dll_perlmain=main +; LAST_ORDINAL=$sym_ord +EOP } sub emit_symbol { diff --git a/os2/Makefile.SHs b/os2/Makefile.SHs index baefec987f..87f0b37093 100644 --- a/os2/Makefile.SHs +++ b/os2/Makefile.SHs @@ -43,7 +43,7 @@ AOUT_CLDFLAGS_DLL = -Zexe -Zmt -Zcrtdll -Zstack 32000 SO_CCCMD = \$(CC) $ccflags \$(OPTIMIZE) LD_OPT = \$(OPTIMIZE) -PERL_DLL_LD_OPT = -Zmap -Zlinker /map +PERL_DLL_LD_OPT = -Zmap -Zlinker /map/li PERL_DLL_BASE = perl$dll_post PERL_DLL = \$(PERL_DLL_BASE)\$(DLSUFFIX) @@ -55,11 +55,15 @@ AOUT_EXTRA_LIBS = $aout_extra_libs $spitshell >>Makefile <<'!NO!SUBS!' PREPLIBRARY_LIBPERL = $(LIBPERL) -$(LIBPERL): perl.imp $(PERL_DLL) perl5.def libperl_override.lib +$(LIBPERL): perl.imp perl5.def libperl_override.lib emximp -o $(LIBPERL) perl.imp cp $(LIBPERL) perl.lib -libperl_override.imp: os2/os2add.sym miniperl +imp_version: $(FIRSTMAKEFILE) + echo $(PERL_DLL_BASE) > imp_version.tmp + sh mv-if-diff imp_version.tmp $@ + +libperl_override.imp: os2/os2add.sym miniperl imp_version ./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 @@ -68,10 +72,20 @@ libperl_override.imp: os2/os2add.sym miniperl libperl_override.lib: libperl_override.imp emximp -o $@ libperl_override.imp +libperl_dllmain.imp: imp_version + echo 'main $(PERL_DLL_BASE) dll_perlmain ?' >> tmpdll.imp + sh mv-if-diff tmpdll.imp $@ + +libperl_dllmain.lib: libperl_dllmain.imp + emximp -o $@ libperl_dllmain.imp + +libperl_dllmain.a: libperl_dllmain.imp + emximp -o $@ libperl_dllmain.imp + $(AOUT_LIBPERL_DLL): perl.imp $(PERL_DLL) perl5.def emximp -o $(AOUT_LIBPERL_DLL) perl.imp -perl.imp: perl5.def +perl.imp: perl5.def imp_version emximp -o perl.imp perl5.def echo 'emx_calloc emxlibcm 400 ?' >> $@ echo 'emx_free emxlibcm 401 ?' >> $@ @@ -82,7 +96,8 @@ perl.imp: perl5.def perlrexx test_prep_perl_ test_prep_perl_sys test_prep_perl_stat \ test_prep_perl_stat_aout test_prep_various \ stat_aout_harness aout_harness stat_harness sys_harness all_harness \ - stat_aout_test aout_test stat_test sys_test all_test + stat_aout_test aout_test stat_test sys_test all_test \ + perl___harness test_harness_redir perl_dll: $(PERL_DLL) @@ -91,8 +106,8 @@ perl_dll_t: t/$(PERL_DLL) t/$(PERL_DLL): $(PERL_DLL) $(LNS) $(PERL_DLL) t/$(PERL_DLL) -$(PERL_DLL): $(obj) perl5.def perl$(OBJ_EXT) - $(LD) $(LD_OPT) $(LDDLFLAGS) $(PERL_DLL_LD_OPT) -o $@ perl$(OBJ_EXT) $(obj) $(libs) perl5.def || ( rm $(PERL_DLL) && sh -c false ) +$(PERL_DLL): $(obj) perl5.def perl$(OBJ_EXT) perlmain$(OBJ_EXT) $(DYNALOADER) + $(LD) $(LD_OPT) $(LDDLFLAGS) $(PERL_DLL_LD_OPT) -o $@ perl$(OBJ_EXT) $(obj) perlmain$(OBJ_EXT) $(DYNALOADER) $(libs) perl5.def || ( rm $(PERL_DLL) && sh -c false ) perl5.olddef: perl.linkexp echo "LIBRARY '$(PERL_DLL_BASE)' INITINSTANCE TERMINSTANCE" > $@ @@ -155,9 +170,16 @@ dlfcn.h: os2/dlfcn.h cp -f $< $@ # Non-Forking dynamically loaded perl +# Make many: they are useful in low-memory conditions (floppy boot? Lot of shared memory used?) -perl___$(EXE_EXT) perl___: $& perlmain$(OBJ_EXT) $(LIBPERL) $(DYNALOADER) $(static_ext) ext.libs - $(SHRPENV) $(CC) $(CLDFLAGS) $(CCDLFLAGS) -o perl___ perlmain$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LIBPERL) `cat ext.libs` $(libs) -Zlinker /map/PM:VIO +perl___$(EXE_EXT) perl___: $& libperl_dllmain$(LIB_EXT) + $(SHRPENV) $(CC) $(CLDFLAGS) $(CCDLFLAGS) -o perl___ libperl_dllmain$(LIB_EXT) -Zlinker /map/PM:VIO + $(SHRPENV) $(CC) $(CLDFLAGS) $(CCDLFLAGS) -Zstack 8192 -o perl___8 libperl_dllmain$(LIB_EXT) -Zlinker /map/PM:VIO + $(SHRPENV) $(CC) $(CLDFLAGS) $(CCDLFLAGS) -Zstack 4096 -o perl___4 libperl_dllmain$(LIB_EXT) -Zlinker /map/PM:VIO + $(SHRPENV) $(CC) $(CLDFLAGS) $(CCDLFLAGS) -Zstack 2048 -o perl___2 libperl_dllmain$(LIB_EXT) -Zlinker /map/PM:VIO + $(SHRPENV) $(CC) $(CLDFLAGS) $(CCDLFLAGS) -Zstack 1024 -o perl___1 libperl_dllmain$(LIB_EXT) -Zlinker /map/PM:VIO + $(SHRPENV) $(CC) $(CLDFLAGS) $(CCDLFLAGS) -Zstack 512 -o perl___05 libperl_dllmain$(LIB_EXT) -Zlinker /map/PM:VIO + $(SHRPENV) $(CC) $(CLDFLAGS) $(CCDLFLAGS) -Zstack 320 -o perl___03 libperl_dllmain$(LIB_EXT) -Zlinker /map/PM:VIO # This one is compiled -Zsys, so cannot do many things: @@ -166,16 +188,16 @@ STAT_CLDFLAGS = -Zexe -Zomf -Zmt -Zstack 32000 # Non-forking dynamically loaded perl with a wrong CRT library: -perl_stat: $& perlmain$(OBJ_EXT) $(LIBPERL) $(DYNALOADER) $(static_ext) ext.libs - $(SHRPENV) $(CC) $(STAT_CLDFLAGS) $(CCDLFLAGS) -o $@ perlmain$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LIBPERL) `cat ext.libs` $(libs) -Zlinker /map/PM:VIO +perl_stat perl_stat$(EXE_EXT): $& libperl_dllmain$(LIB_EXT) + $(SHRPENV) $(CC) $(STAT_CLDFLAGS) $(CCDLFLAGS) -o perl_stat libperl_dllmain$(LIB_EXT) -Zlinker /map/PM:VIO # Remove -Zcrtdll, add -Zsys SYS_CLDFLAGS = $(STAT_CLDFLAGS) -Zsys # Non-Forking dynamically loaded perl without EMX - so with wrong CRT library -perl_sys: $& perlmain$(OBJ_EXT) $(LIBPERL) $(DYNALOADER) $(static_ext) ext.libs - $(SHRPENV) $(CC) $(SYS_CLDFLAGS) $(CCDLFLAGS) -o $@ perlmain$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LIBPERL) `cat ext.libs` $(libs) -Zlinker /map/PM:VIO +perl_sys perl_sys$(EXE_EXT): $& libperl_dllmain$(LIB_EXT) + $(SHRPENV) $(CC) $(SYS_CLDFLAGS) $(CCDLFLAGS) -o perl_sys libperl_dllmain$(LIB_EXT) -Zlinker /map/PM:VIO installcmd : @perl -e 'die qq{Give the option INSTALLCMDDIR=... to make!} if $$ARGV[0] eq ""' $(INSTALLCMDDIR) @@ -203,7 +225,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 + cp $@ perl$(AOUT_LIB_EXT) .c$(AOUT_OBJ_EXT): $(AOUT_CCCMD) $(PLDLFLAGS) -c $*.c @@ -214,9 +236,14 @@ opmini$(AOUT_OBJ_EXT): op.c perlmain(AOUT_OBJ_EXT): perlmain.c $(AOUT_CCCMD_DLL) $(PLDLFLAGS) -c perlmain.c -aout_perlmain.c: miniperlmain.c config.sh makefile $(static_ext_autoinit) - sh writemain $(DYNALOADER) $(aout_static_lib) > tmp - sh mv-if-diff tmp aout_perlmain.c +# Assume that extensions are at most 4 deep (this is so with 5.8.1) +aout_extlist: $(aout_static_ext) + echo lib/auto/*.a lib/auto/*/*.a lib/auto/*/*/*.a lib/auto/*/*/*/*.a | tr ' ' '\n' | grep -v '\*' > $@.tmp + sh mv-if-diff $@.tmp $@ + +aout_perlmain.c: miniperlmain.c config.sh makefile $(static_ext_autoinit) $(aout_static_ext) writemain aout_extlist + sh writemain `cat aout_extlist` > aout_perlmain.tmp + sh mv-if-diff aout_perlmain.tmp aout_perlmain.c _preplibrary = miniperl lib/Config.pm lib/lib.pm lib/re.pm @@ -228,35 +255,35 @@ miniperl_: $& miniperlmain$(AOUT_OBJ_EXT) $(AOUT_LIBPERL) opmini$(AOUT_OBJ_EXT) # 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) +perl_$(EXE_EXT) perl_: $& miniperl_ aout_perlmain$(AOUT_OBJ_EXT) $(AOUT_LIBPERL) $(AOUT_DYNALOADER) $(aout_static_ext) ext.libs aout_extlist + $(CC) $(AOUT_CLDFLAGS) $(CCDLFLAGS) $(OPTIMIZE) -o perl_ aout_perlmain$(AOUT_OBJ_EXT) `cat aout_extlist` $(AOUT_LIBPERL) `cat ext.libs` $(libs) # Remove -Zcrtdll STAT_AOUT_CLDFLAGS = -Zexe -Zmt -Zstack 32000 # Forking dynamically loaded perl with a wrong CRT library: -perl_stat_aout$(EXE_EXT) perl_stat_aout: $& perlmain$(AOUT_OBJ_EXT) $(AOUT_DYNALOADER_OBJ) $(aout_static_ext_dll) $(AOUT_LIBPERL_DLL) ext.libs - $(SHRPENV) $(CC) $(STAT_AOUT_CLDFLAGS) $(CCDLFLAGS) -o $@ perlmain$(AOUT_OBJ_EXT) $(AOUT_DYNALOADER_OBJ) $(aout_static_ext_dll) $(AOUT_LIBPERL_DLL) `cat ext.libs` $(libs) +perl_stat_aout$(EXE_EXT) perl_stat_aout: $& libperl_dllmain$(AOUT_LIB_EXT) + $(SHRPENV) $(CC) $(STAT_AOUT_CLDFLAGS) $(CCDLFLAGS) $(OPTIMIZE) -o perl_stat_aout libperl_dllmain$(AOUT_LIB_EXT) PERLREXX_DLL = perlrexx.dll -perl : perl__ perl___ $(PERLREXX_DLL) +perl perl$(EXE_EXT) : perl__ perl___ $(PERLREXX_DLL) $(PERL_DLL) # Dynamically loaded PM-application perl: -perl__$(EXE_EXT) perl__: $& perlmain$(OBJ_EXT) $(LIBPERL) $(DYNALOADER) $(static_ext) ext.libs - $(CC) $(CLDFLAGS) $(CCDLFLAGS) -o perl__ perlmain$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LIBPERL) `cat ext.libs` $(libs) -Zlinker /PM:PM +perl__$(EXE_EXT) perl__: $& libperl_dllmain$(LIB_EXT) + $(CC) $(CLDFLAGS) $(CCDLFLAGS) -o perl__ libperl_dllmain$(LIB_EXT) -Zlinker /PM:PM # Forking dynamically loaded perl: -perl$(EXE_EXT) perl: $& perlmain$(AOUT_OBJ_EXT) $(AOUT_DYNALOADER_OBJ) $(aout_static_ext_dll) $(AOUT_LIBPERL_DLL) ext.libs - $(CC) $(AOUT_CLDFLAGS_DLL) $(CCDLFLAGS) -o perl perlmain$(AOUT_OBJ_EXT) $(AOUT_DYNALOADER_OBJ) $(aout_static_ext_dll) $(AOUT_LIBPERL_DLL) `cat ext.libs` $(libs) +perl$(EXE_EXT) perl: $& libperl_dllmain$(AOUT_LIB_EXT) + $(CC) $(AOUT_CLDFLAGS_DLL) $(CCDLFLAGS) -o perl libperl_dllmain$(AOUT_LIB_EXT) clean: aout_clean aout_clean: - -rm *perl_.* *.o *.a lib/auto/*/*.a ext/*/Makefile.aout + -rm *perl_.* *.o *.a lib/auto/*/*.a lib/auto/*/*/*.a lib/auto/*/*/*/*.a ext/*/Makefile.aout ext/*/*/Makefile.aout ext/*/*/*/Makefile.aout aout_install: perl_ aout_install.perl @@ -351,7 +378,10 @@ perl___harness: test_prep_perl___ all_test: test aout_test perl___test sys_test stat_test stat_aout_test -all_harness: test_harness aout_harness perl___harness sys_harness stat_harness stat_aout_harness +test_harness_redir: test_prep + -PERL=./perl $(MAKE) TESTFILE=harness _test $(REDIR_TEST) + +all_harness: test_harness_redir aout_harness perl___harness sys_harness stat_harness stat_aout_harness !NO!SUBS! @@ -385,7 +415,7 @@ do else # Need to treat subsubdirectories manually dd_treated='' - for ddd in $dd/* + for ddd in $dd/* # ext/*/*/*/Makefile.PL do if test ! -d $ddd; then continue @@ -404,6 +434,12 @@ do fi done +# ext/threads is marked as NORECURS, so we need to specialcase it +if echo "$static_ext $dynamic_ext" | grep -q threads/shared ; then + preci="$preci ext/threads/%/Makefile.aout" + dirs="$dirs ext/threads" +fi + $spitshell >>Makefile <<!GROK!THIS! .PRECIOUS : $preci diff --git a/os2/OS2/REXX/REXX.xs b/os2/OS2/REXX/REXX.xs index 10ee7ece2b..43bdcac144 100644 --- a/os2/OS2/REXX/REXX.xs +++ b/os2/OS2/REXX/REXX.xs @@ -52,6 +52,8 @@ static LONG APIENTRY (*pRexxStart) (LONG, PRXSTRING, PSZ, PRXSTRING, PSZ, LONG, PRXSYSEXIT, PSHORT, PRXSTRING); static APIRET APIENTRY (*pRexxRegisterFunctionExe) (PSZ, RexxFunctionHandler *); +static APIRET APIENTRY (*pRexxRegisterSubcomExe) (PCSZ pszEnvName, PFN pfnEntryPoint, + PUCHAR pUserArea); static APIRET APIENTRY (*pRexxDeregisterFunction) (PSZ); static ULONG (*pRexxVariablePool) (PSHVBLOCK pRequest); @@ -313,11 +315,13 @@ initialize(void) *(PFN *)&pRexxDeregisterFunction = loadByOrdinal(ORD_RexxDeregisterFunction, 1); *(PFN *)&pRexxVariablePool = loadByOrdinal(ORD_RexxVariablePool, 1); + *(PFN *)&pRexxRegisterSubcomExe + = loadByOrdinal(ORD_RexxRegisterSubcomExe, 1); needstrs(8); needvars(8); trace = getenv("PERL_REXX_DEBUG"); - rc = RexxRegisterSubcomExe("PERLEVAL", (PFN)&SubCommandPerlEval, NULL); + rc = pRexxRegisterSubcomExe("PERLEVAL", (PFN)&SubCommandPerlEval, NULL); } static int @@ -620,6 +620,8 @@ static const struct { {&pmwin_handle, NULL, 780}, /* WinLoadPointer */ {&pmwin_handle, NULL, 828}, /* WinQuerySysPointer */ {&doscalls_handle, NULL, 417}, /* DosReplaceModule */ + {&doscalls_handle, NULL, 976}, /* DosPerfSysCall */ + {&rexxapi_handle, "RexxRegisterSubcomExe", 0}, }; HMODULE @@ -759,15 +761,17 @@ get_sysinfo(ULONG pid, ULONG flags) ULONG rc, buf_len = QSS_INI_BUFFER; PQTOPLEVEL psi; - if (!pidtid_lookup) { - pidtid_lookup = 1; - *(PFN*)&pDosVerifyPidTid = loadByOrdinal(ORD_DosVerifyPidTid, 0); - } - if (pDosVerifyPidTid) { /* Warp3 or later */ - /* Up to some fixpak QuerySysState() kills the system if a non-existent - pid is used. */ - if (CheckOSError(pDosVerifyPidTid(pid, 1))) - return 0; + if (pid) { + if (!pidtid_lookup) { + pidtid_lookup = 1; + *(PFN*)&pDosVerifyPidTid = loadByOrdinal(ORD_DosVerifyPidTid, 0); + } + if (pDosVerifyPidTid) { /* Warp3 or later */ + /* Up to some fixpak QuerySysState() kills the system if a non-existent + pid is used. */ + if (CheckOSError(pDosVerifyPidTid(pid, 1))) + return 0; + } } New(1322, pbuffer, buf_len, char); /* QSS_PROCESS | QSS_MODULE | QSS_SEMAPHORES | QSS_SHARED */ @@ -1127,7 +1131,7 @@ do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag) does not append ".exe", so we could have reached this place). */ sv_catpv(scrsv, ".exe"); - scr = SvPV(scrsv, n_a); /* Reload */ + PL_Argv[0] = scr = SvPV(scrsv, n_a); /* Reload */ if (PerlLIO_stat(scr,&PL_statbuf) >= 0 && !S_ISDIR(PL_statbuf.st_mode)) { /* Found */ real_name = scr; @@ -1851,6 +1855,109 @@ XS(XS_OS2_replaceModule) XSRETURN_EMPTY; } +/* APIRET APIENTRY DosPerfSysCall(ULONG ulCommand, ULONG ulParm1, + ULONG ulParm2, ULONG ulParm3); */ + +DeclOSFuncByORD(ULONG,perfSysCall,ORD_DosPerfSysCall, + (ULONG ulCommand, ULONG ulParm1, ULONG ulParm2, ULONG ulParm3), + (ulCommand, ulParm1, ulParm2, ulParm3)) + +#ifndef CMD_KI_RDCNT +# define CMD_KI_RDCNT 0x63 +#endif +#ifndef CMD_KI_GETQTY +# define CMD_KI_GETQTY 0x41 +#endif +#ifndef QSV_NUMPROCESSORS +# define QSV_NUMPROCESSORS 26 +#endif + +typedef unsigned long long myCPUUTIL[4]; /* time/idle/busy/intr */ + +/* +NO_OUTPUT ULONG +perfSysCall(ULONG ulCommand, ULONG ulParm1, ULONG ulParm2, ULONG ulParm3) + PREINIT: + ULONG rc; + POSTCALL: + if (!RETVAL) + croak_with_os2error("perfSysCall() error"); + */ + +static int +numprocessors(void) +{ + ULONG res; + + if (DosQuerySysInfo(QSV_NUMPROCESSORS, QSV_NUMPROCESSORS, (PVOID)&res, sizeof(res))) + return 1; /* Old system? */ + return res; +} + +XS(XS_OS2_perfSysCall); /* prototype to pass -Wmissing-prototypes */ +XS(XS_OS2_perfSysCall) +{ + dXSARGS; + if (items < 0 || items > 4) + Perl_croak(aTHX_ "Usage: OS2::perfSysCall(ulCommand = CMD_KI_RDCNT, ulParm1= 0, ulParm2= 0, ulParm3= 0)"); + SP -= items; + { + dXSTARG; + ULONG RETVAL, ulCommand, ulParm1, ulParm2, ulParm3, res; + myCPUUTIL u[64]; + int total = 0, tot2 = 0; + + if (items < 1) + ulCommand = CMD_KI_RDCNT; + else { + ulCommand = (ULONG)SvUV(ST(0)); + } + + if (items < 2) { + total = (ulCommand == CMD_KI_RDCNT ? numprocessors() : 0); + ulParm1 = (total ? (ULONG)u : 0); + + if (total > C_ARRAY_LENGTH(u)) + croak("Unexpected number of processors: %d", total); + } else { + ulParm1 = (ULONG)SvUV(ST(1)); + } + + if (items < 3) { + tot2 = (ulCommand == CMD_KI_GETQTY); + ulParm2 = (tot2 ? (ULONG)&res : 0); + } else { + ulParm2 = (ULONG)SvUV(ST(2)); + } + + if (items < 4) + ulParm3 = 0; + else { + ulParm3 = (ULONG)SvUV(ST(3)); + } + + RETVAL = perfSysCall(ulCommand, ulParm1, ulParm2, ulParm3); + if (!RETVAL) + croak_with_os2error("perfSysCall() error"); + if (total) { + int i,j; + + if (GIMME_V != G_ARRAY) { + PUSHn(u[0][0]); /* Total ticks on the first processor */ + XSRETURN(1); + } + for (i=0; i < total; i++) + for (j=0; j < 4; j++) + PUSHs(sv_2mortal(newSVnv(u[i][j]))); + XSRETURN(4*total); + } + if (tot2) { + PUSHu(res); + XSRETURN(1); + } + } + XSRETURN_EMPTY; +} #define PERL_PATCHLEVEL_H_IMPLICIT /* Do not init local_patches. */ #include "patchlevel.h" @@ -3503,6 +3610,7 @@ Xs_OS2_init(pTHX) newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file); newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, file); newXS("OS2::replaceModule", XS_OS2_replaceModule, file); + newXS("OS2::perfSysCall", XS_OS2_perfSysCall, file); newXSproto("OS2::_control87", XS_OS2__control87, file, "$$"); newXSproto("OS2::get_control87", XS_OS2_get_control87, file, ""); newXSproto("OS2::set_control87", XS_OS2_set_control87, file, ";$$"); @@ -3521,6 +3629,11 @@ Xs_OS2_init(pTHX) #ifdef PERL_IS_AOUT sv_setiv(GvSV(gv), 1); #endif + gv = gv_fetchpv("OS2::is_static", TRUE, SVt_PV); + GvMULTI_on(gv); +#ifdef PERL_IS_AOUT + sv_setiv(GvSV(gv), 1); +#endif gv = gv_fetchpv("OS2::can_fork", TRUE, SVt_PV); GvMULTI_on(gv); sv_setiv(GvSV(gv), exe_is_aout()); @@ -3923,6 +4036,40 @@ Perl_OS2_init3(char **env, void **preg, int flags) _control87(MCW_EM, MCW_EM); } +int +fd_ok(int fd) +{ + static ULONG max_fh = 0; + + if (!(_emx_env & 0x200)) return 1; /* not OS/2. */ + if (fd >= max_fh) { /* Renew */ + LONG delta = 0; + + if (DosSetRelMaxFH(&delta, &max_fh)) /* Assume it OK??? */ + return 1; + } + return fd < max_fh; +} + +/* Kernels up to Oct 2003 trap on (invalid) dup(max_fh); [off-by-one + double fault]. */ +int +dup2(int from, int to) +{ + if (fd_ok(from < to ? to : from)) + return _dup2(from, to); + errno = EBADF; + return -1; +} + +int +dup(int from) +{ + if (fd_ok(from)) + return _dup(from); + errno = EBADF; + return -1; +} + #undef tmpnam #undef tmpfile diff --git a/os2/os2_base.t b/os2/os2_base.t index f65a64c532..80181b775e 100644 --- a/os2/os2_base.t +++ b/os2/os2_base.t @@ -32,10 +32,17 @@ $lpe =~ s#\\#/#g; like($lpe, qr/\Q$s_cwd/); -is(uc OS2::DLLname(1), uc $Config{dll_name}); -like(OS2::DLLname, qr#\Q/$Config{dll_name}\E\.dll$#i ); -(my $root_cwd = $s_cwd) =~ s,/t$,,; -like(OS2::DLLname, qr#^\Q$root_cwd\E(/t)?\Q/$Config{dll_name}\E\.dll#i ); +if (uc OS2::DLLname() eq uc $^X) { # Static build + my ($short) = ($^X =~ m,.*[/\\]([^.]+),); + is(uc OS2::DLLname(1), uc $short); + is(uc OS2::DLLname, uc $^X ); # automatically + is(1,1); # automatically... +} else { + is(uc OS2::DLLname(1), uc $Config{dll_name}); + like(OS2::DLLname, qr#\Q/$Config{dll_name}\E\.dll$#i ); + (my $root_cwd = $s_cwd) =~ s,/t$,,; + like(OS2::DLLname, qr#^\Q$root_cwd\E(/t)?\Q/$Config{dll_name}\E\.dll#i ); +} is(OS2::DLLname, OS2::DLLname(2)); like(OS2::DLLname(0), qr#^(\d+)$# ); diff --git a/os2/os2ish.h b/os2/os2ish.h index a4145eab4a..accba2a0c9 100644 --- a/os2/os2ish.h +++ b/os2/os2ish.h @@ -687,6 +687,8 @@ enum entries_ordinals { ORD_WinLoadPointer, ORD_WinQuerySysPointer, ORD_DosReplaceModule, + ORD_DosPerfSysCall, + ORD_RexxRegisterSubcomExe, ORD_NENTRIES }; diff --git a/os2/perl2cmd.pl b/os2/perl2cmd.pl index f9cc03bdac..4db40a0a31 100644 --- a/os2/perl2cmd.pl +++ b/os2/perl2cmd.pl @@ -16,14 +16,25 @@ EOU $idir = $Config{installbin}; $indir =~ s|\\|/|g ; +my %seen; + foreach $file (<$idir/*>) { - next if $file =~ /\.exe/i; + next if $file =~ /\.(exe|bak)/i; $base = $file; $base =~ s/\.$//; # just in case... $base =~ s|.*/||; - $file =~ s|/|\\|g ; + $base =~ s|\.pl$||; + #$file =~ s|/|\\|g ; + warn "Clashing output name for $file, skipping" if $seen{$base}++; print "Processing $file => $dir\\$base.cmd\n"; - system 'cmd.exe', '/c', "echo extproc perl -S>$dir\\$base.cmd"; - system 'cmd.exe', '/c', "type $file >> $dir\\$base.cmd"; + open IN, '<', $file or warn, next; + open OUT, '>', "$dir/$base.cmd" or warn, next; + my $firstline = <IN>; + my $flags = ''; + $flags = $2 if $firstline =~ /^#!\s*(\S+)\s+-([^#]+?)\s*(#|$)/; + print OUT "extproc perl -S$flags\n$firstline"; + print OUT $_ while <IN>; + close IN or warn, next; + close OUT or warn, next; } @@ -2875,6 +2875,10 @@ PerlIOStdio_invalidate_fileno(pTHX_ FILE *f) */ f->_file = -1; return 1; +# elif defined(__EMX__) + /* f->_flags &= ~_IOOPEN; */ /* Will leak stream->_buffer */ + f->_handle = -1; + return 1; # elif defined(__CYGWIN__) /* There may be a better way on CYGWIN: - we could insert a dummy func in the _close function entry |