summaryrefslogtreecommitdiff
path: root/vms/ext/Stdio
diff options
context:
space:
mode:
Diffstat (limited to 'vms/ext/Stdio')
-rw-r--r--vms/ext/Stdio/0README.txt23
-rw-r--r--vms/ext/Stdio/Stdio.pm37
-rw-r--r--vms/ext/Stdio/Stdio.xs108
-rwxr-xr-xvms/ext/Stdio/test.pl30
4 files changed, 158 insertions, 40 deletions
diff --git a/vms/ext/Stdio/0README.txt b/vms/ext/Stdio/0README.txt
index 28f82b3a14..25329f9334 100644
--- a/vms/ext/Stdio/0README.txt
+++ b/vms/ext/Stdio/0README.txt
@@ -3,26 +3,6 @@ VMS::Stdio, which provides access from Perl to VMS-specific
stdio functions. For more specific documentation of its
function, please see the pod section of Stdio.pm.
- *** Please Note ***
-
-This package is the direct descendant of VMS::stdio, but as of Perl
-5.002, the name has been changed to VMS::Stdio, in order to conform
-to the Perl naming convention that extensions whose name begins
-with a lowercase letter represent compile-time "pragmas", while
-extensions which provide added functionality have names whose parts
-begin with uppercase letters. In addition, the functions
-vmsfopen and fgetname have been renamed vmsopen and getname,
-respectively, in order to more closely resemble related Perl
-I/O operators, which do not retain the 'f' from corresponding
-C routine names.
-
-A transitional interface to the old routine names has been
-provided, so that calls to these routines will generate a
-warning, and be routed to the corresponding VMS::Stdio
-routine. This interface will be removed in a future release,
-so please update your code to use the new names.
-
-
===> Installation
This extension, like most Perl extensions, should be installed
@@ -45,3 +25,6 @@ the Perl distribution tree, and then saying
2.0 28-Feb-1996 Charles Bailey bailey@genetics.upenn.edu
major rewrite for Perl 5.002: name changed to VMS::Stdio,
new functions added, and prototypes incorporated
+2.1 24-Mar-1998 Charles Bailey bailey@newman.upenn.edu
+ Added writeof()
+ Removed old VMs::stdio compatibility interface
diff --git a/vms/ext/Stdio/Stdio.pm b/vms/ext/Stdio/Stdio.pm
index 01ff32db64..ea5d9074ef 100644
--- a/vms/ext/Stdio/Stdio.pm
+++ b/vms/ext/Stdio/Stdio.pm
@@ -1,8 +1,8 @@
# VMS::Stdio - VMS extensions to Perl's stdio calls
#
# Author: Charles Bailey bailey@genetics.upenn.edu
-# Version: 2.02
-# Revised: 15-Feb-1997
+# Version: 2.1
+# Revised: 24-Mar-1998
package VMS::Stdio;
@@ -12,17 +12,18 @@ use Carp '&croak';
use DynaLoader ();
use Exporter ();
-$VERSION = '2.02';
+$VERSION = '2.1';
@ISA = qw( Exporter DynaLoader IO::File );
@EXPORT = qw( &O_APPEND &O_CREAT &O_EXCL &O_NDELAY &O_NOWAIT
&O_RDONLY &O_RDWR &O_TRUNC &O_WRONLY );
-@EXPORT_OK = qw( &flush &getname &remove &rewind &sync &tmpnam
- &vmsopen &vmssysopen &waitfh );
+@EXPORT_OK = qw( &flush &getname &remove &rewind &sync &setdef &tmpnam
+ &vmsopen &vmssysopen &waitfh &writeof );
%EXPORT_TAGS = ( CONSTANTS => [ qw( &O_APPEND &O_CREAT &O_EXCL &O_NDELAY
&O_NOWAIT &O_RDONLY &O_RDWR &O_TRUNC
&O_WRONLY ) ],
- FUNCTIONS => [ qw( &flush &getname &remove &rewind &sync
- &tmpnam &vmsopen &vmssysopen &waitfh ) ] );
+ FUNCTIONS => [ qw( &flush &getname &remove &rewind &setdef
+ &sync &tmpnam &vmsopen &vmssysopen
+ &waitfh &writeof ) ] );
bootstrap VMS::Stdio $VERSION;
@@ -80,8 +81,9 @@ VMS::Stdio - standard I/O functions via VMS extensions
=head1 SYNOPSIS
-use VMS::Stdio qw( &flush &getname &remove &rewind &sync &tmpnam
- &vmsopen &vmssysopen &waitfh );
+use VMS::Stdio qw( &flush &getname &remove &rewind &setdef &sync &tmpnam
+ &vmsopen &vmssysopen &waitfh &writeof );
+setdef("new:[default.dir]");
$uniquename = tmpnam;
$fh = vmsopen("my.file","rfm=var","alq=100",...) or die $!;
$name = getname($fh);
@@ -96,7 +98,7 @@ sysread($fh,$data,128);
waitfh($fh);
close($fh);
remove("another.file");
-
+writeof($pipefh);
=head1 DESCRIPTION
This package gives Perl scripts access via VMS extensions to several
@@ -175,6 +177,13 @@ to the beginning of the file. It's really just a convenience
method equivalent in effect to C<seek($fh,0,0)>. It returns a
true value if successful, and C<undef> if it fails.
+=item setdef
+
+This function sets the default device and directory for the process.
+It is identical to the built-in chdir() operator, except that the change
+persists after Perl exits. It returns a true value on success, and
+C<undef> if it encounters and error.
+
=item sync
This function flushes buffered data for the specified file handle
@@ -231,6 +240,14 @@ operation on the file handle specified as its argument. It is
used with handles opened for asynchronous I/O, and performs its
task by calling the CRTL routine fwait().
+=item writeof
+
+This function writes an EOF to a file handle, if the device driver
+supports this operation. Its primary use is to send an EOF to a
+subprocess through a pipe opened for writing without closing the
+pipe. It returns a true value if successful, and C<undef> if
+it encounters an error.
+
=head1 REVISION
This document was last revised on 10-Dec-1996, for Perl 5.004.
diff --git a/vms/ext/Stdio/Stdio.xs b/vms/ext/Stdio/Stdio.xs
index b10fec0d48..0a7b47e514 100644
--- a/vms/ext/Stdio/Stdio.xs
+++ b/vms/ext/Stdio/Stdio.xs
@@ -1,8 +1,8 @@
/* VMS::Stdio - VMS extensions to stdio routines
*
- * Version: 2.02
+ * Version: 2.1
* Author: Charles Bailey bailey@genetics.upenn.edu
- * Revised: 15-Feb-1997
+ * Revised: 24-Mar-1998
*
*/
@@ -10,6 +10,9 @@
#include "perl.h"
#include "XSUB.h"
#include <file.h>
+#include <iodef.h>
+#include <rms.h>
+#include <starlet.h>
static bool
constant(name, pval)
@@ -121,12 +124,10 @@ constant(name)
ST(0) = &sv_undef;
void
-flush(sv)
- SV * sv
+flush(fp)
+ FILE * fp
PROTOTYPE: $
CODE:
- FILE *fp = Nullfp;
- if (SvOK(sv)) fp = IoIFP(sv_2io(sv));
if (fflush(fp)) { ST(0) = &sv_undef; }
else { clearerr(fp); ST(0) = &sv_yes; }
@@ -135,7 +136,7 @@ getname(fp)
FILE * fp
PROTOTYPE: $
CODE:
- char fname[257];
+ char fname[NAM$C_MAXRSS+1];
ST(0) = sv_newmortal();
if (fgetname(fp,fname) != NULL) sv_setpv(ST(0),fname);
@@ -154,6 +155,59 @@ remove(name)
ST(0) = remove(name) ? &sv_undef : &sv_yes;
void
+setdef(...)
+ PROTOTYPE: @
+ CODE:
+ char vmsdef[NAM$C_MAXRSS+1], es[NAM$C_MAXRSS], sep;
+ unsigned long int retsts;
+ struct FAB deffab = cc$rms_fab;
+ struct NAM defnam = cc$rms_nam;
+ struct dsc$descriptor_s dirdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
+ if (items) {
+ SV *defsv = ST(items-1); /* mimic chdir() */
+ ST(0) = &sv_undef;
+ if (!SvPOK(defsv)) { SETERRNO(EINVAL,LIB$_INVARG); XSRETURN(1); }
+ if (tovmsspec(SvPV(defsv,na),vmsdef) == NULL) { XSRETURN(1); }
+ deffab.fab$l_fna = vmsdef; deffab.fab$b_fns = strlen(vmsdef);
+ }
+ else {
+ deffab.fab$l_fna = "SYS$LOGIN"; deffab.fab$b_fns = 9;
+ EXTEND(sp,1); ST(0) = &sv_undef;
+ }
+ defnam.nam$l_esa = es; defnam.nam$b_ess = sizeof es;
+ deffab.fab$l_nam = &defnam;
+ retsts = sys$parse(&deffab,0,0);
+ if (retsts & 1) {
+ if (defnam.nam$v_wildcard) retsts = RMS$_WLD;
+ else if (defnam.nam$b_name || defnam.nam$b_type > 1 ||
+ defnam.nam$b_ver > 1) retsts = RMS$_DIR;
+ }
+ defnam.nam$b_nop |= NAM$M_SYNCHK; defnam.nam$l_rlf = NULL; deffab.fab$b_dns = 0;
+ if (!(retsts & 1)) {
+ set_vaxc_errno(retsts);
+ switch (retsts) {
+ case RMS$_DNF:
+ set_errno(ENOENT); break;
+ case RMS$_SYN: case RMS$_DIR: case RMS$_DEV:
+ set_errno(EINVAL); break;
+ case RMS$_PRV:
+ set_errno(EACCES); break;
+ default:
+ set_errno(EVMSERR); break;
+ }
+ (void) sys$parse(&deffab,0,0); /* free up context */
+ XSRETURN(1);
+ }
+ sep = *defnam.nam$l_dir;
+ *defnam.nam$l_dir = '\0';
+ my_setenv("SYS$DISK",defnam.nam$b_node ? defnam.nam$l_node : defnam.nam$l_dev);
+ *defnam.nam$l_dir = sep;
+ dirdsc.dsc$a_pointer = defnam.nam$l_dir; dirdsc.dsc$w_length = defnam.nam$b_dir;
+ if ((retsts = sys$setddir(&dirdsc,0,0)) & 1) ST(0) = &sv_yes;
+ else { set_errno(EVMSERR); set_vaxc_errno(retsts); }
+ (void) sys$parse(&deffab,0,0); /* free up context */
+
+void
sync(fp)
FILE * fp
PROTOTYPE: $
@@ -295,3 +349,43 @@ waitfh(fp)
PROTOTYPE: $
CODE:
ST(0) = fwait(fp) ? &sv_undef : &sv_yes;
+
+void
+writeof(mysv)
+ SV * mysv
+ PROTOTYPE: $
+ CODE:
+ char devnam[257], *cp;
+ 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;
+ if (fp == NULL || strchr(">was+-|",IoTYPE(io)) == Nullch) {
+ set_errno(EBADF); set_vaxc_errno(SS$_IVCHAN);
+ ST(0) = &sv_undef; XSRETURN(1);
+ }
+ if (fgetname(fp,devnam) == Nullch) { ST(0) = &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);
+ if (retsts & 1) retsts = sys$qiow(0,chan,IO$_WRITEOF,iosb,0,0,0,0,0,0,0,0);
+ if (retsts & 1) retsts = iosb[0];
+ retsts2 = sys$dassgn(chan); /* Be sure to deassign the channel */
+ if (retsts & 1) retsts = retsts2;
+ if (retsts & 1) { ST(0) = &sv_yes; }
+ else {
+ set_vaxc_errno(retsts);
+ switch (retsts) {
+ case SS$_EXQUOTA: case SS$_INSFMEM: case SS$_MBFULL:
+ case SS$_MBTOOSML: case SS$_NOIOCHAN: case SS$_NOLINKS:
+ case SS$_BUFFEROVF:
+ set_errno(ENOSPC); break;
+ case SS$_ILLIOFUNC: case SS$_DEVOFFLINE: case SS$_NOSUCHDEV:
+ set_errno(EBADF); break;
+ case SS$_NOPRIV:
+ set_errno(EACCES); break;
+ default: /* Includes "shouldn't happen" cases that might map */
+ set_errno(EVMSERR); break; /* to other errno values */
+ }
+ ST(0) = &sv_undef;
+ }
diff --git a/vms/ext/Stdio/test.pl b/vms/ext/Stdio/test.pl
index 0b50d63e3a..36353d91b3 100755
--- a/vms/ext/Stdio/test.pl
+++ b/vms/ext/Stdio/test.pl
@@ -1,8 +1,8 @@
-# Tests for VMS::Stdio v2.01
+# Tests for VMS::Stdio v2.1
use VMS::Stdio;
-import VMS::Stdio qw(&flush &getname &rewind &sync);
+import VMS::Stdio qw(&flush &getname &rewind &sync &tmpnam);
-print "1..14\n";
+print "1..19\n";
print +(defined(&getname) ? '' : 'not '), "ok 1\n";
$name = "test$$";
@@ -42,3 +42,27 @@ undef $sfh;
print +(stat("$name.tmp") ? 'not ' : ''),"ok 13\n";
print +(&VMS::Stdio::tmpnam ? '' : 'not '),"ok 14\n";
+
+if (open(P, qq[| MCR $^X -e "1 while (<STDIN>);print 'Foo';1 while (<STDIN>); print 'Bar'" >$name.tmp])) {
+ print P "Baz\nQuux\n";
+ print +(VMS::Stdio::writeof(P) ? '' : 'not '),"ok 15\n";
+ print P "Baz\nQuux\n";
+ print +(close(P) ? '' : 'not '),"ok 16\n";
+ $fh = VMS::Stdio::vmsopen("$name.tmp");
+ chomp($line = <$fh>);
+ close $fh;
+ unlink("$name.tmp");
+ print +($line eq 'FooBar' ? '' : 'not '),"ok 17\n";
+}
+else { print "not ok 15\nnot ok 16\nnot ok 17\n"; }
+
+$sfh = VMS::Stdio::vmsopen(">$name.tmp");
+$setuperl = "\$ MCR $^X\nBEGIN { \@INC = qw(@INC) };\nuse VMS::Stdio qw(&setdef);";
+print $sfh qq[\$ here = F\$Environment("Default")\n];
+print $sfh "$setuperl\nsetdef();\n\$ Show Default\n\$ Set Default 'here'\n";
+print $sfh "$setuperl\nsetdef('..');\n\$ Show Default\n";
+close $sfh;
+@defs = map { /(\S+)/ && $1 } `\@$name.tmp`;
+unlink("$name.tmp");
+print +($defs[0] eq uc($ENV{'SYS$LOGIN'}) ? '' : "not ($defs[0]) "),"ok 18\n";
+print +($defs[1] eq VMS::Filespec::rmsexpand('[-]') ? '' : "not ($defs[1]) "),"ok 19\n";
View Lorry Controller Status