Front page | perl.perl5.porters |
Postings from March 2001
[PATCH 5.6.1] OS/2 cleanup
Thread Next
From:
Ilya Zakharevich
Date:
March 4, 2001 23:29
Subject:
[PATCH 5.6.1] OS/2 cleanup
Message ID:
20010305022944.A10117@math.ohio-state.edu
I think this resolves 95% of known issues, mini-issues, and micro-issues
with the OS/2 port. In fact the solution to the first problem may be
interesting to other platforms as well. I remember somebody asking for
something like PERL_ARCHIVE_AFTER (but for static link?) 3 or 5 years ago...
The only non-OS/2-restricted changes are to MANIFEST, ExtUtils/MM_Unix.pm
(new empty define PERL_ARCHIVE_AFTER added), and makedef.pl (which exports
Perl_strdup and Perl_putenv if MYMALLOC). The documentation is in the first
chunk.
Enjoy,
Ilya
os2/Changes
MANIFEST
lib/ExtUtils/MM_Unix.pm
lib/ExtUtils/MM_OS2.pm
makedef.pl
os2/Makefile.SHs
os2/os2.c
os2/os2.sym
os2/os2add.sym
os2/os2ish.h
os2/OS2/REXX/Makefile.PL
os2/OS2/REXX/REXX.pm
os2/OS2/REXX/REXX.xs
os2/OS2/REXX/t/rx_cmprt.t
--- ./os2/Changes-pre Wed Jan 31 10:56:48 2001
+++ ./os2/Changes Mon Mar 5 02:06:34 2001
@@ -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.
+
--- ./MANIFEST-pre Wed Jan 31 10:56:46 2001
+++ ./MANIFEST Mon Mar 5 00:43:06 2001
@@ -1093,6 +1093,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
--- ./lib/ExtUtils/MM_Unix.pm-pre Wed Jan 31 10:56:46 2001
+++ ./lib/ExtUtils/MM_Unix.pm Sun Mar 4 23:23:56 2001
@@ -208,6 +208,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 ;
@@ -674,6 +675,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{
@@ -1061,7 +1066,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)';
@@ -1083,7 +1088,7 @@ $(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $
');
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) $@
';
@@ -3805,6 +3810,21 @@ and Win32 do.
sub perl_archive
{
return '$(PERL_INC)' . "/$Config{libperl}" if $^O eq "beos";
+ 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 "";
}
--- ./lib/ExtUtils/MM_OS2.pm-pre Wed Jan 31 10:56:46 2001
+++ ./lib/ExtUtils/MM_OS2.pm Mon Mar 5 00:12:04 2001
@@ -93,6 +93,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) = @_;
--- ./makedef.pl-pre Wed Jan 31 10:56:48 2001
+++ ./makedef.pl Mon Mar 5 00:09:50 2001
@@ -281,6 +281,8 @@ elsif ($PLATFORM eq 'os2') {
my_tmpfile
my_tmpnam
my_flock
+ my_rmdir
+ my_mkdir
malloc_mutex
threads_mutex
nthreads
@@ -364,6 +366,8 @@ if ($define{'MYMALLOC'}) {
Perl_mfree
Perl_realloc
Perl_calloc
+ Perl_strdup
+ Perl_putenv
)];
if ($define{'USE_5005THREADS'} || $define{'USE_ITHREADS'}) {
emit_symbols [qw(
--- ./os2/Makefile.SHs-pre Wed Jan 31 10:56:48 2001
+++ ./os2/Makefile.SHs Mon Mar 5 00:15:36 2001
@@ -41,8 +41,17 @@ 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
--- ./os2/os2.c-pre Sat Mar 3 01:27:22 2001
+++ ./os2/os2.c Mon Mar 5 01:05:48 2001
@@ -8,6 +8,7 @@
#define SPU_DISABLESUPPRESSION 0
#define SPU_ENABLESUPPRESSION 1
#include <os2.h>
+#include "dlfcn.h"
#include <sys/uflags.h>
@@ -187,6 +188,16 @@ static USHORT loadOrd[2] = { 874, 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)
{
@@ -196,11 +207,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)
@@ -218,6 +232,8 @@ init_PMWIN_entries(void)
918, /* PeekMsg */
915, /* GetMsg */
912, /* DispatchMsg */
+ 753, /* GetLastError */
+ 705, /* CancelShutdown */
};
BYTE buf[20];
int i = 0;
@@ -226,9 +242,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]);
@@ -1131,12 +1146,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;
@@ -1145,22 +1159,19 @@ tcp0(char *name)
static void
tcp1(char *name, int arg)
{
- 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)
((void (*)(int)) fcn) (arg);
}
-#ifndef HAS_GETHOSTENT /* Older versions of EMX did not have it... */
-void * gethostent() { return tcp0("GETHOSTENT"); }
-void * getnetent() { return tcp0("GETNETENT"); }
-void * getprotoent() { return tcp0("GETPROTOENT"); }
-void * getservent() { return tcp0("GETSERVENT"); }
-#endif
+struct hostent * gethostent() { return tcp0("GETHOSTENT"); }
+struct netent * getnetent() { return tcp0("GETNETENT"); }
+struct protoent * getprotoent() { return tcp0("GETPROTOENT"); }
+struct servent * getservent() { return tcp0("GETSERVENT"); }
void sethostent(x) { tcp1("SETHOSTENT", x); }
void setnetent(x) { tcp1("SETNETENT", x); }
@@ -1362,15 +1373,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);
@@ -1442,7 +1468,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 */
@@ -1451,10 +1476,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;
}
@@ -1464,9 +1499,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++;
@@ -1482,9 +1517,9 @@ Perl_Process_Messages(int force, I32 *cn
{
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)
@@ -1504,21 +1539,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
@@ -2021,6 +2058,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)
{
@@ -2050,6 +2152,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
@@ -2101,6 +2206,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
@@ -2132,6 +2239,38 @@ my_tmpfile ()
}
return fopen(my_tmpnam(NULL), "w+b"); /* Race condition, but
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
--- ./os2/os2.sym-pre Wed Jan 31 10:56:48 2001
+++ ./os2/os2.sym Sun Mar 4 02:23:54 2001
@@ -9,6 +9,8 @@ dlclose
my_tmpfile
my_tmpnam
my_flock
+my_rmdir
+my_mkdir
malloc_mutex
threads_mutex
nthreads
--- ./os2/os2add.sym-pre Sun Mar 4 03:05:34 2001
+++ ./os2/os2add.sym Sun Mar 4 03:08:16 2001
@@ -0,0 +1,9 @@
+dlopen
+dlsym
+dlerror
+dlclose
+malloc
+realloc
+free
+calloc
+ctermid
--- ./os2/os2ish.h-pre Wed Jan 31 10:56:48 2001
+++ ./os2/os2ish.h Sun Mar 4 02:24:38 2001
@@ -261,6 +261,8 @@ PerlIO *my_syspopen(pTHX_ char *cmd, cha
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
--- ./os2/OS2/REXX/Makefile.PL-pre Sat Mar 3 01:02:52 2001
+++ ./os2/OS2/REXX/Makefile.PL Sun Mar 4 16:07:20 2001
@@ -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,
--- ./os2/OS2/REXX/REXX.pm-pre Sat Mar 3 01:02:52 2001
+++ ./os2/OS2/REXX/REXX.pm Sun Mar 4 17:21:42 2001
@@ -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 y
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 cha
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 th
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
--- ./os2/OS2/REXX/REXX.xs-pre Sat Mar 3 01:02:52 2001
+++ ./os2/OS2/REXX/REXX.xs Sun Mar 4 16:28:06 2001
@@ -97,7 +97,7 @@ exec_in_REXX(pTHX_ char *cmd, char * han
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, PRXSTRIN
unsigned long len;
char *str;
char **arr;
+ SV *res;
dSP;
DosSetExceptionHandler(&xreg);
@@ -144,47 +145,41 @@ PERLCALL(PCSZ name, ULONG argc, PRXSTRIN
}
#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
--- ./os2/OS2/REXX/t/rx_cmprt.t-pre Sat Mar 3 01:02:52 2001
+++ ./os2/OS2/REXX/t/rx_cmprt.t Sun Mar 4 16:59:24 2001
@@ -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) };
Thread Next
-
[PATCH 5.6.1] OS/2 cleanup
by Ilya Zakharevich