summaryrefslogtreecommitdiff
path: root/vms
diff options
context:
space:
mode:
Diffstat (limited to 'vms')
-rw-r--r--vms/ext/Stdio/Stdio.xs66
-rw-r--r--vms/gen_shrfls.pl17
-rw-r--r--vms/vms.c29
-rw-r--r--vms/vmsish.h5
4 files changed, 72 insertions, 45 deletions
diff --git a/vms/ext/Stdio/Stdio.xs b/vms/ext/Stdio/Stdio.xs
index d82b17dbfa..9b61c590c0 100644
--- 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 48499d4a49..d393b0f0cc 100644
--- 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 136da276d3..581e7d4d9e 100644
--- 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 2eb8e93c5f..a1f76301a4 100644
--- 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);
View Lorry Controller Status