summaryrefslogtreecommitdiff
path: root/vms/ext
diff options
context:
space:
mode:
authorCraig A. Berry <craigberry@mac.com>2009-09-03 10:20:19 -0500
committerCraig A. Berry <craigberry@mac.com>2009-09-03 12:54:01 -0500
commit26dd53a231877708d84e7376aa20e4e8e561fe4e (patch)
tree126a0804e8f0cae4994aac9a2a4c4cdeab25ba31 /vms/ext
parentb7d7e1dad734d27d791c1f48094cb4b84f6c6165 (diff)
downloadperl-26dd53a231877708d84e7376aa20e4e8e561fe4e.tar.gz
Move vms/ext/DCLsym and vms/ext/Stdio to ext/VMS-DCLsym and ext/VMS-Stdio.
Diffstat (limited to 'vms/ext')
-rw-r--r--vms/ext/DCLsym/0README.txt21
-rw-r--r--vms/ext/DCLsym/DCLsym.pm272
-rw-r--r--vms/ext/DCLsym/DCLsym.xs151
-rw-r--r--vms/ext/DCLsym/Makefile.PL4
-rw-r--r--vms/ext/DCLsym/test.pl41
-rw-r--r--vms/ext/Stdio/0README.txt30
-rw-r--r--vms/ext/Stdio/Makefile.PL5
-rw-r--r--vms/ext/Stdio/Stdio.pm640
-rw-r--r--vms/ext/Stdio/Stdio.xs463
-rwxr-xr-xvms/ext/Stdio/test.pl79
10 files changed, 0 insertions, 1706 deletions
diff --git a/vms/ext/DCLsym/0README.txt b/vms/ext/DCLsym/0README.txt
deleted file mode 100644
index 29f2bdb875..0000000000
--- a/vms/ext/DCLsym/0README.txt
+++ /dev/null
@@ -1,21 +0,0 @@
-VMS::DCLsym is an extension to Perl 5 which allows it to manipulate DCL symbols
-via an object-oriented or tied-hash interface.
-
-In order to build the extension, just say
-
-$ Perl Makefile.PL
-$ MMK
-
-in the directory containing the source files. Once it's built, you can run the
-test script by saying
-
-$ Perl "-Iblib" test.pl
-
-Finally, if you want to make it part of your regular Perl library, you can say
-$ MMK install
-
-If you have any problems or suggestions, please feel free to let me know.
-
-Regards,
-Charles Bailey bailey@newman.upenn.edu
-17-Aug-1995
diff --git a/vms/ext/DCLsym/DCLsym.pm b/vms/ext/DCLsym/DCLsym.pm
deleted file mode 100644
index 1bc72b8b4f..0000000000
--- a/vms/ext/DCLsym/DCLsym.pm
+++ /dev/null
@@ -1,272 +0,0 @@
-package VMS::DCLsym;
-
-use Carp;
-use DynaLoader;
-use vars qw( @ISA $VERSION );
-use strict;
-
-# Package globals
-@ISA = ( 'DynaLoader' );
-$VERSION = '1.03';
-my(%Locsyms) = ( ':ID' => 'LOCAL' );
-my(%Gblsyms) = ( ':ID' => 'GLOBAL');
-my $DoCache = 1;
-my $Cache_set = 0;
-
-
-#====> OO methods
-
-sub new {
- my($pkg,$type) = @_;
- bless { TYPE => $type }, $pkg;
-}
-
-sub DESTROY { }
-
-sub getsym {
- my($self,$name) = @_;
- my($val,$table);
-
- if (($val,$table) = _getsym($name)) {
- if ($table eq 'GLOBAL') { $Gblsyms{$name} = $val; }
- else { $Locsyms{$name} = $val; }
- }
- wantarray ? ($val,$table) : $val;
-}
-
-sub setsym {
- my($self,$name,$val,$table) = @_;
-
- $table = $self->{TYPE} unless $table;
- if (_setsym($name,$val,$table)) {
- if ($table eq 'GLOBAL') { $Gblsyms{$name} = $val; }
- else { $Locsyms{$name} = $val; }
- 1;
- }
- else { 0; }
-}
-
-sub delsym {
- my($self,$name,$table) = @_;
-
- $table = $self->{TYPE} unless $table;
- if (_delsym($name,$table)) {
- if ($table eq 'GLOBAL') { delete $Gblsyms{$name}; }
- else { delete $Locsyms{$name}; }
- 1;
- }
- else { 0; }
-}
-
-sub clearcache {
- my($self,$perm) = @_;
- my($old);
-
- $Cache_set = 0;
- %Locsyms = ( ':ID' => 'LOCAL');
- %Gblsyms = ( ':ID' => 'GLOBAL');
- $old = $DoCache;
- $DoCache = $perm if defined($perm);
- $old;
-}
-
-#====> TIEHASH methods
-
-sub TIEHASH {
- $_[0]->new(@_);
-}
-
-sub FETCH {
- my($self,$name) = @_;
- if ($name eq ':GLOBAL') { $self->{TYPE} eq 'GLOBAL'; }
- elsif ($name eq ':LOCAL' ) { $self->{TYPE} eq 'LOCAL'; }
- else { scalar($self->getsym($name)); }
-}
-
-sub STORE {
- my($self,$name,$val) = @_;
- if ($name eq ':GLOBAL') { $self->{TYPE} = 'GLOBAL'; }
- elsif ($name eq ':LOCAL' ) { $self->{TYPE} = 'LOCAL'; }
- else { $self->setsym($name,$val); }
-}
-
-sub DELETE {
- my($self,$name) = @_;
-
- $self->delsym($name);
-}
-
-sub FIRSTKEY {
- my($self) = @_;
- my($name,$eqs,$val);
-
- if (!$DoCache || !$Cache_set) {
- # We should eventually replace this with a C routine which walks the
- # CLI symbol table directly. If I ever get 'hold of an I&DS manual . . .
- open(P,'Show Symbol * |');
- while (<P>) {
- ($name,$eqs,$val) = /^\s+(\S+) (=+) (.+)/
- or carp "VMS::DCLsym: unparseable line $_";
- $name =~ s#\*##;
- $val =~ s/"(.*)"$/$1/ or $val =~ s/^(\S+).*/$1/;
- if ($eqs eq '==') { $Gblsyms{$name} = $val; }
- else { $Locsyms{$name} = $val; }
- }
- close P;
- $Cache_set = 1;
- }
- $self ->{IDX} = 0;
- $self->{CACHE} = $self->{TYPE} eq 'GLOBAL' ? \%Gblsyms : \%Locsyms;
- while (($name,$val) = each(%{$self->{CACHE}}) and !defined($name)) {
- if ($self->{CACHE}{':ID'} eq 'GLOBAL') { return undef; }
- $self->{CACHE} = \%Gblsyms;
- }
- $name;
-}
-
-sub NEXTKEY {
- my($self) = @_;
- my($name,$val);
-
- while (($name,$val) = each(%{$self->{CACHE}}) and !defined($name)) {
- if ($self->{CACHE}{':ID'} eq 'GLOBAL') { return undef; }
- $self->{CACHE} = \%Gblsyms;
- }
- $name;
-}
-
-
-sub EXISTS { defined($_[0]->FETCH(@_)) ? 1 : 0 }
-
-sub CLEAR { }
-
-
-bootstrap VMS::DCLsym;
-
-1;
-
-__END__
-
-=head1 NAME
-
-VMS::DCLsym - Perl extension to manipulate DCL symbols
-
-=head1 SYNOPSIS
-
- tie %allsyms, VMS::DCLsym;
- tie %cgisyms, VMS::DCLsym, 'GLOBAL';
-
-
- $handle = new VMS::DCLsym;
- $value = $handle->getsym($name);
- $handle->setsym($name,$value,'GLOBAL') or die "Can't create symbol: $!\n";
- $handle->delsym($name,'LOCAL') or die "Can't delete symbol: $!\n";
- $handle->clearcache();
-
-=head1 DESCRIPTION
-
-The VMS::DCLsym extension provides access to DCL symbols using a
-tied hash interface. This allows Perl scripts to manipulate symbols in
-a manner similar to the way in which logical names are manipulated via
-the built-in C<%ENV> hash. Alternatively, one can call methods in this
-package directly to read, create, and delete symbols.
-
-=head2 Tied hash interface
-
-This interface lets you treat the DCL symbol table as a Perl associative array,
-in which the key of each element is the symbol name, and the value of the
-element is that symbol's value. Case is not significant in the key string, as
-DCL converts symbol names to uppercase, but it is significant in the value
-string. All of the usual operations on associative arrays are supported.
-Reading an element retrieves the current value of the symbol, assigning to it
-defines a new symbol (or overwrites the old value of an existing symbol), and
-deleting an element deletes the corresponding symbol. Setting an element to
-C<undef>, or C<undef>ing it directly, sets the corresponding symbol to the null
-string. You may also read the special keys ':GLOBAL' and ':LOCAL' to find out
-whether a default symbol table has been specified for this hash (see C<table>
-below), or set either or these keys to specify a default symbol table.
-
-When you call the C<tie> function to bind an associative array to this package,
-you may specify as an optional argument the symbol table in which you wish to
-create and delete symbols. If the argument is the string 'GLOBAL', then the
-global symbol table is used; any other string causes the local symbol table to
-be used. Note that this argument does not affect attempts to read symbols; if
-a symbol with the specified name exists in the local symbol table, it is always
-returned in preference to a symbol by the same name in the global symbol table.
-
-=head2 Object interface
-
-Although it's less convenient in some ways than the tied hash interface, you
-can also call methods directly to manipulate individual symbols. In some
-cases, this allows you finer control than using a tied hash aggregate. The
-following methods are supported:
-
-=over 4
-
-=item new
-
-This creates a C<VMS::DCLsym> object which can be used as a handle for later
-method calls. The single optional argument specifies the symbol table used
-by default in future method calls, in the same way as the optional argument to
-C<tie> described above.
-
-=item getsym
-
-If called in a scalar context, C<getsym> returns the value of the symbol whose
-name is given as the argument to the call, or C<undef> if no such symbol
-exists. Symbols in the local symbol table are always used in preference to
-symbols in the global symbol table. If called in a list context, C<getsym>
-returns a two-element list, whose first element is the value of the symbol, and
-whose second element is the string 'GLOBAL' or 'LOCAL', indicating the table
-from which the symbol's value was read.
-
-=item setsym
-
-The first two arguments taken by this method are the name of the symbol and the
-value which should be assigned to it. The optional third argument is a string
-specifying the symbol table to be used; 'GLOBAL' specifies the global symbol
-table, and any other string specifies the local symbol table. If this argument
-is omitted, the default symbol table for the object is used. C<setsym> returns
-TRUE if successful, and FALSE otherwise.
-
-=item delsym
-
-This method deletes the symbol whose name is given as the first argument. The
-optional second argument specifies the symbol table, as described above under
-C<setsym>. It returns TRUE if the symbol was successfully deleted, and FALSE
-if it was not.
-
-=item clearcache
-
-Because of the overhead associated with obtaining the list of defined symbols
-for the tied hash iterator, it is only done once, and the list is reused for
-subsequent iterations. Changes to symbols made through this package are
-recorded, but in the rare event that someone changes the process' symbol table
-from outside (as is possible using some software from the net), the iterator
-will be out of sync with the symbol table. If you expect this to happen, you
-can reset the cache by calling this method. In addition, if you pass a FALSE
-value as the first argument, caching will be disabled. It can be reenabled
-later by calling C<clearcache> again with a TRUE value as the first argument.
-It returns TRUE or FALSE to indicate whether caching was previously enabled or
-disabled, respectively.
-
-This method is a stopgap until we can incorporate code into this extension to
-traverse the process' symbol table directly, so it may disappear in a future
-version of this package.
-
-=back
-
-=head1 AUTHOR
-
-Charles Bailey bailey@newman.upenn.edu
-
-=head1 VERSION
-
-1.01 08-Dec-1996
-
-=head1 BUGS
-
-The list of symbols for the iterator is assembled by spawning off a
-subprocess, which can be slow. Ideally, we should just traverse the
-process' symbol table directly from C.
-
diff --git a/vms/ext/DCLsym/DCLsym.xs b/vms/ext/DCLsym/DCLsym.xs
deleted file mode 100644
index f0f19f4d16..0000000000
--- a/vms/ext/DCLsym/DCLsym.xs
+++ /dev/null
@@ -1,151 +0,0 @@
-/* VMS::DCLsym - manipulate DCL symbols
- *
- * Version: 1.0
- * Author: Charles Bailey bailey@newman.upenn.edu
- * Revised: 17-Aug-1995
- *
- *
- * Revision History:
- *
- * 1.0 17-Aug-1995 Charles Bailey bailey@newman.upenn.edu
- * original production version
- */
-
-#include <descrip.h>
-#include <lib$routines.h>
-#include <libclidef.h>
-#include <libdef.h>
-#include <ssdef.h>
-#include "EXTERN.h"
-#include "perl.h"
-#include "XSUB.h"
-
-MODULE = VMS::DCLsym PACKAGE = VMS::DCLsym
-
-void
-_getsym(name)
- SV * name
- PPCODE:
- {
- struct dsc$descriptor_s namdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
- valdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
- STRLEN namlen;
- int tbltype;
- unsigned long int retsts;
- SETERRNO(0,SS$_NORMAL);
- if (!name) {
- PUSHs(sv_newmortal());
- SETERRNO(EINVAL,LIB$_INVARG);
- return;
- }
- namdsc.dsc$a_pointer = SvPV(name,namlen);
- namdsc.dsc$w_length = (unsigned short int) namlen;
- retsts = lib$get_symbol(&namdsc,&valdsc,0,&tbltype);
- if (retsts & 1) {
- PUSHs(sv_2mortal(newSVpv(valdsc.dsc$w_length ?
- valdsc.dsc$a_pointer : "",valdsc.dsc$w_length)));
- if (GIMME) {
- EXTEND(sp,2); /* just in case we're at the end of the stack */
- if (tbltype == LIB$K_CLI_LOCAL_SYM)
- PUSHs(sv_2mortal(newSVpv("LOCAL",5)));
- else
- PUSHs(sv_2mortal(newSVpv("GLOBAL",6)));
- }
- _ckvmssts(lib$sfree1_dd(&valdsc));
- }
- else {
- ST(0) = &PL_sv_undef; /* error - we're returning undef, if anything */
- switch (retsts) {
- case LIB$_NOSUCHSYM:
- break; /* nobody home */;
- case LIB$_INVSYMNAM: /* user errors; set errno return undef */
- case LIB$_INSCLIMEM:
- case LIB$_NOCLI:
- set_errno(EVMSERR);
- set_vaxc_errno(retsts);
- break;
- default: /* bail out */
- { _ckvmssts(retsts); }
- }
- }
- }
-
-
-void
-_setsym(name,val,typestr="LOCAL")
- SV * name
- SV * val
- char * typestr
- CODE:
- {
- struct dsc$descriptor_s namdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
- valdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
- STRLEN slen;
- int type;
- unsigned long int retsts;
- SETERRNO(0,SS$_NORMAL);
- if (!name || !val) {
- SETERRNO(EINVAL,LIB$_INVARG);
- XSRETURN_UNDEF;
- }
- namdsc.dsc$a_pointer = SvPV(name,slen);
- namdsc.dsc$w_length = (unsigned short int) slen;
- valdsc.dsc$a_pointer = SvPV(val,slen);
- valdsc.dsc$w_length = (unsigned short int) slen;
- type = strNE(typestr,"GLOBAL") ?
- LIB$K_CLI_LOCAL_SYM : LIB$K_CLI_GLOBAL_SYM;
- retsts = lib$set_symbol(&namdsc,&valdsc,&type);
- if (retsts & 1) { XSRETURN_YES; }
- else {
- switch (retsts) {
- case LIB$_AMBSYMDEF: /* user errors; set errno and return */
- case LIB$_INSCLIMEM:
- case LIB$_INVSYMNAM:
- case LIB$_NOCLI:
- set_errno(EVMSERR);
- set_vaxc_errno(retsts);
- XSRETURN_NO;
- break; /* NOTREACHED */
- default: /* bail out */
- { _ckvmssts(retsts); }
- }
- }
- }
-
-
-void
-_delsym(name,typestr="LOCAL")
- SV * name
- char * typestr
- CODE:
- {
- struct dsc$descriptor_s namdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
- STRLEN slen;
- int type;
- unsigned long int retsts;
- SETERRNO(0,SS$_NORMAL);
- if (!name || !typestr) {
- SETERRNO(EINVAL,LIB$_INVARG);
- XSRETURN_UNDEF;
- }
- namdsc.dsc$a_pointer = SvPV(name,slen);
- namdsc.dsc$w_length = (unsigned short int) slen;
- type = strNE(typestr,"GLOBAL") ?
- LIB$K_CLI_LOCAL_SYM : LIB$K_CLI_GLOBAL_SYM;
- retsts = lib$delete_symbol(&namdsc,&type);
- if (retsts & 1) { XSRETURN_YES; }
- else {
- switch (retsts) {
- case LIB$_INVSYMNAM: /* user errors; set errno and return */
- case LIB$_NOCLI:
- case LIB$_NOSUCHSYM:
- set_errno(EVMSERR);
- set_vaxc_errno(retsts);
- XSRETURN_NO;
- break; /* NOTREACHED */
- default: /* bail out */
- { _ckvmssts(retsts); }
- }
- }
- }
-
diff --git a/vms/ext/DCLsym/Makefile.PL b/vms/ext/DCLsym/Makefile.PL
deleted file mode 100644
index 28e2fa3758..0000000000
--- a/vms/ext/DCLsym/Makefile.PL
+++ /dev/null
@@ -1,4 +0,0 @@
-use ExtUtils::MakeMaker;
-
-WriteMakefile( 'VERSION_FROM' => 'DCLsym.pm',
- 'MAN3PODS' => {});
diff --git a/vms/ext/DCLsym/test.pl b/vms/ext/DCLsym/test.pl
deleted file mode 100644
index 57f2afbd20..0000000000
--- a/vms/ext/DCLsym/test.pl
+++ /dev/null
@@ -1,41 +0,0 @@
-print "1..15\n";
-
-require VMS::DCLsym or die "failed 1\n";
-print "ok 1\n";
-
-tie %syms, VMS::DCLsym or die "failed 2\n";
-print "ok 2\n";
-
-$name = 'FOO_'.time();
-$syms{$name} = 'Perl_test';
-print +($! ? "(\$! = $!) not " : ''),"ok 3\n";
-
-print +($syms{$name} eq 'Perl_test' ? '' : 'not '),"ok 4\n";
-
-($val) = `Show Symbol $name` =~ /(\w+)"$/;
-print +($val eq 'Perl_test' ? '' : 'not '),"ok 5\n";
-
-while (($sym,$val) = each %syms) {
- last if $sym eq $name && $val eq 'Perl_test';
-}
-print +($sym ? '' : 'not '),"ok 6\n";
-
-delete $syms{$name};
-print +($! ? "(\$! = $!) not " : ''),"ok 7\n";
-
-print +(defined($syms{$name}) ? 'not ' : ''),"ok 8\n";
-undef %syms;
-
-$obj = new VMS::DCLsym 'GLOBAL';
-print +($obj ? '' : 'not '),"ok 9\n";
-
-print +($obj->clearcache(0) ? '' : 'not '),"ok 10\n";
-print +($obj->clearcache(1) ? 'not ' : ''),"ok 11\n";
-
-print +($obj->setsym($name,'Another_test') ? '' : 'not '),"ok 12\n";
-
-($val,$tab) = $obj->getsym($name);
-print +($val eq 'Another_test' && $tab eq 'GLOBAL' ? '' : 'not '),"ok 13\n";
-
-print +($obj->delsym($name,'LOCAL') ? 'not ' : ''),"ok 14\n";
-print +($obj->delsym($name,'GLOBAL') ? '' : 'not '),"ok 15\n";
diff --git a/vms/ext/Stdio/0README.txt b/vms/ext/Stdio/0README.txt
deleted file mode 100644
index 25329f9334..0000000000
--- a/vms/ext/Stdio/0README.txt
+++ /dev/null
@@ -1,30 +0,0 @@
-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@genetics.upenn.edu
- original version - vmsfopen
-1.1 09-Mar-1995 Charles Bailey bailey@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@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/Makefile.PL b/vms/ext/Stdio/Makefile.PL
deleted file mode 100644
index 4e17a48082..0000000000
--- a/vms/ext/Stdio/Makefile.PL
+++ /dev/null
@@ -1,5 +0,0 @@
-use ExtUtils::MakeMaker;
-
-WriteMakefile( 'VERSION_FROM' => 'Stdio.pm',
- 'MAN3PODS' => {}, # pods will be built later
- );
diff --git a/vms/ext/Stdio/Stdio.pm b/vms/ext/Stdio/Stdio.pm
deleted file mode 100644
index 54f37c94fb..0000000000
--- a/vms/ext/Stdio/Stdio.pm
+++ /dev/null
@@ -1,640 +0,0 @@
-# VMS::Stdio - VMS extensions to Perl's stdio calls
-#
-# Author: Charles Bailey bailey@genetics.upenn.edu
-# Version: 2.2
-# Revised: 19-Jul-1998
-# Docs revised: 13-Oct-1998 Dan Sugalski <sugalskd@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.4';
-@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
diff --git a/vms/ext/Stdio/Stdio.xs b/vms/ext/Stdio/Stdio.xs
deleted file mode 100644
index c50bacb3f3..0000000000
--- a/vms/ext/Stdio/Stdio.xs
+++ /dev/null
@@ -1,463 +0,0 @@
-/* VMS::Stdio - VMS extensions to stdio routines
- *
- * Version: 2.3
- * Author: Charles Bailey bailey@newman.upenn.edu
- * Revised: 14-Jun-2007
- *
- */
-
-#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);
- 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 NULL;
- 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 NULL;
- 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 = NULL;
- 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) == NULL) {
- 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 == NULL) *(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_ NULL,acmode,-1,0,0,fp,1,&name) == NULL) 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:
- FILE *stdio = PerlIO_exportFILE(fp,0);
- char fname[NAM$C_MAXRSS+1];
- ST(0) = sv_newmortal();
- if (fgetname(stdio,fname) != NULL) sv_setpv(ST(0),fname);
- PerlIO_releaseFILE(fp,stdio);
-
-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) {
- pio_fp = PerlIO_fdopen(fileno(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;
- 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 &&
- ((pio_fp = PerlIO_fdopen(fd, &("r\000w\000r+"[2*i]))) != NULL)) {
- 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)) == NULL) {
- set_errno(EBADF); set_vaxc_errno(SS$_IVCHAN); XSRETURN_UNDEF;
- }
- if (PerlIO_getname(fp,devnam) == NULL) { 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;
- }
diff --git a/vms/ext/Stdio/test.pl b/vms/ext/Stdio/test.pl
deleted file mode 100755
index 77505d8fac..0000000000
--- a/vms/ext/Stdio/test.pl
+++ /dev/null
@@ -1,79 +0,0 @@
-# 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";
-
-#VMS can pretend that it is UNIX.
-my $perl = $^X;
-$perl = VMS::Filespec::vmsify($perl) if $^O eq 'VMS';
-
-$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) =~/\](.*);/);
-
-#we may be in UNIX emulation mode.
-if (!defined($gotname)) {
- ($gotname) = (VMS::Filespec::vmsify(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[| $^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 $perl\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";