diff options
| -rw-r--r-- | MANIFEST | 1 | ||||
| -rw-r--r-- | lib/ExtUtils/MM_OS2.pm | 16 | ||||
| -rw-r--r-- | lib/ExtUtils/MM_Unix.pm | 24 | ||||
| -rw-r--r-- | makedef.pl | 4 | ||||
| -rw-r--r-- | os2/Changes | 65 | ||||
| -rw-r--r-- | os2/Makefile.SHs | 11 | ||||
| -rw-r--r-- | os2/OS2/REXX/Makefile.PL | 2 | ||||
| -rw-r--r-- | os2/OS2/REXX/REXX.pm | 77 | ||||
| -rw-r--r-- | os2/OS2/REXX/REXX.xs | 49 | ||||
| -rw-r--r-- | os2/OS2/REXX/t/rx_cmprt.t | 12 | ||||
| -rw-r--r-- | os2/os2.c | 186 | ||||
| -rw-r--r-- | os2/os2.sym | 2 | ||||
| -rw-r--r-- | os2/os2add.sym | 9 | ||||
| -rw-r--r-- | os2/os2ish.h | 17 |
14 files changed, 414 insertions, 61 deletions
@@ -1179,6 +1179,7 @@ os2/dl_os2.c Addon for dl_open os2/dlfcn.h Addon for dl_open os2/os2.c Additional code for OS/2 os2/os2.sym Additional symbols to export +os2/os2add.sym Overriding symbols to export os2/os2ish.h Header for OS/2 os2/os2thread.h pthread-like typedefs os2/perl2cmd.pl Corrects installed binaries under OS/2 diff --git a/lib/ExtUtils/MM_OS2.pm b/lib/ExtUtils/MM_OS2.pm index c0c52402f6..d6bbc1c76d 100644 --- a/lib/ExtUtils/MM_OS2.pm +++ b/lib/ExtUtils/MM_OS2.pm @@ -97,6 +97,22 @@ sub perl_archive return "\$(PERL_INC)/libperl\$(LIB_EXT)"; } +=item perl_archive_after + +This is an internal method that returns path to a library which +should be put on the linker command line I<after> the external libraries +to be linked to dynamic extensions. This may be needed if the linker +is one-pass, and Perl includes some overrides for C RTL functions, +such as malloc(). + +=cut + +sub perl_archive_after +{ + return "\$(PERL_INC)/libperl_override\$(LIB_EXT)" unless $OS2::is_aout; + return ""; +} + sub export_list { my ($self) = @_; diff --git a/lib/ExtUtils/MM_Unix.pm b/lib/ExtUtils/MM_Unix.pm index c943f12a57..e043b3cb3f 100644 --- a/lib/ExtUtils/MM_Unix.pm +++ b/lib/ExtUtils/MM_Unix.pm @@ -210,6 +210,7 @@ sub ExtUtils::MM_Unix::parse_version ; sub ExtUtils::MM_Unix::pasthru ; sub ExtUtils::MM_Unix::path ; sub ExtUtils::MM_Unix::perl_archive; +sub ExtUtils::MM_Unix::perl_archive_after; sub ExtUtils::MM_Unix::perl_script ; sub ExtUtils::MM_Unix::perldepend ; sub ExtUtils::MM_Unix::pm_to_blib ; @@ -684,6 +685,10 @@ EXPORT_LIST = $tmp push @m, " PERL_ARCHIVE = $tmp "; + $tmp = $self->perl_archive_after; + push @m, " +PERL_ARCHIVE_AFTER = $tmp +"; # push @m, q{ #INST_PM = }.join(" \\\n\t", sort values %{$self->{PM}}).q{ @@ -1071,7 +1076,7 @@ ARMAYBE = '.$armaybe.' OTHERLDFLAGS = '.$otherldflags.' INST_DYNAMIC_DEP = '.$inst_dynamic_dep.' -$(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $(BOOTSTRAP) $(INST_ARCHAUTODIR)/.exists $(EXPORT_LIST) $(PERL_ARCHIVE) $(INST_DYNAMIC_DEP) +$(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $(BOOTSTRAP) $(INST_ARCHAUTODIR)/.exists $(EXPORT_LIST) $(PERL_ARCHIVE) $(PERL_ARCHIVE_AFTER) $(INST_DYNAMIC_DEP) '); if ($armaybe ne ':'){ $ldfrom = 'tmp$(LIB_EXT)'; @@ -1093,7 +1098,7 @@ $(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $(BOOTSTRAP) $(INST_ARCHAUTODIR)/.exists '); push(@m,' LD_RUN_PATH="$(LD_RUN_PATH)" $(LD) -o $@ '.$ldrun.' $(LDDLFLAGS) '.$ldfrom. - ' $(OTHERLDFLAGS) $(MYEXTLIB) $(PERL_ARCHIVE) $(LDLOADLIBS) $(EXPORT_LIST)'); + ' $(OTHERLDFLAGS) $(MYEXTLIB) $(PERL_ARCHIVE) $(LDLOADLIBS) $(PERL_ARCHIVE_AFTER) $(EXPORT_LIST)'); push @m, ' $(CHMOD) $(PERM_RWX) $@ '; @@ -3829,6 +3834,21 @@ sub perl_archive return ""; } +=item perl_archive_after + +This is an internal method that returns path to a library which +should be put on the linker command line I<after> the external libraries +to be linked to dynamic extensions. This may be needed if the linker +is one-pass, and Perl includes some overrides for C RTL functions, +such as malloc(). + +=cut + +sub perl_archive_after +{ + return ""; +} + =item export_list This is internal method that returns name of a file that is diff --git a/makedef.pl b/makedef.pl index 02305c2773..da0b36c96b 100644 --- a/makedef.pl +++ b/makedef.pl @@ -277,6 +277,8 @@ elsif ($PLATFORM eq 'os2') { my_tmpfile my_tmpnam my_flock + my_rmdir + my_mkdir malloc_mutex threads_mutex nthreads @@ -389,6 +391,8 @@ if ($define{'MYMALLOC'}) { Perl_mfree Perl_realloc Perl_calloc + Perl_strdup + Perl_putenv )]; if ($define{'USE_5005THREADS'} || $define{'USE_ITHREADS'}) { emit_symbols [qw( diff --git a/os2/Changes b/os2/Changes index e56b7081ff..e72e0bd2cd 100644 --- a/os2/Changes +++ b/os2/Changes @@ -322,3 +322,68 @@ after 5.005_62: (alas, uppercased - but with /); t/io/fs.t was failing on HPFS386; Remove extra ';' from defines for MQ operations. + +pre 5.6.1: + Resolved: "Bad free()" messages (e.g., from DB_File) with -Zomf build. + The reason was: when an extension DLL was linked, the order of + libraries was similar to this: + f1.obj f2.obj libperl.lib -llibr1 -llibr2 + (with C RTL implicitly after this). When libperl.lib overrides + some C RTL functions, they are correctly resolved when mentioned + in f1.obj and f2.obj. However, the resolution for libr1.lib and + libr2.lib is implementation-dependent. + + With -Zomf linking the symbols are resolved for libr1.lib and + libr2.lib *only if* they reside in .obj-file-sections of libperl.lib + which were already "picked up" for symbols in f1.obj f2.obj. + However, libperl.lib is an import library for a .DLL, so *each + symbol in libperl.lib sits in its own pseudo-section*! + + Corollary: only those symbol from libperl.lib which were already + mentioned in f1.obj f2.obj would be used for libr1.lib and + libr2.lib. Example: if f1.obj f2.obj do not mention calloc() but + libr1.lib and libr2.lib do, then .lib's will get calloc() of C RTL, + not one of libperl.lib. + + Solution: create a small duplicate of libperl.lib with overriding + symbols only. Put it *after* -llibr1 -llibr2 on the link line. + Map strdup() and putenv() to Perl_strdup() and Perl_putenv() + inside this library. + + Resolved: rmdir() and mkdir() do not accept trailing slashes. + Wrappers are implemented. + Resolved: when loading modules, FP mask may be erroneously changed by + _DLLInitTerm() (e.g., TCP32IP). + Solutions: a) dlopen() saves/restores the FP mask. + b) When starting, reset FP mask to a sane value + (if the DLL was compile-time linked). + New functions in package OS2: + unsigned _control87(unsigned new,unsigned mask) # as in EMX + unsigned get_control87() + # with default values good for handling exception mask: + unsigned set_control87_em(new=MCW_EM,mask=MCW_EM) + Needed to guard against other situations when the FP mask is + stompted upon. Apparently, IBM used a compiler (for some period + of time around '95?) which changes FP mask right and left... + Resolved: $^X was always uppercased (cosmetic). Solution: + use argv[0] if it differs from what the OS returns only in case. + Resolved: when creating PM message queues, WinCancelShutdown() was + not called even if the application said that it would not serve + messages in this queue. Could result in PM refusing to shutdown. + + Solution: resolve WinCancelShutdown at run time, keep the refcount + of who is going to serve the queue. + Resolved: Perl_Deregister_MQ() segfaulted (pid/tid not initialized). + Resolved: FillWinError() would not fetch the error. + Solution: resolve WinGetLastError at run time, call it. + Resolved: OS2::REXX would ignore arguments given to a Perl function + imported into the REXX compartment via REXX_eval_with(). + Resolved: OS2::REXX would treat arguments given to a Perl function + imported into the REXX compartment via _register() as ASCIIZ + strings inside of binary strings. + Resolved: OS2::REXX did not document _register(). + Resolved: OS2::REXX would not report the error to REXX if an error + condition appeared during a call to Perl function from REXX + compartment. As a result, the return string was not initialized. + A complete example of a mini-application added to OS2::REXX. + diff --git a/os2/Makefile.SHs b/os2/Makefile.SHs index 21c99a5948..c167226cef 100644 --- a/os2/Makefile.SHs +++ b/os2/Makefile.SHs @@ -41,9 +41,18 @@ CONFIG_ARGS = $config_args !GROK!THIS! $spitshell >>Makefile <<'!NO!SUBS!' -$(LIBPERL): perl.imp $(PERL_DLL) perl5.def +$(LIBPERL): perl.imp $(PERL_DLL) perl5.def libperl_override.lib emximp -o $(LIBPERL) perl.imp +libperl_override.imp: os2/os2add.sym + ./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 + sh mv-if-diff tmp.imp $@ + +libperl_override.lib: libperl_override.imp + emximp -o $@ libperl_override.imp + $(AOUT_LIBPERL_DLL): perl.imp $(PERL_DLL) perl5.def emximp -o $(AOUT_LIBPERL_DLL) perl.imp diff --git a/os2/OS2/REXX/Makefile.PL b/os2/OS2/REXX/Makefile.PL index 178ef7bac1..9b4c0baf25 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.22', + VERSION_FROM => 'REXX.pm', 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 144dd379cb..1a7cb4d54c 100644 --- a/os2/OS2/REXX/REXX.pm +++ b/os2/OS2/REXX/REXX.pm @@ -10,7 +10,9 @@ require OS2::DLL; # (move infrequently used names to @EXPORT_OK below) @EXPORT = qw(REXX_call REXX_eval REXX_eval_with); # Other items we are prepared to export if requested -@EXPORT_OK = qw(drop); +@EXPORT_OK = qw(drop register); + +$VERSION = '1.00'; # We cannot just put OS2::DLL in @ISA, since some scripts would use # function interface, not method interface... @@ -24,6 +26,8 @@ bootstrap OS2::REXX; # Preloaded methods go here. Autoload methods go after __END__, and are # processed by the autosplit program. +sub register {_register($_) for @_} + sub prefix { my $self = shift; @@ -259,12 +263,37 @@ One enables REXX runtime by bracketing your code by REXX_call \&subroutine_name; -Inside such a call one has access to REXX variables (see below), and to +Inside such a call one has access to REXX variables (see below). + +An alternative way to execute code inside a REXX compartment is REXX_eval EXPR; REXX_eval_with EXPR, subroutine_name_in_REXX => \&Perl_subroutine +Here C<EXPR> is a REXX code to run; to execute Perl code one needs to put +it inside Perl_subroutine(), and call this subroutine from REXX, as in + + REXX_eval_with <<EOE, foo => sub { 123 * shift }; + say foo(2) + EOE + +If one needs more Perl subroutines available, one can "import" them into +REXX from inside Perl_subroutine(); since REXX is not case-sensitive, +the names should be uppercased. + + use OS2::REXX 'register'; + + sub BAR { 123 + shift} + sub BAZ { 789 } + sub importer { register qw(BAR BAZ) } + + REXX_eval_with <<'EOE', importer => \&importer; + call importer + say bar(34) + say baz() + EOE + =head2 Bind scalar variable to REXX variable: tie $var, OS2::REXX, "NAME"; @@ -298,6 +327,12 @@ part of the key and it is subject to character set restrictions. OS2::REXX::dropall("STEM" [, "STEM" [, ...]]); +=head2 Make Perl functions available in REXX: + + OS2::REXX::register("NAME" [, "NAME" [, ...]]); + +Since REXX is not case-sensitive, the names should be uppercase. + =head1 NOTES Note that while function and variable names are case insensitive in the @@ -333,7 +368,43 @@ overridden. So unless you know better than I do, do not access REXX variables (probably tied to Perl variables) or call REXX functions which access REXX queues or REXX variables in signal handlers. -See C<t/rx*.t> for examples. +See C<t/rx*.t> and the next section for examples. + +=head1 EXAMPLE + + use OS2::REXX; + + sub Ender::DESTROY { $vrexx->VExit; print "Exiting...\n" } + + $vrexx = OS2::REXX->load('VREXX'); + REXX_call { # VOpenWindow takes a stem + local $SIG{TERM} = sub {die}; # enable Ender::DESTROY + local $SIG{INT} = sub {die}; # enable Ender::DESTROY + + $code = $vrexx->VInit; + print "Init code = `$code'\n"; + die "error initializing VREXX" if $code eq 'ERROR'; + + my $ender = bless [], 'Ender'; # Call Ender::DESTROY on exit + + print "VREXX Version ", $vrexx->VGetVersion, "\n"; + + tie %pos, 'OS2::REXX', 'POS.' or die; + %pos = ( LEFT => 0, RIGHT => 7, TOP => 5, BOTTOM => 0 ); + + $id = $vrexx->VOpenWindow('To disconnect:', 'WHITE', 'POS'); + $vrexx->VForeColor($id, 'BLACK'); + $vrexx->VSetFont($id, 'TIME', '30'); + $tlim = time + 60; + while ( ($r = $tlim - time) >= 0 ) { + $vrexx->VClearWindow($id); + $vrexx->VSay($id, 100, 50, (sprintf "%02i:%02i", int($r/60), $r % 60)); + sleep 1; + } + print "Close code = `$res'\n" if $res = $vrexx->VCloseWindow($id); + }; + + =head1 ENVIRONMENT diff --git a/os2/OS2/REXX/REXX.xs b/os2/OS2/REXX/REXX.xs index b196ea19b8..f88d0afbc6 100644 --- a/os2/OS2/REXX/REXX.xs +++ b/os2/OS2/REXX/REXX.xs @@ -97,7 +97,7 @@ exec_in_REXX(pTHX_ char *cmd, char * handlerName, RexxFunctionHandler *handler) if (rc || SvTRUE(GvSV(PL_errgv))) { if (SvTRUE(GvSV(PL_errgv))) { STRLEN n_a; - Perl_die(aTHX_ "Error inside perl function called from REXX compartment.\n%s", SvPV(GvSV(PL_errgv), n_a)) ; + Perl_die(aTHX_ "Error inside perl function called from REXX compartment:\n%s", SvPV(GvSV(PL_errgv), n_a)) ; } Perl_die(aTHX_ "REXX compartment returned non-zero status %li", rc); } @@ -129,6 +129,7 @@ PERLCALL(PCSZ name, ULONG argc, PRXSTRING argv, PCSZ queue, PRXSTRING ret) unsigned long len; char *str; char **arr; + SV *res; dSP; DosSetExceptionHandler(&xreg); @@ -144,47 +145,41 @@ PERLCALL(PCSZ name, ULONG argc, PRXSTRING argv, PCSZ queue, PRXSTRING ret) } #endif + for (i = 0; i < argc; ++i) + XPUSHs(sv_2mortal(newSVpvn(argv[i].strptr, argv[i].strlength))); + PUTBACK; if (name) { - int ac = 0; - char **arr = alloca((argc + 1) * sizeof(char *)); - - for (i = 0; i < argc; ++i) - arr[ac++] = argv[i].strptr; - arr[ac] = NULL; - - rc = perl_call_argv(name, G_SCALAR | G_EVAL, arr); + rc = perl_call_pv(name, G_SCALAR | G_EVAL); } else if (exec_cv) { SV *cv = exec_cv; exec_cv = NULL; rc = perl_call_sv(cv, G_SCALAR | G_EVAL); - } else rc = -1; + } else + rc = -1; SPAGAIN; - if (rc == 1 && SvOK(TOPs)) { - str = SvPVx(POPs, len); - if (len > 256) - if (DosAllocMem((PPVOID)&ret->strptr, len, PAG_READ|PAG_WRITE|PAG_COMMIT)) { - DosUnsetExceptionHandler(&xreg); - return 1; - } - memcpy(ret->strptr, str, len); - ret->strlength = len; - } + if (rc == 1) /* must be! */ + res = POPs; + if (rc == 1 && SvOK(res)) { + str = SvPVx(res, len); + if (len <= 256 /* Default buffer is 256-char long */ + || !CheckOSError(DosAllocMem((PPVOID)&ret->strptr, len, + PAG_READ|PAG_WRITE|PAG_COMMIT))) { + memcpy(ret->strptr, str, len); + ret->strlength = len; + } else + rc = 0; + } else + rc = 0; PUTBACK ; FREETMPS ; LEAVE ; - if (rc != 1) { - DosUnsetExceptionHandler(&xreg); - return 1; - } - - DosUnsetExceptionHandler(&xreg); - return 0; + return rc == 1 ? 0 : 1; /* 0 means SUCCESS */ } static void diff --git a/os2/OS2/REXX/t/rx_cmprt.t b/os2/OS2/REXX/t/rx_cmprt.t index f2113e3aa3..6baec7687d 100644 --- a/os2/OS2/REXX/t/rx_cmprt.t +++ b/os2/OS2/REXX/t/rx_cmprt.t @@ -8,11 +8,11 @@ BEGIN { } } -use OS2::REXX; +use OS2::REXX qw(:DEFAULT register); $| = 1; # Otherwise data from REXX may come first -print "1..13\n"; +print "1..16\n"; $n = 1; sub do_me { @@ -38,3 +38,11 @@ REXX_eval 'say "ok 10"'; REXX_eval 'say "ok 11"'; print "ok 12\n" if REXX_eval("return 2 + 3") eq 5; REXX_eval_with 'say myfunc()', myfunc => sub {"ok 13"}; +REXX_eval_with "call myout 'ok' 14", myout => sub {print shift, "\n"}; +REXX_eval_with "say 'ok 'myfunc(3,5)", myfunc => sub {shift() * shift()}; + +sub MYFUNC1 {shift} +sub MYFUNC2 {3 * shift} +REXX_eval_with "call myfunc + say 'ok 'myfunc1(1)myfunc2(2)", + myfunc => sub { register qw(myfunc1 myfunc2) }; @@ -8,6 +8,7 @@ #define SPU_DISABLESUPPRESSION 0 #define SPU_ENABLESUPPRESSION 1 #include <os2.h> +#include "dlfcn.h" #include <sys/uflags.h> @@ -189,6 +190,16 @@ static USHORT loadOrd[2] = { 874, 873 }; /* Query=874, Set=873. */ #define ORD_SET_ELP 1 struct PMWIN_entries_t PMWIN_entries; +HMODULE +loadModule(char *modname) +{ + HMODULE h = (HMODULE)dlopen(modname, 0); + if (!h) + Perl_croak_nocontext("Error loading module '%s': %s", + modname, dlerror()); + return h; +} + APIRET loadByOrd(char *modname, ULONG ord) { @@ -198,11 +209,14 @@ loadByOrd(char *modname, ULONG ord) PFN fcn; APIRET rc; - if ((!hdosc && CheckOSError(DosLoadModule(buf, sizeof buf, - modname, &hdosc))) - || CheckOSError(DosQueryProcAddr(hdosc, loadOrd[ord], NULL, &fcn))) - Perl_croak_nocontext("This version of OS/2 does not support %s.%i", - modname, loadOrd[ord]); + + if (!hdosc) { + hdosc = loadModule(modname); + if (CheckOSError(DosQueryProcAddr(hdosc, loadOrd[ord], NULL, &fcn))) + Perl_croak_nocontext( + "This version of OS/2 does not support %s.%i", + modname, loadOrd[ord]); + } ExtFCN[ord] = fcn; } if ((long)ExtFCN[ord] == -1) @@ -220,6 +234,8 @@ init_PMWIN_entries(void) 918, /* PeekMsg */ 915, /* GetMsg */ 912, /* DispatchMsg */ + 753, /* GetLastError */ + 705, /* CancelShutdown */ }; BYTE buf[20]; int i = 0; @@ -228,9 +244,8 @@ init_PMWIN_entries(void) if (hpmwin) return; - if (CheckOSError(DosLoadModule(buf, sizeof buf, "pmwin", &hpmwin))) - Perl_croak_nocontext("This version of OS/2 does not support pmwin: error in %s", buf); - while (i <= 5) { + hpmwin = loadModule("pmwin"); + while (i < sizeof(ords)/sizeof(int)) { if (CheckOSError(DosQueryProcAddr(hpmwin, ords[i], NULL, ((PFN*)&PMWIN_entries)+i))) Perl_croak_nocontext("This version of OS/2 does not support pmwin.%d", ords[i]); @@ -1138,12 +1153,11 @@ static HMODULE htcp = 0; static void * tcp0(char *name) { - static BYTE buf[20]; PFN fcn; if (!(_emx_env & 0x200)) Perl_croak_nocontext("%s requires OS/2", name); /* Die if not OS/2. */ if (!htcp) - DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp); + htcp = loadModule("tcp32dll"); if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0) return (void *) ((void * (*)(void)) fcn) (); return 0; @@ -1367,15 +1381,30 @@ os2error(int rc) char * os2_execname(pTHX) { - char buf[300], *p; + char buf[300], *p, *o = PL_origargv[0], ok = 1; if (_execname(buf, sizeof buf) != 0) - return PL_origargv[0]; + return o; p = buf; while (*p) { if (*p == '\\') *p = '/'; + if (*p == '/') { + if (ok && *o != '/' && *o != '\\') + ok = 0; + } else if (ok && tolower(*o) != tolower(*p)) + ok = 0; p++; + o++; + } + if (ok) { /* PL_origargv[0] matches the real name. Use PL_origargv[0]: */ + strcpy(buf, PL_origargv[0]); /* _execname() is always uppercased */ + p = buf; + while (*p) { + if (*p == '\\') + *p = '/'; + p++; + } } p = savepv(buf); SAVEFREEPV(p); @@ -1447,7 +1476,6 @@ Perl_Register_MQ(int serve) return Perl_hmq; DosGetInfoBlocks(&tib, &pib); Perl_os2_initial_mode = pib->pib_ultype; - Perl_hmq_refcnt = 1; /* Try morphing into a PM application. */ if (pib->pib_ultype != 3) /* 2 is VIO */ pib->pib_ultype = 3; /* 3 is PM */ @@ -1456,10 +1484,20 @@ Perl_Register_MQ(int serve) Perl_hmq = (*PMWIN_entries.CreateMsgQueue)(perl_hab_GET(), 64); if (!Perl_hmq) { static int cnt; + + SAVEINT(cnt); /* Allow catch()ing. */ if (cnt++) _exit(188); /* Panic can try to create a window. */ Perl_croak_nocontext("Cannot create a message queue, or morph to a PM application"); } + if (serve) { + if ( Perl_hmq_servers <= 0 /* Safe to inform us on shutdown, */ + && Perl_hmq_refcnt > 0 ) /* this was switched off before... */ + (*PMWIN_entries.CancelShutdown)(Perl_hmq, 0); + Perl_hmq_servers++; + } else if (!Perl_hmq_servers) /* Do not inform us on shutdown */ + (*PMWIN_entries.CancelShutdown)(Perl_hmq, 1); + Perl_hmq_refcnt++; return Perl_hmq; } @@ -1469,9 +1507,9 @@ Perl_Serve_Messages(int force) int cnt = 0; QMSG msg; - if (Perl_hmq_servers && !force) + if (Perl_hmq_servers > 0 && !force) return 0; - if (!Perl_hmq_refcnt) + if (Perl_hmq_refcnt <= 0) Perl_croak_nocontext("No message queue"); while ((*PMWIN_entries.PeekMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0, PM_REMOVE)) { cnt++; @@ -1487,9 +1525,9 @@ Perl_Process_Messages(int force, I32 *cntp) { QMSG msg; - if (Perl_hmq_servers && !force) + if (Perl_hmq_servers > 0 && !force) return 0; - if (!Perl_hmq_refcnt) + if (Perl_hmq_refcnt <= 0) Perl_croak_nocontext("No message queue"); while ((*PMWIN_entries.GetMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0)) { if (cntp) @@ -1509,21 +1547,23 @@ Perl_Deregister_MQ(int serve) PPIB pib; PTIB tib; - if (--Perl_hmq_refcnt == 0) { + if (serve) + Perl_hmq_servers--; + if (--Perl_hmq_refcnt <= 0) { + init_PMWIN_entries(); /* To be extra safe */ (*PMWIN_entries.DestroyMsgQueue)(Perl_hmq); Perl_hmq = 0; /* Try morphing back from a PM application. */ + DosGetInfoBlocks(&tib, &pib); if (pib->pib_ultype == 3) /* 3 is PM */ pib->pib_ultype = Perl_os2_initial_mode; else Perl_warn_nocontext("Unexpected program mode %d when morphing back from PM", pib->pib_ultype); - } + } else if (serve && Perl_hmq_servers <= 0) /* Last server exited */ + (*PMWIN_entries.CancelShutdown)(Perl_hmq, 1); } -extern void dlopen(); -void *fakedl = &dlopen; /* Pull in dynaloading part. */ - #define sys_is_absolute(path) ( isALPHA((path)[0]) && (path)[1] == ':' \ && ((path)[2] == '/' || (path)[2] == '\\')) #define sys_is_rooted _fnisabs @@ -2026,6 +2066,71 @@ XS(XS_Cwd_extLibpath_set) XSRETURN(1); } +#define get_control87() _control87(0,0) +#define set_control87 _control87 + +XS(XS_OS2__control87) +{ + dXSARGS; + if (items != 2) + croak("Usage: OS2::_control87(new,mask)"); + { + unsigned new = (unsigned)SvIV(ST(0)); + unsigned mask = (unsigned)SvIV(ST(1)); + unsigned RETVAL; + + RETVAL = _control87(new, mask); + ST(0) = sv_newmortal(); + sv_setiv(ST(0), (IV)RETVAL); + } + XSRETURN(1); +} + +XS(XS_OS2_get_control87) +{ + dXSARGS; + if (items != 0) + croak("Usage: OS2::get_control87()"); + { + unsigned RETVAL; + + RETVAL = get_control87(); + ST(0) = sv_newmortal(); + sv_setiv(ST(0), (IV)RETVAL); + } + XSRETURN(1); +} + + +XS(XS_OS2_set_control87) +{ + dXSARGS; + if (items < 0 || items > 2) + croak("Usage: OS2::set_control87(new=MCW_EM, mask=MCW_EM)"); + { + unsigned new; + unsigned mask; + unsigned RETVAL; + + if (items < 1) + new = MCW_EM; + else { + new = (unsigned)SvIV(ST(0)); + } + + if (items < 2) + mask = MCW_EM; + else { + mask = (unsigned)SvIV(ST(1)); + } + + RETVAL = set_control87(new, mask); + ST(0) = sv_newmortal(); + sv_setiv(ST(0), (IV)RETVAL); + } + XSRETURN(1); +} + int Xs_OS2_init(pTHX) { @@ -2055,6 +2160,9 @@ Xs_OS2_init(pTHX) newXS("Cwd::sys_is_relative", XS_Cwd_sys_is_relative, file); newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file); newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, 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, ";$$"); gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV); GvMULTI_on(gv); #ifdef PERL_IS_AOUT @@ -2106,6 +2214,8 @@ Perl_OS2_init(char **env) } MUTEX_INIT(&start_thread_mutex); os2_mytype = my_type(); /* Do it before morphing. Needed? */ + /* Some DLLs reset FP flags on load. We may have been linked with them */ + _control87(MCW_EM, MCW_EM); } #undef tmpnam @@ -2139,6 +2249,38 @@ my_tmpfile () grants TMP. */ } +#undef rmdir + +int +my_rmdir (__const__ char *s) +{ + char buf[MAXPATHLEN]; + STRLEN l = strlen(s); + + if (s[l-1] == '/' || s[l-1] == '\\') { /* EMX rmdir fails... */ + strcpy(buf,s); + buf[l - 1] = 0; + s = buf; + } + return rmdir(s); +} + +#undef mkdir + +int +my_mkdir (__const__ char *s, long perm) +{ + char buf[MAXPATHLEN]; + STRLEN l = strlen(s); + + if (s[l-1] == '/' || s[l-1] == '\\') { /* EMX mkdir fails... */ + strcpy(buf,s); + buf[l - 1] = 0; + s = buf; + } + return mkdir(s, perm); +} + #undef flock /* This code was contributed by Rocco Caputo. */ diff --git a/os2/os2.sym b/os2/os2.sym index 685568623a..3f535e43fc 100644 --- a/os2/os2.sym +++ b/os2/os2.sym @@ -9,6 +9,8 @@ dlclose my_tmpfile my_tmpnam my_flock +my_rmdir +my_mkdir malloc_mutex threads_mutex nthreads diff --git a/os2/os2add.sym b/os2/os2add.sym new file mode 100644 index 0000000000..36aab853e9 --- /dev/null +++ b/os2/os2add.sym @@ -0,0 +1,9 @@ +dlopen +dlsym +dlerror +dlclose +malloc +realloc +free +calloc +ctermid diff --git a/os2/os2ish.h b/os2/os2ish.h index dccd9320b6..30e67ca071 100644 --- a/os2/os2ish.h +++ b/os2/os2ish.h @@ -261,6 +261,8 @@ PerlIO *my_syspopen(pTHX_ char *cmd, char *mode); int my_syspclose(PerlIO *f); FILE *my_tmpfile (void); char *my_tmpnam (char *); +int my_mkdir (__const__ char *, long); +int my_rmdir (__const__ char *); #undef L_tmpnam #define L_tmpnam MAXPATHLEN @@ -283,6 +285,8 @@ char *my_tmpnam (char *); #define my_getenv(var) getenv(var) #define flock my_flock +#define rmdir my_rmdir +#define mkdir my_mkdir void *emx_calloc (size_t, size_t); void emx_free (void *); @@ -394,6 +398,8 @@ struct PMWIN_entries_t { unsigned long hwndFilter, unsigned long msgFilterFirst, unsigned long msgFilterLast); void * (*DispatchMsg)(unsigned long hab, struct _QMSG *pqmsg); + unsigned long (*GetLastError)(unsigned long hab); + unsigned long (*CancelShutdown)(unsigned long hmq, unsigned long fCancelAlways); }; extern struct PMWIN_entries_t PMWIN_entries; void init_PMWIN_entries(void); @@ -418,9 +424,14 @@ void init_PMWIN_entries(void); #define CheckWinError(expr) ((expr) ? 0: (FillWinError, 1)) #define FillOSError(rc) (os2_setsyserrno(rc), \ Perl_severity = SEVERITY_ERROR) -#define FillWinError (Perl_severity = ERRORIDSEV(Perl_rc), \ - Perl_rc = ERRORIDERROR(Perl_rc)), \ - os2_setsyserrno(Perl_rc) + +/* At this moment init_PMWIN_entries() should be a nop (WinInitialize should + be called already, right?), so we do not risk stepping over our own error */ +#define FillWinError ( init_PMWIN_entries(), \ + Perl_rc=(*PMWIN_entries.GetLastError)(perl_hab_GET()),\ + Perl_severity = ERRORIDSEV(Perl_rc), \ + Perl_rc = ERRORIDERROR(Perl_rc), \ + os2_setsyserrno(Perl_rc)) #define STATIC_FILE_LENGTH 127 |