PerlIO for VMS

Message-Id: <a05100e0ab734816701a5@[172.16.52.1]>

p4raw-id: //depot/perl@10218

diff --git a/configure.com b/configure.com
index 209f4ec..3beba69 100644 (file)
--- a/configure.com
+++ b/configure.com
@@ -4672,7 +4672,7 @@ $   d_locconv="undef"
 $   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

diff --git a/doio.c b/doio.c
index 87e5901..dd840f6 100644 (file)
--- a/doio.c
+++ b/doio.c
@@ -566,7 +566,7 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
 #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 @@ Perl_start_glob (pTHX_ SV *tmpglob, IO *io)
        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 @@ Perl_start_glob (pTHX_ SV *tmpglob, IO *io)
           ((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 @@ Perl_start_glob (pTHX_ SV *tmpglob, IO *io)
                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);

diff --git a/iperlsys.h b/iperlsys.h
index 6c093dd..237fab2 100644 (file)
--- a/iperlsys.h
+++ b/iperlsys.h
@@ -303,7 +303,17 @@ struct IPerlStdIOInfo
 #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)

diff --git a/perlio.c b/perlio.c
index bf628b2..5a9ce2c 100644 (file)
--- a/perlio.c
+++ b/perlio.c
@@ -3647,8 +3647,14 @@ char *
 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;
 }
 
 

diff --git a/perlio.h b/perlio.h
index 914aa4d..ebacfeb 100644 (file)
--- a/perlio.h
+++ b/perlio.h
@@ -237,6 +237,9 @@ extern void PerlIO_releaseFILE      (PerlIO *,FILE *);
 #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 @@ extern int  PerlIO_apply_layers     (pTHX_ PerlIO *f, const char *mode, const char *n
 #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);
 

diff --git a/perliol.h b/perliol.h
index de87547..0bdff47 100644 (file)
--- a/perliol.h
+++ b/perliol.h
@@ -115,8 +115,6 @@ extern SSize_t      PerlIOBase_unread    (PerlIO *f, const void *vbuf, Size_t count);
 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);

diff --git a/perlsdio.h b/perlsdio.h
index fd990c0..da45c32 100644 (file)
--- a/perlsdio.h
+++ b/perlsdio.h
@@ -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

diff --git a/vms/ext/Stdio/Stdio.xs b/vms/ext/Stdio/Stdio.xs
index d82b17d..9b61c59 100644 (file)
--- a/vms/ext/Stdio/Stdio.xs
+++ b/vms/ext/Stdio/Stdio.xs
@@ -81,7 +81,7 @@ IV *pval;
 
 
 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 @@ binmode(fh)
        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 @@ binmode(fh)
            /* 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 @@ binmode(fh)
                   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 @@ binmode(fh)
                                 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 @@ setdef(...)
 
 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 @@ vmsopen(spec,...)
            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 @@ vmsopen(spec,...)
                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 @@ vmssysopen(spec,mode,perm,...)
            char *args[8];
            int i, myargc, fd;
            FILE *fp;
+           PerlIO *pio_fp;
            SV *fh;
            STRLEN n_a;
            if (!spec || !*spec) {
@@ -391,18 +402,21 @@ vmssysopen(spec,mode,perm,...)
            }
            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 @@ writeof(mysv)
            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);

diff --git a/vms/gen_shrfls.pl b/vms/gen_shrfls.pl
index 48499d4..d393b0f 100644 (file)
--- a/vms/gen_shrfls.pl
+++ b/vms/gen_shrfls.pl
@@ -39,7 +39,7 @@ require 5.000;
 
 $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 @@ if ($docc) {
   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 @@ if ($docc) {
     $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 @@ sub scan_func {
   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 @@ if ($use_mymalloc) {
   $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 @@ LINE: while (<CPP>) {
     # 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;

diff --git a/vms/vms.c b/vms/vms.c
index 136da27..581e7d4 100644 (file)
--- a/vms/vms.c
+++ b/vms/vms.c
@@ -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 @@ safe_popen(pTHX_ char *cmd, char *mode)
 }  /* 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 @@ Perl_my_popen(pTHX_ char *cmd, char *mode)
 
 /*}}}*/
 
-/*{{{  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 @@ I32 Perl_my_pclose(pTHX_ FILE *fp)
      *  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 @@ mp_getredirection(pTHX_ int *ac, char ***av)
        /* 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 @@ mp_getredirection(pTHX_ int *ac, char ***av)
 
     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 @@ mp_getredirection(pTHX_ int *ac, char ***av)
            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 @@ int my_fclose(FILE *fp) {
  * 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 @@ candelete_fromperl(pTHX_ CV *cv)
 
   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 @@ rmscopy_fromperl(pTHX_ CV *cv)
 
   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 @@ rmscopy_fromperl(pTHX_ CV *cv)
   }
   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);

diff --git a/vms/vmsish.h b/vms/vmsish.h
index 2eb8e93..a1f7630 100644 (file)
--- a/vms/vmsish.h
+++ b/vms/vmsish.h
@@ -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_aspawn (pTHX_ void *, void **, void **);
 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);