From: Charles Bailey Date: Fri, 2 Jul 1999 19:18:41 +0000 (-0400) Subject: applied new parts of suggested patch X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=1f47e8e2e6e01cf4845f0f3f0f0c7524761ffa80;p=p5sagit%2Fp5-mst-13.2.git applied new parts of suggested patch Message-id: <01JD3M8W1VXS000S5G@mail.newman.upenn.edu> Subject: [PATCH 5.005_57] Consolidated VMS patch p4raw-id: //depot/perl@3650 --- diff --git a/configure.com b/configure.com index 6a1c37a..350d64a 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 d3ac12f..2adb321 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 c77eebe..ba4c2cc 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 191eff9..d1c8666 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 awlays works, since +# A bit of juggling to insure that C 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 30440c2..d13f5e6 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 0484882..bb76f78 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -441,6 +441,12 @@ the return value of your socket() call? See L. %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 (see L) 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 (see L) 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 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 +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 (see L) 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 (see +L) 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 07cc8fd..021d699 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 8dc46e9..7337a5f 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 9ae6de9..daeee23 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, <&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 af35fbd62..031f1c6 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;