#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
#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
# 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',
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 {
';
} else {
'
-$(MYEXTLIB): [.sdbm]descrip.mms
+$(MYEXTLIB) : [.sdbm]descrip.mms
set def [.sdbm]
$(MMS) all
set def [-]
$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)]
sub MY::top_targets {
'
all :: static
+ $(NOECHO) $(NOOP)
config ::
+ $(NOECHO) $(NOOP)
lint:
lint -abchx $(LIBSRCS)
#include <stdio.h>
#include <sys/file.h>
+#include "EXTERN.h"
#include "sdbm.h"
char *progname;
#include <stdio.h>
#include <sys/file.h>
+#include "EXTERN.h"
#include "sdbm.h"
char *progname;
#include <stdio.h>
#include <sys/file.h>
#ifdef SDBM
+#include "EXTERN.h"
#include "sdbm.h"
#else
#include <ndbm.h>
*/
#include "config.h"
+#include "EXTERN.h"
#include "sdbm.h"
/*
* polynomial conversion ignoring overflows
#endif
#include "config.h"
+#include "EXTERN.h"
#include "sdbm.h"
#include "tune.h"
#include "pair.h"
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"
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
/*
001777777777, 003777777777, 007777777777, 017777777777
};
-datum nullitem = {NULL, 0};
-
DBM *
sdbm_open(register char *file, register int flags, register int mode)
{
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
#include <ctype.h>
#include <setjmp.h>
-#if defined(I_UNISTD) || defined(VMS)
+#if defined(I_UNISTD)
#include <unistd.h>
#endif
#ifdef VMS
-# include <fcntl.h>
+# include <file.h>
+# include <unixio.h>
#endif
#if !defined(MSDOS) && !defined(WIN32) && !defined(VMS)
use Thread;
+sub counter {
+$count = 10;
+while ($count--) {
+ sleep 1;
+ print "ping $count\n";
+}
+}
+
sub reader {
my $line;
while ($line = <STDIN>) {
the terminal/stdin.
EOT
-$r = new Thread \&reader;
+$r = new Thread \&counter;
+
+&reader;
+
+__END__
+
+
$count = 10;
while ($count--) {
sleep 1;
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;
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 = (<pod/*.pod>);
%archpms = (Config => 1, FileHandle => 1, overload => 1);
$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"; }
# 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");
# 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.
# 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")
$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";
# 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");
}
$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,^/,;
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');
}
sub safe_unlink {
- return if $nonono;
+ return if $nonono or $Is_VMS;
local @names = @_;
foreach $name (@names) {
next unless -e $name;
$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"
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;
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;
}
# 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;
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
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}}),'
';
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);
my($otherldflags) = $attribs{OTHERLDFLAGS} || "";
my($inst_dynamic_dep) = $attribs{INST_DYNAMIC_DEP} || "";
+ my $shr = $Config{'dbgprefix'} . 'PerlShr';
my(@m);
push @m,"
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
';
';
# 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);
}
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) {
}
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) {
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) {
}
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
#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))
#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
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";
* 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*/
* 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:
# 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
*/
#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:
* 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
* 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:
*/
#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*/
#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 */
.endif
# Updated by fndvers.com -- do not edit by hand
-PERL_VERSION = 5_00462#
+PERL_VERSION = 5_00463#
.ifdef DECC_SOCKETS
SOCKET=1
.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
$(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
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
Set Default [.ext.attrs]
- $(MMS) realclean
Set Default [--]
+ Set Default [.ext.B]
+ - $(MMS) realclean
+ Set Default [--]
.ifdef THREAD
Set Default [.ext.Thread]
- $(MMS) realclean
=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');
=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<undef> 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<rmsexpand>.
+(If the file does not exist, the input specification is expanded as much
+as possible.) If an error occurs, returns C<undef> and sets C<$!>
and C<$^E>.
=head2 vmsify
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
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
# 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;
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;
=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);
waitfh($fh);
close($fh);
remove("another.file");
-
+writeof($pipefh);
=head1 DESCRIPTION
This package gives Perl scripts access via VMS extensions to several
method equivalent in effect to C<seek($fh,0,0)>. It returns a
true value if successful, and C<undef> if it fails.
+=item setdef
+
+This function sets the default device and directory for the process.
+It is identical to the built-in chdir() operator, except that the change
+persists after Perl exits. It returns a true value on success, and
+C<undef> if it encounters and error.
+
=item sync
This function flushes buffered data for the specified file handle
used with handles opened for asynchronous I/O, and performs its
task by calling the CRTL routine fwait().
+=item writeof
+
+This function writes an EOF to a file handle, if the device driver
+supports this operation. Its primary use is to send an EOF to a
+subprocess through a pipe opened for writing without closing the
+pipe. It returns a true value if successful, and C<undef> if
+it encounters an error.
+
=head1 REVISION
This document was last revised on 10-Dec-1996, for Perl 5.004.
/* 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
*
*/
#include "perl.h"
#include "XSUB.h"
#include <file.h>
+#include <iodef.h>
+#include <rms.h>
+#include <starlet.h>
static bool
constant(name, pval)
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; }
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);
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: $
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;
+ }
-# 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$$";
print +(stat("$name.tmp") ? 'not ' : ''),"ok 13\n";
print +(&VMS::Stdio::tmpnam ? '' : 'not '),"ok 14\n";
+
+if (open(P, qq[| MCR $^X -e "1 while (<STDIN>);print 'Foo';1 while (<STDIN>); print 'Bar'" >$name.tmp])) {
+ print P "Baz\nQuux\n";
+ print +(VMS::Stdio::writeof(P) ? '' : 'not '),"ok 15\n";
+ print P "Baz\nQuux\n";
+ print +(close(P) ? '' : 'not '),"ok 16\n";
+ $fh = VMS::Stdio::vmsopen("$name.tmp");
+ chomp($line = <$fh>);
+ close $fh;
+ unlink("$name.tmp");
+ print +($line eq 'FooBar' ? '' : 'not '),"ok 17\n";
+}
+else { print "not ok 15\nnot ok 16\nnot ok 17\n"; }
+
+$sfh = VMS::Stdio::vmsopen(">$name.tmp");
+$setuperl = "\$ MCR $^X\nBEGIN { \@INC = qw(@INC) };\nuse VMS::Stdio qw(&setdef);";
+print $sfh qq[\$ here = F\$Environment("Default")\n];
+print $sfh "$setuperl\nsetdef();\n\$ Show Default\n\$ Set Default 'here'\n";
+print $sfh "$setuperl\nsetdef('..');\n\$ Show Default\n";
+close $sfh;
+@defs = map { /(\S+)/ && $1 } `\@$name.tmp`;
+unlink("$name.tmp");
+print +($defs[0] eq uc($ENV{'SYS$LOGIN'}) ? '' : "not ($defs[0]) "),"ok 18\n";
+print +($defs[1] eq VMS::Filespec::rmsexpand('[-]') ? '' : "not ($defs[1]) "),"ok 19\n";
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);
}
}
+$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";
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"; }
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";
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";
}
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
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
{
#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)
{
#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
{
#if YYDEBUG
if (yydebug)
- fprintf(stderr,
+ PerlIO_printf(Perl_debug_log,
"yydebug: error recovery discarding state %d\n",
*yyssp);
#endif
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);
}
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];
#line 633 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
-#line 2267 "y_tab.c"
+#line 2267 "perly.c"
}
yyssp -= yym;
yystate = *yyssp;
{
#if YYDEBUG
if (yydebug)
- fprintf(stderr,
+ PerlIO_printf(Perl_debug_log,
"yydebug: after reduction, shifting from state 0 to state %d\n",
YYFINAL);
#endif
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
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
*/
{
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;
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);
}
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);
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 &&
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;
}
/*}}}*/
}
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
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;
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);
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;
}
#include <stsdef.h> /* 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() */
/* 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;
https://perl5.git.perl.org / perl5.git / commitdiff