+ULONG
+fill_extLibpath(int type, char *pre, char *post, int replace, char *msg)
+{
+ char buf[2048], *to = buf, buf1[300], *s;
+ STRLEN l;
+ ULONG rc;
+
+ if (!pre && !post)
+ return 0;
+ if (pre) {
+ pre = dir_subst(pre, strlen(pre), buf1, sizeof buf1, dir_subst_pathlike, msg);
+ if (!pre)
+ return ERROR_INVALID_PARAMETER;
+ l = strlen(pre);
+ if (l >= sizeof(buf)/2)
+ return ERROR_BUFFER_OVERFLOW;
+ s = pre - 1;
+ while (*++s)
+ if (*s == '/')
+ *s = '\\'; /* Be extra cautious */
+ memcpy(to, pre, l);
+ if (!l || to[l-1] != ';')
+ to[l++] = ';';
+ to += l;
+ }
+
+ if (!replace) {
+ to[0] = 1; to[1] = 0; /* Sometimes no error reported */
+ rc = ExtLIBPATH(ORD_DosQueryExtLibpath, to, type, 0); /* Do not croak */
+ if (rc)
+ return rc;
+ if (to[0] == 1 && to[1] == 0)
+ return ERROR_INVALID_PARAMETER;
+ to += strlen(to);
+ if (buf + sizeof(buf) - 1 <= to) /* Buffer overflow */
+ early_error("Buffer overflow while getting BEGIN/ENDLIBPATH: `",
+ buf, "'\r\n"); /* Will not return */
+ if (to > buf && to[-1] != ';')
+ *to++ = ';';
+ }
+ if (post) {
+ post = dir_subst(post, strlen(post), buf1, sizeof buf1, dir_subst_pathlike, msg);
+ if (!post)
+ return ERROR_INVALID_PARAMETER;
+ l = strlen(post);
+ if (l + to - buf >= sizeof(buf) - 1)
+ return ERROR_BUFFER_OVERFLOW;
+ s = post - 1;
+ while (*++s)
+ if (*s == '/')
+ *s = '\\'; /* Be extra cautious */
+ memcpy(to, post, l);
+ if (!l || to[l-1] != ';')
+ to[l++] = ';';
+ to += l;
+ }
+ *to = 0;
+ rc = ExtLIBPATH(ORD_DosSetExtLibpath, buf, type, 0); /* Do not croak */
+ return rc;
+}
+
+/* Input: Address, BufLen
+APIRET APIENTRY
+DosQueryModFromEIP (HMODULE * hmod, ULONG * obj, ULONG BufLen, PCHAR Buf,
+ ULONG * Offset, ULONG Address);
+*/
+
+DeclOSFuncByORD(APIRET, _DosQueryModFromEIP,ORD_DosQueryModFromEIP,
+ (HMODULE * hmod, ULONG * obj, ULONG BufLen, PCHAR Buf,
+ ULONG * Offset, ULONG Address),
+ (hmod, obj, BufLen, Buf, Offset, Address))
+
+static SV*
+module_name_at(void *pp, enum module_name_how how)
+{
+ dTHX;
+ char buf[MAXPATHLEN];
+ char *p = buf;
+ HMODULE mod;
+ ULONG obj, offset, rc, addr = (ULONG)pp;
+
+ if (how & mod_name_HMODULE) {
+ if ((how & ~mod_name_HMODULE) == mod_name_shortname)
+ Perl_croak(aTHX_ "Can't get short module name from a handle");
+ mod = (HMODULE)pp;
+ how &= ~mod_name_HMODULE;
+ } else if (!_DosQueryModFromEIP(&mod, &obj, sizeof(buf), buf, &offset, addr))
+ return &PL_sv_undef;
+ if (how == mod_name_handle)
+ return newSVuv(mod);
+ /* Full name... */
+ if ( how != mod_name_shortname
+ && CheckOSError(DosQueryModuleName(mod, sizeof(buf), buf)) )
+ return &PL_sv_undef;
+ while (*p) {
+ if (*p == '\\')
+ *p = '/';
+ p++;
+ }
+ return newSVpv(buf, 0);
+}
+
+static SV*
+module_name_of_cv(SV *cv, enum module_name_how how)
+{
+ if (!cv || !SvROK(cv) || SvTYPE(SvRV(cv)) != SVt_PVCV || !CvXSUB(SvRV(cv))) {
+ dTHX;
+
+ if (how & mod_name_C_function)
+ return module_name_at((void*)SvIV(cv), how & ~mod_name_C_function);
+ else if (how & mod_name_HMODULE)
+ return module_name_at((void*)SvIV(cv), how);
+ Perl_croak(aTHX_ "Not an XSUB reference");
+ }
+ return module_name_at(CvXSUB(SvRV(cv)), how);
+}
+
+XS(XS_OS2_DLLname)
+{
+ dXSARGS;
+ if (items > 2)
+ Perl_croak(aTHX_ "Usage: OS2::DLLname( [ how, [\\&xsub] ] )");
+ {
+ SV * RETVAL;
+ int how;
+
+ if (items < 1)
+ how = mod_name_full;
+ else {
+ how = (int)SvIV(ST(0));
+ }
+ if (items < 2)
+ RETVAL = module_name(how);
+ else
+ RETVAL = module_name_of_cv(ST(1), how);
+ ST(0) = RETVAL;
+ sv_2mortal(ST(0));
+ }
+ XSRETURN(1);
+}
+
+DeclOSFuncByORD(INT, _Dos32QueryHeaderInfo, ORD_Dos32QueryHeaderInfo,
+ (ULONG r1, ULONG r2, PVOID buf, ULONG szbuf, ULONG fnum),
+ (r1, r2, buf, szbuf, fnum))
+
+XS(XS_OS2__headerInfo)
+{
+ dXSARGS;
+ if (items > 4 || items < 2)
+ Perl_croak(aTHX_ "Usage: OS2::_headerInfo(req,size[,handle,[offset]])");
+ {
+ ULONG req = (ULONG)SvIV(ST(0));
+ STRLEN size = (STRLEN)SvIV(ST(1)), n_a;
+ ULONG handle = (items >= 3 ? (ULONG)SvIV(ST(2)) : 0);
+ ULONG offset = (items >= 4 ? (ULONG)SvIV(ST(3)) : 0);
+
+ if (size <= 0)
+ Perl_croak(aTHX_ "OS2::_headerInfo(): unexpected size: %d", (int)size);
+ ST(0) = newSVpvn("",0);
+ SvGROW(ST(0), size + 1);
+ sv_2mortal(ST(0));
+
+ if (!_Dos32QueryHeaderInfo(handle, offset, SvPV(ST(0), n_a), size, req))
+ Perl_croak(aTHX_ "OS2::_headerInfo(%ld,%ld,%ld,%ld) error: %s",
+ req, size, handle, offset, os2error(Perl_rc));
+ SvCUR_set(ST(0), size);
+ *SvEND(ST(0)) = 0;
+ }
+ XSRETURN(1);
+}
+
+#define DQHI_QUERYLIBPATHSIZE 4
+#define DQHI_QUERYLIBPATH 5
+
+XS(XS_OS2_libPath)
+{
+ dXSARGS;
+ if (items != 0)
+ Perl_croak(aTHX_ "Usage: OS2::libPath()");
+ {
+ ULONG size;
+ STRLEN n_a;
+
+ if (!_Dos32QueryHeaderInfo(0, 0, &size, sizeof(size),
+ DQHI_QUERYLIBPATHSIZE))
+ Perl_croak(aTHX_ "OS2::_headerInfo(%ld,%ld,%ld,%ld) error: %s",
+ DQHI_QUERYLIBPATHSIZE, sizeof(size), 0, 0,
+ os2error(Perl_rc));
+ ST(0) = newSVpvn("",0);
+ SvGROW(ST(0), size + 1);
+ sv_2mortal(ST(0));
+
+ /* We should be careful: apparently, this entry point does not
+ pay attention to the size argument, so may overwrite
+ unrelated data! */
+ if (!_Dos32QueryHeaderInfo(0, 0, SvPV(ST(0), n_a), size,
+ DQHI_QUERYLIBPATH))
+ Perl_croak(aTHX_ "OS2::_headerInfo(%ld,%ld,%ld,%ld) error: %s",
+ DQHI_QUERYLIBPATH, size, 0, 0, os2error(Perl_rc));
+ SvCUR_set(ST(0), size);
+ *SvEND(ST(0)) = 0;
+ }
+ XSRETURN(1);
+}
+
+#define get_control87() _control87(0,0)
+#define set_control87 _control87
+
+XS(XS_OS2__control87)
+{
+ dXSARGS;
+ if (items != 2)
+ Perl_croak(aTHX_ "Usage: OS2::_control87(new,mask)");
+ {
+ unsigned new = (unsigned)SvIV(ST(0));
+ unsigned mask = (unsigned)SvIV(ST(1));
+ unsigned RETVAL;
+ dXSTARG;
+
+ RETVAL = _control87(new, mask);
+ XSprePUSH; PUSHi((IV)RETVAL);
+ }
+ XSRETURN(1);
+}
+
+XS(XS_OS2_mytype)
+{
+ dXSARGS;
+ int which = 0;
+
+ if (items < 0 || items > 1)
+ Perl_croak(aTHX_ "Usage: OS2::mytype([which])");
+ if (items == 1)
+ which = (int)SvIV(ST(0));
+ {
+ unsigned RETVAL;
+ dXSTARG;
+
+ switch (which) {
+ case 0:
+ RETVAL = os2_mytype; /* Reset after fork */
+ break;
+ case 1:
+ RETVAL = os2_mytype_ini; /* Before any fork */
+ break;
+ case 2:
+ RETVAL = Perl_os2_initial_mode; /* Before first morphing */
+ break;
+ case 3:
+ RETVAL = my_type(); /* Morphed type */
+ break;
+ default:
+ Perl_croak(aTHX_ "OS2::mytype(which): unknown which=%d", which);
+ }
+ XSprePUSH; PUSHi((IV)RETVAL);
+ }
+ XSRETURN(1);
+}
+
+
+XS(XS_OS2_mytype_set)
+{
+ dXSARGS;
+ int type;
+
+ if (items == 1)
+ type = (int)SvIV(ST(0));
+ else
+ Perl_croak(aTHX_ "Usage: OS2::mytype_set(type)");
+ my_type_set(type);
+ XSRETURN_YES;
+}
+
+
+XS(XS_OS2_get_control87)
+{
+ dXSARGS;
+ if (items != 0)
+ Perl_croak(aTHX_ "Usage: OS2::get_control87()");
+ {
+ unsigned RETVAL;
+ dXSTARG;
+
+ RETVAL = get_control87();
+ XSprePUSH; PUSHi((IV)RETVAL);
+ }
+ XSRETURN(1);
+}
+
+
+XS(XS_OS2_set_control87)
+{
+ dXSARGS;
+ if (items < 0 || items > 2)
+ Perl_croak(aTHX_ "Usage: OS2::set_control87(new=MCW_EM, mask=MCW_EM)");
+ {
+ unsigned new;
+ unsigned mask;
+ unsigned RETVAL;
+ dXSTARG;
+
+ 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);
+ XSprePUSH; PUSHi((IV)RETVAL);
+ }
+ XSRETURN(1);
+}
+
+XS(XS_OS2_incrMaxFHandles) /* DosSetRelMaxFH */
+{
+ dXSARGS;
+ if (items < 0 || items > 1)
+ Perl_croak(aTHX_ "Usage: OS2::incrMaxFHandles(delta = 0)");
+ {
+ LONG delta;
+ ULONG RETVAL, rc;
+ dXSTARG;
+
+ if (items < 1)
+ delta = 0;
+ else
+ delta = (LONG)SvIV(ST(0));
+
+ if (CheckOSError(DosSetRelMaxFH(&delta, &RETVAL)))
+ croak_with_os2error("OS2::incrMaxFHandles(): DosSetRelMaxFH() error");
+ XSprePUSH; PUSHu((UV)RETVAL);
+ }
+ XSRETURN(1);
+}
+
+/* wait>0: force wait, wait<0: force nowait;
+ if restore, save/restore flags; otherwise flags are in oflags.
+
+ Returns 1 if connected, 0 if not (due to nowait); croaks on error. */
+static ULONG
+connectNPipe(ULONG hpipe, int wait, ULONG restore, ULONG oflags)
+{
+ ULONG ret = ERROR_INTERRUPT, rc, flags;
+
+ if (restore && wait)
+ os2cp_croak(DosQueryNPHState(hpipe, &oflags), "DosQueryNPHState()");
+ /* DosSetNPHState fails if more bits than NP_NOWAIT|NP_READMODE_MESSAGE */
+ oflags &= (NP_NOWAIT | NP_READMODE_MESSAGE);
+ flags = (oflags & ~NP_NOWAIT) | (wait > 0 ? NP_WAIT : NP_NOWAIT);
+ /* We know (o)flags unless wait == 0 && restore */
+ if (wait && (flags != oflags))
+ os2cp_croak(DosSetNPHState(hpipe, flags), "DosSetNPHState()");
+ while (ret == ERROR_INTERRUPT)
+ ret = DosConnectNPipe(hpipe);
+ (void)CheckOSError(ret);
+ if (restore && wait && (flags != oflags))
+ os2cp_croak(DosSetNPHState(hpipe, oflags), "DosSetNPHState() back");
+ /* We know flags unless wait == 0 && restore */
+ if ( ((wait || restore) ? (flags & NP_NOWAIT) : 1)
+ && (ret == ERROR_PIPE_NOT_CONNECTED) )
+ return 0; /* normal return value */
+ if (ret == NO_ERROR)
+ return 1;
+ croak_with_os2error("DosConnectNPipe()");
+}
+
+/* With a lot of manual editing:
+NO_OUTPUT ULONG
+DosCreateNPipe(PCSZ pszName, OUTLIST HPIPE hpipe, ULONG ulOpenMode, int connect = 1, int count = 1, ULONG ulInbufLength = 8192, ULONG ulOutbufLength = ulInbufLength, ULONG ulPipeMode = count | NP_NOWAIT | NP_TYPE_BYTE | NP_READMODE_BYTE, ULONG ulTimeout = 0)
+ PREINIT:
+ ULONG rc;
+ C_ARGS:
+ pszName, &hpipe, ulOpenMode, ulPipeMode, ulInbufLength, ulOutbufLength, ulTimeout
+ POSTCALL:
+ if (CheckOSError(RETVAL))
+ croak_with_os2error("OS2::mkpipe() error");
+*/
+XS(XS_OS2_pipe); /* prototype to pass -Wmissing-prototypes */
+XS(XS_OS2_pipe)
+{
+ dXSARGS;
+ if (items < 2 || items > 8)
+ Perl_croak(aTHX_ "Usage: OS2::pipe(pszName, ulOpenMode, connect= 1, count= 1, ulInbufLength= 8192, ulOutbufLength= ulInbufLength, ulPipeMode= count | NP_NOWAIT | NP_TYPE_BYTE | NP_READMODE_BYTE, ulTimeout= 0)");
+ {
+ ULONG RETVAL;
+ PCSZ pszName = ( SvOK(ST(0)) ? (PCSZ)SvPV_nolen(ST(0)) : NULL );
+ HPIPE hpipe;
+ SV *OpenMode = ST(1);
+ ULONG ulOpenMode;
+ int connect = 0, count, message_r = 0, message = 0, b = 0;
+ ULONG ulInbufLength, ulOutbufLength, ulPipeMode, ulTimeout, rc;
+ STRLEN len;
+ char *s, buf[10], *s1, *perltype = NULL;
+ PerlIO *perlio;
+ double timeout;
+
+ if (!pszName || !*pszName)
+ Perl_croak(aTHX_ "OS2::pipe(): empty pipe name");
+ s = SvPV(OpenMode, len);
+ if (len == 4 && strEQ(s, "wait")) { /* DosWaitNPipe() */
+ ULONG ms = 0xFFFFFFFF, ret = ERROR_INTERRUPT; /* Indefinite */
+
+ if (items == 3) {
+ timeout = (double)SvNV(ST(2));
+ ms = timeout * 1000;
+ if (timeout < 0)
+ ms = 0xFFFFFFFF; /* Indefinite */
+ else if (timeout && !ms)
+ ms = 1;
+ } else if (items > 3)
+ Perl_croak(aTHX_ "OS2::pipe(): too many arguments for wait-for-connect: %ld", (long)items);
+
+ while (ret == ERROR_INTERRUPT)
+ ret = DosWaitNPipe(pszName, ms); /* XXXX Update ms? */
+ os2cp_croak(ret, "DosWaitNPipe()");
+ XSRETURN_YES;
+ }
+ if (len == 4 && strEQ(s, "call")) { /* DosCallNPipe() */
+ ULONG ms = 0xFFFFFFFF, got; /* Indefinite */
+ STRLEN l;
+ char *s;
+ char buf[8192];
+ STRLEN ll = sizeof(buf);
+ char *b = buf;
+
+ if (items < 3 || items > 5)
+ Perl_croak(aTHX_ "usage: OS2::pipe(pszName, 'call', write [, timeout= 0xFFFFFFFF, buffsize = 8192])");
+ s = SvPV(ST(2), l);
+ if (items >= 4) {
+ timeout = (double)SvNV(ST(3));
+ ms = timeout * 1000;
+ if (timeout < 0)
+ ms = 0xFFFFFFFF; /* Indefinite */
+ else if (timeout && !ms)
+ ms = 1;
+ }
+ if (items >= 5) {
+ STRLEN lll = SvUV(ST(4));
+ SV *sv = NEWSV(914, lll);
+
+ sv_2mortal(sv);
+ ll = lll;
+ b = SvPVX(sv);
+ }
+
+ os2cp_croak(DosCallNPipe(pszName, s, l, b, ll, &got, ms),
+ "DosCallNPipe()");
+ XSRETURN_PVN(b, got);
+ }
+ s1 = buf;
+ if (len && len <= 3 && !(*s >= '0' && *s <= '9')) {
+ int r, w, R, W;
+
+ r = strchr(s, 'r') != 0;
+ w = strchr(s, 'w') != 0;
+ R = strchr(s, 'R') != 0;
+ W = strchr(s, 'W') != 0;
+ b = strchr(s, 'b') != 0;
+ if (r + w + R + W + b != len || (r && R) || (w && W))
+ Perl_croak(aTHX_ "OS2::pipe(): unknown OpenMode argument: `%s'", s);
+ if ((r || R) && (w || W))
+ ulOpenMode = NP_INHERIT | NP_NOWRITEBEHIND | NP_ACCESS_DUPLEX;
+ else if (r || R)
+ ulOpenMode = NP_INHERIT | NP_NOWRITEBEHIND | NP_ACCESS_INBOUND;
+ else
+ ulOpenMode = NP_INHERIT | NP_NOWRITEBEHIND | NP_ACCESS_OUTBOUND;
+ if (R)
+ message = message_r = 1;
+ if (W)
+ message = 1;
+ else if (w && R)
+ Perl_croak(aTHX_ "OS2::pipe(): can't have message read mode for non-message pipes");
+ } else
+ ulOpenMode = (ULONG)SvUV(OpenMode); /* ST(1) */
+
+ if ( (ulOpenMode & 0x3) == NP_ACCESS_DUPLEX
+ || (ulOpenMode & 0x3) == NP_ACCESS_INBOUND )
+ *s1++ = 'r';
+ if ( (ulOpenMode & 0x3) == NP_ACCESS_DUPLEX )
+ *s1++ = '+';
+ if ( (ulOpenMode & 0x3) == NP_ACCESS_OUTBOUND )
+ *s1++ = 'w';
+ if (b)
+ *s1++ = 'b';
+ *s1 = 0;
+ if ( (ulOpenMode & 0x3) == NP_ACCESS_DUPLEX )
+ perltype = "+<&";
+ else if ( (ulOpenMode & 0x3) == NP_ACCESS_OUTBOUND )
+ perltype = ">&";
+ else
+ perltype = "<&";
+
+ if (items < 3)
+ connect = -1; /* no wait */
+ else if (SvTRUE(ST(2))) {
+ s = SvPV(ST(2), len);
+ if (len == 6 && strEQ(s, "nowait"))
+ connect = -1; /* no wait */
+ else if (len == 4 && strEQ(s, "wait"))
+ connect = 1; /* wait */
+ else
+ Perl_croak(aTHX_ "OS2::pipe(): unknown connect argument: `%s'", s);
+ }
+
+ if (items < 4)
+ count = 1;
+ else
+ count = (int)SvIV(ST(3));
+
+ if (items < 5)
+ ulInbufLength = 8192;
+ else
+ ulInbufLength = (ULONG)SvUV(ST(4));
+
+ if (items < 6)
+ ulOutbufLength = ulInbufLength;
+ else
+ ulOutbufLength = (ULONG)SvUV(ST(5));
+
+ if (count < -1 || count == 0 || count >= 255)
+ Perl_croak(aTHX_ "OS2::pipe(): count should be -1 or between 1 and 254: %ld", (long)count);
+ if (count < 0 )
+ count = 255; /* Unlimited */
+
+ ulPipeMode = count;
+ if (items < 7)
+ ulPipeMode |= (NP_WAIT
+ | (message ? NP_TYPE_MESSAGE : NP_TYPE_BYTE)
+ | (message_r ? NP_READMODE_MESSAGE : NP_READMODE_BYTE));
+ else
+ ulPipeMode |= (ULONG)SvUV(ST(6));
+
+ if (items < 8)
+ timeout = 0;
+ else
+ timeout = (double)SvNV(ST(7));
+ ulTimeout = timeout * 1000;
+ if (timeout < 0)
+ ulTimeout = 0xFFFFFFFF; /* Indefinite */
+ else if (timeout && !ulTimeout)
+ ulTimeout = 1;
+
+ RETVAL = DosCreateNPipe(pszName, &hpipe, ulOpenMode, ulPipeMode, ulInbufLength, ulOutbufLength, ulTimeout);
+ if (CheckOSError(RETVAL))
+ croak_with_os2error("OS2::pipe(): DosCreateNPipe() error");
+
+ if (connect)
+ connectNPipe(hpipe, connect, 1, 0); /* XXXX wait, retval */
+ hpipe = __imphandle(hpipe);
+
+ perlio = PerlIO_fdopen(hpipe, buf);
+ ST(0) = sv_newmortal();
+ {
+ GV *gv = newGVgen("OS2::pipe");
+ if ( do_open(gv, perltype, strlen(perltype), FALSE, 0, 0, perlio) )
+ sv_setsv(ST(0), sv_bless(newRV((SV*)gv), gv_stashpv("IO::Handle",1)));
+ else
+ ST(0) = &PL_sv_undef;
+ }
+ }
+ XSRETURN(1);
+}
+
+XS(XS_OS2_pipeCntl); /* prototype to pass -Wmissing-prototypes */
+XS(XS_OS2_pipeCntl)
+{
+ dXSARGS;
+ if (items < 2 || items > 3)
+ Perl_croak(aTHX_ "Usage: OS2::pipeCntl(pipe, op [, wait])");
+ {
+ ULONG rc;
+ PerlIO *perlio = IoIFP(sv_2io(ST(0)));
+ IV fn = PerlIO_fileno(perlio);
+ HPIPE hpipe = (HPIPE)fn;
+ STRLEN len;
+ char *s = SvPV(ST(1), len);
+ int wait = 0, disconnect = 0, connect = 0, message = -1, query = 0;
+ int peek = 0, state = 0, info = 0;
+
+ if (fn < 0)
+ Perl_croak(aTHX_ "OS2::pipeCntl(): not a pipe");
+ if (items == 3)
+ wait = (SvTRUE(ST(2)) ? 1 : -1);
+
+ switch (len) {
+ case 4:
+ if (strEQ(s, "byte"))
+ message = 0;
+ else if (strEQ(s, "peek"))
+ peek = 1;
+ else if (strEQ(s, "info"))
+ info = 1;
+ else
+ goto unknown;
+ break;
+ case 5:
+ if (strEQ(s, "reset"))
+ disconnect = connect = 1;
+ else if (strEQ(s, "state"))
+ query = 1;
+ else
+ goto unknown;
+ break;
+ case 7:
+ if (strEQ(s, "connect"))
+ connect = 1;
+ else if (strEQ(s, "message"))
+ message = 1;
+ else
+ goto unknown;
+ break;
+ case 9:
+ if (!strEQ(s, "readstate"))
+ goto unknown;
+ state = 1;
+ break;
+ case 10:
+ if (!strEQ(s, "disconnect"))
+ goto unknown;
+ disconnect = 1;
+ break;
+ default:
+ unknown:
+ Perl_croak(aTHX_ "OS2::pipeCntl(): unknown argument: `%s'", s);
+ break;
+ }
+
+ if (items == 3 && !connect)
+ Perl_croak(aTHX_ "OS2::pipeCntl(): no wait argument for `%s'", s);
+
+ XSprePUSH; /* Do not need arguments any more */
+ if (disconnect) {
+ os2cp_croak(DosDisConnectNPipe(hpipe), "OS2::pipeCntl(): DosDisConnectNPipe()");
+ PerlIO_clearerr(perlio);
+ }
+ if (connect) {
+ if (!connectNPipe(hpipe, wait , 1, 0))
+ XSRETURN_IV(-1);
+ }
+ if (query) {
+ ULONG flags;
+
+ os2cp_croak(DosQueryNPHState(hpipe, &flags), "DosQueryNPHState()");
+ XSRETURN_UV(flags);
+ }
+ if (peek || state || info) {
+ ULONG BytesRead, PipeState;
+ AVAILDATA BytesAvail;
+
+ os2cp_croak( DosPeekNPipe(hpipe, NULL, 0, &BytesRead, &BytesAvail,
+ &PipeState), "DosPeekNPipe() for state");
+ if (state) {
+ EXTEND(SP, 3);
+ mPUSHu(PipeState);
+ /* Bytes (available/in-message) */
+ mPUSHi(BytesAvail.cbpipe);
+ mPUSHi(BytesAvail.cbmessage);
+ XSRETURN(3);
+ } else if (info) {
+ /* L S S C C C/Z*
+ ID of the (remote) computer
+ buffers (out/in)
+ instances (max/actual)
+ */
+ struct pipe_info_t {
+ ULONG id; /* char id[4]; */
+ PIPEINFO pInfo;
+ char buf[512];
+ } b;
+ int size;
+
+ os2cp_croak( DosQueryNPipeInfo(hpipe, 1, &b.pInfo, sizeof(b) - STRUCT_OFFSET(struct pipe_info_t, pInfo)),
+ "DosQueryNPipeInfo(1)");
+ os2cp_croak( DosQueryNPipeInfo(hpipe, 2, &b.id, sizeof(b.id)),
+ "DosQueryNPipeInfo(2)");
+ size = b.pInfo.cbName;
+ /* Trailing 0 is included in cbName - undocumented; so
+ one should always extract with Z* */
+ if (size) /* name length 254 or less */
+ size--;
+ else
+ size = strlen(b.pInfo.szName);
+ EXTEND(SP, 6);
+ mPUSHp(b.pInfo.szName, size);
+ mPUSHu(b.id);
+ mPUSHi(b.pInfo.cbOut);
+ mPUSHi(b.pInfo.cbIn);
+ mPUSHi(b.pInfo.cbMaxInst);
+ mPUSHi(b.pInfo.cbCurInst);
+ XSRETURN(6);
+ } else if (BytesAvail.cbpipe == 0) {
+ XSRETURN_NO;
+ } else {
+ SV *tmp = NEWSV(914, BytesAvail.cbpipe);
+ char *s = SvPVX(tmp);
+
+ sv_2mortal(tmp);
+ os2cp_croak( DosPeekNPipe(hpipe, s, BytesAvail.cbpipe, &BytesRead,
+ &BytesAvail, &PipeState), "DosPeekNPipe()");
+ SvCUR_set(tmp, BytesRead);
+ *SvEND(tmp) = 0;
+ SvPOK_on(tmp);
+ XSprePUSH; PUSHs(tmp);
+ XSRETURN(1);
+ }
+ }
+ if (message > -1) {
+ ULONG oflags, flags;
+
+ os2cp_croak(DosQueryNPHState(hpipe, &oflags), "DosQueryNPHState()");
+ /* DosSetNPHState fails if more bits than NP_NOWAIT|NP_READMODE_MESSAGE */
+ oflags &= (NP_NOWAIT | NP_READMODE_MESSAGE);
+ flags = (oflags & NP_NOWAIT)
+ | (message ? NP_READMODE_MESSAGE : NP_READMODE_BYTE);
+ if (flags != oflags)
+ os2cp_croak(DosSetNPHState(hpipe, flags), "DosSetNPHState()");
+ }
+ }
+ XSRETURN_YES;
+}
+
+/*
+NO_OUTPUT ULONG
+DosOpen(PCSZ pszFileName, OUTLIST HFILE hFile, OUTLIST ULONG ulAction, ULONG ulOpenFlags, ULONG ulOpenMode = OPEN_ACTION_OPEN_IF_EXISTS | OPEN_ACTION_FAIL_IF_NEW, ULONG ulAttribute = FILE_NORMAL, ULONG ulFileSize = 0, PEAOP2 pEABuf = NULL);
+ PREINIT:
+ ULONG rc;
+ C_ARGS:
+ pszFileName, &hFile, &ulAction, ulFileSize, ulAttribute, ulOpenFlags, ulOpenMode, pEABuf
+ POSTCALL:
+ if (CheckOSError(RETVAL))
+ croak_with_os2error("OS2::open() error");
+*/
+XS(XS_OS2_open); /* prototype to pass -Wmissing-prototypes */
+XS(XS_OS2_open)
+{
+ dXSARGS;
+ if (items < 2 || items > 6)
+ Perl_croak(aTHX_ "Usage: OS2::open(pszFileName, ulOpenMode, ulOpenFlags= OPEN_ACTION_OPEN_IF_EXISTS | OPEN_ACTION_FAIL_IF_NEW, ulAttribute= FILE_NORMAL, ulFileSize= 0, pEABuf= NULL)");
+ {
+#line 39 "pipe.xs"
+ ULONG rc;
+#line 113 "pipe.c"
+ ULONG RETVAL;
+ PCSZ pszFileName = ( SvOK(ST(0)) ? (PCSZ)SvPV_nolen(ST(0)) : NULL );
+ HFILE hFile;
+ ULONG ulAction;
+ ULONG ulOpenMode = (ULONG)SvUV(ST(1));
+ ULONG ulOpenFlags;
+ ULONG ulAttribute;
+ ULONG ulFileSize;
+ PEAOP2 pEABuf;
+
+ if (items < 3)
+ ulOpenFlags = OPEN_ACTION_OPEN_IF_EXISTS | OPEN_ACTION_FAIL_IF_NEW;
+ else {
+ ulOpenFlags = (ULONG)SvUV(ST(2));
+ }
+
+ if (items < 4)
+ ulAttribute = FILE_NORMAL;
+ else {
+ ulAttribute = (ULONG)SvUV(ST(3));
+ }
+
+ if (items < 5)
+ ulFileSize = 0;
+ else {
+ ulFileSize = (ULONG)SvUV(ST(4));
+ }
+
+ if (items < 6)
+ pEABuf = NULL;
+ else {
+ pEABuf = (PEAOP2)SvUV(ST(5));
+ }
+
+ RETVAL = DosOpen(pszFileName, &hFile, &ulAction, ulFileSize, ulAttribute, ulOpenFlags, ulOpenMode, pEABuf);
+ if (CheckOSError(RETVAL))
+ croak_with_os2error("OS2::open() error");
+ XSprePUSH; EXTEND(SP,2);
+ PUSHs(sv_newmortal());
+ sv_setuv(ST(0), (UV)hFile);
+ PUSHs(sv_newmortal());
+ sv_setuv(ST(1), (UV)ulAction);
+ }
+ XSRETURN(2);
+}
+