summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--configure.com2
-rw-r--r--iperlsys.h6
-rw-r--r--lib/ExtUtils/MM_VMS.pm52
-rw-r--r--lib/File/Basename.pm2
-rw-r--r--lib/File/Spec/VMS.pm68
-rw-r--r--pod/perldiag.pod46
-rwxr-xr-xt/base/rs.t3
-rw-r--r--t/lib/io_multihomed.t1
-rwxr-xr-xt/lib/textfill.t2
-rwxr-xr-xt/lib/textwrap.t1
-rwxr-xr-xt/op/filetest.t1
-rwxr-xr-xt/op/mkdir.t9
-rw-r--r--vms/vms.c26
13 files changed, 177 insertions, 42 deletions
diff --git a/configure.com b/configure.com
index 6a1c37ae82..350d64ac28 100644
--- a/configure.com
+++ b/configure.com
@@ -1837,7 +1837,7 @@ $ echo "you might, for example, want to build GDBM_File instead of
$ echo "SDBM_File if you have the GDBM library built on your machine
$ echo "
$ echo "Which modules do you want to build into perl?"
-$ dflt = "Fcntl Errno IO Opcode Data::Dumper attrs re VMS::Stdio VMS::DCLsym B SDBM_File"
+$ dflt = "Fcntl Errno IO Opcode Byteloader Devel::Peek Data::Dumper attrs re VMS::Stdio VMS::DCLsym B SDBM_File"
$ if Using_Dec_C.eqs."Yes"
$ THEN
$ dflt = dflt + " POSIX"
diff --git a/iperlsys.h b/iperlsys.h
index d3ac12f58d..2adb321956 100644
--- a/iperlsys.h
+++ b/iperlsys.h
@@ -777,10 +777,11 @@ struct IPerlLIOInfo
#define PerlLIO_ioctl(fd, u, buf) ioctl((fd), (u), (buf))
#define PerlLIO_isatty(fd) isatty((fd))
#define PerlLIO_lseek(fd, offset, mode) lseek((fd), (offset), (mode))
+#define PerlLIO_stat(name, buf) Stat((name), (buf))
#ifdef HAS_LSTAT
-#define PerlLIO_lstat(name, buf) lstat((name), (buf))
+# define PerlLIO_lstat(name, buf) lstat((name), (buf))
#else
-#define PerlLIO_lstat(name, buf) PerlLIO_stat((name), (buf))
+# define PerlLIO_lstat(name, buf) PerlLIO_stat((name), (buf))
#endif
#define PerlLIO_mktemp(file) mktemp((file))
#define PerlLIO_mkstemp(file) mkstemp((file))
@@ -789,7 +790,6 @@ struct IPerlLIOInfo
#define PerlLIO_read(fd, buf, count) read((fd), (buf), (count))
#define PerlLIO_rename(old, new) rename((old), (new))
#define PerlLIO_setmode(fd, mode) setmode((fd), (mode))
-#define PerlLIO_stat(name, buf) Stat((name), (buf))
#define PerlLIO_tmpnam(str) tmpnam((str))
#define PerlLIO_umask(mode) umask((mode))
#define PerlLIO_unlink(file) unlink((file))
diff --git a/lib/ExtUtils/MM_VMS.pm b/lib/ExtUtils/MM_VMS.pm
index c77eebe50f..ba4c2cc0c4 100644
--- a/lib/ExtUtils/MM_VMS.pm
+++ b/lib/ExtUtils/MM_VMS.pm
@@ -14,7 +14,7 @@ use VMS::Filespec;
use File::Basename;
use vars qw($Revision);
-$Revision = '5.52 (12-Sep-1998)';
+$Revision = '5.56 (27-Apr-1999)';
unshift @MM::ISA, 'ExtUtils::MM_VMS';
@@ -626,10 +626,13 @@ sub constants {
my(@m,$def,$macro);
if ($self->{DEFINE} ne '') {
- my(@defs) = split(/\s+/,$self->{DEFINE});
- foreach $def (@defs) {
+ my(@terms) = split(/\s+/,$self->{DEFINE});
+ my(@defs,@udefs);
+ foreach $def (@terms) {
next unless $def;
- if ($def =~ s/^-D//) { # If it was a Unix-style definition
+ my $targ = \@defs;
+ if ($def =~ s/^-([DU])//) { # If it was a Unix-style definition
+ if ($1 eq 'U') { $targ = \@udefs; }
$def =~ s/='(.*)'$/=$1/; # then remove shell-protection ''
$def =~ s/^'(.*)'$/$1/; # from entire term or argument
}
@@ -637,8 +640,11 @@ sub constants {
$def =~ s/"/""/g; # Protect existing " from DCL
$def = qq["$def"]; # and quote to prevent parsing of =
}
+ push @$targ, $def;
}
- $self->{DEFINE} = join ',',@defs;
+ $self->{DEFINE} = '';
+ if (@defs) { $self->{DEFINE} = '/Define=(' . join(',',@defs) . ')'; }
+ if (@udefs) { $self->{DEFINE} .= '/Undef=(' . join(',',@udefs) . ')'; }
}
if ($self->{OBJECT} =~ /\s/) {
@@ -842,27 +848,25 @@ sub cflags {
# Deal with $self->{DEFINE} here since some C compilers pay attention
# to only one /Define clause on command line, so we have to
# conflate the ones from $Config{'ccflags'} and $self->{DEFINE}
- if ($quals =~ m:(.*)/define=\(?([^\(\/\)\s]+)\)?(.*)?:i) {
- $quals = "$1/Define=($2," . ($self->{DEFINE} ? "$self->{DEFINE}," : '') .
- "\$(DEFINE_VERSION),\$(XS_DEFINE_VERSION))$3";
- }
- else {
- $quals .= '/Define=(' . ($self->{DEFINE} ? "$self->{DEFINE}," : '') .
- '$(DEFINE_VERSION),$(XS_DEFINE_VERSION))';
+ # ($self->{DEFINE} has already been VMSified in constants() above)
+ if ($self->{DEFINE}) { $quals .= $self->{DEFINE}; }
+ for $type (qw(Def Undef)) {
+ my(@terms);
+ while ($quals =~ m:/${type}i?n?e?=([^/]+):ig) {
+ my $term = $1;
+ $term =~ s:^\((.+)\)$:$1:;
+ push @terms, $term;
+ }
+ if ($type eq 'Def') {
+ push @terms, qw[ $(DEFINE_VERSION) $(XS_DEFINE_VERSION) ];
+ }
+ if (@terms) {
+ $quals =~ s:/${type}i?n?e?=[^/]+::ig;
+ $quals .= "/${type}ine=(" . join(',',@terms) . ')';
+ }
}
$libperl or $libperl = $self->{LIBPERL_A} || "libperl.olb";
-# This whole section is commented out, since I don't think it's necessary (or applicable)
-# if ($libperl =~ s/^$Config{'dbgprefix'}//) { $libperl =~ s/perl([^Dd]*)\./perld$1./; }
-# if ($libperl =~ /libperl(\w+)\./i) {
-# my($type) = uc $1;
-# my(%map) = ( 'D' => 'DEBUGGING', 'E' => 'EMBED', 'M' => 'MULTIPLICITY',
-# 'DE' => 'DEBUGGING,EMBED', 'DM' => 'DEBUGGING,MULTIPLICITY',
-# 'EM' => 'EMBED,MULTIPLICITY', 'DEM' => 'DEBUGGING,EMBED,MULTIPLICITY' );
-# my($add) = join(',', grep { $quals !~ /\b$_\b/ } split(/,/,$map{$type}));
-# $quals =~ s:/define=\(([^\)]+)\):/Define=($1,$add):i if $add;
-# $self->{PERLTYPE} ||= $type;
-# }
# Likewise with $self->{INC} and /Include
if ($self->{'INC'}) {
@@ -873,7 +877,7 @@ sub cflags {
}
}
$quals .= "$incstr)";
- $quals =~ s/\(,/\(/g;
+# $quals =~ s/,,/,/g; $quals =~ s/\(,/(/g;
$self->{CCFLAGS} = $quals;
$self->{OPTIMIZE} ||= $flagoptstr || $Config{'optimize'};
diff --git a/lib/File/Basename.pm b/lib/File/Basename.pm
index 191eff970a..d1c8666bbb 100644
--- a/lib/File/Basename.pm
+++ b/lib/File/Basename.pm
@@ -124,7 +124,7 @@ directory name to be F<.>).
## use strict;
-# A bit of juggling to insure that C<use re 'taint';> awlays works, since
+# A bit of juggling to insure that C<use re 'taint';> always works, since
# File::Basename is used during the Perl build, when the re extension may
# not be available.
BEGIN {
diff --git a/lib/File/Spec/VMS.pm b/lib/File/Spec/VMS.pm
index 30440c2218..d13f5e68c2 100644
--- a/lib/File/Spec/VMS.pm
+++ b/lib/File/Spec/VMS.pm
@@ -22,6 +22,74 @@ See File::Spec::Unix for a documentation of the methods provided
there. This package overrides the implementation of these methods, not
the semantics.
+=cut
+
+sub eliminate_macros {
+ my($self,$path) = @_;
+ return '' unless $path;
+ $self = {} unless ref $self;
+ my($npath) = unixify($path);
+ my($complex) = 0;
+ my($head,$macro,$tail);
+
+ # perform m##g in scalar context so it acts as an iterator
+ while ($npath =~ m#(.*?)\$\((\S+?)\)(.*)#g) {
+ if ($self->{$2}) {
+ ($head,$macro,$tail) = ($1,$2,$3);
+ if (ref $self->{$macro}) {
+ if (ref $self->{$macro} eq 'ARRAY') {
+ $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; }
+ $npath;
+}
+
+sub fixpath {
+ my($self,$path,$force_path) = @_;
+ return '' unless $path;
+ $self = bless {} unless ref $self;
+ my($fixedpath,$prefix,$name);
+
+ if ($path =~ m#^\$\([^\)]+\)$# || $path =~ m#[/:>\]]#) {
+ if ($force_path or $path =~ /(?:DIR\)|\])$/) {
+ $fixedpath = vmspath($self->eliminate_macros($path));
+ }
+ else {
+ $fixedpath = vmsify($self->eliminate_macros($path));
+ }
+ }
+ elsif ((($prefix,$name) = ($path =~ m#^\$\(([^\)]+)\)(.+)#)) && $self->{$prefix}) {
+ my($vmspre) = $self->eliminate_macros("\$($prefix)");
+ # is it a dir or just a name?
+ $vmspre = ($vmspre =~ m|/| or $prefix =~ /DIR$/) ? vmspath($vmspre) : '';
+ $fixedpath = ($vmspre ? $vmspre : $self->{$prefix}) . $name;
+ $fixedpath = vmspath($fixedpath) if $force_path;
+ }
+ else {
+ $fixedpath = $path;
+ $fixedpath = vmspath($fixedpath) if $force_path;
+ }
+ # No hints, so we try to guess
+ if (!defined($force_path) and $fixedpath !~ /[:>(.\]]/) {
+ $fixedpath = vmspath($fixedpath) if -d $fixedpath;
+ }
+ # Trim off root dirname if it's had other dirs inserted in front of it.
+ $fixedpath =~ s/\.000000([\]>])/$1/;
+ $fixedpath;
+}
+
+
=head2 Methods always loaded
=over
diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index 0484882c91..bb76f78465 100644
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -441,6 +441,12 @@ the return value of your socket() call? See L<perlfunc/bind>.
%ENV, it encountered a logical name or symbol definition which was too long,
so it was truncated to the string shown.
+=item Buffer overflow in prime_env_iter: %s
+
+(W) A warning peculiar to VMS. While Perl was preparing to iterate over
+%ENV, it encountered a logical name or symbol definition which was too long,
+so it was truncated to the string shown.
+
=item Callback called exit
(F) A subroutine invoked from an external package via perl_call_sv()
@@ -482,6 +488,13 @@ from the CRTL's internal environment array and discovered the array was
missing. You need to figure out where your CRTL misplaced its environ
or define F<PERL_ENV_TABLES> (see L<perlvms>) so that environ is not searched.
+=item Can't read CRTL environ
+
+(S) A warning peculiar to VMS. Perl tried to read an element of %ENV
+from the CRTL's internal environment array and discovered the array was
+missing. You need to figure out where your CRTL misplaced its environ
+or define F<PERL_ENV_TABLES> (see L<perlvms>) so that environ is not searched.
+
=item Can't "redo" outside a block
(F) A "redo" statement was executed to restart the current block, but
@@ -1818,6 +1831,14 @@ to UTC. If it's not, define the logical name F<SYS$TIMEZONE_DIFFERENTIAL>
to translate to the number of seconds which need to be added to UTC to
get local time.
+=item no UTC offset information; assuming local time is UTC
+
+(S) A warning peculiar to VMS. Per was unable to find the local
+timezone offset, so it's assuming that local system time is equivalent
+to UTC. If it's not, define the logical name F<SYS$TIMEZONE_DIFFERENTIAL>
+to translate to the number of seconds which need to be added to UTC to
+get local time.
+
=item Not a CODE reference
(F) Perl was trying to evaluate a reference to a code value (that is, a
@@ -2692,6 +2713,17 @@ rebuild Perl with a CRTL that does, or redefine F<PERL_ENV_TABLES> (see
L<perlvms>) so that the environ array isn't the target of the change to
%ENV which produced the warning.
+=item This Perl can't reset CRTL eviron elements (%s)
+
+=item This Perl can't set CRTL environ elements (%s=%s)
+
+(W) Warnings peculiar to VMS. You tried to change or delete an element
+of the CRTL's internal environ array, but your copy of Perl wasn't
+built with a CRTL that contained the setenv() function. You'll need to
+rebuild Perl with a CRTL that does, or redefine F<PERL_ENV_TABLES> (see
+L<perlvms>) so that the environ array isn't the target of the change to
+%ENV which produced the warning.
+
=item times not implemented
(F) Your version of the C library apparently doesn't do times(). I suspect
@@ -2853,6 +2885,13 @@ iterating over it, and someone else stuck a message in the stream of
data Perl expected. Someone's very confused, or perhaps trying to
subvert Perl's population of %ENV for nefarious purposes.
+=item Unknown process %x sent message to prime_env_iter: %s
+
+(P) An error peculiar to VMS. Perl was reading values for %ENV before
+iterating over it, and someone else stuck a message in the stream of
+data Perl expected. Someone's very confused, or perhaps trying to
+subvert Perl's population of %ENV for nefarious purposes.
+
=item unmatched () in regexp
(F) Unbackslashed parentheses must always be balanced in regular
@@ -3061,6 +3100,13 @@ element from a CLI symbol table, and found a resultant string longer
than 1024 characters. The return value has been truncated to 1024
characters.
+=item Value of CLI symbol "%s" too long
+
+(W) A warning peculiar to VMS. Perl tried to read the value of an %ENV
+element from a CLI symbol table, and found a resultant string longer
+than 1024 characters. The return value has been truncated to 1024
+characters.
+
=item Variable "%s" is not imported%s
(F) While "use strict" in effect, you referred to a global variable
diff --git a/t/base/rs.t b/t/base/rs.t
index 07cc8fd447..021d699e2e 100755
--- a/t/base/rs.t
+++ b/t/base/rs.t
@@ -122,8 +122,7 @@ if ($^O eq 'VMS') {
if ($bar eq "z\n") {print "ok 14\n";} else {print "not ok 14\n";}
close TESTFILE;
- unlink "./foo.bar";
- unlink "./foo.com";
+ 1 while unlink qw(foo.bar foo.com foo.fdl);
} else {
# Nobody else does this at the moment (well, maybe OS/390, but they can
# put their own tests in) so we just punt
diff --git a/t/lib/io_multihomed.t b/t/lib/io_multihomed.t
index 8dc46e96b4..7337a5f8d6 100644
--- a/t/lib/io_multihomed.t
+++ b/t/lib/io_multihomed.t
@@ -21,7 +21,6 @@ BEGIN {
elsif ($Config{'extensions'} !~ /\bIO\b/) {
$reason = 'IO extension unavailable';
}
- undef $reason if $^O eq 'VMS' and $Config{d_socket};
if ($reason) {
print "1..0 # Skip: $reason\n";
exit 0;
diff --git a/t/lib/textfill.t b/t/lib/textfill.t
index 9ae6de9fc1..daeee2367c 100755
--- a/t/lib/textfill.t
+++ b/t/lib/textfill.t
@@ -5,6 +5,8 @@ BEGIN {
unshift @INC, '../lib';
}
+use Text::Wrap qw(&fill);
+
@tests = (split(/\nEND\n/s, <<DONE));
TEST1
Cyberdog Information
diff --git a/t/lib/textwrap.t b/t/lib/textwrap.t
index aee2500108..bb1d5ca4a5 100755
--- a/t/lib/textwrap.t
+++ b/t/lib/textwrap.t
@@ -4,6 +4,7 @@ BEGIN {
chdir 't' if -d 't';
unshift @INC, '../lib';
}
+use Text::Wrap qw(&wrap);
@tests = (split(/\nEND\n/s, <<DONE));
TEST1
diff --git a/t/op/filetest.t b/t/op/filetest.t
index 1e095be7e1..d03ff75b04 100755
--- a/t/op/filetest.t
+++ b/t/op/filetest.t
@@ -3,6 +3,7 @@
# There are few filetest operators that are portable enough to test.
# See pod/perlport.pod for details.
+use Config;
BEGIN {
chdir 't' if -d 't';
unshift @INC, '../lib' if -d '../lib';
diff --git a/t/op/mkdir.t b/t/op/mkdir.t
index fc91b6b6a2..4bd1b21c80 100755
--- a/t/op/mkdir.t
+++ b/t/op/mkdir.t
@@ -4,7 +4,14 @@
print "1..7\n";
-$^O eq 'MSWin32' ? `del /s /q blurfl 2>&1` : `rm -rf blurfl`;
+if ($^O eq 'VMS') { # May as well test the library too
+ unshift @INC, '../lib';
+ require File::Path;
+ File::Path::rmtree('blurfl');
+}
+else {
+ $^O eq 'MSWin32' ? `del /s /q blurfl 2>&1` : `rm -rf blurfl`;
+}
# tests 3 and 7 rather naughtily expect English error messages
$ENV{'LC_ALL'} = 'C';
diff --git a/vms/vms.c b/vms/vms.c
index af35fbd62f..031f1c6b35 100644
--- a/vms/vms.c
+++ b/vms/vms.c
@@ -466,15 +466,22 @@ prime_env_iter(void)
key = cp1; keylen = cp2 - cp1;
if (keylen && hv_exists(seenhv,key,keylen)) continue;
while (*cp2 && *cp2 != '=') cp2++;
- while (*cp2 && *cp2 != '"') cp2++;
- for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
- if ((!keylen || (cp1 - cp2 <= 0)) && ckWARN(WARN_INTERNAL)) {
+ while (*cp2 && *cp2 == '=') cp2++;
+ while (*cp2 && *cp2 == ' ') cp2++;
+ if (*cp2 == '"') { /* String translation; may embed "" */
+ for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
+ cp2++; cp1--; /* Skip "" surrounding translation */
+ }
+ else { /* Numeric translation */
+ for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
+ cp1--; /* stop on last non-space char */
+ }
+ if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
warner(WARN_INTERNAL,"Ill-formed message in prime_env_iter: |%s|",buf);
continue;
}
- /* Skip "" surrounding translation */
PERL_HASH(hash,key,keylen);
- hv_store(envhv,key,keylen,newSVpv(cp2+1,cp1 - cp2 - 1),hash);
+ hv_store(envhv,key,keylen,newSVpvn(cp2,cp1 - cp2 + 1),hash);
hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
}
if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
@@ -917,7 +924,7 @@ static int waitpid_asleep = 0;
* to a mbx; that's the caller's responsibility.
*/
static unsigned long int
-pipe_eof(FILE *fp)
+pipe_eof(FILE *fp, int immediate)
{
char devnam[NAM$C_MAXRSS+1], *cp;
unsigned long int chan, iosb[2], retsts, retsts2;
@@ -929,7 +936,8 @@ pipe_eof(FILE *fp)
if ((cp = strrchr(devnam,':')) != NULL) *(cp+1) = '\0';
devdsc.dsc$w_length = strlen(devnam);
_ckvmssts(sys$assign(&devdsc,&chan,0,0));
- retsts = sys$qiow(0,chan,IO$_WRITEOF,iosb,0,0,0,0,0,0,0,0);
+ retsts = sys$qiow(0,chan,IO$_WRITEOF|(immediate?IO$M_NOW|IO$M_NORSWAIT:0),
+ 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;
@@ -956,7 +964,7 @@ pipe_exit_routine()
while (info) {
if (info->mode != 'r' && !info->done) {
- if (pipe_eof(info->fp) & 1) did_stuff = 1;
+ if (pipe_eof(info->fp, 1) & 1) did_stuff = 1;
}
info = info->next;
}
@@ -1098,7 +1106,7 @@ I32 my_pclose(FILE *fp)
/* If we were writing to a subprocess, insure that someone reading from
* the mailbox gets an EOF. It looks like a simple fclose() doesn't
* produce an EOF record in the mailbox. */
- if (info->mode != 'r' && !info->done) pipe_eof(info->fp);
+ if (info->mode != 'r' && !info->done) pipe_eof(info->fp,0);
PerlIO_close(info->fp);
if (info->done) retsts = info->completion;
View Lorry Controller Status