This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
applied non-conflicting parts of suggested patch
authorCharles Bailey <bailey@newman.upenn.edu>
Sat, 27 Mar 1999 00:16:51 +0000 (20:16 -0400)
committerGurusamy Sarathy <gsar@cpan.org>
Wed, 5 May 1999 17:17:34 +0000 (17:17 +0000)
Message-id: <01J9AZY8I2PW001O2S@mail.newman.upenn.edu>
Subject: [Patch 5.005_56] Revised VMS patch

p4raw-id: //depot/perl@3306

Changes
ext/B/defsubs.h.PL
hv.c
iperlsys.h
perl.c
pod/perldiag.pod
proto.h
util.c
vms/perlvms.pod
vms/vms.c

diff --git a/Changes b/Changes
index 4400017..4a0c75f 100644 (file)
--- a/Changes
+++ b/Changes
@@ -79,6 +79,116 @@ Version 5.005_57        Development release working toward 5.006
 ----------------
 
 ____________________________________________________________________________
+[  3305] By: gsar                                  on 1999/05/05  16:20:19
+        Log: make perldoc use backslashed pathnames within system() on win32
+     Branch: perl
+           ! pod/perldiag.pod pod/perlthrtut.pod utils/perldoc.PL
+____________________________________________________________________________
+[  3304] By: gsar                                  on 1999/05/05  07:29:43
+        Log: upgrade Pod::Parser to v1.081 from CPAN
+     Branch: perl
+          ! lib/Pod/Checker.pm lib/Pod/InputObjects.pm lib/Pod/Parser.pm
+          ! lib/Pod/PlainText.pm lib/Pod/Select.pm lib/Pod/Usage.pm
+           ! t/pod/special_seqs.t t/pod/special_seqs.xr t/pod/testp2pt.pl
+____________________________________________________________________________
+[  3303] By: gsar                                  on 1999/05/05  07:02:07
+        Log: From: Andy Dougherty <doughera@lafayette.edu>
+             Date: Fri, 19 Mar 1999 12:31:35 -0500 (EST)
+             Message-Id: <Pine.GSU.4.05.9903191208250.8899-100000@newton.phys>
+             Subject: [PATCH 5.005_03-MT3] INSTALL patches
+     Branch: perl
+           ! INSTALL
+____________________________________________________________________________
+[  3302] By: gsar                                  on 1999/05/05  06:55:21
+        Log: load base packages based on nonexistent $VERSION
+             From: andreas.koenig@anima.de (Andreas J. Koenig)
+             Date: 19 Mar 1999 06:00:28 +0100
+             Message-ID: <sfcsob2m5ub.fsf@dubravka.in-berlin.de>
+             Subject: Re: base.pm flaw
+     Branch: perl
+           ! lib/base.pm lib/locale.pm
+____________________________________________________________________________
+[  3301] By: gsar                                  on 1999/05/04  05:41:08
+        Log: pod2man outputs switched date and revision label (fix suggested by
+             EthanSasiela@mede.com)
+     Branch: perl
+           ! pod/pod2man.PL
+____________________________________________________________________________
+[  3300] By: gsar                                  on 1999/05/03  18:48:25
+        Log: adjust win32_stat() to cope with FindFirstFile() and stat() bugs
+             (makes opendir(D,"c:") work reliably)
+     Branch: perl
+           ! win32/win32.c
+____________________________________________________________________________
+[  3299] By: gsar                                  on 1999/05/02  19:39:55
+        Log: add test case for change#3298
+     Branch: perl
+           ! sv.c t/op/readdir.t
+____________________________________________________________________________
+[  3298] By: gsar                                  on 1999/05/02  19:24:41
+        Log: close directory handles properly when localized
+     Branch: perl
+           ! sv.c
+____________________________________________________________________________
+[  3297] By: jhi                                   on 1999/04/30  11:42:14
+        Log: Integrate from mainperl.
+     Branch: cfgperl
+         !> Changes config_h.SH configure.com lib/AutoLoader.pm
+         !> lib/AutoSplit.pm lib/File/Path.pm pod/perlre.pod pp.c pp_ctl.c
+         !> pp_sys.c proto.h regcomp.c t/op/die.t t/op/ref.t util.c
+         !> vms/descrip_mms.template vms/gen_shrfls.pl vms/munchconfig.c
+          !> vms/subconfigure.com win32/win32.c
+____________________________________________________________________________
+[  3293] By: chip                                  on 1999/04/29  18:50:49
+        Log: Fix shebang lines.
+     Branch: maint-5.004/perl
+          ! Porting/p4d2p h2pl/mksizes pod/checkpods.PL pod/pod2html.PL
+          ! pod/pod2latex.PL pod/pod2man.PL pod/pod2text.PL utils/c2ph.PL
+          ! utils/h2ph.PL utils/h2xs.PL utils/perlbug.PL utils/perldoc.PL
+          ! utils/pl2pm.PL utils/splain.PL win32/bin/search.pl
+           ! x2p/find2perl.PL x2p/s2p.PL
+____________________________________________________________________________
+[  3284] By: gsar                                  on 1999/04/27  00:48:42
+        Log: integrate change#3279 from maint-5.004
+     Branch: perl
+           ! lib/AutoLoader.pm
+____________________________________________________________________________
+[  3279] By: chip                                  on 1999/04/26  23:09:26
+        Log: Make &AutoLoad::AUTOLOAD reentrant.
+     Branch: maint-5.004/perl
+           ! lib/AutoLoader.pm
+____________________________________________________________________________
+[  3276] By: chip                                  on 1999/04/26  22:34:36
+        Log: Make porting scripts executable.
+     Branch: maint-5.004/perl
+          ! Changes Porting/genlog Porting/makerel Porting/p4desc
+           ! Porting/patchls
+____________________________________________________________________________
+[  3274] By: gsar                                  on 1999/04/26  17:30:31
+        Log: allow embedded null characters in diagnostics
+     Branch: perl
+           ! pp_ctl.c pp_sys.c proto.h regcomp.c t/op/die.t util.c
+____________________________________________________________________________
+[  3273] By: gsar                                  on 1999/04/26  08:27:22
+        Log: hand-applied conflicting parts of suggested patch
+             From: Charles Bailey <BAILEY@newman.upenn.edu>
+             Date: Wed, 17 Mar 1999 23:55:23 -0400 (EDT)
+             Message-id: <01J8YELSL7WK001E7S@mail.newman.upenn.edu>
+             Subject: [PATCH 5.005_56] VMS configuration/build
+     Branch: perl
+          ! configure.com vms/descrip_mms.template vms/gen_shrfls.pl
+           ! vms/munchconfig.c vms/subconfigure.com
+____________________________________________________________________________
+[  3272] By: gsar                                  on 1999/04/26  08:25:41
+        Log: update Changes; tweak minor regressions
+     Branch: perl
+           ! Changes lib/AutoSplit.pm lib/File/Path.pm
+____________________________________________________________________________
+[  3271] By: gsar                                  on 1999/04/26  07:52:51
+        Log: integrate change#3229 from maint-5.004
+     Branch: perl
+           ! pp_ctl.c util.c
+____________________________________________________________________________
 [  3270] By: gsar                                  on 1999/04/25  22:58:27
         Log: fix buggy reference count on refs to SVs with autoviv magic
              (resulted in C<my @a; $a[1] = 1; print \$_ for @a> and Data::Dumper
index 94ca5b3..c04c1a3 100644 (file)
@@ -2,8 +2,8 @@
 # this file as a template for defsubs.h
 # Extracting defsubs.h (with variable substitutions)
 #!perl
-my ($out) = __FILE__ =~ /(^.*)[._]PL/i;
-if ($^O eq 'VMS') { $out =~ s/(^.*)[._](.*$)/$1.$2/;}
+my ($out) = __FILE__ =~ /(^.*)\.PL/;
+if ($^O eq 'VMS') { ($out) = __FILE__ =~ /^(.+)_PL$/i; }
 open(OUT,">$out") || die "Cannot open $file:$!";
 print "Extracting $out . . .\n";
 foreach my $const (qw(AVf_REAL 
diff --git a/hv.c b/hv.c
index 5a42d2f..e7a73ce 100644 (file)
--- a/hv.c
+++ b/hv.c
@@ -150,10 +150,7 @@ hv_fetch(HV *hv, const char *key, U32 klen, I32 lval)
     }
 #ifdef DYNAMIC_ENV_FETCH  /* %ENV lookup?  If so, try to fetch the value now */
     if (HvNAME(hv) && strEQ(HvNAME(hv),ENV_HV_NAME)) {
-      char *gotenv;
-
-      if ((gotenv = PerlEnv_getenv(key)) != Nullch) {
-        sv = newSVpvn(gotenv,strlen(gotenv));
+      if ((sv = PerlEnv_ENVgetenv_sv(key)) != &PL_sv_undef) {
         SvTAINTED_on(sv);
         return hv_store(hv,key,klen,sv,hash);
       }
@@ -241,10 +238,7 @@ hv_fetch_ent(HV *hv, SV *keysv, I32 lval, register U32 hash)
     }
 #ifdef DYNAMIC_ENV_FETCH  /* %ENV lookup?  If so, try to fetch the value now */
     if (HvNAME(hv) && strEQ(HvNAME(hv),ENV_HV_NAME)) {
-      char *gotenv;
-
-      if ((gotenv = PerlEnv_getenv(key)) != Nullch) {
-        sv = newSVpvn(gotenv,strlen(gotenv));
+      if ((sv = PerlEnv_ENVgetenv_sv(key)) != &PL_sv_undef) {
         SvTAINTED_on(sv);
         return hv_store_ent(hv,keysv,sv,hash);
       }
@@ -597,11 +591,17 @@ hv_exists(HV *hv, const char *key, U32 klen)
     }
 
     xhv = (XPVHV*)SvANY(hv);
+#ifndef DYNAMIC_ENV_FETCH
     if (!xhv->xhv_array)
        return 0; 
+#endif
 
     PERL_HASH(hash, key, klen);
 
+#ifdef DYNAMIC_ENV_FETCH
+    if (!xhv->xhv_array) entry = Null(HE*);
+    else
+#endif
     entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
     for (; entry; entry = HeNEXT(entry)) {
        if (HeHASH(entry) != hash)              /* strings can't be equal */
@@ -612,6 +612,14 @@ hv_exists(HV *hv, const char *key, U32 klen)
            continue;
        return TRUE;
     }
+#ifdef DYNAMIC_ENV_FETCH  /* is it out there? */
+    if (HvNAME(hv) && strEQ(HvNAME(hv), ENV_HV_NAME) &&
+        (sv = PerlEnv_ENVgetenv_sv(key)) != &PL_sv_undef) {
+       SvTAINTED_on(sv);
+       hv_store(hv,key,klen,sv,hash);
+       return TRUE;
+    }
+#endif
     return FALSE;
 }
 
@@ -648,13 +656,19 @@ hv_exists_ent(HV *hv, SV *keysv, U32 hash)
     }
 
     xhv = (XPVHV*)SvANY(hv);
+#ifndef DYNAMIC_ENV_FETCH
     if (!xhv->xhv_array)
        return 0; 
+#endif
 
     key = SvPV(keysv, klen);
     if (!hash)
        PERL_HASH(hash, key, klen);
 
+#ifdef DYNAMIC_ENV_FETCH
+    if (!xhv->xhv_array) entry = Null(HE*);
+    else
+#endif
     entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
     for (; entry; entry = HeNEXT(entry)) {
        if (HeHASH(entry) != hash)              /* strings can't be equal */
@@ -665,6 +679,14 @@ hv_exists_ent(HV *hv, SV *keysv, U32 hash)
            continue;
        return TRUE;
     }
+#ifdef DYNAMIC_ENV_FETCH  /* is it out there? */
+    if (HvNAME(hv) && strEQ(HvNAME(hv), ENV_HV_NAME) &&
+        (sv = PerlEnv_ENVgetenv_sv(key)) != &PL_sv_undef) {
+       SvTAINTED_on(sv);
+       hv_store_ent(hv,keysv,sv,hash);
+       return TRUE;
+    }
+#endif
     return FALSE;
 }
 
@@ -990,10 +1012,6 @@ hv_iterinit(HV *hv)
        croak("Bad hash");
     xhv = (XPVHV*)SvANY(hv);
     entry = xhv->xhv_eiter;
-#ifdef DYNAMIC_ENV_FETCH  /* set up %ENV for iteration */
-    if (HvNAME(hv) && strEQ(HvNAME(hv), ENV_HV_NAME))
-       prime_env_iter();
-#endif
     if (entry && HvLAZYDEL(hv)) {      /* was deleted earlier? */
        HvLAZYDEL_off(hv);
        hv_free_ent(hv, entry);
@@ -1046,6 +1064,10 @@ hv_iternext(HV *hv)
        xhv->xhv_eiter = Null(HE*);
        return Null(HE*);
     }
+#ifdef DYNAMIC_ENV_FETCH  /* set up %ENV for iteration */
+    if (!entry && HvNAME(hv) && strEQ(HvNAME(hv), ENV_HV_NAME))
+       prime_env_iter();
+#endif
 
     if (!xhv->xhv_array)
        Newz(506,xhv->xhv_array, ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
index 03e3c08..7251e8f 100644 (file)
@@ -447,6 +447,9 @@ class IPerlEnv
 {
 public:
     virtual char *     Getenv(const char *varname, int &err) = 0;
+#ifdef HAS_ENVGETENV
+    virtual char *     ENVGetenv(const char *varname, int &err) = 0;
+#endif
     virtual int                Putenv(const char *envstring, int &err) = 0;
     virtual char *     LibPath(char *patchlevel) =0;
     virtual char *     SiteLibPath(char *patchlevel) =0;
@@ -455,6 +458,14 @@ public:
 
 #define PerlEnv_putenv(str)            PL_piENV->Putenv((str), ErrorNo())
 #define PerlEnv_getenv(str)            PL_piENV->Getenv((str), ErrorNo())
+#define PerlEnv_getenv_sv(str)         PL_piENV->getenv_sv((str))
+#ifdef HAS_ENVGETENV
+#  define PerlEnv_ENVgetenv(str)       PL_piENV->ENVGetenv((str), ErrorNo())
+#  define PerlEnv_ENVgetenv_sv(str)    PL_piENV->ENVgetenv_sv((str))
+#else
+#  define PerlEnv_ENVgetenv(str)       PerlEnv_getenv((str))
+#  define PerlEnv_ENVgetenv_sv(str)    PerlEnv_getenv_sv((str))
+#endif
 #define PerlEnv_uname(name)            PL_piENV->Uname((name), ErrorNo())
 #ifdef WIN32
 #define PerlEnv_lib_path(str)          PL_piENV->LibPath((str))
@@ -465,6 +476,14 @@ public:
 
 #define PerlEnv_putenv(str)            putenv((str))
 #define PerlEnv_getenv(str)            getenv((str))
+#define PerlEnv_getenv_sv(str)         getenv_sv((str))
+#ifdef HAS_ENVGETENV
+#  define PerlEnv_ENVgetenv(str)       ENVgetenv((str))
+#  define PerlEnv_ENVgetenv_sv(str)    ENVgetenv_sv((str))
+#else
+#  define PerlEnv_ENVgetenv(str)       PerlEnv_getenv((str))
+#  define PerlEnv_ENVgetenv_sv(str)    PerlEnv_getenv_sv((str))
+#endif
 #define PerlEnv_uname(name)            uname((name))
 
 #endif /* PERL_OBJECT */
diff --git a/perl.c b/perl.c
index 5321eff..7c784fc 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -895,7 +895,11 @@ print \"  \\@INC:\\n    @INC\\n\";");
     }
   switch_end:
 
-    if (!PL_tainting && (s = PerlEnv_getenv("PERL5OPT"))) {
+    if (
+#ifndef SECURE_INTERNAL_GETENV
+        !PL_tainting &&
+#endif
+                        (s = PerlEnv_getenv("PERL5OPT"))) {
        while (isSPACE(*s))
            s++;
        if (*s == '-' && *(s+1) == 'T')
index 8bc5cdb..cc9160e 100644 (file)
@@ -430,6 +430,12 @@ the return value of your socket() call?  See L<perlfunc/bind>.
 
 (P) Perl detected an attempt to copy an internal value that is not copiable.
 
+=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()
@@ -464,6 +470,13 @@ count as a "loopish" block, as doesn't a block given to sort().  You can
 usually double the curlies to get the same effect though, because the inner
 curlies will be considered a block that loops once.  See L<perlfunc/next>.
 
+=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
@@ -1340,14 +1353,18 @@ about 250 characters for simple names, and somewhat more for compound
 names (like C<$A::B>).  You've exceeded Perl's limits.  Future
 versions of Perl are likely to eliminate these arbitrary limitations.
 
-=item Ill-formed logical name |%s| in prime_env_iter
+=item Ill-formed CRTL environ value "%s"
+
+(W) A warning peculiar to VMS.  Perl tried to read the CRTL's internal
+environ array, and encountered an element without the C<=> delimiter
+used to spearate keys from values.  The element is ignored.
+
+=item Ill-formed message in prime_env_iter: |%s|
 
-(W) A warning peculiar to VMS.  A logical name was encountered when preparing
-to iterate over %ENV which violates the syntactic rules governing logical
-names.  Because it cannot be translated normally, it is skipped, and will not
-appear in %ENV.  This may be a benign occurrence, as some software packages
-might directly modify logical name tables and introduce nonstandard names,
-or it may indicate that a logical name table has been corrupted.
+(W) A warning peculiar to VMS.  Perl tried to read a logical name
+or CLI symbol definition when preparing to iterate over %ENV, and
+didn't see the expected delimiter between key and value, so the
+line was ignored.
 
 =item Illegal character %s (carriage return)
 
@@ -1777,6 +1794,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
@@ -2621,6 +2646,17 @@ will deny it.
 if the last stat that wrote to the stat buffer already went past
 the symlink to get to the real file.  Use an actual filename instead.
 
+=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
@@ -2775,6 +2811,13 @@ representative, who probably put it there in the first place.
 
 (F) There are no byte-swapping functions for a machine with this byte order.
 
+=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
@@ -2976,6 +3019,13 @@ value of "0"; that would make the conditional expression false, which is
 probably not what you intended.  When using these constructs in conditional
 expressions, test their values with the C<defined> operator.
 
+=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/proto.h b/proto.h
index d430c45..4ba68fe 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -154,6 +154,9 @@ VIRTUAL OP* fold_constants _((OP* arg));
 VIRTUAL char*  form _((const char* pat, ...));
 VIRTUAL void   free_tmps _((void));
 VIRTUAL OP*    gen_constant_list _((OP* o));
+#ifndef HAS_GETENV_SV
+VIRTUAL SV*    getenv_sv _((char* key));
+#endif
 VIRTUAL void   gp_free _((GV* gv));
 VIRTUAL GP*    gp_ref _((GP* gp));
 VIRTUAL GV*    gv_AVadd _((GV* gv));
diff --git a/util.c b/util.c
index 1318c31..43d9aca 100644 (file)
--- a/util.c
+++ b/util.c
@@ -3026,6 +3026,21 @@ get_specialsv_list(void)
  return PL_specialsv_list;
 }
 
+#ifndef HAS_GETENV_SV
+SV *
+getenv_sv(char *env_elem)
+{
+  char *env_trans;
+  SV *temp_sv;
+  if ((env_trans = PerlEnv_getenv(env_elem)) != Nullch) {
+    temp_sv = newSVpv(env_trans, strlen(env_trans));
+    return temp_sv;
+  } else {
+    return &PL_sv_undef;
+  }
+}
+#endif
+
 
 MGVTBL*
 get_vtbl(int vtbl_id)
index 89c4bbf..56f6649 100644 (file)
@@ -17,7 +17,7 @@ subdirectory of the Perl distribution.
 We hope these notes will save you from confusion and lost 
 sleep when writing Perl scripts on VMS.  If you find we've 
 missed something you think should appear here, please don't 
-hesitate to drop a line to vmsperl@genetics.upenn.edu.
+hesitate to drop a line to vmsperl@newman.upenn.edu.
 
 =head1 Installation
 
@@ -648,48 +648,100 @@ takes precedence.
 
 =item %ENV 
 
-Reading the elements of the %ENV array returns the 
-translation of the logical name specified by the key, 
-according to the normal search order of access modes and 
-logical name tables.  If you append a semicolon to the
-logical name, followed by an integer, that integer is
-used as the translation index for the logical name,
-so that you can look up successive values for search
-list logical names.  For instance, if you say
+The operation of the C<%ENV> array depends on the translation
+of the logical name F<PERL_ENV_TABLES>.  If defined, it should
+be a search list, each element of which specifies a location
+for C<%ENV> elements.  If you tell Perl to read or set the
+element C<$ENV{>I<name>C<}>, then Perl uses the translations of
+F<PERL_ENV_TABLES> as follows:
+
+=over 4
+
+=item CRTL_ENV
+
+This string tells Perl to consult the CRTL's internal C<environ>
+array of key-value pairs, using I<name> as the key.  In most cases,
+this contains only a few keys, but if Perl was invoked via the C
+C<exec[lv]e()> function, as is the case for CGI processing by some
+HTTP servers, then the C<environ> array may have been populated by
+the calling program.
+
+=item CLISYM_[LOCAL]
+
+A string beginning with C<CLISYM_>tells Perl to consult the CLI's
+symbol tables, using I<name> as the name of the symbol.  When reading
+an element of C<%ENV>, the local symbol table is scanned first, followed
+by the global symbol table..  The characters following C<CLISYM_> are
+significant when an element of C<%ENV> is set or deleted: if the
+complete string is C<CLISYM_LOCAL>, the change is made in the local
+symbol table, otherwise the global symbol table is changed.
+
+=item Any other string
+
+If an element of F<PERL_ENV_TABLES> translates to any other string,
+that string is used as the name of a logical name table, which is
+consulted using I<name> as the logical name.  The normal search
+order of access modes is used.
+
+=back
+
+F<PERL_ENV_TABLES> is translated once when Perl starts up; any changes
+you make while Perl is running do not affect the behavior of C<%ENV>.
+If F<PERL_ENV_TABLES> is not defined, then Perl defaults to consulting
+first the logical name tables specified by F<LNM$FILE_DEV>, and then
+the CRTL C<environ> array.
+
+In all operations on %ENV, the key string is treated as if it 
+were entirely uppercase, regardless of the case actually 
+specified in the Perl expression.
+
+When an element of C<%ENV> is read, the locations to which
+F<PERL_ENV_TABLES> points are checked in order, and the value
+obtained from the first successful lookup is returned.  If the
+name of the C<%ENV> element contains a semi-colon, it and
+any characters after it are removed.  These are ignored when
+the CRTL C<environ> array or a CLI symbol table is consulted.
+However, the name is looked up in a logical name table, the
+suffix after the semi-colon is treated as the translation index
+to be used for the lookup.   This lets you look up successive values
+for search list logical names.  For instance, if you say
 
    $  Define STORY  once,upon,a,time,there,was
    $  perl -e "for ($i = 0; $i <= 6; $i++) " -
    _$ -e "{ print $ENV{'story;'.$i},' '}"
 
-Perl will print C<ONCE UPON A TIME THERE WAS>.
-
-The key C<default> returns the current default device
-and directory specification, regardless of whether
-there is a logical name DEFAULT defined.  If you try to
-read an element of %ENV for which there is no corresponding
-logical name, and for which no corresponding CLI symbol
-exists (this is to identify "blocking" symbols only; to
-manipulate CLI symbols, see L<VMS::DCLSym>) then the key
-will be looked up in the CRTL-local environment array, and
-the corresponding value, if any returned.  This lets you
-get at C-specific keys like C<home>, C<path>,C<term>, and
-C<user>, as well as other keys which may have been passed
-directly into the C-specific array if Perl was called from
-another C program using the version of execve() or execle() 
-present in recent revisions of the DECCRTL.
-
-Setting an element of %ENV defines a supervisor-mode logical 
-name in the process logical name table.  C<Undef>ing or 
-C<delete>ing an element of %ENV deletes the equivalent user-
-mode or supervisor-mode logical name from the process logical 
-name table.  If you use C<undef>, the %ENV element remains 
-empty.  If you use C<delete>, another attempt is made at 
-logical name translation after the deletion, so an inner-mode 
-logical name or a name in another logical name table will 
-replace the logical name just deleted.  It is not possible
-at present to define a search list logical name via %ENV.
-It is also not possible to delete an element from the
-C-local environ array.
+Perl will print C<ONCE UPON A TIME THERE WAS>, assuming, of course,
+that F<PERL_ENV_TABLES> is set up so that the logical name C<story>
+is found, rather than a CLI symbol or CRTL C<environ> element with
+the same name.
+
+When an element of C<%ENV> is set to a non-empty string, the
+corresponding definition is made in the location to which the
+first translation of F<PERL_ENV_TABLES> points.  If this causes a
+logical name to be created, it is defined in supervisor mode.
+An element of the CRTL C<environ> array can be set only if your
+copy of Perl knows about the CRTL's C<setenv()> function.  (This is
+present only in some versions of the DECCRTL; check C<$Config{d_setenv}>
+to see whether your copy of Perl was built with a CRTL that has this
+function.)
+          
+When an element of C<%ENV> is set to an empty string or C<undef>,
+the element is looked up as if it were being read, and if it is
+found, it is deleted.  (An item "deleted" from the CRTL C<environ>
+array is set to the empty string; this can only be done if your
+copy of Perl knows about the CRTL C<setenv()> function.)  Using
+C<delete> to remove an element from C<%ENV> has a similar effect,
+but after the element is deleted, another attempt is made to
+look up the element, so an inner-mode logical name or a name in
+another location will replace the logical name just deleted.
+It is not possible at present to define a search list logical name
+via %ENV.
+
+The element C<$ENV{DEFAULT}> is special: when read, it returns
+Perl's current default device and directory, and when set, it
+resets them, regardless of the definition of F<PERL_ENV_TABLES>.
+It cannot be cleared or deleted; attempts to do so are silently
+ignored.
 
 Note that if you want to pass on any elements of the
 C-local environ array to a subprocess which isn't
@@ -711,19 +763,14 @@ C<keys>, or C<values>,  you will incur a time penalty as all
 logical names are read, in order to fully populate %ENV.
 Subsequent iterations will not reread logical names, so they
 won't be as slow, but they also won't reflect any changes
-to logical name tables caused by other programs.  The C<each>
-operator is special: it returns each element I<already> in
-%ENV, but doesn't go out and look for more.   Therefore, if
-you've previously used C<keys> or C<values>, you'll see all
-the logical names visible to your process, and if not, you'll
-see only the names you've looked up so far.  (This is a
-consequence of the way C<each> is implemented now, and it
-may change in the future, so it wouldn't be a good idea
-to rely on it too much.)
-
-In all operations on %ENV, the key string is treated as if it 
-were entirely uppercase, regardless of the case actually 
-specified in the Perl expression.
+to logical name tables caused by other programs.
+
+You do need to be careful with the logicals representing process-permanent
+files, such as C<SYS$INPUT> and C<SYS$OUTPUT>.  The translations for these
+logicals are prepended with a two-byte binary value (0x1B 0x00) that needs to be
+stripped off if you want to use it. (In previous versions of perl it wasn't
+possible to get the values of these logicals, as the null byte acted as an
+end-of-string marker)
 
 =item $!
 
index 8870a0f..6302603 100644 (file)
--- a/vms/vms.c
+++ b/vms/vms.c
@@ -2,8 +2,8 @@
  *
  * VMS-specific routines for perl5
  *
- * Last revised: 27-Feb-1998 by Charles Bailey  bailey@newman.upenn.edu
- * Version: 5.4.61
+ * Last revised: 13-Sep-1998 by Charles Bailey  bailey@newman.upenn.edu
+ * Version: 5.5.2
  */
 
 #include <acedef.h>
@@ -21,6 +21,7 @@
 #include <iodef.h>
 #include <jpidef.h>
 #include <kgbdef.h>
+#include <libclidef.h>
 #include <libdef.h>
 #include <lib$routines.h>
 #include <lnmdef.h>
@@ -77,55 +78,140 @@ static char *__mystrtolower(char *str)
   return str;
 }
 
+static struct dsc$descriptor_s fildevdsc = 
+  { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
+static struct dsc$descriptor_s crtlenvdsc = 
+  { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
+static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
+static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
+static struct dsc$descriptor_s **env_tables = defenv;
+static bool will_taint = FALSE;  /* tainting active, but no PL_curinterp yet */
+
+/*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
 int
-my_trnlnm(char *lnm, char *eqv, unsigned long int idx)
+vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
+  struct dsc$descriptor_s **tabvec, unsigned long int flags)
 {
-    static char __my_trnlnm_eqv[LNM$C_NAMLENGTH+1];
-    unsigned short int eqvlen;
+    char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
+    unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
     unsigned long int retsts, attr = LNM$M_CASE_BLIND;
-    $DESCRIPTOR(tabdsc,"LNM$FILE_DEV");
-    struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
-    struct itmlst_3 lnmlst[3] = {{sizeof idx,      LNM$_INDEX,  &idx, 0},
-                                 {LNM$C_NAMLENGTH, LNM$_STRING, 0,    &eqvlen},
+    unsigned char acmode;
+    struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
+                            tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
+    struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
+                                 {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
                                  {0, 0, 0, 0}};
+    $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
 
-    if (!lnm || idx > LNM$_MAX_INDEX) {
+    if (!lnm || !eqv || idx > LNM$_MAX_INDEX) {
       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
     }
-    if (!eqv) eqv = __my_trnlnm_eqv;
-    lnmlst[1].bufadr = (void *)eqv;
-    lnmdsc.dsc$a_pointer = lnm;
-    lnmdsc.dsc$w_length = strlen(lnm);
-    retsts = sys$trnlnm(&attr,&tabdsc,&lnmdsc,0,lnmlst);
-    if (retsts == SS$_NOLOGNAM || retsts == SS$_IVLOGNAM) {
-      set_vaxc_errno(retsts); set_errno(EINVAL); return 0;
+    for (cp1 = (char *)lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
+      *cp2 = _toupper(*cp1);
+      if (cp1 - lnm > LNM$C_NAMLENGTH) {
+        set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
+        return 0;
+      }
+    }
+    lnmdsc.dsc$w_length = cp1 - lnm;
+    lnmdsc.dsc$a_pointer = uplnm;
+    secure = flags & PERL__TRNENV_SECURE;
+    acmode = secure ? PSL$C_EXEC : PSL$C_USER;
+    if (!tabvec || !*tabvec) tabvec = env_tables;
+
+    for (curtab = 0; tabvec[curtab]; curtab++) {
+      if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
+        if (!ivenv && !secure) {
+          char *eq, *end;
+          int i;
+          if (!environ) {
+            ivenv = 1; 
+            warn("Can't read CRTL environ\n");
+            continue;
+          }
+          retsts = SS$_NOLOGNAM;
+          for (i = 0; environ[i]; i++) { 
+            if ((eq = strchr(environ[i],'=')) && 
+                !strncmp(environ[i],uplnm,eq - environ[i])) {
+              eq++;
+              for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
+              if (!eqvlen) continue;
+              retsts = SS$_NORMAL;
+              break;
+            }
+          }
+          if (retsts != SS$_NOLOGNAM) break;
+        }
+      }
+      else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
+               !str$case_blind_compare(&tmpdsc,&clisym)) {
+        if (!ivsym && !secure) {
+          unsigned short int deflen = LNM$C_NAMLENGTH;
+          struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
+          /* dynamic dsc to accomodate possible long value */
+          _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
+          retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
+          if (retsts & 1) { 
+            if (eqvlen > 1024) {
+              if (PL_curinterp && PL_dowarn) warn("Value of CLI symbol \"%s\" too long",lnm);
+              eqvlen = 1024;
+              set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
+            }
+            strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
+          }
+          _ckvmssts(lib$sfree1_dd(&eqvdsc));
+          if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
+          if (retsts == LIB$_NOSUCHSYM) continue;
+          break;
+        }
+      }
+      else if (!ivlnm) {
+        retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
+        if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
+        if (retsts == SS$_NOLOGNAM) continue;
+        break;
+      }
     }
-    else if (retsts & 1) {
-      eqv[eqvlen] = '\0';
-      return eqvlen;
+    if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
+    else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
+             retsts == SS$_IVLOGNAM   || retsts == SS$_IVLOGTAB   ||
+             retsts == SS$_NOLOGNAM) {
+      set_errno(EINVAL);  set_vaxc_errno(retsts);
     }
-    _ckvmssts(retsts);  /* Must be an error */
-    return 0;      /* Not reached, assuming _ckvmssts() bails out */
+    else _ckvmssts(retsts);
+    return 0;
+}  /* end of vmstrnenv */
+/*}}}*/
 
-}  /* end of my_trnlnm */
+
+/*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
+/* Define as a function so we can access statics. */
+int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)
+{
+  return vmstrnenv(lnm,eqv,idx,fildev,                                   
+#ifdef SECURE_INTERNAL_GETENV
+                   (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
+#else
+                   0
+#endif
+                                                                              );
+}
+/*}}}*/
 
 /* my_getenv
- * Translate a logical name.  Substitute for CRTL getenv() to avoid
- * memory leak, and to keep my_getenv() and my_setenv() in the same
- * domain (mostly - my_getenv() need not return a translation from
- * the process logical name table)
- *
  * Note: Uses Perl temp to store result so char * can be returned to
  * caller; this pointer will be invalidated at next Perl statement
  * transition.
+ * We define this as a function rather than a macro in terms of my_getenv_sv()
+ * so that it'll work when PL_curinterp is undefined (and we therefore can't
+ * allocate SVs).
  */
-/*{{{ char *my_getenv(const char *lnm)*/
+/*{{{ char *my_getenv(const char *lnm, bool sys)*/
 char *
-my_getenv(const char *lnm)
+my_getenv(const char *lnm, bool sys)
 {
     static char __my_getenv_eqv[LNM$C_NAMLENGTH+1];
-    char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
-    const char *cp1;
+    char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2, *eqv;
     unsigned long int idx = 0;
     int trnsuccess;
     SV *tmpsv;
@@ -138,44 +224,66 @@ my_getenv(const char *lnm)
       eqv = SvPVX(tmpsv);
     }
     else eqv = __my_getenv_eqv;  /* Assume no interpreter ==> single thread */
-    for (cp1 = lnm, cp2= uplnm; *cp1; cp1++, cp2++) *cp2 = _toupper(*cp1);
-    *cp2 = '\0';
-    if (cp1 - lnm == 7 && !strncmp(uplnm,"DEFAULT",7)) {
+    for (cp1 = (char *) lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
+    if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
       getcwd(eqv,LNM$C_NAMLENGTH);
       return eqv;
     }
     else {
-      if ((cp2 = strchr(uplnm,';')) != NULL) {
-        *cp2 = '\0';
+      if ((cp2 = strchr(lnm,';')) != NULL) {
+        strcpy(uplnm,lnm);
+        uplnm[cp2-lnm] = '\0';
         idx = strtoul(cp2+1,NULL,0);
+        lnm = uplnm;
       }
-      trnsuccess = my_trnlnm(uplnm,eqv,idx);
-      /* If we had a translation index, we're only interested in lnms */
-      if (!trnsuccess && cp2 != NULL) return Nullch;
-      if (trnsuccess) return eqv;
-      else {
-        unsigned long int retsts;
-        struct dsc$descriptor_s symdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
-                                valdsc = {LNM$C_NAMLENGTH,DSC$K_DTYPE_T,
-                                          DSC$K_CLASS_S, eqv};
-        symdsc.dsc$w_length = cp1 - lnm;
-        symdsc.dsc$a_pointer = uplnm;
-        retsts = lib$get_symbol(&symdsc,&valdsc,&(valdsc.dsc$w_length),0);
-        if (retsts == LIB$_INVSYMNAM) return Nullch;
-        if (retsts != LIB$_NOSUCHSYM) {
-          /* We want to return only logical names or CRTL Unix emulations */
-          if (retsts & 1) return Nullch;
-          _ckvmssts(retsts);
-        }
-        /* Try for CRTL emulation of a Unix/POSIX name */
-        else return getenv(uplnm);
-      }
+      if (vmstrnenv(lnm,eqv,idx,
+                    sys ? fildev : NULL,
+#ifdef SECURE_INTERNAL_GETENV
+                    sys ? PERL__TRNENV_SECURE : 0
+#else
+                                                0
+#endif
+                                                 )) return eqv;
+      else return Nullch;
     }
-    return Nullch;
 
 }  /* end of my_getenv() */
 /*}}}*/
 
+
+/*{{{ SV *my_getenv_sv(const char *lnm, bool sys)*/
+SV *
+my_getenv_sv(const char *lnm, bool sys)
+{
+    char buf[LNM$C_NAMLENGTH+1], *cp1, *cp2;
+    unsigned long int len, idx = 0;
+
+    for (cp1 = (char *)lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
+    if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
+      getcwd(buf,LNM$C_NAMLENGTH);
+      return newSVpv(buf,0);
+    }
+    else {
+      if ((cp2 = strchr(lnm,';')) != NULL) {
+        strcpy(buf,lnm);
+        buf[cp2-lnm] = '\0';
+        idx = strtoul(cp2+1,NULL,0);
+        lnm = buf;
+      }
+      if ((len = vmstrnenv(lnm,buf,idx,
+                           sys ? fildev : NULL,
+#ifdef SECURE_INTERNAL_GETENV
+                           sys ? PERL__TRNENV_SECURE : 0
+#else
+                                                       0
+#endif
+                                                         ))) return newSVpv(buf,len);
+      else return &PL_sv_undef;
+    }
+
+}  /* end of my_getenv_sv() */
+/*}}}*/
+
 static void create_mbx(unsigned short int *, struct dsc$descriptor_s *);
 
 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
@@ -189,20 +297,21 @@ prime_env_iter(void)
 {
   dTHR;
   static int primed = 0;
-  HV *envhv = GvHVn(PL_envgv);
-  PerlIO *sholog;
-  char eqv[LNM$C_NAMLENGTH+1],mbxnam[LNM$C_NAMLENGTH+1],*start,*end;
+  HV *seenhv = NULL, *envhv = GvHVn(PL_envgv);
+  char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
   unsigned short int chan;
 #ifndef CLI$M_TRUSTED
 #  define CLI$M_TRUSTED 0x40  /* Missing from VAXC headers */
 #endif
-  unsigned long int flags = CLI$M_NOWAIT | CLI$M_NOCLISYM | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
-  unsigned long int i, retsts, substs = 0, wakect = 0;
-  STRLEN eqvlen;
-  SV *oldrs, *linesv, *eqvsv;
-  $DESCRIPTOR(cmddsc,"Show Logical *"); $DESCRIPTOR(nldsc,"_NLA0:");
-  $DESCRIPTOR(clidsc,"DCL");            $DESCRIPTOR(tabdsc,"DCLTABLES");
-  $DESCRIPTOR(mbxdsc,mbxnam); 
+  unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
+  unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
+  long int i;
+  bool have_sym = FALSE, have_lnm = FALSE;
+  struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
+  $DESCRIPTOR(cmddsc,cmd);    $DESCRIPTOR(nldsc,"_NLA0:");
+  $DESCRIPTOR(clidsc,"DCL");  $DESCRIPTOR(clitabdsc,"DCLTABLES");
+  $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
+  $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam); 
 #ifdef USE_THREADS
   static perl_mutex primenv_mutex;
   MUTEX_INIT(&primenv_mutex);
@@ -214,115 +323,278 @@ prime_env_iter(void)
   /* Perform a dummy fetch as an lval to insure that the hash table is
    * set up.  Otherwise, the hv_store() will turn into a nullop. */
   (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
-  /* Also, set up any "special" keys that the CRTL defines,
-   * either by itself or becasue we were called from a C program
-   * using exec[lv]e() */
-  for (i = 0; environ[i]; i++) { 
-    if (!(start = strchr(environ[i],'='))) {
-      warn("Ill-formed CRTL environ value \"%s\"\n",environ[i]);
-    }
-    else {
-      start++;
-      (void) hv_store(envhv,environ[i],start - environ[i] - 1,newSVpv(start,0),0);
-    }
-  }
 
-  /* Now, go get the logical names */
-  create_mbx(&chan,&mbxdsc);
-  if ((sholog = PerlIO_open(mbxnam,"r")) != Nullfp) {
-    if ((retsts = sys$dassgn(chan)) & 1) {
-      /* Be certain that subprocess is using the CLI and command tables we
-       * expect, and don't pass symbols through so that we insure that
-       * "Show Logical" can't be subverted.
-       */
-      do {
-        retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,0,&substs,
-                           0,&riseandshine,0,0,&clidsc,&tabdsc);
-        flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
-      } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
-    }
+  for (i = 0; env_tables[i]; i++) {
+     if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
+         !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
+     if (!have_lnm && !str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
   }
-  if (sholog == Nullfp || !(retsts & 1)) {
-    if (sholog != Nullfp) PerlIO_close(sholog);
-    MUTEX_UNLOCK(&primenv_mutex);
-    _ckvmssts(sholog == Nullfp ? vaxc$errno : retsts);
+  if (have_sym || have_lnm) {
+    long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
+    _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
+    _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
+    _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
   }
-  /* We use Perl's sv_gets to read from the pipe, since PerlIO_open is
-   * tied to Perl's I/O layer, so it may not return a simple FILE * */
-  oldrs = PL_rs;
-  PL_rs = newSVpv("\n",1);
-  linesv = newSVpv("",0);
-  while (1) {
-    if ((start = sv_gets(linesv,sholog,0)) == Nullch) {
-      PerlIO_close(sholog);
-      SvREFCNT_dec(linesv); SvREFCNT_dec(PL_rs); PL_rs = oldrs;
-      primed = 1;
-      /* Wait for subprocess to clean up (we know subproc won't return 0) */
-      while (substs == 0) { sys$hiber(); wakect++;}
-      if (wakect > 1) sys$wake(0,0);  /* Stole someone else's wake */
-      _ckvmssts(substs);
-      MUTEX_UNLOCK(&primenv_mutex);
-      return;
+
+  for (i--; i >= 0; i--) {
+    if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
+      char *start;
+      int j;
+      for (j = 0; environ[j]; j++) { 
+        if (!(start = strchr(environ[j],'='))) {
+          if (PL_curinterp && PL_dowarn) 
+            warn("Ill-formed CRTL environ value \"%s\"\n",environ[j]);
+        }
+        else {
+          start++;
+          (void) hv_store(envhv,environ[j],start - environ[j] - 1,
+                          newSVpv(start,0),0);
+        }
+      }
+      continue;
     }
-    while (*start != '"' && *start != '=' && *start) start++;
-    if (*start != '"') continue;
-    for (end = ++start; *end && *end != '"'; end++) ;
-    if (*end) *end = '\0';
-    else end = Nullch;
-    if ((eqvlen = my_trnlnm(start,eqv,0)) == 0) {
-      if (vaxc$errno == SS$_NOLOGNAM || vaxc$errno == SS$_IVLOGNAM) {
-        if (PL_dowarn)
-          warn("Ill-formed logical name |%s| in prime_env_iter",start);
+    else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
+             !str$case_blind_compare(&tmpdsc,&clisym)) {
+      strcpy(cmd,"Show Symbol/Global *");
+      cmddsc.dsc$w_length = 20;
+      if (env_tables[i]->dsc$w_length == 12 &&
+          (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
+          !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local  *");
+      flags = defflags | CLI$M_NOLOGNAM;
+    }
+    else {
+      strcpy(cmd,"Show Logical *");
+      if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
+        strcat(cmd," /Table=");
+        strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
+        cmddsc.dsc$w_length = strlen(cmd);
+      }
+      else cmddsc.dsc$w_length = 14;  /* N.B. We test this below */
+      flags = defflags | CLI$M_NOCLISYM;
+    }
+    
+    /* Create a new subprocess to execute each command, to exclude the
+     * remote possibility that someone could subvert a mbx or file used
+     * to write multiple commands to a single subprocess.
+     */
+    do {
+      retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
+                         0,&riseandshine,0,0,&clidsc,&clitabdsc);
+      flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
+      defflags &= ~CLI$M_TRUSTED;
+    } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
+    _ckvmssts(retsts);
+    if (!buf) New(1322,buf,mbxbufsiz + 1,char);
+    if (seenhv) SvREFCNT_dec(seenhv);
+    seenhv = newHV();
+    while (1) {
+      char *cp1, *cp2, *key;
+      unsigned long int sts, iosb[2], retlen, keylen;
+      register U32 hash;
+
+      sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
+      if (sts & 1) sts = iosb[0] & 0xffff;
+      if (sts == SS$_ENDOFFILE) {
+        int wakect = 0;
+        while (substs == 0) { sys$hiber(); wakect++;}
+        if (wakect > 1) sys$wake(0,0);  /* Stole someone else's wake */
+        _ckvmssts(substs);
+        break;
+      }
+      _ckvmssts(sts);
+      retlen = iosb[0] >> 16;      
+      if (!retlen) continue;  /* blank line */
+      buf[retlen] = '\0';
+      if (iosb[1] != subpid) {
+        if (iosb[1]) {
+          croak("Unknown process %x sent message to prime_env_iter: %s",buf);
+        }
+        continue;
+      }
+      if (sts == SS$_BUFFEROVF && PL_curinterp && PL_dowarn)
+        warn("Buffer overflow in prime_env_iter: %s",buf);
+
+      for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
+      if (*cp1 == '(' || /* Logical name table name */
+          *cp1 == '='    /* Next eqv of searchlist  */) continue;
+      if (*cp1 == '"') cp1++;
+      for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
+      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)) {
+        warn("Ill-formed message in prime_env_iter: |%s|",buf);
         continue;
       }
-      else { MUTEX_UNLOCK(&primenv_mutex); _ckvmssts(vaxc$errno); }
+      /* Skip "" surrounding translation */
+      PERL_HASH(hash,key,keylen);
+      hv_store(envhv,key,keylen,newSVpv(cp2+1,cp1 - cp2 - 1),hash);
+      hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
     }
-    else {
-      eqvsv = newSVpv(eqv,eqvlen);
-      hv_store(envhv,start,(end ? end - start : strlen(start)),eqvsv,0);
+    if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
+      /* get the PPFs for this process, not the subprocess */
+      char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
+      char eqv[LNM$C_NAMLENGTH+1];
+      int trnlen, i;
+      for (i = 0; ppfs[i]; i++) {
+        trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
+        hv_store(envhv,ppfs[i],strlen(ppfs[i]),newSVpv(eqv,trnlen),0);
+      }
     }
   }
+  primed = 1;
+  if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
+  if (buf) Safefree(buf);
+  if (seenhv) SvREFCNT_dec(seenhv);
+  MUTEX_UNLOCK(&primenv_mutex);
+  return;
+
 }  /* end of prime_env_iter */
 /*}}}*/
-  
 
-/*{{{ void  my_setenv(char *lnm, char *eqv)*/
-void
-my_setenv(char *lnm,char *eqv)
-/* Define a supervisor-mode logical name in the process table.
- * In the future we'll add tables, attribs, and acmodes,
- * probably through a different call.
+
+/*{{{ int  vmssetenv(char *lnm, char *eqv)*/
+/* Define or delete an element in the same "environment" as
+ * vmstrnenv().  If an element is to be deleted, it's removed from
+ * the first place it's found.  If it's to be set, it's set in the
+ * place designated by the first element of the table vector.
  */
+int
+vmssetenv(char *lnm, char *eqv, struct dsc$descriptor_s **tabvec)
 {
     char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
+    unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
     unsigned long int retsts, usermode = PSL$C_USER;
-    $DESCRIPTOR(tabdsc,"LNM$PROCESS");
     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
-                            eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
-
-    for(cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) *cp2 = _toupper(*cp1);
+                            eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
+                            tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
+    $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
+    $DESCRIPTOR(local,"_LOCAL");
+
+    for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
+      *cp2 = _toupper(*cp1);
+      if (cp1 - lnm > LNM$C_NAMLENGTH) {
+        set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
+        return SS$_IVLOGNAM;
+      }
+    }
     lnmdsc.dsc$w_length = cp1 - lnm;
-
-    if (!eqv || !*eqv) {  /* we're deleting a logical name */
-      retsts = sys$dellnm(&tabdsc,&lnmdsc,&usermode); /* try user mode first */
-      if (retsts == SS$_IVLOGNAM) return;
-      if (retsts != SS$_NOLOGNAM) _ckvmssts(retsts);
-      if (!(retsts & 1)) {
-        retsts = lib$delete_logical(&lnmdsc,&tabdsc); /* then supervisor mode */
-        if (retsts != SS$_NOLOGNAM) _ckvmssts(retsts);
+    if (!tabvec || !*tabvec) tabvec = env_tables;
+
+    if (!eqv || !*eqv) {  /* we're deleting a symbol */
+      for (curtab = 0; tabvec[curtab]; curtab++) {
+        if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
+        int i;
+#ifdef HAS_SETENV
+          for (i = 0; environ[i]; i++) { /* Iff it's an environ elt, reset */
+            if ((cp1 = strchr(environ[i],'=')) && 
+                !strncmp(environ[i],lnm,cp1 - environ[i])) {
+              setenv(lnm,eqv,1);
+              return;
+            }
+          }
+          ivenv = 1; retsts = SS$_NOLOGNAM;
+#else
+          if (PL_curinterp && PL_dowarn)
+            warn("This Perl can't reset CRTL environ elements (%s)",lnm)
+          ivenv = 1; retsts = SS$_NOSUCHPGM;
+#endif
+        }
+        else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
+                 !str$case_blind_compare(&tmpdsc,&clisym)) {
+          unsigned int symtype;
+          if (tabvec[curtab]->dsc$w_length == 12 &&
+              (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
+              !str$case_blind_compare(&tmpdsc,&local)) 
+            symtype = LIB$K_CLI_LOCAL_SYM;
+          else symtype = LIB$K_CLI_GLOBAL_SYM;
+          retsts = lib$delete_symbol(&lnmdsc,&symtype);
+          if (retsts = LIB$_INVSYMNAM) { ivsym = 1; continue; }
+          if (retsts = LIB$_NOSUCHSYM) continue;
+          break;
+        }
+        else if (!ivlnm) {
+          retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
+          if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
+          if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
+          retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
+          if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
+        }
       }
     }
-    else {
-      eqvdsc.dsc$w_length = strlen(eqv);
-      eqvdsc.dsc$a_pointer = eqv;
-
-      _ckvmssts(lib$set_logical(&lnmdsc,&eqvdsc,&tabdsc,0,0));
+    else {  /* we're defining a value */
+      if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
+#ifdef HAS_SETENV
+        return setenv(lnm,eqv,1) ? vaxc$errno : SS$_NORMAL;
+#else
+        if (PL_curinterp && PL_dowarn)
+          warn("This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv)
+        retsts = SS$_NOSUCHPGM;
+#endif
+      }
+      else {
+        eqvdsc.dsc$a_pointer = eqv;
+        eqvdsc.dsc$w_length  = strlen(eqv);
+        if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
+            !str$case_blind_compare(&tmpdsc,&clisym)) {
+          unsigned int symtype;
+          if (tabvec[0]->dsc$w_length == 12 &&
+              (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
+               !str$case_blind_compare(&tmpdsc,&local)) 
+            symtype = LIB$K_CLI_LOCAL_SYM;
+          else symtype = LIB$K_CLI_GLOBAL_SYM;
+          retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
+        }
+        else retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
+      }
+    }
+    if (!(retsts & 1)) {
+      switch (retsts) {
+        case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
+        case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
+          set_errno(EVMSERR); break;
+        case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM: 
+        case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
+          set_errno(EINVAL); break;
+        case SS$_NOPRIV:
+          set_errno(EACCES);
+        default:
+          _ckvmssts(retsts);
+          set_errno(EVMSERR);
+       }
+       set_vaxc_errno(retsts);
+       return (int) retsts || 44; /* retsts should never be 0, but just in case */
     }
+    else if (retsts != SS$_NORMAL) {  /* alternate success codes */
+      set_errno(0); set_vaxc_errno(retsts);
+      return 0;
+    }
+
+}  /* end of vmssetenv() */
+/*}}}*/
 
-}  /* end of my_setenv() */
+/*{{{ void  my_setenv(char *lnm, char *eqv)*/
+/* This has to be a function since there's a prototype for it in proto.h */
+void
+my_setenv(char *lnm,char *eqv)
+{
+  if (lnm && *lnm && strlen(lnm) == 7) {
+    char uplnm[8];
+    int i;
+    for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
+    if (!strcmp(uplnm,"DEFAULT")) {
+      if (eqv && *eqv) chdir(eqv);
+      return;
+    }
+  }
+  (void) vmssetenv(lnm,eqv,NULL);
+}
 /*}}}*/
 
 
+
 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
 /* my_crypt - VMS password hashing
  * my_crypt() provides an interface compatible with the Unix crypt()
@@ -1530,7 +1802,7 @@ static char *do_tounixspec(char *spec, char *buf, int ts)
         while (*cp3 != ':' && *cp3) cp3++;
         *(cp3++) = '\0';
         if (strchr(cp3,']') != NULL) break;
-      } while (((cp3 = my_getenv(tmp)) != NULL) && strcpy(tmp,cp3));
+      } while (vmstrnenv(tmp,tmp,0,fildev,0));
       if (ts && !buf &&
           ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
         retlen = devlen + dirlen;
@@ -2113,14 +2385,18 @@ int isunix = 0;
 char *had_version;
 char *had_device;
 int had_directory;
-char *devdir;
+char *devdir,*cp;
 char vmsspec[NAM$C_MAXRSS+1];
 $DESCRIPTOR(filespec, "");
 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
 $DESCRIPTOR(resultspec, "");
 unsigned long int zero = 0, sts;
 
-    if (strcspn(item, "*%") == strlen(item) || strchr(item,' ') != NULL)
+    for (cp = item; *cp; cp++) {
+       if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
+       if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
+    }
+    if (!*cp || isspace(*cp))
        {
        add_item(head, tail, item, count);
        return;
@@ -2331,9 +2607,12 @@ unsigned long int flags = 17, one = 1, retsts;
 void
 vms_image_init(int *argcp, char ***argvp)
 {
-  unsigned long int *mask, iosb[2], i, rlst[128], rsz, add_taint = FALSE;
+  char eqv[LNM$C_NAMLENGTH+1] = "";
+  unsigned int len, tabct = 8, tabidx = 0;
+  unsigned long int *mask, iosb[2], i, rlst[128], rsz;
   unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
   unsigned short int dummy, rlen;
+  struct dsc$descriptor_s **tabvec;
   struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
                                  {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
                                  { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
@@ -2344,12 +2623,12 @@ vms_image_init(int *argcp, char ***argvp)
   for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
     if (iprv[i]) {           /* Running image installed with privs? */
       _ckvmssts(sys$setprv(0,iprv,0,NULL));       /* Turn 'em off. */
-      add_taint = TRUE;
+      will_taint = TRUE;
       break;
     }
   }
   /* Rights identifiers might trigger tainting as well. */
-  if (!add_taint && (rlen || rsz)) {
+  if (!will_taint && (rlen || rsz)) {
     while (rlen < rsz) {
       /* We didn't get all the identifiers on the first pass.  Allocate a
        * buffer much larger than $GETJPI wants (rsz is size in bytes that
@@ -2368,7 +2647,7 @@ vms_image_init(int *argcp, char ***argvp)
      */
     for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
       if (mask[i] & KGB$M_SUBSYSTEM) {
-        add_taint = TRUE;
+        will_taint = TRUE;
         break;
       }
     }
@@ -2378,7 +2657,7 @@ vms_image_init(int *argcp, char ***argvp)
    * since its tainting flag may be part of the PL_curinterp struct, which
    * hasn't been allocated when vms_image_init() is called.
    */
-  if (add_taint) {
+  if (will_taint) {
     char ***newap;
     New(1320,newap,*argcp+2,char **);
     newap[0] = argvp[0];
@@ -2389,6 +2668,37 @@ vms_image_init(int *argcp, char ***argvp)
      */
     *argcp++; argvp = newap;
   }
+  else {  /* Did user explicitly request tainting? */
+    int i;
+    char *cp, **av = *argvp;
+    for (i = 1; i < *argcp; i++) {
+      if (*av[i] != '-') break;
+      for (cp = av[i]+1; *cp; cp++) {
+        if (*cp == 'T') { will_taint = 1; break; }
+        else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
+                  strchr("DFIiMmx",*cp)) break;
+      }
+      if (will_taint) break;
+    }
+  }
+
+  for (tabidx = 0;
+       len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
+       tabidx++) {
+    if (!tabidx) New(1321,tabvec,tabct,struct dsc$descriptor_s *);
+    else if (tabidx >= tabct) {
+      tabct += 8;
+      Renew(tabvec,tabct,struct dsc$descriptor_s *);
+    }
+    New(1322,tabvec[tabidx],1,struct dsc$descriptor_s);
+    tabvec[tabidx]->dsc$w_length  = 0;
+    tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
+    tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_D;
+    tabvec[tabidx]->dsc$a_pointer = NULL;
+    _ckvmssts(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
+  }
+  if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
+
   getredirection(argcp,argvp);
 #if defined(USE_THREADS) && defined(__DECC)
   {
@@ -2727,7 +3037,8 @@ readdir(DIR *dd)
     dd->count++;
     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
     buff[sizeof buff - 1] = '\0';
-    for (p = buff; !isspace(*p); p++) *p = _tolower(*p);
+    for (p = buff; *p; p++) *p = _tolower(*p);
+    while (--p >= buff) if (!isspace(*p)) break;  /* Do we really need this? */
     *p = '\0';
 
     /* Skip any directory component and just copy the name. */
@@ -3547,10 +3858,10 @@ time_t my_time(time_t *timep)
 
     gmtime_emulation_type++;
     if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
-      char *off;
+      char off[LNM$C_NAMLENGTH+1];;
 
       gmtime_emulation_type++;
-      if ((off = my_getenv("SYS$TIMEZONE_DIFFERENTIAL")) == NULL) {
+      if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
         gmtime_emulation_type++;
         warn("no UTC offset information; assuming local time is UTC");
       }
@@ -4153,49 +4464,6 @@ flex_stat(char *fspec, Stat_t *statbufp)
 }  /* end of flex_stat() */
 /*}}}*/
 
-/* Insures that no carriage-control translation will be done on a file. */
-/*{{{FILE *my_binmode(FILE *fp, char iotype)*/
-FILE *
-my_binmode(FILE *fp, char iotype)
-{
-    char filespec[NAM$C_MAXRSS], *acmode, *s, *colon, *dirend = Nullch;
-    int ret = 0, saverrno = errno, savevmserrno = vaxc$errno;
-    fpos_t pos;
-
-    if (!fgetname(fp,filespec,1)) return NULL;
-    for (s = filespec; *s; s++) {
-      if (*s == ':') colon = s;
-      else if (*s == ']' || *s == '>') dirend = s;
-    }
-    /* Looks like a tmpfile, which will go away if reopened */
-    if (s == dirend + 3) return fp;
-    /* If we've got a non-file-structured device, clip off the trailing
-     * junk, and don't lose sleep if we can't get a stream position.  */
-    if (dirend == Nullch) *(colon+1) = '\0'; 
-    if (iotype != '-'&& (ret = fgetpos(fp, &pos)) == -1 && dirend) return NULL;
-    switch (iotype) {
-      case '<': case 'r':           acmode = "rb";                      break;
-      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 's':          acmode = "rb+";                     break;
-      case '-':                     acmode = fileno(fp) ? "ab" : "rb";  break;
-      /* iotype'll be null for the SYS$INPUT:/SYS$OUTPUT:/SYS$ERROR: files */
-      /* since we didn't really open them and can't really */
-      /* reopen them */
-      case 0:                       return NULL;                        break;
-      default:
-        warn("Unrecognized iotype %x for %s in my_binmode",iotype, filespec);
-        acmode = "rb+";
-    }
-    if (freopen(filespec,acmode,fp) == NULL) return NULL;
-    if (iotype != '-' && ret != -1 && fsetpos(fp,&pos) == -1) return NULL;
-    if (ret == -1) { set_errno(saverrno); set_vaxc_errno(savevmserrno); }
-    return fp;
-}  /* end of my_binmode() */
-/*}}}*/
-
 
 /*{{{char *my_getlogin()*/
 /* VMS cuserid == Unix getlogin, except calling sequence */
@@ -4608,10 +4876,6 @@ init_os_extras()
   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
 
-#ifdef PRIME_ENV_AT_STARTUP
-  prime_env_iter();
-#endif
-
   return;
 }