I finally got this working and have included a patch against perl@10176 at
the end of this message. All my testing was done with Compaq C V6.4-005 on
OpenVMS Alpha V7.2-1, so if someone has an opportunity to test on other
flavors of VMS please do. I'll probably send this along to p5p in a day or
two but thought I would give folks one last chance to comment, critique,
fix, etc.
The test suite looks identical before and after the patch with -Uuseperlio:
[.lib]b-deparse.........FAILED on test 2
[.lib]b-showlex.........FAILED on test 1
[.lib]sigaction.........FAILED on test 13
[.lib]u-tainted.........FAILED on test 3
With -Duseperlio after the patch those four failures are unchanged plus
there is one additional one:
[.op]misc...............FAILED on test 49
A brief description of my changes:
o configure.com -- set d_stdio_ptr_lval_nochange_cnt to "define"; for now
I have not made useperlio the default nor removed the word "experimental"
from the useperlio configuration question.
o doio.c -- changed a couple of stdio calls to PerlIO_* equivalents in
VMS-specific sections.
o iperlsys.h -- borrowed some VMS-specific ungetc shenanigans from perlsdio.h.
o perlio.c -- implemented PerlIO_getname() (for VMS only).
o perlio.h -- added missing prototypes for PerlIO_unread() and
PerlIO_getname().
o perliol.h -- removed 2 prototypes for nonexistent functions to avoid link
errors.
o perlsdio.h -- placeholder for PerlIO_unread to prevent link error in
-Uuseperlio case.
o vms/gen_shrfls.pl -- collect external symbols from perliol.h for creation
of the PerlShr shareable image (but only with -Duseperlio configure).
o vms/vms.c -- changed various FILE objects and stdio calls to PerlIO
objects and PerlIO calls and vice versa depending on context.
o vms/vmsish.h -- make my_fwrite visible to and compatible with
PerlSIO_fwrite; make low-level status checker output to stderr rather than
Perl_debug_log.
o vms/ext/Stdio/Stdio.xs -- now talk to outside world using PerlIO rather
than FILE objects.
and the patch:
--- configure.com;-0 Tue May 15 09:58:06 2001
+++ configure.com Tue May 22 13:21:50 2001
@@ -4672,7 +4672,7 @@
$ d_setlocale="undef"
$ ENDIF
$ d_stdio_ptr_lval_sets_cnt="undef"
-$ d_stdio_ptr_lval_nochange_cnt="undef"
+$ d_stdio_ptr_lval_nochange_cnt="define"
$!
$! Sockets?
$ if Has_Socketshr .OR. Has_Dec_C_Sockets
--- doio.c;-0 Sun May 20 17:13:36 2001
+++ doio.c Tue May 22 13:21:51 2001
@@ -566,7 +566,7 @@
#ifdef VMS
if (savefd != PerlIO_fileno(PerlIO_stdin())) {
char newname[FILENAME_MAX+1];
- if (fgetname(fp, newname)) {
+ if (PerlIO_getname(fp, newname)) {
if (fd == PerlIO_fileno(PerlIO_stdout())) Perl_vmssetuserlnm(aTHX_
"SYS$OUTPUT", newname);
if (fd == PerlIO_fileno(PerlIO_stderr())) Perl_vmssetuserlnm(aTHX_
"SYS$ERROR", newname);
}
@@ -2103,7 +2103,6 @@
char rslt[NAM$C_MAXRSS+1+sizeof(unsigned short int)] = {'\0','\0'};
char vmsspec[NAM$C_MAXRSS+1];
char *rstr = rslt + sizeof(unsigned short int), *begin, *end, *cp;
- char tmpfnam[L_tmpnam] = "SYS$SCRATCH:";
$DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
PerlIO *tmpfp;
STRLEN i;
@@ -2118,7 +2117,6 @@
((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
but that's unsupported, so I don't want to do it now and
have it bite someone in the future. */
- strcat(tmpfnam,PerlLIO_tmpnam(NULL));
cp = SvPV(tmpglob,i);
for (; i; i--) {
if (cp[i] == ';') hasver = 1;
@@ -2135,7 +2133,7 @@
break;
}
}
- if ((tmpfp = PerlIO_open(tmpfnam,"w+","fop=dlt")) != NULL) {
+ if ((tmpfp = PerlIO_tmpfile()) != NULL) {
Stat_t st;
if (!PerlLIO_stat(SvPVX(tmpglob),&st) && S_ISDIR(st.st_mode))
ok = ((wilddsc.dsc$a_pointer = tovmspath(SvPVX(tmpglob),vmsspec)) !=
NULL);
--- iperlsys.h;-0 Sat Mar 24 09:55:30 2001
+++ iperlsys.h Tue May 22 13:21:51 2001
@@ -303,7 +303,17 @@
#define PerlSIO_fputs(f,s) fputs(s,f)
#define PerlSIO_fflush(f) Fflush(f)
#define PerlSIO_fgets(s, n, fp) fgets(s,n,fp)
-#define PerlSIO_ungetc(c,f) ungetc(c,f)
+#if defined(VMS) && defined(__DECC)
+ /* Unusual definition of ungetc() here to accomodate fast_sv_gets()'
+ * belief that it can mix getc/ungetc with reads from stdio buffer */
+ int decc$ungetc(int __c, FILE *__stream);
+# define PerlSIO_ungetc(c,f) ((c) == EOF ? EOF : \
+ ((*(f) && !((*(f))->_flag & _IONBF) && \
+ ((*(f))->_ptr > (*(f))->_base)) ? \
+ ((*(f))->_cnt++, *(--(*(f))->_ptr) = (c)) : decc$ungetc(c,f)))
+#else
+# define PerlSIO_ungetc(c,f) ungetc(c,f)
+#endif
#define PerlSIO_fileno(f) fileno(f)
#define PerlSIO_fdopen(f, s) fdopen(f,s)
#define PerlSIO_freopen(p, m, f) freopen(p,m,f)
--- perlio.c;-0 Sun May 20 08:20:00 2001
+++ perlio.c Tue May 22 13:21:52 2001
@@ -3647,8 +3647,14 @@
PerlIO_getname(PerlIO *f, char *buf)
{
dTHX;
+ char *name = NULL;
+#ifdef VMS
+ FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
+ if (stdio) name = fgetname(stdio, buf);
+#else
Perl_croak(aTHX_ "Don't know how to get file name");
- return NULL;
+#endif
+ return name;
}
--- perlio.h;-0 Thu Mar 29 09:01:15 2001
+++ perlio.h Tue May 22 13:21:53 2001
@@ -237,6 +237,9 @@
#ifndef PerlIO_read
extern SSize_t PerlIO_read (PerlIO *,void *,Size_t);
#endif
+#ifndef PerlIO_unread
+extern SSize_t PerlIO_unread (PerlIO *,const void *,Size_t);
+#endif
#ifndef PerlIO_write
extern SSize_t PerlIO_write (PerlIO *,const void *,Size_t);
#endif
@@ -326,6 +329,9 @@
#ifndef PerlIO_binmode
extern int PerlIO_binmode (pTHX_ PerlIO *f, int iotype, int omode, const
char *names);
#endif
+#ifndef PerlIO_getname
+extern char * PerlIO_getname (PerlIO *, char *);
+#endif
extern void PerlIO_destruct(pTHX);
--- perliol.h;-0 Mon Mar 26 12:35:15 2001
+++ perliol.h Tue May 22 13:21:53 2001
@@ -115,8 +115,6 @@
extern IV PerlIOBase_eof (PerlIO *f);
extern IV PerlIOBase_error (PerlIO *f);
extern void PerlIOBase_clearerr (PerlIO *f);
-extern IV PerlIOBase_flush (PerlIO *f);
-extern IV PerlIOBase_fill (PerlIO *f);
extern IV PerlIOBase_close (PerlIO *f);
extern void PerlIOBase_setlinebuf(PerlIO *f);
extern void PerlIOBase_flush_linebuf(void);
--- perlsdio.h;-0 Mon Mar 5 20:06:19 2001
+++ perlsdio.h Tue May 22 16:42:36 2001
@@ -15,6 +15,7 @@
#define PerlIO_stdoutf printf
#define PerlIO_vprintf(f,fmt,a) vfprintf(f,fmt,a)
#define PerlIO_write(f,buf,count) fwrite1(buf,1,count,f)
+#define PerlIO_unread(f,buf,count) (-1)
#define PerlIO_open fopen
#define PerlIO_fdopen fdopen
#define PerlIO_reopen freopen
--- vms/gen_shrfls.pl;-0 Mon Mar 5 20:07:27 2001
+++ vms/gen_shrfls.pl Tue May 22 14:51:50 2001
@@ -39,7 +39,7 @@
$debug = $ENV{'GEN_SHRFLS_DEBUG'};
-print "gen_shrfls.pl Rev. 14-Dec-1997\n" if $debug;
+print "gen_shrfls.pl Rev. 18-May-2001\n" if $debug;
if ($ARGV[0] eq '-f') {
open(INP,$ARGV[1]) or die "Can't read input file $ARGV[1]: $!\n";
@@ -69,7 +69,7 @@
else { die "$0: Can't find perl.h\n"; }
$use_threads = $use_mymalloc = $case_about_case = $debugging_enabled = 0;
- $hide_mymalloc = $isgcc = 0;
+ $hide_mymalloc = $isgcc = $use_perlio = 0;
# Go see what is enabled in config.sh
$config = $dir . "config.sh";
@@ -81,6 +81,7 @@
$debugging_enabled++ if /usedebugging_perl='Y'/;
$hide_mymalloc++ if /embedmymalloc='Y'/;
$isgcc++ if /gccversion='[^']/;
+ $use_perlio++ if /useperlio='define'/;
}
close CONFIG;
@@ -147,6 +148,7 @@
my($line) = @_;
print "\tchecking for global routine\n" if $debug > 1;
+ $line =~ s/\b(IV|Off_t|Size_t|SSize_t|void)\b//i;
if ( $line =~ /(\w+)\s*\(/ ) {
print "\troutine name is \\$1\\\n" if $debug > 1;
if ($1 eq 'main' || $1 eq 'perl_init_ext') {
@@ -164,10 +166,16 @@
$fcns{'Perl_mfree'}++;
}
+if ($use_perlio) {
+ $preprocess_list = "${dir}perl.h,${dir}perliol.h";
+} else {
+ $preprocess_list = "${dir}perl.h";
+}
+
$used_expectation_enum = $used_opcode_enum = 0; # avoid warnings
if ($docc) {
- open(CPP,"${cc_cmd}/NoObj/PreProc=Sys\$Output ${dir}perl.h|")
- or die "$0: Can't preprocess ${dir}perl.h: $!\n";
+ open(CPP,"${cc_cmd}/NoObj/PreProc=Sys\$Output $preprocess_list|")
+ or die "$0: Can't preprocess $preprocess_list: $!\n";
}
else {
open(CPP,"$cpp_file") or die "$0: Can't read preprocessed file $cpp_file: $!\n";
@@ -198,6 +206,7 @@
# Pull name from library module or header filespec
$spec =~ /^(\w+)$/ or $spec =~ /(\w+)\.h/i;
my $name = lc $1;
+ $name = 'perlio' if $name eq 'perliol';
$ckfunc = exists $checkh{$name} ? 1 : 0;
$scanname = $name if $ckfunc;
print "Header file transition: ckfunc = $ckfunc for $name.h\n" if $debug > 1;
--- vms/vms.c;-0 Wed May 2 15:30:16 2001
+++ vms/vms.c Tue May 22 13:21:55 2001
@@ -49,6 +49,9 @@
# define SS$_NOSUCHOBJECT 2696
#endif
+/* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
+#define PERLIO_NOT_STDIO 0
+
/* Don't replace system definitions of vfork, getenv, and stat,
* code below needs to get to the underlying CRTL routines. */
#define DONT_MASK_RTL_CALLS
@@ -2184,8 +2187,8 @@
} /* end of safe_popen */
-/*{{{ FILE *my_popen(char *cmd, char *mode)*/
-FILE *
+/*{{{ PerlIO *my_popen(char *cmd, char *mode)*/
+PerlIO *
Perl_my_popen(pTHX_ char *cmd, char *mode)
{
TAINT_ENV();
@@ -2196,8 +2199,8 @@
/*}}}*/
-/*{{{ I32 my_pclose(FILE *fp)*/
-I32 Perl_my_pclose(pTHX_ FILE *fp)
+/*{{{ I32 my_pclose(PerlIO *fp)*/
+I32 Perl_my_pclose(pTHX_ PerlIO *fp)
{
pInfo info, last = NULL;
unsigned long int retsts;
@@ -2220,7 +2223,7 @@
* the first EOF closing the pipe (and DASSGN'ing the channel)...
*/
- fsync(fileno(info->fp)); /* first, flush data */
+ PerlIO_flush(info->fp); /* first, flush data */
_ckvmssts(sys$setast(0));
info->closing = TRUE;
@@ -3620,7 +3623,7 @@
/* Input from a pipe, reopen it in binary mode to disable */
/* carriage control processing. */
- PerlIO_getname(stdin, mbxname);
+ fgetname(stdin, mbxname);
mbxnam.dsc$a_pointer = mbxname;
mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
@@ -3652,7 +3655,7 @@
if (err != NULL) {
if (strcmp(err,"&1") == 0) {
- dup2(fileno(stdout), fileno(Perl_debug_log));
+ dup2(fileno(stdout), fileno(stderr));
Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
} else {
FILE *tmperr;
@@ -3662,7 +3665,7 @@
exit(vaxc$errno);
}
fclose(tmperr);
- if (NULL == freopen(err, "a", Perl_debug_log, "mbc=32", "mbf=2"))
+ if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
{
exit(vaxc$errno);
}
@@ -4847,9 +4850,9 @@
* data with nulls sprinkled in the middle but also data with no null
* byte at the end.
*/
-/*{{{ int my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)*/
+/*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
int
-my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)
+my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
{
register char *cp, *end, *cpd, *data;
register unsigned int fd = fileno(dest);
@@ -6577,7 +6580,7 @@
mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
if (SvTYPE(mysv) == SVt_PVGV) {
- if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),fspec,1)) {
+ if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
ST(0) = &PL_sv_no;
XSRETURN(1);
@@ -6614,7 +6617,7 @@
mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
if (SvTYPE(mysv) == SVt_PVGV) {
- if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),inspec,1)) {
+ if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
ST(0) = &PL_sv_no;
XSRETURN(1);
@@ -6630,7 +6633,7 @@
}
mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
if (SvTYPE(mysv) == SVt_PVGV) {
- if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),outspec,1)) {
+ if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
ST(0) = &PL_sv_no;
XSRETURN(1);
--- vms/vmsish.h;-0 Fri May 4 23:03:10 2001
+++ vms/vmsish.h Tue May 22 13:21:56 2001
@@ -310,7 +310,7 @@
#define _ckvmssts_noperl(call) STMT_START { register unsigned long int __ckvms_sts; \
if (!((__ckvms_sts=(call))&1)) { \
set_errno(EVMSERR); set_vaxc_errno(__ckvms_sts); \
- fprintf(Perl_debug_log,"Fatal VMS error (status=%d) at %s, line %d", \
+ fprintf(stderr,"Fatal VMS error (status=%d) at %s, line %d", \
__ckvms_sts,__FILE__,__LINE__); lib$signal(__ckvms_sts); } } STMT_END
#ifdef VMS_DO_SOCKETS
@@ -411,6 +411,7 @@
#ifndef DONT_MASK_RTL_CALLS
+# define fwrite my_fwrite /* for PerlSIO_fwrite */
# define fdopen my_fdopen
# define fclose my_fclose
#endif
@@ -774,7 +775,7 @@
unsigned long int Perl_do_spawn (pTHX_ char *);
FILE * my_fdopen (int, const char *);
int my_fclose (FILE *);
-int my_fwrite (void *, size_t, size_t, FILE *);
+int my_fwrite (const void *, size_t, size_t, FILE *);
int Perl_my_flush (pTHX_ FILE *);
struct passwd * Perl_my_getpwnam (pTHX_ char *name);
struct passwd * Perl_my_getpwuid (pTHX_ Uid_t uid);
--- vms/ext/Stdio/Stdio.xs;-0 Mon Mar 5 20:07:26 2001
+++ vms/ext/Stdio/Stdio.xs Tue May 22 13:21:56 2001
@@ -81,7 +81,7 @@
static SV *
-newFH(FILE *fp, char type) {
+newFH(PerlIO *fp, char type) {
SV *rv;
GV **stashp, *gv = (GV *)NEWSV(0,0);
HV *stash;
@@ -129,15 +129,15 @@
PROTOTYPE: $
CODE:
IO *io = sv_2io(fh);
- FILE *fp = io ? IoOFP(io) : NULL;
+ PerlIO *fp = io ? IoOFP(io) : NULL;
char iotype = io ? IoTYPE(io) : '\0';
char filespec[NAM$C_MAXRSS], *acmode, *s, *colon, *dirend = Nullch;
int ret = 0, saverrno = errno, savevmserrno = vaxc$errno;
- fpos_t pos;
+ SV pos;
if (fp == NULL || strchr(">was+-|",iotype) == Nullch) {
set_errno(EBADF); set_vaxc_errno(SS$_IVCHAN); XSRETURN_UNDEF;
}
- if (!fgetname(fp,filespec)) XSRETURN_UNDEF;
+ if (!PerlIO_getname(fp,filespec)) XSRETURN_UNDEF;
for (s = filespec; *s; s++) {
if (*s == ':') colon = s;
else if (*s == ']' || *s == '>') dirend = s;
@@ -149,7 +149,7 @@
/* If we've got a non-file-structured device, clip off the trailing
* junk, and don't lose sleep if we can't get a stream position. */
if (dirend == Nullch) *(colon+1) = '\0';
- if (iotype != '-' && (ret = fgetpos(fp, &pos)) == -1 && dirend)
+ if (iotype != '-' && (ret = PerlIO_getpos(fp, &pos)) == -1 && dirend)
XSRETURN_UNDEF;
switch (iotype) {
case '<': case 'r': acmode = "rb"; break;
@@ -158,7 +158,7 @@
fsetpos below will take care of restoring file position */
case 'a': acmode = "ab"; break;
case '+': case 's': acmode = "rb+"; break;
- case '-': acmode = fileno(fp) ? "ab" : "rb"; break;
+ case '-': acmode = PerlIO_fileno(fp) ? "ab" : "rb";
+break;
/* iotype'll be null for the SYS$INPUT:/SYS$OUTPUT:/SYS$ERROR: files */
/* since we didn't really open them and can't really */
/* reopen them */
@@ -168,35 +168,41 @@
iotype, filespec);
acmode = "rb+";
}
- if (freopen(filespec,acmode,fp) == NULL) XSRETURN_UNDEF;
- if (iotype != '-' && ret != -1 && fsetpos(fp,&pos) == -1) XSRETURN_UNDEF;
+ /* appearances to the contrary, this is an freopen substitute */
+ SV *name = sv_2mortal(newSVpvn(filespec,strlen(filespec)));
+ if (PerlIO_openn(Nullch,acmode,-1,0,0,fp,1,&name) == Nullfp)
+XSRETURN_UNDEF;
+ if (iotype != '-' && ret != -1 && PerlIO_setpos(fp,&pos) == -1)
+XSRETURN_UNDEF;
if (ret == -1) { set_errno(saverrno); set_vaxc_errno(savevmserrno); }
XSRETURN_YES;
void
flush(fp)
- FILE * fp
+ PerlIO * fp
PROTOTYPE: $
CODE:
- if (fflush(fp)) { ST(0) = &PL_sv_undef; }
- else { clearerr(fp); ST(0) = &PL_sv_yes; }
+ FILE *stdio = PerlIO_exportFILE(fp,0);
+ if (fflush(stdio)) { ST(0) = &PL_sv_undef; }
+ else { clearerr(stdio); ST(0) = &PL_sv_yes; }
+ PerlIO_releaseFILE(fp,stdio);
char *
getname(fp)
- FILE * fp
+ PerlIO * fp
PROTOTYPE: $
CODE:
char fname[NAM$C_MAXRSS+1];
ST(0) = sv_newmortal();
- if (fgetname(fp,fname) != NULL) sv_setpv(ST(0),fname);
+ if (PerlIO_getname(fp,fname) != NULL) sv_setpv(ST(0),fname);
void
rewind(fp)
- FILE * fp
+ PerlIO * fp
PROTOTYPE: $
CODE:
- ST(0) = rewind(fp) ? &PL_sv_undef : &PL_sv_yes;
+ FILE *stdio = PerlIO_exportFILE(fp,0);
+ ST(0) = rewind(stdio) ? &PL_sv_undef : &PL_sv_yes;
+ PerlIO_releaseFILE(fp,stdio);
void
remove(name)
@@ -261,11 +267,13 @@
void
sync(fp)
- FILE * fp
+ PerlIO * fp
PROTOTYPE: $
CODE:
- if (fsync(fileno(fp))) { ST(0) = &PL_sv_undef; }
- else { clearerr(fp); ST(0) = &PL_sv_yes; }
+ FILE *stdio = PerlIO_exportFILE(fp,0);
+ if (fsync(fileno(stdio))) { ST(0) = &PL_sv_undef; }
+ else { clearerr(stdio); ST(0) = &PL_sv_yes; }
+ PerlIO_releaseFILE(fp,stdio);
char *
tmpnam()
@@ -283,6 +291,7 @@
char *args[8],mode[3] = {'r','\0','\0'}, type = '<';
register int i, myargc;
FILE *fp;
+ PerlIO *pio_fp;
STRLEN n_a;
if (!spec || !*spec) {
@@ -333,8 +342,9 @@
fp =
fopen(spec,mode,args[0],args[1],args[2],args[3],args[4],args[5],args[6],args[7]);
break;
}
- if (fp != Nullfp) {
- SV *fh = newFH(fp,(mode[1] ? '+' : (mode[0] == 'r' ? '<' : (mode[0] ==
'a' ? 'a' : '>'))));
+ if (fp != Null(FILE*)) {
+ pio_fp = PerlIO_importFILE(fp,0);
+ SV *fh = newFH(pio_fp,(mode[1] ? '+' : (mode[0] == 'r' ? '<' : (mode[0]
+== 'a' ? 'a' : '>'))));
ST(0) = (fh ? sv_2mortal(fh) : &PL_sv_undef);
}
else { ST(0) = &PL_sv_undef; }
@@ -349,6 +359,7 @@
char *args[8];
int i, myargc, fd;
FILE *fp;
+ PerlIO *pio_fp;
SV *fh;
STRLEN n_a;
if (!spec || !*spec) {
@@ -391,18 +402,21 @@
}
i = mode & 3;
if (fd >= 0 &&
- ((fp = fdopen(fd, &("r\000w\000r+"[2*i]))) != Nullfp)) {
- SV *fh = newFH(fp,"<>++"[i]);
+ ((fp = fdopen(fd, &("r\000w\000r+"[2*i]))) != Null(FILE*))) {
+ pio_fp = PerlIO_importFILE(fp,0);
+ SV *fh = newFH(pio_fp,"<>++"[i]);
ST(0) = (fh ? sv_2mortal(fh) : &PL_sv_undef);
}
else { ST(0) = &PL_sv_undef; }
void
waitfh(fp)
- FILE * fp
+ PerlIO * fp
PROTOTYPE: $
CODE:
- ST(0) = fwait(fp) ? &PL_sv_undef : &PL_sv_yes;
+ FILE *stdio = PerlIO_exportFILE(fp,0);
+ ST(0) = fwait(stdio) ? &PL_sv_undef : &PL_sv_yes;
+ PerlIO_releaseFILE(fp,stdio);
void
writeof(mysv)
@@ -413,11 +427,11 @@
unsigned long int chan, iosb[2], retsts, retsts2;
struct dsc$descriptor devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, devnam};
IO *io = sv_2io(mysv);
- FILE *fp = io ? IoOFP(io) : NULL;
+ PerlIO *fp = io ? IoOFP(io) : NULL;
if (fp == NULL || strchr(">was+-|",IoTYPE(io)) == Nullch) {
set_errno(EBADF); set_vaxc_errno(SS$_IVCHAN); XSRETURN_UNDEF;
}
- if (fgetname(fp,devnam) == Nullch) { ST(0) = &PL_sv_undef; XSRETURN(1); }
+ if (PerlIO_getname(fp,devnam) == Nullch) { ST(0) = &PL_sv_undef;
+XSRETURN(1); }
if ((cp = strrchr(devnam,':')) != NULL) *(cp+1) = '\0';
devdsc.dsc$w_length = strlen(devnam);
retsts = sys$assign(&devdsc,&chan,0,0);
