From 17f28c40fa08b585b95d4a2531b1cd975d11e986 Mon Sep 17 00:00:00 2001 From: Charles Bailey Date: Thu, 26 Mar 1998 10:11:50 -0500 Subject: [PATCH] Next wave of _63 VMS patches p4raw-id: //depot/perl@854 --- EXTERN.h | 4 ++ INTERN.h | 4 ++ ext/SDBM_File/Makefile.PL | 13 ++--- ext/SDBM_File/sdbm/Makefile.PL | 12 ++++- ext/SDBM_File/sdbm/dba.c | 1 + ext/SDBM_File/sdbm/dbd.c | 1 + ext/SDBM_File/sdbm/dbu.c | 1 + ext/SDBM_File/sdbm/hash.c | 1 + ext/SDBM_File/sdbm/pair.c | 1 + ext/SDBM_File/sdbm/sdbm.c | 5 +- ext/SDBM_File/sdbm/sdbm.h | 11 +++-- ext/Thread/io.t | 16 +++++- installperl | 65 +++++++++++++++++++----- lib/ExtUtils/MM_VMS.pm | 69 ++++++++++++++------------ lib/Net/Ping.pm | 2 +- perldir.h | 6 ++- perlsdio.h | 7 ++- t/lib/english.t | 2 +- vms/config.vms | 109 +++++++++++++++++++++++++++++++++++++++-- vms/descrip.mms | 24 +++++++-- vms/ext/Filespec.pm | 10 ++-- vms/ext/Stdio/0README.txt | 23 ++------- vms/ext/Stdio/Stdio.pm | 37 ++++++++++---- vms/ext/Stdio/Stdio.xs | 108 +++++++++++++++++++++++++++++++++++++--- vms/ext/Stdio/test.pl | 30 ++++++++++-- vms/ext/filespec.t | 29 ++++++----- vms/genconfig.pl | 13 +++++ vms/perly_c.vms | 22 ++++----- vms/vms.c | 27 ++++++++-- vms/vmsish.h | 8 +-- 30 files changed, 508 insertions(+), 153 deletions(-) diff --git a/EXTERN.h b/EXTERN.h index a48d0d3..8b0584e 100644 --- a/EXTERN.h +++ b/EXTERN.h @@ -18,6 +18,10 @@ #undef EXTCONST #undef dEXTCONST #if defined(VMS) && !defined(__GNUC__) + /* Suppress portability warnings from DECC for VMS-specific extensions */ +# ifdef __DECC +# pragma message disable (GLOBALEXT,NOSHAREEXT,READONLYEXT) +# endif # define EXT globalref # define dEXT globaldef {"$GLOBAL_RW_VARS"} noshare # define EXTCONST globalref diff --git a/INTERN.h b/INTERN.h index 22e42c5..6ce0367 100644 --- a/INTERN.h +++ b/INTERN.h @@ -18,6 +18,10 @@ #undef EXTCONST #undef dEXTCONST #if defined(VMS) && !defined(__GNUC__) + /* Suppress portability warnings from DECC for VMS-specific extensions */ +# ifdef __DECC +# pragma message disable (GLOBALEXT,NOSHAREEXT,READONLYEXT) +# endif # define EXT globaldef {"$GLOBAL_RW_VARS"} noshare # define dEXT globaldef {"$GLOBAL_RW_VARS"} noshare # define EXTCONST globaldef {"$GLOBAL_RO_VARS"} readonly diff --git a/ext/SDBM_File/Makefile.PL b/ext/SDBM_File/Makefile.PL index c0daa06..b639b29 100644 --- a/ext/SDBM_File/Makefile.PL +++ b/ext/SDBM_File/Makefile.PL @@ -6,13 +6,8 @@ use ExtUtils::MakeMaker; # which perform the corresponding actions in the subdirectory. $define = ($^O eq 'MSWin32') ? '-DMSDOS' : ''; -if ($^O eq 'MSWin32') { - $myextlib = 'sdbm\\libsdbm$(LIB_EXT)'; -} elsif ($^O eq 'VMS') { - $myextlib = 'sdbm/libsdbm$(LIB_EXT)'; -} else { - $myextlib = 'sdbm/libsdbm$(LIB_EXT)'; -} +if ($^O eq 'MSWin32') { $myextlib = 'sdbm\\libsdbm$(LIB_EXT)'; } +else { $myextlib = 'sdbm/libsdbm$(LIB_EXT)'; } WriteMakefile( NAME => 'SDBM_File', @@ -21,8 +16,6 @@ WriteMakefile( XSPROTOARG => '-noprototypes', # XXX remove later? VERSION_FROM => 'SDBM_File.pm', DEFINE => $define, -# NORECURS => $^O eq 'VMS', -# SKIP => $^O eq 'VMS' ? 'subdirs' : '', # Don't do the subdirs section for VMS ); sub MY::postamble { @@ -33,7 +26,7 @@ $(MYEXTLIB): sdbm/Makefile '; } else { ' -$(MYEXTLIB): [.sdbm]descrip.mms +$(MYEXTLIB) : [.sdbm]descrip.mms set def [.sdbm] $(MMS) all set def [-] diff --git a/ext/SDBM_File/sdbm/Makefile.PL b/ext/SDBM_File/sdbm/Makefile.PL index e9d4dcd..96f5b7a 100644 --- a/ext/SDBM_File/sdbm/Makefile.PL +++ b/ext/SDBM_File/sdbm/Makefile.PL @@ -3,13 +3,19 @@ use ExtUtils::MakeMaker; $define = '-DSDBM -DDUFF'; $define .= ' -DWIN32' if ($^O eq 'MSWin32'); +if ($^O eq 'VMS') { # Old VAXC compiler can't handle Duff's device + require Config; + $define =~ s/\s+-DDUFF// if $Config::Config{'vms_cc_type'} eq 'vaxc'; +} + WriteMakefile( NAME => 'sdbm', # (doesn't matter what the name is here) oh yes it does # LINKTYPE => 'static', DEFINE => $define, INC => '-I$(PERL_INC)', # force PERL_INC dir ahead of system -I's - SKIP => [qw(dynamic dynamic_lib)], - OBJECT => ($^O eq 'VMS') ? 'sdbm.obj pair.obj hash.obj' : '$(O_FILES)', + INST_ARCHLIB => '.', + SKIP => [qw(dynamic dynamic_lib dlsyms)], + OBJECT => '$(O_FILES)', clean => {'FILES' => 'dbu libsdbm.a dbd dba dbe x-dbu *.dir *.pag'}, H => [qw(tune.h sdbm.h pair.h $(PERL_INC)/config.h)], C => [qw(sdbm.c pair.c hash.c)] @@ -24,8 +30,10 @@ INST_STATIC = libsdbm$(LIB_EXT) sub MY::top_targets { ' all :: static + $(NOECHO) $(NOOP) config :: + $(NOECHO) $(NOOP) lint: lint -abchx $(LIBSRCS) diff --git a/ext/SDBM_File/sdbm/dba.c b/ext/SDBM_File/sdbm/dba.c index 4f227e5..05e70c8 100644 --- a/ext/SDBM_File/sdbm/dba.c +++ b/ext/SDBM_File/sdbm/dba.c @@ -4,6 +4,7 @@ #include #include +#include "EXTERN.h" #include "sdbm.h" char *progname; diff --git a/ext/SDBM_File/sdbm/dbd.c b/ext/SDBM_File/sdbm/dbd.c index 697a547..04ab842 100644 --- a/ext/SDBM_File/sdbm/dbd.c +++ b/ext/SDBM_File/sdbm/dbd.c @@ -4,6 +4,7 @@ #include #include +#include "EXTERN.h" #include "sdbm.h" char *progname; diff --git a/ext/SDBM_File/sdbm/dbu.c b/ext/SDBM_File/sdbm/dbu.c index 1062628..a3c0004 100644 --- a/ext/SDBM_File/sdbm/dbu.c +++ b/ext/SDBM_File/sdbm/dbu.c @@ -1,6 +1,7 @@ #include #include #ifdef SDBM +#include "EXTERN.h" #include "sdbm.h" #else #include diff --git a/ext/SDBM_File/sdbm/hash.c b/ext/SDBM_File/sdbm/hash.c index 514bb5e..9b27648 100644 --- a/ext/SDBM_File/sdbm/hash.c +++ b/ext/SDBM_File/sdbm/hash.c @@ -8,6 +8,7 @@ */ #include "config.h" +#include "EXTERN.h" #include "sdbm.h" /* * polynomial conversion ignoring overflows diff --git a/ext/SDBM_File/sdbm/pair.c b/ext/SDBM_File/sdbm/pair.c index e1a6ee6..6b41f88 100644 --- a/ext/SDBM_File/sdbm/pair.c +++ b/ext/SDBM_File/sdbm/pair.c @@ -12,6 +12,7 @@ static char rcsid[] = "$Id: pair.c,v 1.10 90/12/13 13:00:35 oz Exp $"; #endif #include "config.h" +#include "EXTERN.h" #include "sdbm.h" #include "tune.h" #include "pair.h" diff --git a/ext/SDBM_File/sdbm/sdbm.c b/ext/SDBM_File/sdbm/sdbm.c index 7fbba0f..7bf9d3a 100644 --- a/ext/SDBM_File/sdbm/sdbm.c +++ b/ext/SDBM_File/sdbm/sdbm.c @@ -11,6 +11,7 @@ static char rcsid[] = "$Id: sdbm.c,v 1.16 90/12/13 13:01:31 oz Exp $"; #endif +#include "INTERN.h" #include "config.h" #include "sdbm.h" #include "tune.h" @@ -39,7 +40,7 @@ extern int errno; extern Malloc_t malloc proto((MEM_SIZE)); extern Free_t free proto((Malloc_t)); -extern Off_t lseek(int, off_t, int); +extern Off_t lseek(int, Off_t, int); #endif /* @@ -72,8 +73,6 @@ static long masks[] = { 001777777777, 003777777777, 007777777777, 017777777777 }; -datum nullitem = {NULL, 0}; - DBM * sdbm_open(register char *file, register int flags, register int mode) { diff --git a/ext/SDBM_File/sdbm/sdbm.h b/ext/SDBM_File/sdbm/sdbm.h index b3ed2d4..591ff24 100644 --- a/ext/SDBM_File/sdbm/sdbm.h +++ b/ext/SDBM_File/sdbm/sdbm.h @@ -51,7 +51,11 @@ typedef struct { int dsize; } datum; -extern datum nullitem; +EXTCONST datum nullitem +#ifdef DOINIT + = {NULL, 0} +#endif + ; #if defined(__STDC__) || defined(__cplusplus) || defined(CAN_PROTOTYPE) #define proto(p) p @@ -120,12 +124,13 @@ extern long sdbm_hash proto((char *, int)); #include #include -#if defined(I_UNISTD) || defined(VMS) +#if defined(I_UNISTD) #include #endif #ifdef VMS -# include +# include +# include #endif #if !defined(MSDOS) && !defined(WIN32) && !defined(VMS) diff --git a/ext/Thread/io.t b/ext/Thread/io.t index 8ade265..6012008 100644 --- a/ext/Thread/io.t +++ b/ext/Thread/io.t @@ -1,5 +1,13 @@ use Thread; +sub counter { +$count = 10; +while ($count--) { + sleep 1; + print "ping $count\n"; +} +} + sub reader { my $line; while ($line = ) { @@ -17,7 +25,13 @@ finished counting down and the I/O thread has seen end-of-file on the terminal/stdin. EOT -$r = new Thread \&reader; +$r = new Thread \&counter; + +&reader; + +__END__ + + $count = 10; while ($count--) { sleep 1; diff --git a/installperl b/installperl index 4c87f55..fe168c9 100755 --- a/installperl +++ b/installperl @@ -5,6 +5,8 @@ BEGIN { chdir '..' if !-d 'lib' and -d '..\lib'; @INC = 'lib'; $ENV{PERL5LIB} = 'lib'; + $Is_VMS = $^O eq 'VMS'; + if ($Is_VMS) { eval 'use VMS::Filespec;' } } use File::Find; @@ -30,13 +32,15 @@ while (@ARGV) { shift; } -umask 022; +umask 022 unless $Is_VMS; @scripts = qw( utils/c2ph utils/h2ph utils/h2xs utils/perlbug utils/perldoc utils/pl2pm utils/splain x2p/s2p x2p/find2perl pod/pod2man pod/pod2html pod/pod2latex pod/pod2text); +if ($Is_VMS) { @scripts = map { "$_.Com" } @scripts; } + @pods = (); %archpms = (Config => 1, FileHandle => 1, overload => 1); @@ -77,6 +81,14 @@ $dlext = $Config{dlext}; $d_dosuid = $Config{d_dosuid}; $binexp = $Config{binexp}; +if ($Is_VMS) { # Hang in there until File::Spec hits the big time + foreach ( \$installbin, \$installscript, \$installprivlib, + \$installarchlib, \$installsitelib, \$installsitearch, + \$installman1dir ) { + $$_ = unixify($$_); $$_ =~ s:/$::; + } +} + # Do some quick sanity checks. if ($d_dosuid && $>) { die "You must run as root to install suidperl\n"; } @@ -110,7 +122,15 @@ $packlist = ExtUtils::Packlist->new("$installarchlib/.packlist"); # First we install the version-numbered executables. -if ($^O ne 'dos') { +if ($Is_VMS) { + safe_unlink("$installbin/perl$exe_ext"); + copy("perl$exe_ext", "$installbin/perl$exe_ext"); + chmod(0755, "$installbin/perl$exe_ext"); + safe_unlink("$installbin/perlshr$exe_ext"); + copy("perlshr$exe_ext", "$installbin/perlshr$exe_ext"); + chmod(0755, "$installbin/perlshr$exe_ext"); +} +elsif ($^O ne 'dos') { safe_unlink("$installbin/perl$ver$exe_ext"); copy("perl$exe_ext", "$installbin/perl$ver$exe_ext"); chmod(0755, "$installbin/perl$ver$exe_ext"); @@ -150,11 +170,18 @@ else { # Install header files and libraries. mkpath("$installarchlib/CORE", 1, 0777); -@corefiles = <*.h libperl*.*>; -# AIX needs perl.exp installed as well. -push(@corefiles,'perl.exp') if $^O eq 'aix'; -# If they have built sperl.o... -push(@corefiles,'sperl.o') if -f 'sperl.o'; +if ($Is_VMS) { # We did core file selection during build + my $coredir = "lib/$Config{'arch'}/$]"; + $coredir =~ tr/./_/; + @corefiles = <$coredir/*.*>; +} +else { + @corefiles = <*.h libperl*.*>; + # AIX needs perl.exp installed as well. + push(@corefiles,'perl.exp') if $^O eq 'aix'; + # If they have built sperl.o... + push(@corefiles,'sperl.o') if -f 'sperl.o'; +} foreach $file (@corefiles) { # HP-UX (at least) needs to maintain execute permissions # on dynamically-loadable libraries. So we do it for all. @@ -166,7 +193,7 @@ foreach $file (@corefiles) { # Install main perl executables # Make links to ordinary names if installbin directory isn't current directory. -if (! $versiononly && ! samepath($installbin, '.') && ($^O ne 'dos')) { +if (! $versiononly && ! samepath($installbin, '.') && ($^O ne 'dos') && ! $Is_VMS) { safe_unlink("$installbin/perl$exe_ext", "$installbin/suidperl$exe_ext"); link("$installbin/perl$ver$exe_ext", "$installbin/perl$exe_ext"); link("$installbin/sperl$ver$exe_ext", "$installbin/suidperl$exe_ext") @@ -177,7 +204,7 @@ if (! $versiononly && ! samepath($installbin, '.') && ($^O ne 'dos')) { $mainperl_is_instperl = 0; -if (!$versiononly && !$nonono && $^O ne 'MSWin32' && -t STDIN && -t STDERR +if (!$versiononly && !$nonono && $^O ne 'MSWin32' && !$Is_VMS && -t STDIN && -t STDERR && -w $mainperldir && ! samepath($mainperldir, $installbin)) { local($usrbinperl) = "$mainperldir/perl$exe_ext"; local($instperl) = "$installbin/perl$exe_ext"; @@ -241,9 +268,10 @@ if (! $versiononly) { # pstruct should be a link to c2ph if (! $versiononly) { - safe_unlink("$installscript/pstruct"); - if ($^O eq 'dos') { - copy("$installscript/c2ph","$installscript/pstruct"); + safe_unlink("$installscript/pstruct" . ($Is_VMS ? '.Com' : '')); + if ($^O eq 'dos' or $Is_VMS) { + copy("$installscript/c2ph" . ($Is_VMS ? '.Com' : ''), + "$installscript/pstruct" . ($Is_VMS ? '.Com' : '')); } else { link("$installscript/c2ph","$installscript/pstruct"); } @@ -296,6 +324,13 @@ if (!$versiononly) { $dirsep = ($^O eq 'os2' || $^O eq 'MSWin32') ? ';' : ':' ; ($path = $ENV{"PATH"}) =~ s:\\:/:g ; @path = split(/$dirsep/, $path); + if ($Is_VMS) { + my $i = 0; + while (exists $ENV{'DCL$PATH' . $i}) { + $dir = unixpath($ENV{'DCL$PATH' . $i}); $dir =~ s-/$--; + push(@path,$dir); + } + } @otherperls = (); for (@path) { next unless m,^/,; @@ -338,6 +373,8 @@ sub unlink { local(@names) = @_; my($cnt) = 0; + return scalar(@names) if $Is_VMS; + foreach $name (@names) { next unless -e $name; chmod 0777, $name if ($^O eq 'os2' || $^O eq 'MSWin32'); @@ -349,7 +386,7 @@ sub unlink { } sub safe_unlink { - return if $nonono; + return if $nonono or $Is_VMS; local @names = @_; foreach $name (@names) { next unless -e $name; @@ -394,6 +431,7 @@ sub link { $packlist->{$to} = { from => $from, type => 'link' }; }; if ($@) { + print STDERR " creating new version of $to\n" if $Is_VMS and -e $to; File::Copy::copy($from, $to) ? $success++ : warn "Couldn't copy $from to $to: $!\n" @@ -417,6 +455,7 @@ sub copy { my($from,$to) = @_; print STDERR " cp $from $to\n"; + print STDERR " creating new version of $to\n" if $Is_VMS and -e $to; File::Copy::copy($from, $to) || warn "Couldn't copy $from to $to: $!\n" unless $nonono; diff --git a/lib/ExtUtils/MM_VMS.pm b/lib/ExtUtils/MM_VMS.pm index 87c27df..29bfaf2 100644 --- a/lib/ExtUtils/MM_VMS.pm +++ b/lib/ExtUtils/MM_VMS.pm @@ -61,15 +61,22 @@ sub eliminate_macros { if ($self->{$2}) { ($head,$macro,$tail) = ($1,$2,$3); if (ref $self->{$macro}) { - carp "Can't expand macro containing " . ref $self->{$macro}; - $npath = "$head\cB$macro\cB$tail"; - $complex = 1; + if (ref $self->{$macro} eq 'ARRAY') { + print "Note: expanded array macro \$($macro) in $path\n" if $Verbose; + $macro = join ' ', @{$self->{$macro}}; + } + else { + print "Note: can't expand macro \$($macro) containing ",ref($self->{$macro}), + "\n\t(using MMK-specific deferred substitutuon; MMS will break)\n"; + $macro = "\cB$macro\cB"; + $complex = 1; + } } else { ($macro = unixify($self->{$macro})) =~ s#/$##; } $npath = "$head$macro$tail"; } } - if ($complex) { $npath =~ s#\cB(.*?)\cB#\$($1)#g; } + if ($complex) { $npath =~ s#\cB(.*?)\cB#\${$1}#g; } print "eliminate_macros($path) = |$npath|\n" if $Verbose >= 3; $npath; } @@ -193,7 +200,7 @@ sub wraplist { # traversing array (scalar(@array) doesn't show them, but # foreach(@array) does) (5.00307) next unless $word =~ /\w/; - $line .= ', ' if length($line); + $line .= ' ' if length($line); if ($hlen > 80) { $line .= "\\\n\t"; $hlen = 0; } $line .= $word; $hlen += length($word) + 2; @@ -632,9 +639,9 @@ sub constants { if ($self->{OBJECT} =~ /\s/) { $self->{OBJECT} =~ s/(\\)?\n+\s+/ /g; - $self->{OBJECT} = join(' ',map($self->fixpath($_),split(/,?\s+/,$self->{OBJECT}))); + $self->{OBJECT} = $self->wraplist(map($self->fixpath($_),split(/,?\s+/,$self->{OBJECT}))); } - $self->{LDFROM} = join(' ',map($self->fixpath($_),split(/,?\s+/,$self->{LDFROM}))); + $self->{LDFROM} = $self->wraplist(map($self->fixpath($_),split(/,?\s+/,$self->{LDFROM}))); # Fix up directory specs @@ -726,12 +733,12 @@ MM_VMS_REVISION = $ExtUtils::MM_VMS::Revision push @m,' # Handy lists of source code files: -XS_FILES = ',$self->wraplist(', ', sort keys %{$self->{XS}}),' -C_FILES = ',$self->wraplist(', ', @{$self->{C}}),' -O_FILES = ',$self->wraplist(', ', @{$self->{O_FILES}} ),' -H_FILES = ',$self->wraplist(', ', @{$self->{H}}),' -MAN1PODS = ',$self->wraplist(', ', sort keys %{$self->{MAN1PODS}}),' -MAN3PODS = ',$self->wraplist(', ', sort keys %{$self->{MAN3PODS}}),' +XS_FILES = ',$self->wraplist(sort keys %{$self->{XS}}),' +C_FILES = ',$self->wraplist(@{$self->{C}}),' +O_FILES = ',$self->wraplist(@{$self->{O_FILES}} ),' +H_FILES = ',$self->wraplist(@{$self->{H}}),' +MAN1PODS = ',$self->wraplist(sort keys %{$self->{MAN1PODS}}),' +MAN3PODS = ',$self->wraplist(sort keys %{$self->{MAN3PODS}}),' '; @@ -764,21 +771,22 @@ INST_DYNAMIC = $(INST_ARCHAUTODIR)$(BASEEXT).$(DLEXT) INST_BOOT = $(INST_ARCHAUTODIR)$(BASEEXT).bs '; } else { + my $shr = $Config{'dbgprefix'} . 'PERLSHR'; push @m,' INST_STATIC = INST_DYNAMIC = INST_BOOT = EXPORT_LIST = $(BASEEXT).opt -PERL_ARCHIVE = ',($ENV{'PERLSHR'} ? $ENV{'PERLSHR'} : "Sys\$Share:PerlShr.$Config{'dlext'}"),' +PERL_ARCHIVE = ',($ENV{$shr} ? $ENV{$shr} : "Sys\$Share:$shr.$Config{'dlext'}"),' '; } $self->{TO_INST_PM} = [ sort keys %{$self->{PM}} ]; $self->{PM_TO_BLIB} = [ %{$self->{PM}} ]; push @m,' -TO_INST_PM = ',$self->wraplist(', ',@{$self->{TO_INST_PM}}),' +TO_INST_PM = ',$self->wraplist(@{$self->{TO_INST_PM}}),' -PM_TO_BLIB = ',$self->wraplist(', ',@{$self->{PM_TO_BLIB}}),' +PM_TO_BLIB = ',$self->wraplist(@{$self->{PM_TO_BLIB}}),' '; join('',@m); @@ -1365,6 +1373,7 @@ sub dynamic_lib { my($otherldflags) = $attribs{OTHERLDFLAGS} || ""; my($inst_dynamic_dep) = $attribs{INST_DYNAMIC_DEP} || ""; + my $shr = $Config{'dbgprefix'} . 'PerlShr'; my(@m); push @m," @@ -1375,7 +1384,7 @@ INST_DYNAMIC_DEP = $inst_dynamic_dep push @m, ' $(INST_DYNAMIC) : $(INST_STATIC) $(PERL_INC)perlshr_attr.opt $(INST_ARCHAUTODIR).exists $(EXPORT_LIST) $(PERL_ARCHIVE) $(INST_DYNAMIC_DEP) $(NOECHO) $(MKPATH) $(INST_ARCHAUTODIR) - $(NOECHO) If F$TrnLNm("PerlShr").eqs."" Then Define/NoLog/User PerlShr Sys$Share:PerlShr.',$Config{'dlext'},' + $(NOECHO) If F$TrnLNm("',$shr,'").eqs."" Then Define/NoLog/User ',"$shr Sys\$Share:$shr.$Config{'dlext'}",' Link $(LDFLAGS) /Shareable=$(MMS$TARGET)$(OTHERLDFLAGS) $(BASEEXT).opt/Option,$(PERL_INC)perlshr_attr.opt/Option '; @@ -1436,27 +1445,20 @@ $(INST_STATIC) : $(OBJECT) $(MYEXTLIB) '; # If this extension has it's own library (eg SDBM_File) # then copy that to $(INST_STATIC) and add $(OBJECT) into it. - push(@m, ' $(CP) $(MYEXTLIB) $(MMS$TARGET)',"\n") if $self->{MYEXTLIB}; + push(@m, "\t",'$(CP) $(MYEXTLIB) $(MMS$TARGET)',"\n") if $self->{MYEXTLIB}; + + push(@m,"\t",'If F$Search("$(MMS$TARGET)").eqs."" Then Library/Object/Create $(MMS$TARGET)',"\n"); - push(@m,' - If F$Search("$(MMS$TARGET)").eqs."" Then Library/Object/Create $(MMS$TARGET) -'); # if there was a library to copy, then we can't use MMS$SOURCE_LIST, # 'cause it's a library and you can't stick them in other libraries. # In that case, we use $OBJECT instead and hope for the best if ($self->{MYEXTLIB}) { - push(@m,' - Library/Object/Replace $(MMS$TARGET) $(OBJECT) -'); + push(@m,"\t",'Library/Object/Replace $(MMS$TARGET) $(OBJECT)',"\n"); } else { - push(@m,' - Library/Object/Replace $(MMS$TARGET) $(MMS$SOURCE_LIST) -'); + push(@m,"\t",'Library/Object/Replace $(MMS$TARGET) $(MMS$SOURCE_LIST)',"\n"); } - push(@m, ' - $(NOECHO) $(PERL) -e "open F,\'>>$(INST_ARCHAUTODIR)extralibs.ld\';print F qq{$(EXTRALIBS)\n};close F;" -'); + push(@m,"\t",'$(NOECHO) $(PERL) -e "open F,\'>>$(INST_ARCHAUTODIR)extralibs.ld\';print F qq{$(EXTRALIBS)\n};close F;"',"\n"); push @m, $self->dir_target('$(INST_ARCHAUTODIR)'); join('',@m); } @@ -1679,6 +1681,9 @@ clean :: push(@otherfiles,$self->catfile('$(INST_ARCHAUTODIR)','extralibs.all')); my($file,$line); $line = ''; #avoid unitialized var warning + # Occasionally files are repeated several times from different sources + { my(%of) = map { ($_,1) } @otherfiles; @otherfiles = keys %of; } + foreach $file (@otherfiles) { $file = $self->fixpath($file); if (length($line) + length($file) > 80) { @@ -1723,6 +1728,8 @@ realclean :: clean } push(@files, values %{$self->{PM}}); $line = ''; #avoid unitialized var warning + # Occasionally files are repeated several times from different sources + { my(%f) = map { ($_,1) } @files; @files = keys %f; } foreach $file (@files) { $file = $self->fixpath($file); if (length($line) + length($file) > 80 || ++$fcnt >= 2) { @@ -1744,6 +1751,8 @@ realclean :: clean else { push(@allfiles, $attribs{FILES}); } } $line = ''; + # Occasionally files are repeated several times from different sources + { my(%af) = map { ($_,1) } @allfiles; @allfiles = keys %af; } foreach $file (@allfiles) { $file = $self->fixpath($file); if (length($line) + length($file) > 80) { diff --git a/lib/Net/Ping.pm b/lib/Net/Ping.pm index 91077dd..495b82f 100644 --- a/lib/Net/Ping.pm +++ b/lib/Net/Ping.pm @@ -106,7 +106,7 @@ sub new } elsif ($self->{"proto"} eq "icmp") { - croak("icmp ping requires root privilege") if $>; + croak("icmp ping requires root privilege") if ($> and $^O ne 'VMS'); $self->{"proto_num"} = (getprotobyname('icmp'))[2] || croak("Can't get icmp protocol by name"); $self->{"pid"} = $$ & 0xffff; # Save lower 16 bits of pid diff --git a/perldir.h b/perldir.h index 23d20ac..e3e68ff 100644 --- a/perldir.h +++ b/perldir.h @@ -4,7 +4,11 @@ #ifdef PERL_OBJECT #else #define PerlDir_mkdir(name, mode) Mkdir((name), (mode)) -#define PerlDir_chdir(name) chdir((name)) +#ifdef VMS +# define PerlDir_chdir(name) chdir(((name) && *(name)) ? (name) : "SYS$LOGIN") +#else +# define PerlDir_chdir(name) chdir((name)) +#endif #define PerlDir_rmdir(name) rmdir((name)) #define PerlDir_close(dir) closedir((dir)) #define PerlDir_open(name) opendir((name)) diff --git a/perlsdio.h b/perlsdio.h index 9825f8e..a539a0a 100644 --- a/perlsdio.h +++ b/perlsdio.h @@ -55,7 +55,12 @@ #define PerlIO_clearerr(f) clearerr(f) #define PerlIO_flush(f) Fflush(f) #define PerlIO_tell(f) ftell(f) -#define PerlIO_seek(f,o,w) fseek(f,o,w) +#if defined(VMS) && !defined(__DECC) + /* Old VAXC RTL doesn't reset EOF on seek; Perl folk seem to expect this */ +# define PerlIO_seek(f,o,w) (((f) && (*f) && ((*f)->_flag &= ~_IOEOF)),fseek(f,o,w)) +#else +# define PerlIO_seek(f,o,w) fseek(f,o,w) +#endif #ifdef HAS_FGETPOS #define PerlIO_getpos(f,p) fgetpos(f,p) #endif diff --git a/t/lib/english.t b/t/lib/english.t index 1a96c77..9691229 100755 --- a/t/lib/english.t +++ b/t/lib/english.t @@ -5,7 +5,7 @@ print "1..16\n"; BEGIN { @INC = '../lib' } use English; use Config; -my $threads = $Config{archname} =~ /-thread$/; +my $threads = $Config{'usethreads'} || 0; print $PID == $$ ? "ok 1\n" : "not ok 1\n"; diff --git a/vms/config.vms b/vms/config.vms index 24a3906..35abbdb 100644 --- a/vms/config.vms +++ b/vms/config.vms @@ -76,7 +76,7 @@ * 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_00462" /**/ +#define ARCHLIB_EXP "/perl_root/lib/VMS_VAX/5_00463" /**/ #define ARCHLIB ARCHLIB_EXP /*config-skip*/ @@ -177,6 +177,7 @@ * This symbol, if defined, indicates that the C-shell exists. * If defined, contains the full pathname of csh. */ +#undef HAS_CSH /**/ #undef CSH /**/ /* HAS_DUP2: @@ -242,6 +243,26 @@ # define Timeval struct timeval /*config-skip*/ #endif +/* HAS_LONG_DOUBLE: + * This symbol will be defined if the C compiler supports long + * doubles. + */ +/* LONG_DOUBLESIZE: + * This symbol contains the size of a long double, so that the + * C preprocessor can make decisions based on it. It is only + * defined if the system supports long doubles. + */ +#undef HAS_LONG_DOUBLE /**/ +#ifdef HAS_LONG_DOUBLE +# define LONG_DOUBLESIZE 8 /**/ +#endif + +/* HAS_MKSTEMP: + * This symbol, if defined, indicates that the mkstemp routine is + * available to create and open a unique temporary file. + */ +#undef HAS_MKSTEMP /**/ + /* HAS_GETGROUPS: * This symbol, if defined, indicates that the getgroups() routine is * available to get the list of process groups. If unavailable, multiple @@ -1847,6 +1868,13 @@ */ #undef USE_PERLIO /**/ +/* HAS_SETVBUF: + * This symbol, if defined, indicates that the setvbuf routine is + * available to change buffering on an open stdio stream. + * to a line-buffered mode. + */ +#define HAS_SETVBUF /**/ + /* VOIDFLAGS: * This symbol indicates how much support of the void type is given by this * compiler. What various bits mean: @@ -1916,8 +1944,8 @@ * This symbol, if defined, indicates that the getprotobynumber() * routine is available to look up protocols by their number. */ -#define HAS_GETPROTOBYNAME /**/ -#define HAS_GETPROTOBYNUMBER /**/ +#define HAS_GETPROTOBYNAME /*config-skip*/ +#define HAS_GETPROTOBYNUMBER /*config-skip*/ /* HAS_GETHOSTBYNAME: * This symbol, if defined, indicates that the gethostbyname routine is @@ -1952,9 +1980,30 @@ * available to lookup networks by their names. */ #define HAS_GETNETBYNAME /*config-skip*/ + +/* HAS_GETNETENT: + * This symbol, if defined, indicates that the getnetent() routine is + * available to look up network names in some data base or another. + */ +#define HAS_GETNETENT /*config-skip*/ + +/* HAS_SETNETENT: + * This symbol, if defined, indicates that the setnetent() routine is + * available. + */ +#define HAS_SETNETENT /*config-skip*/ + +/* HAS_ENDNETENT: + * This symbol, if defined, indicates that the endnetent() routine is + * available to close whatever was being used for network queries. + */ +#define HAS_ENDNETENT /*config-skip*/ #else -#undef HAS_GETNETBYADDR /*config-skip*/ +#undef HAS_GETNETBYADDR /*config-skip*/ #undef HAS_GETNETBYNAME /*config-skip*/ +#undef HAS_GETNETENT /*config-skip*/ +#undef HAS_SETNETENT /*config-skip*/ +#undef HAS_ENDNETENT /*config-skip*/ #endif /* HAS_GETPROTOBYNAME: @@ -2014,6 +2063,48 @@ */ #define HAS_SELECT /**/ /* config-skip */ +/* HAS_ENDHOSTENT: + * This symbol, if defined, indicates that the endhostent() routine is + * available to close whatever was being used for host queries. + */ +#define HAS_ENDHOSTENT /*config-skip*/ + +/* HAS_GETPROTOENT: + * This symbol, if defined, indicates that the getprotoent() routine is + * available to look up protocols in some data base or another. + */ +#define HAS_GETPROTOENT /*config-skip*/ + +/* HAS_ENDPROTOENT: + * This symbol, if defined, indicates that the endprotoent() routine is + * available to close whatever was being used for protocol queries. + */ +#define HAS_ENDPROTOENT /*config-skip*/ + +/* HAS_SETPROTOENT: + * This symbol, if defined, indicates that the setprotoent() routine is + * available. + */ +#define HAS_SETPROTOENT /*config-skip*/ + +/* HAS_GETSERVENT: + * This symbol, if defined, indicates that the getservent() routine is + * available to look up network services in some data base or another. + */ +#define HAS_GETSERVENT /*config-skip*/ + +/* HAS_SETSERVENT: + * This symbol, if defined, indicates that the setservent() routine is + * available. + */ +#define HAS_SETSERVENT /*config-skip*/ + +/* HAS_ENDSERVENT: + * This symbol, if defined, indicates that the endservent() routine is + * available to close whatever was being used for service queries. + */ +#define HAS_ENDSERVENT /*config-skip*/ + #else /* VMS_DO_SOCKETS */ #undef HAS_SOCKET /*config-skip*/ @@ -2026,12 +2117,22 @@ #undef HAS_SELECT /*config-skip*/ #undef HAS_GETHOSTBYADDR /*config-skip*/ #undef HAS_GETNETBYADDR /*config-skip*/ +#undef HAS_GETNETENT /*config-skip*/ +#undef HAS_SETNETENT /*config-skip*/ +#undef HAS_ENDNETENT /*config-skip*/ #undef HAS_GETHOSTBYNAME /*config-skip*/ #undef HAS_GETNETBYNAME /*config-skip*/ #undef HAS_GETPROTOBYNAME /*config-skip*/ #undef HAS_GETPROTOBYNUMBER /*config-skip*/ #undef HAS_GETSERVBYNAME /*config-skip*/ #undef HAS_GETSERVBYPORT /*config-skip*/ +#undef HAS_ENDHOSTENT /*config-skip*/ +#undef HAS_GETPROTOENT /*config-skip*/ +#undef HAS_SETPROTOENT /*config-skip*/ +#undef HAS_ENDPROTOENT /*config-skip*/ +#undef HAS_GETSERVENT /*config-skip*/ +#undef HAS_SETSERVENT /*config-skip*/ +#undef HAS_ENDSERVENT /*config-skip*/ #endif /* !VMS_DO_SOCKETS */ diff --git a/vms/descrip.mms b/vms/descrip.mms index 683f40d..00a5c0b 100644 --- a/vms/descrip.mms +++ b/vms/descrip.mms @@ -74,7 +74,7 @@ OBJVAL = $(MMS$TARGET_NAME)$(O) .endif # Updated by fndvers.com -- do not edit by hand -PERL_VERSION = 5_00462# +PERL_VERSION = 5_00463# .ifdef DECC_SOCKETS SOCKET=1 @@ -395,8 +395,8 @@ byteperl.c : [.ext.B]byteperl.c .ifdef __DEBUG__ # Link an extra perl that doesn't invoke the debugger perl : $(DBG)perl$(E) $(DBG)byteperl$(E) - Link $(LINKFLAGS)/NoDebug/Trace/NoMap/NoCross/NoFull/Exe=N$(DBG)perl$(E) perlmain$(O), perlshr.opt/Option, perlshr_attr.opt/Option - Link $(LINKFLAGS)/NoDebug/Trace/NoMap/NoCross/NoFull/Exe=N$(DBG)byteperl$(E) byteperl$(O), perlshr.opt/Option, perlshr_attr.opt/Option + Link $(LINKFLAGS)/NoDebug/Trace/NoMap/NoCross/NoFull/Exe=N$(DBG)perl$(E) perlmain$(O), perlshr.opt/Option, perlshr_attr.opt/Option $(CRTLOPTS) + Link $(LINKFLAGS)/NoDebug/Trace/NoMap/NoCross/NoFull/Exe=N$(DBG)byteperl$(E) byteperl$(O), perlshr.opt/Option, perlshr_attr.opt/Option $(CRTLOPTS) .else perl : $(DBG)perl$(E) $(DBG)byteperl$(E) @ Continue @@ -404,11 +404,11 @@ perl : $(DBG)perl$(E) $(DBG)byteperl$(E) $(DBG)perl$(E) : perlmain$(O), $(DBG)perlshr$(E), $(MINIPERL_EXE) @ @[.vms]genopt "PerlShr.Opt/Write" "|" "''F$Environment("Default")'$(DBG)PerlShr$(E)/Share" - Link $(LINKFLAGS)/Exe=$(MMS$TARGET) perlmain$(O), perlshr.opt/Option, perlshr_attr.opt/Option + Link $(LINKFLAGS)/Exe=$(MMS$TARGET) perlmain$(O), perlshr.opt/Option, perlshr_attr.opt/Option $(CRTLOPTS) $(DBG)byteperl$(E) : byteperl$(O), $(DBG)perlshr$(E), $(MINIPERL_EXE) @ @[.vms]genopt "PerlShr.Opt/Write" "|" "''F$Environment("Default")'$(DBG)PerlShr$(E)/Share" - Link $(LINKFLAGS)/Exe=$(MMS$TARGET) byteperl$(O), perlshr.opt/Option, perlshr_attr.opt/Option + Link $(LINKFLAGS)/Exe=$(MMS$TARGET) byteperl$(O), perlshr.opt/Option, perlshr_attr.opt/Option $(CRTLOPTS) $(DBG)perlshr$(E) : $(DBG)libperl$(OLB) $(extobj) $(DBG)perlshr_xtras.ts Link $(LINKFLAGS)/Share=$(MMS$TARGET) $(extobj) []$(DBG)perlshr_bld.opt/Option, perlshr_attr.opt/Option @@ -1342,6 +1342,17 @@ clean : tidy Set Default [.ext.Opcode] - $(MMS) clean Set Default [--] + Set Default [.ext.attrs] + - $(MMS) clean + Set Default [--] + Set Default [.ext.B] + - $(MMS) clean + Set Default [--] +.ifdef THREAD + Set Default [.ext.Thread] + - $(MMS) realclean + Set Default [--] +.endif .ifdef DECC Set Default [.ext.POSIX] - $(MMS) clean @@ -1384,6 +1395,9 @@ realclean : clean Set Default [.ext.attrs] - $(MMS) realclean Set Default [--] + Set Default [.ext.B] + - $(MMS) realclean + Set Default [--] .ifdef THREAD Set Default [.ext.Thread] - $(MMS) realclean diff --git a/vms/ext/Filespec.pm b/vms/ext/Filespec.pm index db3283c..b0b1414 100644 --- a/vms/ext/Filespec.pm +++ b/vms/ext/Filespec.pm @@ -12,7 +12,7 @@ VMS::Filespec - convert between VMS and Unix file specification syntax =head1 SYNOPSIS use VMS::Filespec; -$fullspec = rmsexpand('[.VMS]file.specification'); +$fullspec = rmsexpand('[.VMS]file.specification'[, 'default:[file.spec]']); $vmsspec = vmsify('/my/Unix/file/specification'); $unixspec = unixify('my:[VMS]file.specification'); $path = pathify('my:[VMS.or.Unix.directory]specification.dir'); @@ -65,9 +65,11 @@ The routines provided are: =head2 rmsexpand Uses the RMS $PARSE and $SEARCH services to expand the input -specification to its fully qualified form. (If the file does -not exist, the input specification is expanded as much as -possible.) If an error occurs, returns C and sets C<$!> +specification to its fully qualified form, except that a null type +or version is not added unless it was present in either the original +file specification or the default specification passed to C. +(If the file does not exist, the input specification is expanded as much +as possible.) If an error occurs, returns C and sets C<$!> and C<$^E>. =head2 vmsify diff --git a/vms/ext/Stdio/0README.txt b/vms/ext/Stdio/0README.txt index 28f82b3..25329f9 100644 --- a/vms/ext/Stdio/0README.txt +++ b/vms/ext/Stdio/0README.txt @@ -3,26 +3,6 @@ VMS::Stdio, which provides access from Perl to VMS-specific stdio functions. For more specific documentation of its function, please see the pod section of Stdio.pm. - *** Please Note *** - -This package is the direct descendant of VMS::stdio, but as of Perl -5.002, the name has been changed to VMS::Stdio, in order to conform -to the Perl naming convention that extensions whose name begins -with a lowercase letter represent compile-time "pragmas", while -extensions which provide added functionality have names whose parts -begin with uppercase letters. In addition, the functions -vmsfopen and fgetname have been renamed vmsopen and getname, -respectively, in order to more closely resemble related Perl -I/O operators, which do not retain the 'f' from corresponding -C routine names. - -A transitional interface to the old routine names has been -provided, so that calls to these routines will generate a -warning, and be routed to the corresponding VMS::Stdio -routine. This interface will be removed in a future release, -so please update your code to use the new names. - - ===> Installation This extension, like most Perl extensions, should be installed @@ -45,3 +25,6 @@ the Perl distribution tree, and then saying 2.0 28-Feb-1996 Charles Bailey bailey@genetics.upenn.edu major rewrite for Perl 5.002: name changed to VMS::Stdio, new functions added, and prototypes incorporated +2.1 24-Mar-1998 Charles Bailey bailey@newman.upenn.edu + Added writeof() + Removed old VMs::stdio compatibility interface diff --git a/vms/ext/Stdio/Stdio.pm b/vms/ext/Stdio/Stdio.pm index 01ff32d..ea5d907 100644 --- a/vms/ext/Stdio/Stdio.pm +++ b/vms/ext/Stdio/Stdio.pm @@ -1,8 +1,8 @@ # VMS::Stdio - VMS extensions to Perl's stdio calls # # Author: Charles Bailey bailey@genetics.upenn.edu -# Version: 2.02 -# Revised: 15-Feb-1997 +# Version: 2.1 +# Revised: 24-Mar-1998 package VMS::Stdio; @@ -12,17 +12,18 @@ use Carp '&croak'; use DynaLoader (); use Exporter (); -$VERSION = '2.02'; +$VERSION = '2.1'; @ISA = qw( Exporter DynaLoader IO::File ); @EXPORT = qw( &O_APPEND &O_CREAT &O_EXCL &O_NDELAY &O_NOWAIT &O_RDONLY &O_RDWR &O_TRUNC &O_WRONLY ); -@EXPORT_OK = qw( &flush &getname &remove &rewind &sync &tmpnam - &vmsopen &vmssysopen &waitfh ); +@EXPORT_OK = qw( &flush &getname &remove &rewind &sync &setdef &tmpnam + &vmsopen &vmssysopen &waitfh &writeof ); %EXPORT_TAGS = ( CONSTANTS => [ qw( &O_APPEND &O_CREAT &O_EXCL &O_NDELAY &O_NOWAIT &O_RDONLY &O_RDWR &O_TRUNC &O_WRONLY ) ], - FUNCTIONS => [ qw( &flush &getname &remove &rewind &sync - &tmpnam &vmsopen &vmssysopen &waitfh ) ] ); + FUNCTIONS => [ qw( &flush &getname &remove &rewind &setdef + &sync &tmpnam &vmsopen &vmssysopen + &waitfh &writeof ) ] ); bootstrap VMS::Stdio $VERSION; @@ -80,8 +81,9 @@ VMS::Stdio - standard I/O functions via VMS extensions =head1 SYNOPSIS -use VMS::Stdio qw( &flush &getname &remove &rewind &sync &tmpnam - &vmsopen &vmssysopen &waitfh ); +use VMS::Stdio qw( &flush &getname &remove &rewind &setdef &sync &tmpnam + &vmsopen &vmssysopen &waitfh &writeof ); +setdef("new:[default.dir]"); $uniquename = tmpnam; $fh = vmsopen("my.file","rfm=var","alq=100",...) or die $!; $name = getname($fh); @@ -96,7 +98,7 @@ sysread($fh,$data,128); waitfh($fh); close($fh); remove("another.file"); - +writeof($pipefh); =head1 DESCRIPTION This package gives Perl scripts access via VMS extensions to several @@ -175,6 +177,13 @@ to the beginning of the file. It's really just a convenience method equivalent in effect to C. It returns a true value if successful, and C 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 if it encounters and error. + =item sync This function flushes buffered data for the specified file handle @@ -231,6 +240,14 @@ operation on the file handle specified as its argument. It is used with handles opened for asynchronous I/O, and performs its task by calling the CRTL routine fwait(). +=item writeof + +This function writes an EOF to a file handle, if the device driver +supports this operation. Its primary use is to send an EOF to a +subprocess through a pipe opened for writing without closing the +pipe. It returns a true value if successful, and C if +it encounters an error. + =head1 REVISION This document was last revised on 10-Dec-1996, for Perl 5.004. diff --git a/vms/ext/Stdio/Stdio.xs b/vms/ext/Stdio/Stdio.xs index b10fec0..0a7b47e 100644 --- a/vms/ext/Stdio/Stdio.xs +++ b/vms/ext/Stdio/Stdio.xs @@ -1,8 +1,8 @@ /* VMS::Stdio - VMS extensions to stdio routines * - * Version: 2.02 + * Version: 2.1 * Author: Charles Bailey bailey@genetics.upenn.edu - * Revised: 15-Feb-1997 + * Revised: 24-Mar-1998 * */ @@ -10,6 +10,9 @@ #include "perl.h" #include "XSUB.h" #include +#include +#include +#include static bool constant(name, pval) @@ -121,12 +124,10 @@ constant(name) ST(0) = &sv_undef; void -flush(sv) - SV * sv +flush(fp) + FILE * fp PROTOTYPE: $ CODE: - FILE *fp = Nullfp; - if (SvOK(sv)) fp = IoIFP(sv_2io(sv)); if (fflush(fp)) { ST(0) = &sv_undef; } else { clearerr(fp); ST(0) = &sv_yes; } @@ -135,7 +136,7 @@ getname(fp) FILE * fp PROTOTYPE: $ CODE: - char fname[257]; + char fname[NAM$C_MAXRSS+1]; ST(0) = sv_newmortal(); if (fgetname(fp,fname) != NULL) sv_setpv(ST(0),fname); @@ -154,6 +155,59 @@ remove(name) ST(0) = remove(name) ? &sv_undef : &sv_yes; void +setdef(...) + PROTOTYPE: @ + CODE: + char vmsdef[NAM$C_MAXRSS+1], es[NAM$C_MAXRSS], sep; + unsigned long int retsts; + struct FAB deffab = cc$rms_fab; + struct NAM defnam = cc$rms_nam; + struct dsc$descriptor_s dirdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}; + if (items) { + SV *defsv = ST(items-1); /* mimic chdir() */ + ST(0) = &sv_undef; + if (!SvPOK(defsv)) { SETERRNO(EINVAL,LIB$_INVARG); XSRETURN(1); } + if (tovmsspec(SvPV(defsv,na),vmsdef) == NULL) { XSRETURN(1); } + deffab.fab$l_fna = vmsdef; deffab.fab$b_fns = strlen(vmsdef); + } + else { + deffab.fab$l_fna = "SYS$LOGIN"; deffab.fab$b_fns = 9; + EXTEND(sp,1); ST(0) = &sv_undef; + } + defnam.nam$l_esa = es; defnam.nam$b_ess = sizeof es; + deffab.fab$l_nam = &defnam; + retsts = sys$parse(&deffab,0,0); + if (retsts & 1) { + if (defnam.nam$v_wildcard) retsts = RMS$_WLD; + else if (defnam.nam$b_name || defnam.nam$b_type > 1 || + defnam.nam$b_ver > 1) retsts = RMS$_DIR; + } + defnam.nam$b_nop |= NAM$M_SYNCHK; defnam.nam$l_rlf = NULL; deffab.fab$b_dns = 0; + if (!(retsts & 1)) { + set_vaxc_errno(retsts); + switch (retsts) { + case RMS$_DNF: + set_errno(ENOENT); break; + case RMS$_SYN: case RMS$_DIR: case RMS$_DEV: + set_errno(EINVAL); break; + case RMS$_PRV: + set_errno(EACCES); break; + default: + set_errno(EVMSERR); break; + } + (void) sys$parse(&deffab,0,0); /* free up context */ + XSRETURN(1); + } + sep = *defnam.nam$l_dir; + *defnam.nam$l_dir = '\0'; + my_setenv("SYS$DISK",defnam.nam$b_node ? defnam.nam$l_node : defnam.nam$l_dev); + *defnam.nam$l_dir = sep; + dirdsc.dsc$a_pointer = defnam.nam$l_dir; dirdsc.dsc$w_length = defnam.nam$b_dir; + if ((retsts = sys$setddir(&dirdsc,0,0)) & 1) ST(0) = &sv_yes; + else { set_errno(EVMSERR); set_vaxc_errno(retsts); } + (void) sys$parse(&deffab,0,0); /* free up context */ + +void sync(fp) FILE * fp PROTOTYPE: $ @@ -295,3 +349,43 @@ waitfh(fp) PROTOTYPE: $ CODE: ST(0) = fwait(fp) ? &sv_undef : &sv_yes; + +void +writeof(mysv) + SV * mysv + PROTOTYPE: $ + CODE: + char devnam[257], *cp; + unsigned long int chan, iosb[2], retsts, retsts2; + struct dsc$descriptor devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, devnam}; + IO *io = sv_2io(mysv); + FILE *fp = io ? IoOFP(io) : NULL; + if (fp == NULL || strchr(">was+-|",IoTYPE(io)) == Nullch) { + set_errno(EBADF); set_vaxc_errno(SS$_IVCHAN); + ST(0) = &sv_undef; XSRETURN(1); + } + if (fgetname(fp,devnam) == Nullch) { ST(0) = &sv_undef; XSRETURN(1); } + if ((cp = strrchr(devnam,':')) != NULL) *(cp+1) = '\0'; + devdsc.dsc$w_length = strlen(devnam); + retsts = sys$assign(&devdsc,&chan,0,0); + if (retsts & 1) retsts = sys$qiow(0,chan,IO$_WRITEOF,iosb,0,0,0,0,0,0,0,0); + if (retsts & 1) retsts = iosb[0]; + retsts2 = sys$dassgn(chan); /* Be sure to deassign the channel */ + if (retsts & 1) retsts = retsts2; + if (retsts & 1) { ST(0) = &sv_yes; } + else { + set_vaxc_errno(retsts); + switch (retsts) { + case SS$_EXQUOTA: case SS$_INSFMEM: case SS$_MBFULL: + case SS$_MBTOOSML: case SS$_NOIOCHAN: case SS$_NOLINKS: + case SS$_BUFFEROVF: + set_errno(ENOSPC); break; + case SS$_ILLIOFUNC: case SS$_DEVOFFLINE: case SS$_NOSUCHDEV: + set_errno(EBADF); break; + case SS$_NOPRIV: + set_errno(EACCES); break; + default: /* Includes "shouldn't happen" cases that might map */ + set_errno(EVMSERR); break; /* to other errno values */ + } + ST(0) = &sv_undef; + } diff --git a/vms/ext/Stdio/test.pl b/vms/ext/Stdio/test.pl index 0b50d63..36353d9 100755 --- a/vms/ext/Stdio/test.pl +++ b/vms/ext/Stdio/test.pl @@ -1,8 +1,8 @@ -# Tests for VMS::Stdio v2.01 +# Tests for VMS::Stdio v2.1 use VMS::Stdio; -import VMS::Stdio qw(&flush &getname &rewind &sync); +import VMS::Stdio qw(&flush &getname &rewind &sync &tmpnam); -print "1..14\n"; +print "1..19\n"; print +(defined(&getname) ? '' : 'not '), "ok 1\n"; $name = "test$$"; @@ -42,3 +42,27 @@ undef $sfh; print +(stat("$name.tmp") ? 'not ' : ''),"ok 13\n"; print +(&VMS::Stdio::tmpnam ? '' : 'not '),"ok 14\n"; + +if (open(P, qq[| MCR $^X -e "1 while ();print 'Foo';1 while (); print 'Bar'" >$name.tmp])) { + print P "Baz\nQuux\n"; + print +(VMS::Stdio::writeof(P) ? '' : 'not '),"ok 15\n"; + print P "Baz\nQuux\n"; + print +(close(P) ? '' : 'not '),"ok 16\n"; + $fh = VMS::Stdio::vmsopen("$name.tmp"); + chomp($line = <$fh>); + close $fh; + unlink("$name.tmp"); + print +($line eq 'FooBar' ? '' : 'not '),"ok 17\n"; +} +else { print "not ok 15\nnot ok 16\nnot ok 17\n"; } + +$sfh = VMS::Stdio::vmsopen(">$name.tmp"); +$setuperl = "\$ MCR $^X\nBEGIN { \@INC = qw(@INC) };\nuse VMS::Stdio qw(&setdef);"; +print $sfh qq[\$ here = F\$Environment("Default")\n]; +print $sfh "$setuperl\nsetdef();\n\$ Show Default\n\$ Set Default 'here'\n"; +print $sfh "$setuperl\nsetdef('..');\n\$ Show Default\n"; +close $sfh; +@defs = map { /(\S+)/ && $1 } `\@$name.tmp`; +unlink("$name.tmp"); +print +($defs[0] eq uc($ENV{'SYS$LOGIN'}) ? '' : "not ($defs[0]) "),"ok 18\n"; +print +($defs[1] eq VMS::Filespec::rmsexpand('[-]') ? '' : "not ($defs[1]) "),"ok 19\n"; diff --git a/vms/ext/filespec.t b/vms/ext/filespec.t index 1b31f06..0564491 100644 --- a/vms/ext/filespec.t +++ b/vms/ext/filespec.t @@ -10,7 +10,7 @@ foreach () { next if /^\s*$/; push(@tests,$_); } -print '1..',scalar(@tests)+5,"\n"; +print '1..',scalar(@tests)+6,"\n"; foreach $test (@tests) { ($arg,$func,$expect) = split(/\t+/,$test); @@ -25,14 +25,17 @@ foreach $test (@tests) { } } +$defwarn = <<'EOW'; +# Note: This failure may have occurred because your default device +# was set using a non-concealed logical name. If this is the case, +# you will need to determine by inspection that the two resultant +# file specifications shwn above are in fact equivalent. +EOW + if (rmsexpand('[]') eq "\U$ENV{DEFAULT}") { print 'ok ',++$idx,"\n"; } else { print 'not ok ', ++$idx, ": rmsexpand('[]') = |", rmsexpand('[]'), - "|, \$ENV{DEFAULT} = |\U$ENV{DEFAULT}|\n"; - print "# Note: This failure may have occurred because your default device\n"; - print "# was set using a non-concealed logical name. If this is the case,\n"; - print "# you will need to determine by inspection that the two resultant\n"; - print "# file specifications shwn above are in fact equivalent.\n"; + "|, \$ENV{DEFAULT} = |\U$ENV{DEFAULT}|\n$defwarn"; } if (rmsexpand('from.here') eq "\L$ENV{DEFAULT}from.here") { print 'ok ', ++$idx, "\n"; @@ -40,11 +43,15 @@ if (rmsexpand('from.here') eq "\L$ENV{DEFAULT}from.here") { else { print 'not ok ', ++$idx, ": rmsexpand('from.here') = |", rmsexpand('from.here'), - "|, \$ENV{DEFAULT}from.here = |\L$ENV{DEFAULT}from.here|\n"; - print "# Note: This failure may have occurred because your default device\n"; - print "# was set using a non-concealed logical name. If this is the case,\n"; - print "# you will need to determine by inspection that the two resultant\n"; - print "# file specifications shwn above are in fact equivalent.\n"; + "|, \$ENV{DEFAULT}from.here = |\L$ENV{DEFAULT}from.here|\n$defwarn"; +} +if (rmsexpand('from') eq "\L$ENV{DEFAULT}from") { + print 'ok ', ++$idx, "\n"; +} +else { + print 'not ok ', ++$idx, ": rmsexpand('from') = |", + rmsexpand('from'), + "|, \$ENV{DEFAULT}from = |\L$ENV{DEFAULT}from|\n$defwarn"; } if (rmsexpand('from.here','cant:[get.there];2') eq 'cant:[get.there]from.here;2') { print 'ok ',++$idx,"\n"; } diff --git a/vms/genconfig.pl b/vms/genconfig.pl index 94fcdd7..4e0cf31 100644 --- a/vms/genconfig.pl +++ b/vms/genconfig.pl @@ -180,6 +180,13 @@ foreach (@ARGV) { print OUT "d_getpbynumber=",$dosock ? "'define'\n" : "'undef'\n"; print OUT "d_getsbyname=",$dosock ? "'define'\n" : "'undef'\n"; print OUT "d_getsbyport=",$dosock ? "'define'\n" : "'undef'\n"; + print OUT "d_endhent=",$dosock ? "'define'\n" : "'undef'\n"; + print OUT "d_getpent=",$dosock ? "'define'\n" : "'undef'\n"; + print OUT "d_setpent=",$dosock ? "'define'\n" : "'undef'\n"; + print OUT "d_endpent=",$dosock ? "'define'\n" : "'undef'\n"; + print OUT "d_getsent=",$dosock ? "'define'\n" : "'undef'\n"; + print OUT "d_setsent=",$dosock ? "'define'\n" : "'undef'\n"; + print OUT "d_endsent=",$dosock ? "'define'\n" : "'undef'\n"; print OUT "netdb_name_type=",$dosock ? "'char *'\n" : "'undef'\n"; print OUT "netdb_host_type=",$dosock ? "'char *'\n" : "'undef'\n"; print OUT "netdb_hlen_type=",$dosock ? "'int'\n" : "'undef'\n"; @@ -188,12 +195,18 @@ foreach (@ARGV) { print OUT "selecttype='fd_set'\n"; print OUT "d_getnbyaddr='define'\n"; print OUT "d_getnbyname='define'\n"; + print OUT "d_getnent='define'\n"; + print OUT "d_setnent='define'\n"; + print OUT "d_endnent='define'\n"; print OUT "netdb_net_type='long'\n"; } else { print OUT "selecttype='int'\n"; print OUT "d_getnybname='undef'\n"; print OUT "d_getnybaddr='undef'\n"; + print OUT "d_getnent='undef'\n"; + print OUT "d_setnent='undef'\n"; + print OUT "d_endnent='undef'\n"; print OUT "netdb_net_type='undef'\n"; } diff --git a/vms/perly_c.vms b/vms/perly_c.vms index 2e68d12..5f2a6f9 100644 --- a/vms/perly_c.vms +++ b/vms/perly_c.vms @@ -1276,7 +1276,7 @@ dEXT YYSTYPE yyval; dEXT YYSTYPE yylval; #line 636 "perly.y" /* PROGRAM */ -#line 1349 "y_tab.c" +#line 1349 "perly.c" #define YYABORT goto yyabort #define YYACCEPT goto yyaccept #define YYERROR goto yyerrlab @@ -1375,7 +1375,7 @@ yyloop: yys = 0; if (yychar <= YYMAXTOKEN) yys = yyname[yychar]; if (!yys) yys = "illegal-symbol"; - fprintf(stderr, "yydebug: state %d, reading %d (%s)\n", yystate, + PerlIO_printf(Perl_debug_log, "yydebug: state %d, reading %d (%s)\n", yystate, yychar, yys); } #endif @@ -1385,7 +1385,7 @@ yyloop: { #if YYDEBUG if (yydebug) - fprintf(stderr, "yydebug: state %d, shifting to state %d\n", + PerlIO_printf(Perl_debug_log, "yydebug: state %d, shifting to state %d\n", yystate, yytable[yyn]); #endif if (yyssp >= yyss + yystacksize - 1) @@ -1440,7 +1440,7 @@ yyinrecovery: { #if YYDEBUG if (yydebug) - fprintf(stderr, + PerlIO_printf(Perl_debug_log, "yydebug: state %d, error recovery shifting to state %d\n", *yyssp, yytable[yyn]); #endif @@ -1470,7 +1470,7 @@ yyinrecovery: { #if YYDEBUG if (yydebug) - fprintf(stderr, + PerlIO_printf(Perl_debug_log, "yydebug: error recovery discarding state %d\n", *yyssp); #endif @@ -1489,7 +1489,7 @@ yyinrecovery: yys = 0; if (yychar <= YYMAXTOKEN) yys = yyname[yychar]; if (!yys) yys = "illegal-symbol"; - fprintf(stderr, + PerlIO_printf(Perl_debug_log, "yydebug: state %d, error recovery discards token %d (%s)\n", yystate, yychar, yys); } @@ -1500,7 +1500,7 @@ yyinrecovery: yyreduce: #if YYDEBUG if (yydebug) - fprintf(stderr, "yydebug: state %d, reducing by rule %d (%s)\n", + PerlIO_printf(Perl_debug_log, "yydebug: state %d, reducing by rule %d (%s)\n", yystate, yyn, yyrule[yyn]); #endif yym = yylen[yyn]; @@ -2285,7 +2285,7 @@ case 176: #line 633 "perly.y" { yyval.opval = yyvsp[0].opval; } break; -#line 2267 "y_tab.c" +#line 2267 "perly.c" } yyssp -= yym; yystate = *yyssp; @@ -2295,7 +2295,7 @@ break; { #if YYDEBUG if (yydebug) - fprintf(stderr, + PerlIO_printf(Perl_debug_log, "yydebug: after reduction, shifting from state 0 to state %d\n", YYFINAL); #endif @@ -2311,7 +2311,7 @@ break; yys = 0; if (yychar <= YYMAXTOKEN) yys = yyname[yychar]; if (!yys) yys = "illegal-symbol"; - fprintf(stderr, "yydebug: state %d, reading %d (%s)\n", + PerlIO_printf(Perl_debug_log, "yydebug: state %d, reading %d (%s)\n", YYFINAL, yychar, yys); } #endif @@ -2326,7 +2326,7 @@ break; yystate = yydgoto[yym]; #if YYDEBUG if (yydebug) - fprintf(stderr, + PerlIO_printf(Perl_debug_log, "yydebug: after reduction, shifting from state %d to state %d\n", *yyssp, yystate); #endif diff --git a/vms/vms.c b/vms/vms.c index 91ec8af..f57762e 100644 --- a/vms/vms.c +++ b/vms/vms.c @@ -184,7 +184,7 @@ prime_env_iter(void) */ { dTHR; - static int primed = 0; /* XXX Not thread-safe!!! */ + static int primed = 0; HV *envhv = GvHVn(envgv); FILE *sholog; char eqv[LNM$C_NAMLENGTH+1],*start,*end; @@ -841,12 +841,14 @@ do_rmsexpand(char *filespec, char *outbuf, int ts, char *defspec, unsigned opts) retsts = sys$parse(&myfab,0,0); if (!(retsts & 1)) { + mynam.nam$b_nop |= NAM$M_SYNCHK; 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; } + mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0; + (void) sys$parse(&myfab,0,0); /* Free search context */ if (out) Safefree(out); set_vaxc_errno(retsts); if (retsts == RMS$_PRV) set_errno(EACCES); @@ -857,6 +859,8 @@ do_rmsexpand(char *filespec, char *outbuf, int ts, char *defspec, unsigned opts) } retsts = sys$search(&myfab,0,0); if (!(retsts & 1) && retsts != RMS$_FNF) { + mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL; + myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */ if (out) Safefree(out); set_vaxc_errno(retsts); if (retsts == RMS$_PRV) set_errno(EACCES); @@ -874,6 +878,10 @@ do_rmsexpand(char *filespec, char *outbuf, int ts, char *defspec, unsigned opts) if (!(mynam.nam$l_fnb & NAM$M_EXP_VER) && (!defspec || !*defspec || !strchr(myfab.fab$l_dna,';'))) speclen = mynam.nam$l_ver - out; + if (!(mynam.nam$l_fnb & NAM$M_EXP_TYPE) && + (!defspec || !*defspec || defspec[myfab.fab$b_dns-1] != '.' || + defspec[myfab.fab$b_dns-2] == '.')) + speclen = mynam.nam$l_type - 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 && @@ -895,6 +903,9 @@ do_rmsexpand(char *filespec, char *outbuf, int ts, char *defspec, unsigned opts) if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL; strcpy(outbuf,tmpfspec); } + mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL; + mynam.nam$l_rsa = NULL; mynam.nam$b_rss = 0; + myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */ return outbuf; } /*}}}*/ @@ -1032,6 +1043,7 @@ static char *do_fileify_dirspec(char *dir,char *buf,int ts) } cp1++; } while ((cp1 = strstr(cp1,"/.")) != NULL); + lastdir = strrchr(dir,'/'); } else if (!strcmp(&dir[dirlen-7],"/000000")) { /* Ditto for specs that end in an MFD -- let the VMS code @@ -2441,7 +2453,7 @@ trim_unixpath(char *fspec, char *wildspec, int opts) for (front = end ; front >= base; front--) if (*front == '/' && !dirs--) { front++; break; } } - for (cp1=template,cp2=lcres; *cp1; + for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + sizeof lcres; cp1++,cp2++) *cp2 = _tolower(*cp1); /* Make lc copy for match */ if (cp1 != '\0') return 0; /* Path too long. */ lcend = cp2; @@ -4119,11 +4131,11 @@ my_binmode(FILE *fp, char iotype) if (iotype != '-'&& (ret = fgetpos(fp, &pos)) == -1 && dirend) return NULL; switch (iotype) { case '<': case 'r': acmode = "rb"; break; - case '>': case 'w': + 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 '|': case 's': acmode = "rb+"; break; + case '+': case 's': acmode = "rb+"; break; case '-': acmode = fileno(fp) ? "ab" : "rb"; break; default: warn("Unrecognized iotype %c in my_binmode",iotype); @@ -4538,6 +4550,11 @@ init_os_extras() newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$"); newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$"); newXS("File::Copy::rmscopy",rmscopy_fromperl,file); + +#ifdef PRIME_ENV_AT_STARTUP + prime_env_iter(); +#endif + return; } diff --git a/vms/vmsish.h b/vms/vmsish.h index 31a42d9..1cda1e2 100644 --- a/vms/vmsish.h +++ b/vms/vmsish.h @@ -16,12 +16,11 @@ #include /* bitmasks for exit status testing */ /* Suppress compiler warnings from DECC for VMS-specific extensions: - * GLOBALEXT, NOSHAREEXT, READONLYEXT: global[dr]ef declarations * ADDRCONSTEXT,NEEDCONSTEXT: initialization of data with non-constant values * (e.g. pointer fields of descriptors) */ #ifdef __DECC -# pragma message disable (GLOBALEXT,NOSHAREEXT,READONLYEXT,ADDRCONSTEXT,NEEDCONSTEXT) +# pragma message disable (ADDRCONSTEXT,NEEDCONSTEXT) #endif /* DEC's C compilers and gcc use incompatible definitions of _to(upp|low)er() */ @@ -75,11 +74,6 @@ /* DECC introduces this routine in the RTL as of VMS 7.0; for now, * we'll use ours, since it gives us the full VMS exit status. */ -#ifdef __PID_T -# define Pid_t pid_t -#else -# define Pid_t unsigned int -#endif #define waitpid my_waitpid /* Don't redeclare standard RTL routines in Perl's header files; -- 2.7.4