dslinux/user/perl/vms/ext/Stdio 0README.txt Makefile.PL Stdio.pm Stdio.xs test.pl

cayenne dslinux_cayenne at user.in-berlin.de
Mon Dec 4 18:02:18 CET 2006


Update of /cvsroot/dslinux/dslinux/user/perl/vms/ext/Stdio
In directory antilope:/tmp/cvs-serv17422/vms/ext/Stdio

Added Files:
	0README.txt Makefile.PL Stdio.pm Stdio.xs test.pl 
Log Message:
Adding fresh perl source to HEAD to branch from

--- NEW FILE: Stdio.xs ---
/* VMS::Stdio - VMS extensions to stdio routines 
 *
 * Version:  2.2
 * Author:   Charles Bailey  bailey at newman.upenn.edu
 * Revised:  18-Jul-1998
 *
 */

#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#include <file.h>
#include <iodef.h>
#include <rms.h>
#include <starlet.h>

static bool
constant(name, pval)
char *name;
IV *pval;
{
    if (strnNE(name, "O_", 2)) return FALSE;

    if (strEQ(name, "O_APPEND"))
#ifdef O_APPEND
	{ *pval = O_APPEND; return TRUE; }
#else
	return FALSE;
#endif
    if (strEQ(name, "O_CREAT"))
#ifdef O_CREAT
	{ *pval = O_CREAT; return TRUE; }
#else
	return FALSE;
#endif
    if (strEQ(name, "O_EXCL"))
#ifdef O_EXCL
	{ *pval = O_EXCL; return TRUE; }
#else
	return FALSE;
#endif
    if (strEQ(name, "O_NDELAY"))
#ifdef O_NDELAY
	{ *pval = O_NDELAY; return TRUE; }
#else
	return FALSE;
#endif
    if (strEQ(name, "O_NOWAIT"))
#ifdef O_NOWAIT
	{ *pval = O_NOWAIT; return TRUE; }
#else
	return FALSE;
#endif
    if (strEQ(name, "O_RDONLY"))
#ifdef O_RDONLY
	{ *pval = O_RDONLY; return TRUE; }
#else
	return FALSE;
#endif
    if (strEQ(name, "O_RDWR"))
#ifdef O_RDWR
	{ *pval = O_RDWR; return TRUE; }
#else
	return FALSE;
#endif
    if (strEQ(name, "O_TRUNC"))
#ifdef O_TRUNC
	{ *pval = O_TRUNC; return TRUE; }
#else
	return FALSE;
#endif
    if (strEQ(name, "O_WRONLY"))
#ifdef O_WRONLY
	{ *pval = O_WRONLY; return TRUE; }
#else
	return FALSE;
#endif

    return FALSE;
}


static SV *
newFH(PerlIO *fp, char type) {
    SV *rv;
    GV **stashp, *gv = (GV *)NEWSV(0,0);
    HV *stash;
    IO *io;

    /* Find stash for VMS::Stdio.  We don't do this once at boot
     * to allow for possibility of threaded Perl with per-thread
     * symbol tables.  This code (through io = ...) is really
     * equivalent to gv_fetchpv("VMS::Stdio::__FH__",TRUE,SVt_PVIO),
     * with a little less overhead, and good exercise for me. :-) */
    stashp = (GV **)hv_fetch(PL_defstash,"VMS::",5,TRUE);
    if (!stashp || *stashp == (GV *)&PL_sv_undef) return Nullsv;
    if (!(stash = GvHV(*stashp))) stash = GvHV(*stashp) = newHV();
    stashp = (GV **)hv_fetch(GvHV(*stashp),"Stdio::",7,TRUE);
    if (!stashp || *stashp == (GV *)&PL_sv_undef) return Nullsv;
    if (!(stash = GvHV(*stashp))) stash = GvHV(*stashp) = newHV();

    /* Set up GV to point to IO, and then take reference */
    gv_init(gv,stash,"__FH__",6,0);
    io = GvIOp(gv) = newIO();
    IoIFP(io) = fp;
    if (type != '<') IoOFP(io) = fp;
    IoTYPE(io) = type;
    rv = newRV((SV *)gv);
    SvREFCNT_dec(gv);
    return sv_bless(rv,stash);
}

MODULE = VMS::Stdio  PACKAGE = VMS::Stdio

void
constant(name)
	char *	name
	PROTOTYPE: $
	CODE:
	IV i;
	if (constant(name, &i))
	    ST(0) = sv_2mortal(newSViv(i));
	else
	    ST(0) = &PL_sv_undef;

void
binmode(fh)
	SV *	fh
	PROTOTYPE: $
	CODE:
           SV *name;
	   IO *io;
	   char iotype;
	   char filespec[NAM$C_MAXRSS], *acmode, *s, *colon, *dirend = Nullch;
	   int ret = 0, saverrno = errno, savevmserrno = vaxc$errno;
           SV pos;
           PerlIO *fp;
	   io = sv_2io(fh);
           fp = io ? IoOFP(io) : NULL;
	   iotype = io ? IoTYPE(io) : '\0';
	    if (fp == NULL || strchr(">was+-|",iotype) == Nullch) {
	      set_errno(EBADF); set_vaxc_errno(SS$_IVCHAN); XSRETURN_UNDEF;
	    }
           if (!PerlIO_getname(fp,filespec)) XSRETURN_UNDEF;
	    for (s = filespec; *s; s++) {
	      if (*s == ':') colon = s;
	      else if (*s == ']' || *s == '>') dirend = s;
	    }
	    /* Looks like a tmpfile, which will go away if reopened */
	    if (s == dirend + 3) {
	      set_errno(EBADF); set_vaxc_errno(RMS$_IOP); XSRETURN_UNDEF;
	    }
	    /* 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 = PerlIO_getpos(fp, &pos)) == -1 && dirend)
	      XSRETURN_UNDEF;
	    switch (iotype) {
	      case '<': case 'r':           acmode = "rb";                      break;
	      case '>': case 'w': case '|':
	        /* use 'a' instead of 'w' to avoid creating new file;
	           fsetpos below will take care of restoring file position */
	      case 'a':                     acmode = "ab";                      break;
	      case '+':  case 's':          acmode = "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 */
	      case 0:                       XSRETURN_UNDEF;
	      default:
	        if (PL_dowarn) warn("Unrecognized iotype %c for %s in binmode",
	                         iotype, filespec);
	        acmode = "rb+";
	    }
           /* appearances to the contrary, this is an freopen substitute */
           name = sv_2mortal(newSVpvn(filespec,strlen(filespec)));
           if (PerlIO_openn(aTHX_ 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)
       PerlIO * fp
	PROTOTYPE: $
	CODE:
           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)
       PerlIO * fp
	PROTOTYPE: $
	CODE:
	    char fname[NAM$C_MAXRSS+1];
	    ST(0) = sv_newmortal();
           if (PerlIO_getname(fp,fname) != NULL) sv_setpv(ST(0),fname);

void
rewind(fp)
       PerlIO * fp
	PROTOTYPE: $
	CODE:
           FILE *stdio = PerlIO_exportFILE(fp,0);
           ST(0) = rewind(stdio) ? &PL_sv_undef : &PL_sv_yes;
           PerlIO_releaseFILE(fp,stdio);

void
remove(name)
	char *name
	PROTOTYPE: $
	CODE:
	    ST(0) = remove(name) ? &PL_sv_undef : &PL_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};
	    STRLEN n_a;
	    if (items) {
		SV *defsv = ST(items-1);  /* mimic chdir() */
		ST(0) = &PL_sv_undef;
		if (!SvPOK(defsv)) { SETERRNO(EINVAL,LIB$_INVARG); XSRETURN(1); }
		if (tovmsspec(SvPV(defsv,n_a),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) = &PL_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) = &PL_sv_yes;
	    else { set_errno(EVMSERR); set_vaxc_errno(retsts); }
	    (void) sys$parse(&deffab,0,0);  /* free up context */

void
sync(fp)
       PerlIO * fp
	PROTOTYPE: $
	CODE:
           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()
	PROTOTYPE:
	CODE:
	    char fname[L_tmpnam];
	    ST(0) = sv_newmortal();
	    if (tmpnam(fname) != NULL) sv_setpv(ST(0),fname);

void
vmsopen(spec,...)
	char *	spec
	PROTOTYPE: @
	CODE:
	    char *args[8],mode[3] = {'r','\0','\0'}, type = '<';
	    register int i, myargc;
	    FILE *fp;
            SV *fh;
           PerlIO *pio_fp;
	    STRLEN n_a;
	
	    if (!spec || !*spec) {
	       SETERRNO(EINVAL,LIB$_INVARG);
	       XSRETURN_UNDEF;
	    }
	    if (items > 9) croak("too many args");
	
	    /* First, set up name and mode args from perl's string */
	    if (*spec == '+') {
	      mode[1] = '+';
	      spec++;
	    }
	    if (*spec == '>') {
	      if (*(spec+1) == '>') *mode = 'a', spec += 2;
	      else *mode = 'w',  spec++;
	    }
	    else if (*spec == '<') spec++;
	    myargc = items - 1;
	    for (i = 0; i < myargc; i++) args[i] = SvPV(ST(i+1),n_a);
	    /* This hack brought to you by C's opaque arglist management */
	    switch (myargc) {
	      case 0:
	        fp = fopen(spec,mode);
	        break;
	      case 1:
	        fp = fopen(spec,mode,args[0]);
	        break;
	      case 2:
	        fp = fopen(spec,mode,args[0],args[1]);
	        break;
	      case 3:
	        fp = fopen(spec,mode,args[0],args[1],args[2]);
	        break;
	      case 4:
	        fp = fopen(spec,mode,args[0],args[1],args[2],args[3]);
	        break;
	      case 5:
	        fp = fopen(spec,mode,args[0],args[1],args[2],args[3],args[4]);
	        break;
	      case 6:
	        fp = fopen(spec,mode,args[0],args[1],args[2],args[3],args[4],args[5]);
	        break;
	      case 7:
	        fp = fopen(spec,mode,args[0],args[1],args[2],args[3],args[4],args[5],args[6]);
	        break;
	      case 8:
	        fp = fopen(spec,mode,args[0],args[1],args[2],args[3],args[4],args[5],args[6],args[7]);
	        break;
	    }
           if (fp != Null(FILE*)) {
             pio_fp = PerlIO_importFILE(fp,mode);
             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; }

void
vmssysopen(spec,mode,perm,...)
	char *	spec
	int	mode
	int	perm
	PROTOTYPE: @
	CODE:
	    char *args[8];
	    int i, myargc, fd;
	    FILE *fp;
           PerlIO *pio_fp;
	    SV *fh;
	    STRLEN n_a;
	    if (!spec || !*spec) {
	       SETERRNO(EINVAL,LIB$_INVARG);
	       XSRETURN_UNDEF;
	    }
	    if (items > 11) croak("too many args");
	    myargc = items - 3;
	    for (i = 0; i < myargc; i++) args[i] = SvPV(ST(i+3),n_a);
	    /* More fun with C calls; can't combine with above because
	       args 2,3 of different types in fopen() and open() */
	    switch (myargc) {
	      case 0:
	        fd = open(spec,mode,perm);
	        break;
	      case 1:
	        fd = open(spec,mode,perm,args[0]);
	        break;
	      case 2:
	        fd = open(spec,mode,perm,args[0],args[1]);
	        break;
	      case 3:
	        fd = open(spec,mode,perm,args[0],args[1],args[2]);
	        break;
	      case 4:
	        fd = open(spec,mode,perm,args[0],args[1],args[2],args[3]);
	        break;
	      case 5:
	        fd = open(spec,mode,perm,args[0],args[1],args[2],args[3],args[4]);
	        break;
	      case 6:
	        fd = open(spec,mode,perm,args[0],args[1],args[2],args[3],args[4],args[5]);
	        break;
	      case 7:
	        fd = open(spec,mode,perm,args[0],args[1],args[2],args[3],args[4],args[5],args[6]);
	        break;
	      case 8:
	        fd = open(spec,mode,perm,args[0],args[1],args[2],args[3],args[4],args[5],args[6],args[7]);
	        break;
	    }
	    i = mode & 3;
	    if (fd >= 0 &&
              ((fp = fdopen(fd, &("r\000w\000r+"[2*i]))) != Null(FILE*))) {
             pio_fp = PerlIO_importFILE(fp,&("r\000w\000r+"[2*i]));
             fh = newFH(pio_fp,"<>++"[i]);
	     ST(0) = (fh ? sv_2mortal(fh) : &PL_sv_undef);
	    }
	    else { ST(0) = &PL_sv_undef; }

void
waitfh(fp)
       PerlIO * fp
	PROTOTYPE: $
	CODE:
           FILE *stdio = PerlIO_exportFILE(fp,0);
           ST(0) = fwait(stdio) ? &PL_sv_undef : &PL_sv_yes;
           PerlIO_releaseFILE(fp,stdio);

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);
           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 (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);
	    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) = &PL_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) = &PL_sv_undef;
	    }

--- NEW FILE: test.pl ---
# Tests for VMS::Stdio v2.2
use VMS::Stdio;
import VMS::Stdio qw(&flush &getname &rewind &sync &tmpnam);

print "1..18\n";
print +(defined(&getname) ? '' : 'not '), "ok 1\n";

$name = "test$$";
$name++ while -e "$name.tmp";
$fh = VMS::Stdio::vmsopen("+>$name",'ctx=rec','shr=put','fop=dlt','dna=.tmp');
print +($fh ? '' : 'not '), "ok 2\n";

print +(flush($fh) ? '' : 'not '),"ok 3\n";
print +(sync($fh) ? '' : 'not '),"ok 4\n";

$time = (stat("$name.tmp"))[9];
print +($time ? '' : 'not '), "ok 5\n";

$fh->autoflush;  # Can we autoload autoflush from IO::File?  Do or die.
print "ok 6\n";

print 'not ' unless print $fh scalar(localtime($time)),"\n";
print "ok 7\n";

print +(rewind($fh) ? '' : 'not '),"ok 8\n";

chop($line = <$fh>);
print +($line eq localtime($time) ? '' : 'not '), "ok 9\n";

($gotname) = (getname($fh) =~/\](.*);/);
print +("\U$gotname" eq "\U$name.tmp" ? '' : 'not '), "ok 10\n";

$sfh = VMS::Stdio::vmssysopen($name, O_RDONLY, 0,
                              'ctx=rec', 'shr=put', 'dna=.tmp');
print +($sfh ? '' : 'not ($!) '), "ok 11\n";

close($fh);
sysread($sfh,$line,24);
print +($line eq localtime($time) ? '' : 'not '), "ok 12\n";

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) ? '' : ''),"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 "ok 15\nok 16\nok 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";

--- NEW FILE: Makefile.PL ---
use ExtUtils::MakeMaker;

WriteMakefile( 'VERSION_FROM' => 'Stdio.pm',
               'MAN3PODS'     => {}, # pods will be built later
             );

--- NEW FILE: Stdio.pm ---
#   VMS::Stdio - VMS extensions to Perl's stdio calls
#
#   Author:  Charles Bailey  bailey at genetics.upenn.edu
#   Version: 2.2
#   Revised: 19-Jul-1998
#   Docs revised: 13-Oct-1998 Dan Sugalski <sugalskd at ous.edu>

package VMS::Stdio;

require 5.002;
use vars qw( $VERSION @EXPORT @EXPORT_OK %EXPORT_TAGS @ISA );
use Carp '&croak';
use DynaLoader ();
use Exporter ();
 
$VERSION = '2.3';
@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( &binmode &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( &binmode &flush &getname &remove &rewind
                                    &setdef &sync &tmpnam &vmsopen &vmssysopen
                                    &waitfh &writeof ) ] );

bootstrap VMS::Stdio $VERSION;

sub AUTOLOAD {
    my($constname) = $AUTOLOAD;
    $constname =~ s/.*:://;
    if ($constname =~ /^O_/) {
      my($val) = constant($constname);
      defined $val or croak("Unknown VMS::Stdio constant $constname");
      *$AUTOLOAD = sub { $val; }
    }
    else { # We don't know about it; hand off to IO::File
      require IO::File;

      *$AUTOLOAD = eval "sub { shift->IO::File::$constname(\@_) }";
      croak "Error autoloading IO::File::$constname: $@" if $@;
    }
    goto &$AUTOLOAD;
}

sub DESTROY { close($_[0]); }


################################################################################
# Intercept calls to old VMS::stdio package, complain, and hand off
# This will be removed in a future version of VMS::Stdio

package VMS::stdio;

sub AUTOLOAD {
  my($func) = $AUTOLOAD;
  $func =~ s/.*:://;
  # Cheap trick: we know DynaLoader has required Carp.pm
  Carp::carp("Old package VMS::stdio is now VMS::Stdio; please update your code");
  if ($func eq 'vmsfopen') {
    Carp::carp("Old function &vmsfopen is now &vmsopen");
    goto &VMS::Stdio::vmsopen;
  }
  elsif ($func eq 'fgetname') {
    Carp::carp("Old function &fgetname is now &getname");
    goto &VMS::Stdio::getname;
  }
  else { goto &{"VMS::Stdio::$func"}; }
}

package VMS::Stdio;  # in case we ever use AutoLoader

1;

__END__

=head1 NAME

VMS::Stdio - standard I/O functions via VMS extensions

=head1 SYNOPSIS

  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);
  print $fh "Hello, world!\n";
  flush($fh);
  sync($fh);
  rewind($fh);
  $line = <$fh>;
  undef $fh;  # closes file
  $fh = vmssysopen("another.file", O_RDONLY | O_NDELAY, 0, "ctx=bin");
  sysread($fh,$data,128);
  waitfh($fh);
  close($fh);
  remove("another.file");
  writeof($pipefh);
  binmode($fh);

=head1 DESCRIPTION

This package gives Perl scripts access via VMS extensions to several
C stdio operations not available through Perl's CORE I/O functions.
The specific routines are described below.  These functions are
prototyped as unary operators, with the exception of C<vmsopen>
and C<vmssysopen>, which can take any number of arguments, and
C<tmpnam>, which takes none.

All of the routines are available for export, though none are
exported by default.  All of the constants used by C<vmssysopen>
to specify access modes are exported by default.  The routines
are associated with the Exporter tag FUNCTIONS, and the constants
are associated with the Exporter tag CONSTANTS, so you can more
easily choose what you'd like to import:

    # import constants, but not functions
    use VMS::Stdio;  # same as use VMS::Stdio qw( :DEFAULT );
    # import functions, but not constants
    use VMS::Stdio qw( !:CONSTANTS :FUNCTIONS ); 
    # import both
    use VMS::Stdio qw( :CONSTANTS :FUNCTIONS ); 
    # import neither
    use VMS::Stdio ();

Of course, you can also choose to import specific functions by
name, as usual.

This package C<ISA> IO::File, so that you can call IO::File
methods on the handles returned by C<vmsopen> and C<vmssysopen>.
The IO::File package is not initialized, however, until you
actually call a method that VMS::Stdio doesn't provide.  This
is done to save startup time for users who don't wish to use
the IO::File methods.

B<Note:>  In order to conform to naming conventions for Perl
extensions and functions, the name of this package has been
changed to VMS::Stdio as of Perl 5.002, and the names of some
routines have been changed.  Calls to the old VMS::stdio routines
will generate a warning, and will be routed to the equivalent
VMS::Stdio function.  This compatibility interface will be
removed in a future release of this extension, so please
update your code to use the new routines.

=over 4

=item binmode

This function causes the file handle to be reopened with the CRTL's
carriage control processing disabled; its effect is the same as that
of the C<b> access mode in C<vmsopen>.  After the file is reopened,
the file pointer is positioned as close to its position before the
call as possible (I<i.e.> as close as fsetpos() can get it -- for
some record-structured files, it's not possible to return to the
exact byte offset in the file).  Because the file must be reopened,
this function cannot be used on temporary-delete files. C<binmode>
returns true if successful, and C<undef> if not.

Note that the effect of C<binmode> differs from that of the binmode()
function on operating systems such as Windows and MSDOS, and is not
needed to process most types of file.

=item flush

This function causes the contents of stdio buffers for the specified
file handle to be flushed.  If C<undef> is used as the argument to
C<flush>, all currently open file handles are flushed.  Like the CRTL
fflush() routine, it does not flush any underlying RMS buffers for the
file, so the data may not be flushed all the way to the disk.  C<flush>
returns a true value if successful, and C<undef> if not.

=item getname

The C<getname> function returns the file specification associated
with a Perl I/O handle.  If an error occurs, it returns C<undef>.

=item remove

This function deletes the file named in its argument, returning
a true value if successful and C<undef> if not.  It differs from
the CORE Perl function C<unlink> in that it does not try to
reset file protection if the original protection does not give
you delete access to the file (cf. L<perlvms>).  In other words,
C<remove> is equivalent to

  unlink($file) if VMS::Filespec::candelete($file);

=item rewind

C<rewind> resets the current position of the specified file handle
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 an error.

=item sync

This function flushes buffered data for the specified file handle
from stdio and RMS buffers all the way to disk.  If successful, it
returns a true value; otherwise, it returns C<undef>.

=item tmpnam

The C<tmpnam> function returns a unique string which can be used
as a filename when creating temporary files.  If, for some
reason, it is unable to generate a name, it returns C<undef>.

=item vmsopen

The C<vmsopen> function enables you to specify optional RMS arguments
to the VMS CRTL when opening a file.  Its operation is similar to the built-in
Perl C<open> function (see L<perlfunc> for a complete description),
but it will only open normal files; it cannot open pipes or duplicate
existing I/O handles.  Up to 8 optional arguments may follow the
file name.  These arguments should be strings which specify
optional file characteristics as allowed by the CRTL. (See the
CRTL reference manual description of creat() and fopen() for details.)
If successful, C<vmsopen> returns a VMS::Stdio file handle; if an
error occurs, it returns C<undef>.

You can use the file handle returned by C<vmsopen> just as you
would any other Perl file handle.  The class VMS::Stdio ISA
IO::File, so you can call IO::File methods using the handle
returned by C<vmsopen>.  However, C<use>ing VMS::Stdio does not
automatically C<use> IO::File; you must do so explicitly in
your program if you want to call IO::File methods.  This is
done to avoid the overhead of initializing the IO::File package
in programs which intend to use the handle returned by C<vmsopen>
as a normal Perl file handle only.  When the scalar containing
a VMS::Stdio file handle is overwritten, C<undef>d, or goes
out of scope, the associated file is closed automatically.

File characteristic options:

=over 2

=item alq=INTEGER

Sets the allocation quantity for this file

=item bls=INTEGER

File blocksize

=item ctx=STRING

Sets the context for the file. Takes one of these arguments:

=over 4

=item bin

Disables LF to CRLF translation

=item cvt

Negates previous setting of C<ctx=noctx>

=item nocvt

Disables conversion of FORTRAN carriage control

=item rec

Force record-mode access

=item stm

Force stream mode

=item xplct

Causes records to be flushed I<only> when the file is closed, or when an
explicit flush is done

=back

=item deq=INTEGER

Sets the default extension quantity

=item dna=FILESPEC

Sets the default filename string. Used to fill in any missing pieces of the
filename passed.

=item fop=STRING

File processing option. Takes one or more of the following (in a
comma-separated list if there's more than one)

=over 4

=item ctg

Contiguous.

=item cbt

Contiguous-best-try.

=item dfw

Deferred write; only applicable to files opened for shared access.

=item dlt

Delete file on close.

=item tef

Truncate at end-of-file.

=item cif

Create if nonexistent.

=item sup

Supersede.

=item scf

Submit as command file on close.

=item spl

Spool to system printer on close.

=item tmd

Temporary delete.

=item tmp

Temporary (no file directory).

=item nef

Not end-of-file.

=item rck

Read check compare operation.

=item wck

Write check compare operation.

=item mxv

Maximize version number.

=item rwo

Rewind file on open.

=item pos

Current position.

=item rwc

Rewind file on close.

=item sqo

File can only be processed in a sequential manner.

=back

=item fsz=INTEGER

Fixed header size

=item gbc=INTEGER

Global buffers requested for the file

=item mbc=INTEGER

Multiblock count

=item mbf=INTEGER

Bultibuffer count

=item mrs=INTEGER

Maximum record size

=item rat=STRING

File record attributes. Takes one of the following:

=over 4

=item cr

Carriage-return control.

=item blk

Disallow records to span block boundaries.

=item ftn

FORTRAN print control.

=item none

Explicitly forces no carriage control.

=item prn

Print file format.

=back

=item rfm=STRING

File record format. Takes one of the following:

=over 4

=item fix

Fixed-length record format.

=item stm

RMS stream record format.

=item stmlf

Stream format with line-feed terminator.

=item stmcr

Stream format with carriage-return terminator.

=item var

Variable-length record format.

=item vfc

Variable-length record with fixed control.

=item udf

Undefined format

=back

=item rop=STRING

Record processing operations. Takes one or more of the following in a
comma-separated list:

=over 4

=item asy

Asynchronous I/O.

=item cco

Cancel Ctrl/O (used with Terminal I/O).

=item cvt

Capitalizes characters on a read from the terminal.

=item eof

Positions the record stream to the end-of-file for the connect operation
only.

=item nlk

Do not lock record.

=item pmt

Enables use of the prompt specified by pmt=usr-prmpt on input from the
terminal.

=item pta

Eliminates any information in the type-ahead buffer on a read from the
terminal.

=item rea

Locks record for a read operation for this process, while allowing other
accessors to read the record.

=item rlk

Locks record for write.

=item rne

Suppresses echoing of input data on the screen as it is entered on the
keyboard.

=item rnf

Indicates that Ctrl/U, Ctrl/R, and DELETE are not to be considered control
commands on terminal input, but are to be passed to the application
program.

=item rrl

Reads regardless of lock.

=item syncsts

Returns success status of RMS$_SYNCH if the requested service completes its
task immediately.

=item tmo

Timeout I/O.

=item tpt

Allows put/write services using sequential record access mode to occur at
any point in the file, truncating the file at that point.

=item ulk

Prohibits RMS from automatically unlocking records.

=item wat

Wait until record is available, if currently locked by another stream.

=item rah

Read ahead.

=item wbh

Write behind.

=back

=item rtv=INTEGER

The number of retrieval pointers that RMS has to maintain (0 to 127255)

=item shr=STRING

File sharing options. Choose one of the following:

=over 4

=item del

Allows users to delete.

=item get

Allows users to read.

=item mse

Allows mainstream access.

=item nil

Prohibits file sharing.

=item put

Allows users to write.

=item upd

Allows users to update.

=item upi

Allows one or more writers.

=back

=item tmo=INTEGER

I/O timeout value

=back

=item vmssysopen

This function bears the same relationship to the CORE function
C<sysopen> as C<vmsopen> does to C<open>.  Its first three arguments
are the name, access flags, and permissions for the file.  Like
C<vmsopen>, it takes up to 8 additional string arguments which
specify file characteristics.  Its return value is identical to
that of C<vmsopen>.

The symbolic constants for the mode argument are exported by
VMS::Stdio by default, and are also exported by the Fcntl package.

=item waitfh

This function causes Perl to wait for the completion of an I/O
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.

=back

=head1 REVISION

This document was last revised on 13-Oct-1998, for Perl 5.004, 5.005, and
5.6.0.

=cut

--- NEW FILE: 0README.txt ---
This directory contains the source code for the Perl extension
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.

===> Installation

This extension, like most Perl extensions, should be installed
by copying the files in this directory to a location *outside*
the Perl distribution tree, and then saying

    $ perl Makefile.PL  ! Build Descrip.MMS for this extension
    $ MMK               ! Build the extension
    $ MMK test          ! Run its regression tests
    $ MMK install       ! Install required files in public Perl tree


===> Revision History

1.0  29-Nov-1994  Charles Bailey  bailey at genetics.upenn.edu
     original version - vmsfopen
1.1  09-Mar-1995  Charles Bailey  bailey at genetics.upenn.edu
     changed calling sequence to return FH/undef - like POSIX::open
     added fgetname and tmpnam
2.0  28-Feb-1996  Charles Bailey  bailey at 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 at newman.upenn.edu
     Added writeof()
     Removed old VMs::stdio compatibility interface




More information about the dslinux-commit mailing list