The diffs at the end of this message are a first cut at getting
PerlIO to work on VMS. I've slapped together a PerlIO_getname
implementation and flogged a number of other things until they
compile. I do get a clean compile with this (taken against
perl@10001) but that's about it; the first attempt to run miniperl
yields:
MCR Sys$Disk:[]miniperl.exe "-I[.lib]" [.VMS]Writemain.pl "DynaLoader Socket"
Bareword found where operator expected at [.vms]writemain.pl line 74, near "]VMS_AXP"
(Missing operator before VMS_AXP?)
Number found where operator expected at [.vms]writemain.pl line 74, near "*;1"
(Missing operator before 1?)
Bareword found where operator expected at [.vms]writemain.pl line 74, near "1NTRAL"
(Missing operator before NTRAL?)
syntax error at [.vms]writemain.pl line 74, near "]VMS_AXP"
syntax error at [.vms]writemain.pl line 74, near "*;"
syntax error at [.vms]writemain.pl line 74, near "*;1"
Unrecognized character \x1D at [.vms]writemain.pl line 80.
Since Writemain.pl only has 73 lines, it's really quite confused
about where it is. I strongly suspect the following lines from
Perl_sv_gets() in sv.c are where the problem is:
#if defined(VMS) && defined(PERLIO_IS_STDIO)
/* An ungetc()d char is handled separately from the regular
* buffer, so we getc() it back out and stuff it in the buffer.
*/
i = PerlIO_getc(fp);
if (i == EOF) return 0;
*(--((*fp)->_ptr)) = (unsigned char) i;
(*fp)->_cnt++;
#endif
These lines obviously get skipped with a -Duseperlio configuration.
Any help with what to do here in the USE_PERLIO case would be
appreciated; are there equivalents to _ptr and _cnt in a PerlIO
thingie?
Another question. In PerlIO_getname, do I really need to export the
PerlIO object, get the name, and then release it, or can I access the
FILE gizmo directly by doing PerlIOSelf(f,PerlIOStdio)->stdio ? I
got rather lost trying to trace through the headers to see what the
latter is actually doing.
Here's the not-quite-a-patch. There are probably lots of things
wrong with it so let me know about them. I'm sure there will be
further changes necessary to keep these from breaking a non-PerlIO
configuration.
--- doio.c;-0 Wed May 2 11:29:50 2001
+++ doio.c Mon May 7 23:19:36 2001
@@ -564,7 +564,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);
}
@@ -2101,7 +2101,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;
@@ -2116,7 +2115,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;
@@ -2133,7 +2131,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);
--- perlio.c;-0 Fri May 4 22:03:09 2001
+++ perlio.c Mon May 7 23:19:36 2001
@@ -3645,8 +3645,15 @@
PerlIO_getname(PerlIO *f, char *buf)
{
dTHX;
+ char *name = NULL;
+#ifdef VMS
+ FILE *stdio = PerlIO_exportFILE(f, 0);
+ name = fgetname(stdio, buf);
+ PerlIO_releaseFILE(f, stdio);
+#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 8 00:13:54 2001
@@ -326,6 +326,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);
--- vms/vms.c;-0 Wed May 2 14:30:16 2001
+++ vms/vms.c Tue May 8 22:22:26 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), PerlIO_fileno(Perl_debug_log));
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 22:03:10 2001
+++ vms/vmsish.h Tue May 8 22:23:08 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);
[end of patch]
--
________________________________________
Craig A. Berry
mailto:[EMAIL PROTECTED]
"... getting out of a sonnet is much more
difficult than getting in."
Brad Leithauser
