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) = @_;
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 ;
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{
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)';
$ldfrom = "-all $ldfrom -none" if ($^O eq 'dec_osf');
# The IRIX linker doesn't use LD_RUN_PATH
- $ldrun = qq{-rpath "$self->{LD_RUN_PATH}"}
+ my $ldrun = qq{-rpath "$self->{LD_RUN_PATH}"}
if ($^O eq 'irix' && $self->{LD_RUN_PATH});
# For example in AIX the shared objects/libraries from previous builds
');
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) $@
';
push @m, "
\$(MAP_TARGET) :: $tmp/perlmain\$(OBJ_EXT) \$(MAP_LIBPERL) \$(MAP_STATIC) \$(INST_ARCHAUTODIR)/extralibs.all
- \$(MAP_LINKCMD) -o \$\@ \$(OPTIMIZE) $tmp/perlmain\$(OBJ_EXT) $ldfrom \$(MAP_STATIC) $llibperl `cat \$(INST_ARCHAUTODIR)/extralibs.all` \$(MAP_PRELIBS)
+ \$(MAP_LINKCMD) -o \$\@ \$(OPTIMIZE) $tmp/perlmain\$(OBJ_EXT) \$(LDFROM) \$(MAP_STATIC) $llibperl `cat \$(INST_ARCHAUTODIR)/extralibs.all` \$(MAP_PRELIBS)
$self->{NOECHO}echo 'To install the new \"\$(MAP_TARGET)\" binary, call'
$self->{NOECHO}echo ' make -f $makefilename inst_perl MAP_TARGET=\$(MAP_TARGET)'
$self->{NOECHO}echo 'To remove the intermediate files say'
my $list = ref($self->{PL_FILES}->{$plfile})
? $self->{PL_FILES}->{$plfile}
: [$self->{PL_FILES}->{$plfile}];
+ my $target;
foreach $target (@$list) {
push @m, "
all :: $target
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
my_tmpfile
my_tmpnam
my_flock
+ my_rmdir
+ my_mkdir
malloc_mutex
threads_mutex
nthreads
Perl_mfree
Perl_realloc
Perl_calloc
+ Perl_strdup
+ Perl_putenv
)];
if ($define{'USE_5005THREADS'} || $define{'USE_ITHREADS'}) {
emit_symbols [qw(
case OP_MATCH:
case OP_QR:
clear_pmop:
+ {
+ HV *pmstash = PmopSTASH(cPMOPo);
+ if (pmstash) {
+ PMOP *pmop = HvPMROOT(pmstash);
+ PMOP *lastpmop = NULL;
+ while (pmop) {
+ if (cPMOPo == pmop) {
+ if (lastpmop)
+ lastpmop->op_pmnext = pmop->op_pmnext;
+ else
+ HvPMROOT(pmstash) = pmop->op_pmnext;
+ break;
+ }
+ lastpmop = pmop;
+ pmop = pmop->op_pmnext;
+ }
+#ifdef USE_ITHREADS
+ Safefree(PmopSTASHPV(cPMOPo));
+#else
+ /* NOTE: PMOP.op_pmstash is not refcounted */
+#endif
+ }
+ }
cPMOPo->op_pmreplroot = Nullop;
ReREFCNT_dec(cPMOPo->op_pmregexp);
cPMOPo->op_pmregexp = (REGEXP*)NULL;
if (type != OP_TRANS && PL_curstash) {
pmop->op_pmnext = HvPMROOT(PL_curstash);
HvPMROOT(PL_curstash) = pmop;
+ PmopSTASH_set(pmop,PL_curstash);
}
return (OP*)pmop;
U16 op_pmflags;
U16 op_pmpermflags;
U8 op_pmdynflags;
+#ifdef USE_ITHREADS
+ char * op_pmstashpv;
+#else
+ HV * op_pmstash;
+#endif
};
#define PMdf_USED 0x01 /* pm has been used once already */
/* mask of bits stored in regexp->reganch */
#define PMf_COMPILETIME (PMf_MULTILINE|PMf_SINGLELINE|PMf_LOCALE|PMf_FOLD|PMf_EXTENDED)
+#ifdef USE_ITHREADS
+# define PmopSTASHPV(o) ((o)->op_pmstashpv)
+# define PmopSTASHPV_set(o,pv) ((o)->op_pmstashpv = ((pv) ? savepv(pv) : Nullch))
+# define PmopSTASH(o) (PmopSTASHPV(o) \
+ ? gv_stashpv(PmopSTASHPV(o),GV_ADD) : Nullhv)
+# define PmopSTASH_set(o,hv) PmopSTASHPV_set(o, (hv) ? HvNAME(hv) : Nullch)
+#else
+# define PmopSTASH(o) ((o)->op_pmstash)
+# define PmopSTASH_set(o,hv) ((o)->op_pmstash = (hv))
+# define PmopSTASHPV(o) (PmopSTASH(o) ? HvNAME(PmopSTASH(o)) : Nullch)
+ /* op_pmstash is not refcounted */
+# define PmopSTASHPV_set(o,pv) PmopSTASH_set((o), gv_stashpv(pv,GV_ADD))
+#endif
+
struct svop {
BASEOP
SV * op_sv;
(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.
+
!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
WriteMakefile(
NAME => 'OS2::REXX',
- VERSION => '0.22',
+ VERSION_FROM => 'REXX.pm',
MAN3PODS => {}, # Pods will be built by installman.
XSPROTOARG => '-noprototypes',
PERL_MALLOC_OK => 1,
# (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...
# 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;
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";
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
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
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);
}
unsigned long len;
char *str;
char **arr;
+ SV *res;
dSP;
DosSetExceptionHandler(&xreg);
}
#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
}
}
-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 {
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) };
#define SPU_DISABLESUPPRESSION 0
#define SPU_ENABLESUPPRESSION 1
#include <os2.h>
+#include "dlfcn.h"
#include <sys/uflags.h>
#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)
{
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)
918, /* PeekMsg */
915, /* GetMsg */
912, /* DispatchMsg */
+ 753, /* GetLastError */
+ 705, /* CancelShutdown */
};
BYTE buf[20];
int i = 0;
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]);
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;
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);
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 */
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;
}
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++;
{
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)
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
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)
{
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
}
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
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. */
my_tmpfile
my_tmpnam
my_flock
+my_rmdir
+my_mkdir
malloc_mutex
threads_mutex
nthreads
--- /dev/null
+dlopen
+dlsym
+dlerror
+dlclose
+malloc
+realloc
+free
+calloc
+ctermid
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
#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 *);
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);
#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
SV* cv_const_sv(CV* cv)
=for hackers
-Found in file opmini.c
+Found in file op.c
=item dMARK
CV* newCONSTSUB(HV* stash, char* name, SV* sv)
=for hackers
-Found in file opmini.c
+Found in file op.c
=item newHV
Used by C<xsubpp> to hook up XSUBs as Perl subs.
=for hackers
-Found in file opmini.c
+Found in file op.c
=item newXSproto
=item POPp
-Pops a string off the stack.
+Pops a string off the stack. Deprecated. New code should provide
+a STRLEN n_a and use POPpx.
char* POPp
=for hackers
Found in file pp.h
+=item POPpbytex
+
+Pops a string off the stack which must consist of bytes i.e. characters < 256.
+Requires a variable STRLEN n_a in scope.
+
+ char* POPpbytex
+
+=for hackers
+Found in file pp.h
+
+=item POPpx
+
+Pops a string off the stack.
+Requires a variable STRLEN n_a in scope.
+
+ char* POPpx
+
+=for hackers
+Found in file pp.h
+
=item POPs
Pops an SV off the stack.
=for hackers
Found in file sv.h
-=item svtype
+=item SvTYPE
-An enum of flags for Perl types. These are found in the file B<sv.h>
-in the C<svtype> enum. Test these flags with the C<SvTYPE> macro.
+Returns the type of the SV. See C<svtype>.
+
+ svtype SvTYPE(SV* sv)
=for hackers
Found in file sv.h
-=item SvTYPE
-
-Returns the type of the SV. See C<svtype>.
+=item svtype
- svtype SvTYPE(SV* sv)
+An enum of flags for Perl types. These are found in the file B<sv.h>
+in the C<svtype> enum. Test these flags with the C<SvTYPE> macro.
=for hackers
Found in file sv.h
# the format supported by op/regexp.t. If you want to add a test
# that does fit that format, add it to op/re_tests, not here.
-print "1..243\n";
+print "1..245\n";
BEGIN {
chdir 't' if -d 't';
}
}
-# 241..242
-#
-# The tr is admittedly NOT a regular expression operator,
-# but this test is more of an EBCDIC test, the background is
-# that \x89 is 'i' and \x90 is 'j', and \x8e is not a letter,
-# not even a printable character. Now for the trick:
-# if the range is specified using letters, the \x8e should most
-# probably not match, but if the range is specified using explicit
-# numeric endpoints, it probably should match. The first case,
-# not matching if using letters, is already tested elsewhere,
-# here we test for the matching cases.
-
-$_ = qq/\x8E/;
-
-print "not " unless /[\x89-\x91]/;
-print "ok 241\n";
-
-print "not " unless tr/\x89-\x91//d == 1;
-print "ok 242\n";
-
{
# japhy -- added 03/03/2001
() = (my $str = "abc") =~ /(...)/;
$str = "def";
print "not " if $1 ne "abc";
+ print "ok 241\n";
+}
+
+# The 242 and 243 go with the 244 and 245.
+# The trick is that in EBCDIC the explicit numeric range should match
+# (as also in non-EBCDIC) but the explicit alphabetic range should not match.
+
+if ("\x8e" =~ /[\x89-\x91]/) {
+ print "ok 242\n";
+} else {
+ print "not ok 242\n";
+}
+
+if ("\xce" =~ /[\xc9-\xd1]/) {
print "ok 243\n";
+} else {
+ print "not ok 243\n";
+}
+
+# In most places these tests would succeed since \x8e does not
+# in most character sets match 'i' or 'j' nor would \xce match
+# 'I' or 'J', but strictly speaking these tests are here for
+# the good of EBCDIC, so let's test these only there.
+if (ord('i') == 0x89 && ord('J') == 0xd1) { # EBCDIC
+ if ("\x8e" !~ /[i-j]/) {
+ print "ok 244\n";
+ } else {
+ print "not ok 244\n";
+ }
+ if ("\xce" !~ /[I-J]/) {
+ print "ok 245\n";
+ } else {
+ print "not ok 245\n";
+ }
+} else {
+ for (244..245) {
+ print "ok $_ # Skip: not EBCDIC\n";
+ }
}
@INC = '../lib';
}
-print "1..57\n";
+print "1..61\n";
$_ = "abcdefghijklmnopqrstuvwxyz";
print "not " unless $a eq "X";
print "ok 57\n";
+# Tricky on EBCDIC: while [a-z] [A-Z] must not match the gap characters,
+# (i-j, r-s, I-J, R-S), [\x89-\x91] [\xc9-\xd1] has to match them,
+# from Karsten Sperling.
+
+$c = ($a = "\x89\x8a\x8b\x8c\x8d\x8f\x90\x91") =~ tr/\x89-\x91/X/;
+print "not " unless $c == 8 and $a eq "XXXXXXXX";
+print "ok 58\n";
+
+$c = ($a = "\xc9\xca\xcb\xcc\xcd\xcf\xd0\xd1") =~ tr/\xc9-\xd1/X/;
+print "not " unless $c == 8 and $a eq "XXXXXXXX";
+print "ok 59\n";
+
+if (ord('i') == 0x89 & ord('J') == 0xd1) {
+
+$c = ($a = "\x89\x8a\x8b\x8c\x8d\x8f\x90\x91") =~ tr/i-j/X/;
+print "not " unless $c == 2 and $a eq "X\x8a\x8b\x8c\x8d\x8f\x90X";
+print "ok 60\n";
+
+$c = ($a = "\xc9\xca\xcb\xcc\xcd\xcf\xd0\xd1") =~ tr/I-J/X/;
+print "not " unless $c == 2 and $a eq "X\xca\xcb\xcc\xcd\xcf\xd0X";
+print "ok 61\n";
+
+} else {
+ for (60..61) { print "ok $_ # Skip: not EBCDIC\n" }
+}
projects / p5sagit/p5-mst-13.2.git / commitdiff