This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
applied new parts of suggested patch
authorCharles Bailey <bailey@newman.upenn.edu>
Fri, 2 Jul 1999 19:18:41 +0000 (15:18 -0400)
committerGurusamy Sarathy <gsar@cpan.org>
Wed, 7 Jul 1999 17:45:52 +0000 (17:45 +0000)
Message-id: <01JD3M8W1VXS000S5G@mail.newman.upenn.edu>
Subject: [PATCH 5.005_57] Consolidated VMS patch

p4raw-id: //depot/perl@3650

13 files changed:
configure.com
iperlsys.h
lib/ExtUtils/MM_VMS.pm
lib/File/Basename.pm
lib/File/Spec/VMS.pm
pod/perldiag.pod
t/base/rs.t
t/lib/io_multihomed.t
t/lib/textfill.t
t/lib/textwrap.t
t/op/filetest.t
t/op/mkdir.t
vms/vms.c

index 6a1c37a..350d64a 100644 (file)
@@ -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"
index d3ac12f..2adb321 100644 (file)
@@ -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))
index c77eebe..ba4c2cc 100644 (file)
@@ -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'};
index 191eff9..d1c8666 100644 (file)
@@ -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 {
index 30440c2..d13f5e6 100644 (file)
@@ -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
index 0484882..bb76f78 100644 (file)
@@ -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
index 07cc8fd..021d699 100755 (executable)
@@ -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
index 8dc46e9..7337a5f 100644 (file)
@@ -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;
index 9ae6de9..daeee23 100755 (executable)
@@ -5,6 +5,8 @@ BEGIN {
     unshift @INC, '../lib';
 }
 
+use Text::Wrap qw(&fill);
+
 @tests = (split(/\nEND\n/s, <<DONE));
 TEST1
 Cyberdog Information
index aee2500..bb1d5ca 100755 (executable)
@@ -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
index 1e095be..d03ff75 100755 (executable)
@@ -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';
index fc91b6b..4bd1b21 100755 (executable)
@@ -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';
index af35fbd..031f1c6 100644 (file)
--- 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;