diff options
author | Perl 5 Porters <perl5-porters@africa.nicoh.com> | 1996-09-07 03:16:00 +0000 |
---|---|---|
committer | Andy Dougherty <doughera@lafcol.lafayette.edu> | 1996-09-07 03:16:00 +0000 |
commit | 740ce14cd863bb8986a54f425a6f1ec20b26c6cc (patch) | |
tree | e25f5b48ba535ed07ec57bf13ed1c50973dbacd1 /vms | |
parent | c43cd16b2d0254cdf3b775a546b5a6986ff4b90a (diff) | |
download | perl-740ce14cd863bb8986a54f425a6f1ec20b26c6cc.tar.gz |
VMS 5.003_05 Update.
Diffstat (limited to 'vms')
-rw-r--r-- | vms/Makefile | 39 | ||||
-rw-r--r-- | vms/config.vms | 126 | ||||
-rw-r--r-- | vms/descrip.mms | 39 | ||||
-rw-r--r-- | vms/ext/Stdio/Stdio.pm | 26 | ||||
-rw-r--r-- | vms/ext/filespec.t | 7 | ||||
-rw-r--r-- | vms/gen_shrfls.pl | 4 | ||||
-rw-r--r-- | vms/perlvms.pod | 10 | ||||
-rw-r--r-- | vms/vms.c | 151 |
8 files changed, 324 insertions, 78 deletions
diff --git a/vms/Makefile b/vms/Makefile index 5246b50506..98c0747735 100644 --- a/vms/Makefile +++ b/vms/Makefile @@ -32,7 +32,7 @@ ARCH = VMS_VAX OBJVAL = $@ # Updated by fndvers.com -- do not edit by hand -PERL_VERSION = 5_00301# +PERL_VERSION = 5_00304# ARCHDIR = [.lib.$(ARCH).$(PERL_VERSION)] @@ -114,16 +114,16 @@ extobj = $(myextobj) h1 = EXTERN.h, INTERN.h, XSUB.h, av.h, config.h, cop.h, cv.h h2 = embed.h, form.h, gv.h, handy.h, hv.h, keywords.h, mg.h, op.h h3 = opcode.h, patchlevel.h, perl.h, perly.h, pp.h, proto.h, regcomp.h -h4 = regexp.h, scope.h, sv.h, vmsish.h, util.h +h4 = regexp.h, scope.h, sv.h, vmsish.h, util.h, perlio.h, perlsdio.h h = $(h1), $(h2), $(h3), $(h4) $(SOCKHLIS) -c1 = av.c, scope.c, op.c, doop.c, doio.c, dump.c, hv.c, mg.c, universal.c +c1 = av.c, scope.c, op.c, doop.c, doio.c, dump.c, hv.c, mg.c, universal.c, perlio.c c2 = perl.c, perly.c, pp.c, pp_hot.c, pp_ctl.c, pp_sys.c, regcomp.c, regexec.c c3 = gv.c, sv.c, taint.c, toke.c, util.c, deb.c, run.c, globals.c, vms.c $(SOCKCLIS) c = $(c1), $(c2), $(c3), miniperlmain.c, perlmain.c -obj1 = perl$(O), gv$(O), toke$(O), perly$(O), op$(O), regcomp$(O), dump$(O), util$(O), mg$(O) +obj1 = perl$(O), gv$(O), toke$(O), perly$(O), op$(O), regcomp$(O), dump$(O), util$(O), mg$(O), perlio$(O) obj2 = hv$(O), av$(O), run$(O), pp_hot$(O), sv$(O), pp$(O), scope$(O), pp_ctl$(O), pp_sys$(O) obj3 = doop$(O), doio$(O), regexec$(O), taint$(O), deb$(O), universal$(O), globals$(O), vms$(O) $(SOCKOBJ) @@ -134,7 +134,7 @@ ac2 = $(ARCHCORE)config.h $(ARCHCORE)cop.h $(ARCHCORE)cv.h $(ARCHCORE)embed.h ac3 = $(ARCHCORE)form.h $(ARCHCORE)gv.h $(ARCHCORE)handy.h $(ARCHCORE)hv.h ac4 = $(ARCHCORE)keywords.h $(ARCHCORE)mg.h $(ARCHCORE)op.h $(ARCHCORE)opcode.h ac5 = $(ARCHCORE)patchlevel.h $(ARCHCORE)perl.h $(ARCHCORE)perly.h -ac6 = $(ARCHCORE)pp.h $(ARCHCORE)proto.h $(ARCHCORE)regcomp.h +ac6 = $(ARCHCORE)pp.h $(ARCHCORE)proto.h $(ARCHCORE)regcomp.h $(ARCHCORE)perlio.h $(ARCHCORE)perlsdio.h ac7 = $(ARCHCORE)regexp.h $(ARCHCORE)scope.h $(ARCHCORE)sv.h $(ARCHCORE)util.h ac8 = $(ARCHCORE)vmsish.h $(ARCHCORE)$(DBG)libperl$(OLB) $(ARCHCORE)perlshr_attr.opt ac9 = $(ARCHCORE)$(DBG)perlshr_bld.opt @@ -651,6 +651,12 @@ $(ARCHCORE)patchlevel.h : patchlevel.h $(ARCHCORE)perl.h : perl.h @ If f$$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE) Copy/Log perl.h $@ +$(ARCHCORE)perlio.h : perlio.h + @ If f$$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE) + Copy/Log perlio.h $@ +$(ARCHCORE)perlsdio.h : perlsdio.h + @ If f$$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE) + Copy/Log perlsdio.h $@ $(ARCHCORE)perly.h : perly.h @ If f$$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE) Copy/Log perly.h $@ @@ -1271,6 +1277,29 @@ vms$(O) : scope.h vms$(O) : sv.h vms$(O) : vmsish.h vms$(O) : util.h +perlio$(O) : EXTERN.h +perlio$(O) : av.h +perlio$(O) : config.h +perlio$(O) : cop.h +perlio$(O) : cv.h +perlio$(O) : embed.h +perlio$(O) : form.h +perlio$(O) : gv.h +perlio$(O) : handy.h +perlio$(O) : hv.h +perlio$(O) : mg.h +perlio$(O) : op.h +perlio$(O) : opcode.h +perlio$(O) : perl.h +perlio$(O) : perly.h +perlio$(O) : pp.h +perlio$(O) : proto.h +perlio$(O) : regexp.h +perlio$(O) : perlio.c +perlio$(O) : scope.h +perlio$(O) : sv.h +perlio$(O) : vmsish.h +perlio$(O) : util.h miniperlmain$(O) : EXTERN.h miniperlmain$(O) : av.h miniperlmain$(O) : config.h diff --git a/vms/config.vms b/vms/config.vms index e1d609a747..59407ceca4 100644 --- a/vms/config.vms +++ b/vms/config.vms @@ -58,21 +58,26 @@ */ #define OSNAME "VMS" /**/ -/* ARCHLIB_EXP: +/* ARCHLIB: * This variable, if defined, holds the name of the directory in * which the user wants to put architecture-dependent public * library files for $package. It is most often a local directory * such as /usr/local/lib. Programs using this variable must be - * prepared to deal with filename expansion. If ARCHLIB_EXP is the - * same as PRIVLIB_EXP, it is not defined, since presumably the - * program already searches PRIVLIB_EXP. + * prepared to deal with filename expansion. If ARCHLIB is the + * same as PRIVLIB, it is not defined, since presumably the + * program already searches PRIVLIB. + */ +/* ARCHLIB_EXP: + * This symbol contains the ~name expanded version of ARCHLIB, to be used + * in programs that are not prepared to deal with ~ expansion at run-time. */ /* ==> NOTE <== * This value is automatically updated by FndVers.Com * when Perl is built. Please do not change it by hand; make * any changes to FndVers.Com instead. */ -#define ARCHLIB_EXP "/perl_root/lib/VMS_VAX/5_00301" /**/ +#define ARCHLIB_EXP "/perl_root/lib/VMS_VAX/5_00304" /**/ +#define ARCHLIB ARCHLIB_EXP /*config-skip*/ /* CPPSTDIN: * This symbol contains the first part of the string which will invoke @@ -499,8 +504,8 @@ * I/O uses a summy FILE *, and Perl doesn't distinguish between socket * and non-socket filehandles. */ -#undef USE_STDIO_PTR /**/ -#undef USE_STDIO_BASE /**/ +#define USE_STDIO_PTR /**/ +#define USE_STDIO_BASE /**/ /* FILE_ptr: * This macro is used to access the _ptr field (or equivalent) of the @@ -520,10 +525,20 @@ * This symbol is defined if the FILE_cnt macro can be used as an * lvalue. */ -#undef FILE_ptr -#undef STDIO_PTR_LVALUE -#undef FILE_cnt -#undef STDIO_CNT_LVALUE +#define FILE_ptr(fp) ((*fp)->_ptr) +#define STDIO_PTR_LVALUE +#define FILE_cnt(fp) ((*fp)->_cnt) +#define STDIO_CNT_LVALUE + +/* FILE_filbuf: + * This macro is used to access the internal stdio _filbuf function + * (or equivalent), if STDIO_CNT_LVALUE and STDIO_PTR_LVALUE + * are defined. It is typically either _filbuf or __filbuf. + * This macro will only be defined if both STDIO_CNT_LVALUE and + * STDIO_PTR_LVALUE are defined. + */ +#define FILE_filbuf(fp) do { register int c; if ((c = fgetc(fp)) != EOF) \ + ungetc(c,(fp)); } while (0); /* FILE_base: * This macro is used to access the _base field (or equivalent) of the @@ -536,8 +551,8 @@ * structure pointed to its argument. This macro will always be defined * if USE_STDIO_BASE is defined. */ -#undef FILE_base -#undef FILE_bufsiz +#define FILE_base(fp) ((*fp)->_base) +#define FILE_bufsiz(fp) ((*fp)->_cnt + (*fp)->_ptr - (*fp)->_base) /* USE_STRUCT_COPY: * This symbol, if defined, indicates that this C compiler knows how @@ -681,7 +696,7 @@ * include <limits.h> to get definition of symbols like WORD_BIT or * LONG_MAX, i.e. machine dependant limitations. */ -#undef I_LIMITS /**/ +#define I_LIMITS /**/ /* I_MEMORY: * This symbol, if defined, indicates to the C program that it should @@ -779,6 +794,12 @@ */ #undef I_SYS_NDIR /**/ +/* I_SYS_RESOURCE: + * This symbol, if defined, indicates to the C program that it should + * include <sys/resource.h>. + */ +#undef I_SYS_RESOURCE /**/ + /* I_SYS_SELECT: * This symbol, if defined, indicates to the C program that it should * include <sys/select.h> in order to get definition of struct timeval. @@ -796,6 +817,12 @@ #undef I_DBM /**/ #undef I_RPCSVC_DBM /**/ +/* I_SFIO: + * This symbol, if defined, indicates to the C program that it should + * include <sfio.h>. + */ +#undef I_SFIO /**/ + /* I_SYS_STAT: * This symbol, if defined, indicates to the C program that it should * include <sys/stat.h>. @@ -820,6 +847,12 @@ */ #undef I_SYS_UN /**/ +/* I_SYS_WAIT: + * This symbol, if defined, indicates to the C program that it should + * include <sys/wait.h>. + */ +#undef I_SYS_WAIT /**/ + /* I_TERMIO: * This symbol, if defined, indicates that the program should include * <termio.h> rather than <sgtty.h>. There are also differences in @@ -1203,6 +1236,14 @@ */ #define Off_t int /* <offset> type */ +/* I_VALUES: + * This symbol, if defined, indicates to the C program that it should + * include <values.h> to get definition of symbols like MINFLOAT or + * MAXLONG, i.e. machine dependant limitations. Probably, you + * should use <limits.h> instead, if it is available. + */ +#undef I_VALUES /**/ + /* Free_t: * This variable contains the return type of free(). It is usually * void, but occasionally int. @@ -1218,6 +1259,14 @@ */ #undef MYMALLOC /**/ +/* SH_PATH: + * This symbol contains the full pathname to the shell used on this + * on this system to execute Bourne shell scripts. Usually, this will be + * /bin/sh, though it's possible that some systems will have /bin/ksh, + * /bin/pdksh, /bin/ash, /bin/bash, or even something such as D:/bin/sh. + */ +#define SH_PATH "MCR" /**/ + /* SIG_NAME: * This symbol contains a list of signal names in order. This is intended * to be used as a static array initialization, like this: @@ -1294,6 +1343,13 @@ #undef RD_NODATA #undef EOF_NONBLOCK +/* OLDARCHLIB: + * This variable, if defined, holds the name of the directory in + * which the user has perl5.000 or perl5.001 architecture-dependent + * public library files for $package. For the most part, these + * files will work with 5.002 (and later), but that is not + * guaranteed. + */ /* OLDARCHLIB_EXP: * This symbol contains the ~name expanded version of OLDARCHLIB, to be * used in programs that are not prepared to deal with ~ expansion at @@ -1305,21 +1361,46 @@ * any changes to FndVers.Com instead. */ #define OLDARCHLIB_EXP "/perl_root/lib/VMS_VAX" /**/ +#define OLDARCHLIB OLDARCHLIB_EXP /*config-skip*/ -/* PRIVLIB_EXP: +/* PRIVLIB: * This symbol contains the name of the private library for this package. * The library is private in the sense that it needn't be in anyone's * execution path, but it should be accessible by the world. The program * should be prepared to do ~ expansion. */ +/* PRIVLIB_EXP: + * This symbol contains the ~name expanded version of PRIVLIB, to be used + * in programs that are not prepared to deal with ~ expansion at run-time. + */ #define PRIVLIB_EXP "/perl_root/lib" /**/ +#define PRIVLIB PRIVLIB_EXP /*config-skip*/ +/* SITELIB: + * This symbol contains the name of the private library for this package. + * The library is private in the sense that it needn't be in anyone's + * execution path, but it should be accessible by the world. The program + * should be prepared to do ~ expansion. + * The standard distribution will put nothing in this directory. + * Individual sites may place their own extensions and modules in + * this directory. + */ /* SITELIB_EXP: * This symbol contains the ~name expanded version of SITELIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ #define SITELIB_EXP "/perl_root/lib/site_perl" /**/ +#define SITELIB SITELIB_EXP /*config-skip*/ +/* SITEARCH: + * This symbol contains the name of the private library for this package. + * The library is private in the sense that it needn't be in anyone's + * execution path, but it should be accessible by the world. The program + * should be prepared to do ~ expansion. + * The standard distribution will put nothing in this directory. + * Individual sites may place their own extensions and modules in + * this directory. + */ /* SITEARCH_EXP: * This symbol contains the ~name expanded version of SITEARCH, to be used * in programs that are not prepared to deal with ~ expansion at run-time. @@ -1330,6 +1411,7 @@ * any changes to FndVers.Com instead. */ #define SITEARCH_EXP "/perl_root/lib/site_perl/VMS_VAX" /**/ +#define SITEARCH SITEARCH_EXP /*config-skip*/ /* SCRIPTDIR: * This symbol holds the name of the directory in which the user wants @@ -1485,6 +1567,12 @@ */ #define Gconvert(x,n,t,b) my_gconvert(x,n,t,b) +/* USE_SFIO: + * This symbol, if defined, indicates that sfio should + * be used. + */ +#undef USE_SFIO /**/ + /* Sigjmp_buf: * This is the buffer type to be used with Sigsetjmp and Siglongjmp. */ @@ -1545,10 +1633,12 @@ #undef DB_Hash_t /**/ #undef DB_Prefix_t /**/ -/* BIN_SH: - * This variable contains the path to the shell. +/* USE_PERLIO: + * This symbol, if defined, indicates that the PerlIO abstraction should + * be used throughout. If not defined, stdio should be + * used in a fully backward compatible manner. */ -#define BIN_SH "MCR" /**/ +#undef USE_PERLIO /**/ /* VOIDFLAGS: * This symbol indicates how much support of the void type is given by this diff --git a/vms/descrip.mms b/vms/descrip.mms index 31d13e8eb8..ad26b1d33d 100644 --- a/vms/descrip.mms +++ b/vms/descrip.mms @@ -65,7 +65,7 @@ OBJVAL = $(MMS$TARGET_NAME)$(O) .endif # Updated by fndvers.com -- do not edit by hand -PERL_VERSION = 5_00301# +PERL_VERSION = 5_00304# ARCHDIR = [.lib.$(ARCH).$(PERL_VERSION)] @@ -211,16 +211,16 @@ extobj = $(myextobj) h1 = EXTERN.h, INTERN.h, XSUB.h, av.h, config.h, cop.h, cv.h h2 = embed.h, form.h, gv.h, handy.h, hv.h, keywords.h, mg.h, op.h h3 = opcode.h, patchlevel.h, perl.h, perly.h, pp.h, proto.h, regcomp.h -h4 = regexp.h, scope.h, sv.h, vmsish.h, util.h +h4 = regexp.h, scope.h, sv.h, vmsish.h, util.h, perlio.h, perlsdio.h h = $(h1), $(h2), $(h3), $(h4) $(SOCKHLIS) -c1 = av.c, scope.c, op.c, doop.c, doio.c, dump.c, hv.c, mg.c, universal.c +c1 = av.c, scope.c, op.c, doop.c, doio.c, dump.c, hv.c, mg.c, universal.c, perlio.c c2 = perl.c, perly.c, pp.c, pp_hot.c, pp_ctl.c, pp_sys.c, regcomp.c, regexec.c c3 = gv.c, sv.c, taint.c, toke.c, util.c, deb.c, run.c, globals.c, vms.c $(SOCKCLIS) c = $(c1), $(c2), $(c3), miniperlmain.c, perlmain.c -obj1 = perl$(O), gv$(O), toke$(O), perly$(O), op$(O), regcomp$(O), dump$(O), util$(O), mg$(O) +obj1 = perl$(O), gv$(O), toke$(O), perly$(O), op$(O), regcomp$(O), dump$(O), util$(O), mg$(O), perlio$(O) obj2 = hv$(O), av$(O), run$(O), pp_hot$(O), sv$(O), pp$(O), scope$(O), pp_ctl$(O), pp_sys$(O) obj3 = doop$(O), doio$(O), regexec$(O), taint$(O), deb$(O), universal$(O), globals$(O), vms$(O) $(SOCKOBJ) @@ -231,7 +231,7 @@ ac2 = $(ARCHCORE)config.h $(ARCHCORE)cop.h $(ARCHCORE)cv.h $(ARCHCORE)embed.h ac3 = $(ARCHCORE)form.h $(ARCHCORE)gv.h $(ARCHCORE)handy.h $(ARCHCORE)hv.h ac4 = $(ARCHCORE)keywords.h $(ARCHCORE)mg.h $(ARCHCORE)op.h $(ARCHCORE)opcode.h ac5 = $(ARCHCORE)patchlevel.h $(ARCHCORE)perl.h $(ARCHCORE)perly.h -ac6 = $(ARCHCORE)pp.h $(ARCHCORE)proto.h $(ARCHCORE)regcomp.h +ac6 = $(ARCHCORE)pp.h $(ARCHCORE)proto.h $(ARCHCORE)regcomp.h $(ARCHCORE)perlio.h $(ARCHCORE)perlsdio.h ac7 = $(ARCHCORE)regexp.h $(ARCHCORE)scope.h $(ARCHCORE)sv.h $(ARCHCORE)util.h ac8 = $(ARCHCORE)vmsish.h $(ARCHCORE)$(DBG)libperl$(OLB) $(ARCHCORE)perlshr_attr.opt ac9 = $(ARCHCORE)$(DBG)perlshr_bld.opt @@ -797,6 +797,12 @@ $(ARCHCORE)patchlevel.h : patchlevel.h $(ARCHCORE)perl.h : perl.h @ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE) Copy/Log $(MMS$SOURCE) $(MMS$TARGET) +$(ARCHCORE)perlio.h : perlio.h + @ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE) + Copy/Log $(MMS$SOURCE) $(MMS$TARGET) +$(ARCHCORE)perlsdio.h : perlsdio.h + @ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE) + Copy/Log $(MMS$SOURCE) $(MMS$TARGET) $(ARCHCORE)perly.h : perly.h @ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE) Copy/Log $(MMS$SOURCE) $(MMS$TARGET) @@ -1424,6 +1430,29 @@ vms$(O) : scope.h vms$(O) : sv.h vms$(O) : vmsish.h vms$(O) : util.h +perlio$(O) : EXTERN.h +perlio$(O) : av.h +perlio$(O) : config.h +perlio$(O) : cop.h +perlio$(O) : cv.h +perlio$(O) : embed.h +perlio$(O) : form.h +perlio$(O) : gv.h +perlio$(O) : handy.h +perlio$(O) : hv.h +perlio$(O) : mg.h +perlio$(O) : op.h +perlio$(O) : opcode.h +perlio$(O) : perl.h +perlio$(O) : perly.h +perlio$(O) : pp.h +perlio$(O) : proto.h +perlio$(O) : regexp.h +perlio$(O) : perlio.c +perlio$(O) : scope.h +perlio$(O) : sv.h +perlio$(O) : vmsish.h +perlio$(O) : util.h miniperlmain$(O) : EXTERN.h miniperlmain$(O) : av.h miniperlmain$(O) : config.h diff --git a/vms/ext/Stdio/Stdio.pm b/vms/ext/Stdio/Stdio.pm index f87631a32a..275081329c 100644 --- a/vms/ext/Stdio/Stdio.pm +++ b/vms/ext/Stdio/Stdio.pm @@ -13,7 +13,7 @@ use DynaLoader (); use Exporter (); $VERSION = '2.0'; -@ISA = qw( Exporter DynaLoader FileHandle ); +@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 @@ -34,10 +34,10 @@ sub AUTOLOAD { defined $val or croak("Unknown VMS::Stdio constant $constname"); *$AUTOLOAD = sub { $val }; } - else { # We don't know about it; hand off to FileHandle - require FileHandle; + else { # We don't know about it; hand off to IO::File + require IO::File; my($obj) = shift(@_); - $obj->FileHandle::$constname(@_); + $obj->IO::File::$constname(@_); } goto &$AUTOLOAD; } @@ -124,12 +124,12 @@ easily choose what you'd like to import: Of course, you can also choose to import specific functions by name, as usual. -This package C<ISA> FileHandle, so that you can call FileHandle +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 FileHandle package is not initialized, however, until you +The IO::File package is not initialized, however, until you actually call a method that VMS::Stdio doesn't provide. This is doen to save startup time for users who don't wish to use -the FileHandle methods. +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 @@ -152,7 +152,7 @@ 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 FileHandle. If an error occurs, it returns C<undef>. +with a Perl I/O handle. If an error occurs, it returns C<undef>. =item remove @@ -190,7 +190,7 @@ The C<vmsopen> function enables you to specify optional RMS arguments to the VMS CRTL when opening a file. It is similar to the built-in Perl C<open> function (see L<perlfunc> for a complete description), but will only open normal files; it cannot open pipes or duplicate -existing FileHandles. Up to 8 optional arguments may follow the +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.) @@ -199,11 +199,11 @@ error occurs, it returns C<undef>. You can use the file handle returned by C<vmsfopen> just as you would any other Perl file handle. The class VMS::Stdio ISA -FileHandle, so you can call FileHandle methods using the handle +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> FileHandle; you must do so explicitly in -your program if you want to call FileHandle methods. This is -done to avoid the overhead of initializing the FileHandle package +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 diff --git a/vms/ext/filespec.t b/vms/ext/filespec.t index 7c1d4c9d4e..38cd5368c9 100644 --- a/vms/ext/filespec.t +++ b/vms/ext/filespec.t @@ -8,7 +8,7 @@ foreach (<DATA>) { next if /^\s*$/; push(@tests,$_); } -print '1..',scalar(@tests)+1,"\n"; +print '1..',scalar(@tests)+3,"\n"; foreach $test (@tests) { ($arg,$func,$expect) = split(/\t+/,$test); @@ -24,6 +24,10 @@ foreach $test (@tests) { } print +(rmsexpand('[]') eq "\U$ENV{DEFAULT}" ? 'ok ' : 'not ok '),++$idx,"\n"; +print +(rmsexpand('from.here') eq "\L$ENV{DEFAULT}from.here" ? + 'ok ' : 'not ok '),++$idx,"\n"; +print +(rmsexpand('from.here','cant:[get.there];2') eq + 'cant:[get.there]from.here;2' ? 'ok ' : 'not ok '),++$idx,"\n"; __DATA__ @@ -81,6 +85,7 @@ down/the/garden/path vmspath [.down.the.garden.path] path vmspath [.path] # Redundant characters in Unix paths +//some/where//over/../the.rainbow vmsify some:[where]the.rainbow /some/where//over/./the.rainbow vmsify some:[where.over]the.rainbow ..//../ vmspath [--] ./././ vmspath [] diff --git a/vms/gen_shrfls.pl b/vms/gen_shrfls.pl index 6972c67edf..8753893b8d 100644 --- a/vms/gen_shrfls.pl +++ b/vms/gen_shrfls.pl @@ -222,10 +222,10 @@ close CPP; # Kluge to determine whether we need to add EMBED prefix to -# symbols read from local list. init_os_extras() is a VMS- +# symbols read from local list. vmsreaddirversions() is a VMS- # specific function whose Perl_ prefix is added in vmsish.h # if EMBED is #defined. -$embed = exists($fcns{'Perl_init_os_extras'}) ? 'Perl_' : ''; +$embed = exists($fcns{'Perl_vmsreaddirversions'}) ? 'Perl_' : ''; while (<DATA>) { next if /^#/; s/\s+#.*\n//; diff --git a/vms/perlvms.pod b/vms/perlvms.pod index b7804f0b42..7d441cb4e2 100644 --- a/vms/perlvms.pod +++ b/vms/perlvms.pod @@ -611,7 +611,7 @@ list logical names. For instance, if you say $ Define STORY once,upon,a,time,there,was $ perl -e "for ($i = 0; $i <= 6; $i++) " - - _$ -e "{ print $ENV{'foo'.$i},' '}" + _$ -e "{ print $ENV{'story;'.$i},' '}" Perl will print C<ONCE UPON A TIME THERE WAS>. @@ -633,6 +633,14 @@ logical name or a name in another logical name table will replace the logical name just deleted. It is not possible at present to define a search list logical name via %ENV. +At present, the first time you iterate over %ENV using +C<keys>, C<values>, or C<each>, you will incur a time +penalty as all logical names are read, in order to fully +populate %ENV. Subsequent iterations will not reread +logical names, so they won't be as slow, but they also +won't reflect any changes to logical name tables caused +by other programs. + In all operations on %ENV, the key string is treated as if it were entirely uppercase, regardless of the case actually specified in the Perl expression. @@ -33,7 +33,11 @@ #include <uaidef.h> #include <uicdef.h> -#ifndef SS$_NOSUCHOBJECT /* Older versions of ssdef.h don't have this */ +/* Older versions of ssdef.h don't have these */ +#ifndef SS$_INVFILFOROP +# define SS$_INVFILFOROP 3930 +#endif +#ifndef SS$_NOSUCHOBJECT # define SS$_NOSUCHOBJECT 2696 #endif @@ -95,7 +99,7 @@ my_trnlnm(char *lnm, char *eqv, unsigned long int idx) } else if (retsts & 1) { eqv[eqvlen] = '\0'; - return 1; + return eqvlen; } _ckvmssts(retsts); /* Must be an error */ return 0; /* Not reached, assuming _ckvmssts() bails out */ @@ -147,7 +151,7 @@ my_getenv(char *lnm) _ckvmssts(retsts); } /* Try for CRTL emulation of a Unix/POSIX name */ - else return getenv(lnm); + else return getenv(uplnm); } } return Nullch; @@ -155,6 +159,61 @@ my_getenv(char *lnm) } /* end of my_getenv() */ /*}}}*/ +/*{{{ void prime_env_iter() */ +void +prime_env_iter(void) +/* Fill the %ENV associative array with all logical names we can + * find, in preparation for iterating over it. + */ +{ + static int primed = 0; /* XXX Not thread-safe!!! */ + HV *envhv = GvHVn(envgv); + FILE *sholog; + char eqv[LNM$C_NAMLENGTH+1],*start,*end; + STRLEN eqvlen; + SV *oldrs, *linesv, *eqvsv; + + if (primed) return; + /* Perform a dummy fetch as an lval to insure that the hash table is + * set up. Otherwise, the hv_store() will turn into a nullop */ + (void) hv_fetch(envhv,"DEFAULT",7,TRUE); + /* Also, set up the four "special" keys that the CRTL defines, + * whether or not underlying logical names exist. */ + (void) hv_fetch(envhv,"HOME",4,TRUE); + (void) hv_fetch(envhv,"TERM",4,TRUE); + (void) hv_fetch(envhv,"PATH",4,TRUE); + (void) hv_fetch(envhv,"USER",4,TRUE); + + /* Now, go get the logical names */ + if ((sholog = my_popen("$ Show Logical *","r")) == Nullfp) + _ckvmssts(vaxc$errno); + /* We use Perl's sv_gets to read from the pipe, since my_popen is + * tied to Perl's I/O layer, so it may not return a simple FILE * */ + oldrs = rs; + rs = newSVpv("\n",1); + linesv = newSVpv("",0); + while (1) { + if ((start = sv_gets(linesv,sholog,0)) == Nullch) { + my_pclose(sholog); + SvREFCNT_dec(linesv); SvREFCNT_dec(rs); rs = oldrs; + primed = 1; + return; + } + while (*start != '"' && *start != '=' && *start) start++; + if (*start != '"') continue; + for (end = ++start; *end && *end != '"'; end++) ; + if (*end) *end = '\0'; + else end = Nullch; + if ((eqvlen = my_trnlnm(start,eqv,0)) == 0) _ckvmssts(vaxc$errno); + else { + eqvsv = newSVpv(eqv,eqvlen); + hv_store(envhv,start,(end ? end - start : strlen(start)),eqvsv,0); + } + } +} /* end of prime_env_iter */ +/*}}}*/ + + /*{{{ void my_setenv(char *lnm, char *eqv)*/ void my_setenv(char *lnm,char *eqv) @@ -306,7 +365,9 @@ kill_file(char *name) lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}}, ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}}; - if (!remove(name)) return 0; /* Can we just get rid of it? */ + if (!remove(name)) return 0; /* Can we just get rid of it? */ + /* If not, can changing protections help? */ + if (vaxc$errno != RMS$_PRV) return -1; /* No, so we get our own UIC to use as a rights identifier, * and the insert an ACE at the head of the ACL which allows us @@ -319,7 +380,22 @@ kill_file(char *name) cxt = 0; newace.myace$l_ident = oldace.myace$l_ident; if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) { - set_errno(EVMSERR); + switch (aclsts) { + case RMS$_FNF: + case RMS$_DNF: + case RMS$_DIR: + case SS$_NOSUCHOBJECT: + set_errno(ENOENT); break; + case RMS$_DEV: + set_errno(ENODEV); break; + case RMS$_SYN: + case SS$_INVFILFOROP: + set_errno(EINVAL); break; + case RMS$_PRV: + set_errno(EACCES); break; + default: + _ckvmssts(aclsts); + } set_vaxc_errno(aclsts); return -1; } @@ -545,7 +621,7 @@ create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc) struct pipe_details { struct pipe_details *next; - FILE *fp; /* stdio file pointer to pipe mailbox */ + PerlIO *fp; /* stdio file pointer to pipe mailbox */ int pid; /* PID of subprocess */ int mode; /* == 'r' if pipe open for reading */ int done; /* subprocess has completed */ @@ -625,7 +701,7 @@ my_popen(char *cmd, char *mode) create_mbx(&chan,&namdsc); /* open a FILE* onto it */ - info->fp=fopen(mbxname, mode); + info->fp = PerlIO_open(mbxname, mode); /* give up other channel onto it */ _ckvmssts(sys$dassgn(chan)); @@ -673,7 +749,7 @@ I32 my_pclose(FILE *fp) /* get here => no such pipe open */ croak("No such pipe open"); - fclose(info->fp); + PerlIO_close(info->fp); if (info->done) retsts = info->completion; else waitpid(info->pid,(int *) &retsts,0); @@ -1659,7 +1735,7 @@ getredirection(int *ac, char ***av) { if (j+1 >= argc) { - fprintf(Perl_debug_log,"No input file after < on command line"); + PerlIO_printf(Perl_debug_log,"No input file after < on command line"); exit(LIB$_WRONUMARG); } in = argv[++j]; @@ -1674,7 +1750,7 @@ getredirection(int *ac, char ***av) { if (j+1 >= argc) { - fprintf(Perl_debug_log,"No output file after > on command line"); + PerlIO_printf(Perl_debug_log,"No output file after > on command line"); exit(LIB$_WRONUMARG); } out = argv[++j]; @@ -1694,7 +1770,7 @@ getredirection(int *ac, char ***av) out = 1 + ap; if (j >= argc) { - fprintf(Perl_debug_log,"No output file after > or >> on command line"); + PerlIO_printf(Perl_debug_log,"No output file after > or >> on command line"); exit(LIB$_WRONUMARG); } continue; @@ -1716,7 +1792,7 @@ getredirection(int *ac, char ***av) err = 2 + ap; if (j >= argc) { - fprintf(Perl_debug_log,"No output file after 2> or 2>> on command line"); + PerlIO_printf(Perl_debug_log,"No output file after 2> or 2>> on command line"); exit(LIB$_WRONUMARG); } continue; @@ -1725,7 +1801,7 @@ getredirection(int *ac, char ***av) { if (j+1 >= argc) { - fprintf(Perl_debug_log,"No command into which to pipe on command line"); + PerlIO_printf(Perl_debug_log,"No command into which to pipe on command line"); exit(LIB$_WRONUMARG); } cmargc = argc-(j+1); @@ -1756,7 +1832,7 @@ getredirection(int *ac, char ***av) { if (out != NULL) { - fprintf(Perl_debug_log,"'|' and '>' may not both be specified on command line"); + PerlIO_printf(Perl_debug_log,"'|' and '>' may not both be specified on command line"); exit(LIB$_INVARGORD); } pipe_and_fork(cmargv); @@ -1775,7 +1851,7 @@ getredirection(int *ac, char ***av) /* Input from a pipe, reopen it in binary mode to disable */ /* carriage control processing. */ - fgetname(stdin, mbxname,1); + PerlIO_getname(stdin, mbxname); mbxnam.dsc$a_pointer = mbxname; mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer); lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0); @@ -1789,25 +1865,25 @@ getredirection(int *ac, char ***av) freopen(mbxname, "rb", stdin); if (errno != 0) { - fprintf(Perl_debug_log,"Can't reopen input pipe (name: %s) in binary mode",mbxname); + PerlIO_printf(Perl_debug_log,"Can't reopen input pipe (name: %s) in binary mode",mbxname); exit(vaxc$errno); } } if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2"))) { - fprintf(Perl_debug_log,"Can't open input file %s as stdin",in); + PerlIO_printf(Perl_debug_log,"Can't open input file %s as stdin",in); exit(vaxc$errno); } if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2"))) { - fprintf(Perl_debug_log,"Can't open output file %s as stdout",out); + PerlIO_printf(Perl_debug_log,"Can't open output file %s as stdout",out); exit(vaxc$errno); } if (err != NULL) { FILE *tmperr; if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2"))) { - fprintf(Perl_debug_log,"Can't open error file %s as stderr",err); + PerlIO_printf(Perl_debug_log,"Can't open error file %s as stderr",err); exit(vaxc$errno); } fclose(tmperr); @@ -1817,9 +1893,9 @@ getredirection(int *ac, char ***av) } } #ifdef ARGPROC_DEBUG - fprintf(Perl_debug_log, "Arglist:\n"); + PerlIO_printf(Perl_debug_log, "Arglist:\n"); for (j = 0; j < *ac; ++j) - fprintf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]); + PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]); #endif /* Clear errors we may have hit expanding wildcards, so they don't show up in Perl's $! later */ @@ -1950,7 +2026,7 @@ short iosb[4]; if (0 == child_st[0]) { #ifdef ARGPROC_DEBUG - fprintf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n"); + PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n"); #endif fflush(stdout); /* Have to flush pipe for binary data to */ /* terminate properly -- <tp@mccall.com> */ @@ -1965,7 +2041,7 @@ short iosb[4]; static void sig_child(int chan) { #ifdef ARGPROC_DEBUG - fprintf(Perl_debug_log, "Child Completion AST\n"); + PerlIO_printf(Perl_debug_log, "Child Completion AST\n"); #endif if (child_st[0] == 0) child_st[0] = 1; @@ -2001,19 +2077,19 @@ static void pipe_and_fork(char **cmargv) create_mbx(&child_chan,&mbxdsc); #ifdef ARGPROC_DEBUG - fprintf(Perl_debug_log, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer); - fprintf(Perl_debug_log, "Sub Process Command = '%s'\n", cmddsc.dsc$a_pointer); + PerlIO_printf(Perl_debug_log, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer); + PerlIO_printf(Perl_debug_log, "Sub Process Command = '%s'\n", cmddsc.dsc$a_pointer); #endif _ckvmssts_noperl(lib$spawn(&cmddsc, &mbxdsc, 0, &one, 0, &pid, child_st, &zero, sig_child, &child_chan)); #ifdef ARGPROC_DEBUG - fprintf(Perl_debug_log, "Subprocess's Pid = %08X\n", pid); + PerlIO_printf(Perl_debug_log, "Subprocess's Pid = %08X\n", pid); #endif sys$dclexh(&exit_block); if (NULL == freopen(mbxname, "wb", stdout)) { - fprintf(Perl_debug_log,"Can't open output pipe (name %s)",mbxname); + PerlIO_printf(Perl_debug_log,"Can't open output pipe (name %s)",mbxname); } } @@ -2047,10 +2123,10 @@ unsigned long int flags = 17, one = 1, retsts; _ckvmssts_noperl(retsts); } #ifdef ARGPROC_DEBUG - fprintf(Perl_debug_log, "%s\n", command); + PerlIO_printf(Perl_debug_log, "%s\n", command); #endif sprintf(pidstring, "%08X", pid); - fprintf(Perl_debug_log, "%s\n", pidstring); + PerlIO_printf(Perl_debug_log, "%s\n", pidstring); pidstr.dsc$a_pointer = pidstring; pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer); lib$set_symbol(&pidsymbol, &pidstr); @@ -3522,7 +3598,8 @@ rmsexpand_fromperl(CV *cv) retsts = sys$parse(&myfab,0,0); if (!(retsts & 1)) { - if (retsts == RMS$_DNF) { + if (retsts == RMS$_DNF || retsts == RMS$_DIR || + retsts == RMS$_DEV || retsts == RMS$_DEV) { mynam.nam$b_nop |= NAM$M_SYNCHK; retsts = sys$parse(&myfab,0,0); if (retsts & 1) goto expanded; @@ -3549,12 +3626,20 @@ rmsexpand_fromperl(CV *cv) if (islower(*out)) { haslower = 1; break; } if (mynam.nam$b_rsl) { out = rsa; speclen = mynam.nam$b_rsl; } else { out = esa; speclen = mynam.nam$b_esl; } - if (!(mynam.nam$l_fnb & NAM$M_EXP_VER)) - speclen = mynam.nam$l_type - out; + if (!(mynam.nam$l_fnb & NAM$M_EXP_VER) && + (items == 1 || !strchr(myfab.fab$l_dna,';'))) + speclen = mynam.nam$l_ver - out; + /* If we just had a directory spec on input, $PARSE "helpfully" + * adds an empty name and type for us */ + if (mynam.nam$l_name == mynam.nam$l_type && + mynam.nam$l_ver == mynam.nam$l_type + 1 && + !(mynam.nam$l_fnb & NAM$M_EXP_NAME)) + speclen = mynam.nam$l_name - out; out[speclen] = '\0'; if (haslower) __mystrtolower(out); ST(0) = sv_2mortal(newSVpv(out, speclen)); + XSRETURN(1); } void @@ -3724,7 +3809,7 @@ init_os_extras() { char* file = __FILE__; - newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$"); + newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$"); newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$"); newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$"); newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$"); |