VMS patch (from Peter Prymmer)

[p5sagit/p5-mst-13.2.git] / vms / vms.c

diff --git a/vms/vms.c b/vms/vms.c
index bf2726f..fac9243 100644 (file)
--- a/vms/vms.c
+++ b/vms/vms.c
@@ -2,8 +2,8 @@
  *
  * VMS-specific routines for perl5
  *
- * Last revised: 24-Apr-1999 by Charles Bailey  bailey@newman.upenn.edu
- * Version: 5.5.58
+ * Last revised: 15-Aug-1999 by Charles Bailey  bailey@newman.upenn.edu
+ * Version: 5.5.60
  */
 
 #include <acedef.h>
@@ -91,6 +91,10 @@ 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 */
 
+/* True if we shouldn't treat barewords as logicals during directory */
+/* munching */ 
+static int no_translate_barewords;
+
 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
 int
 vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
@@ -1721,7 +1725,8 @@ static char *do_pathify_dirspec(char *dir,char *buf, int ts)
     if (*dir) strcpy(trndir,dir);
     else getcwd(trndir,sizeof trndir - 1);
 
-    while (!strpbrk(trndir,"/]:>") && my_trnlnm(trndir,trndir,0)) {
+    while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
+          && my_trnlnm(trndir,trndir,0)) {
       STRLEN trnlen = strlen(trndir);
 
       /* Trap simple rooted lnms, and return lnm:[000000] */
@@ -3966,6 +3971,27 @@ static long int utc_offset_secs;
 #  define RTL_USES_UTC 1
 #endif
 
+/*
+ * DEC C previous to 6.0 corrupts the behavior of the /prefix
+ * qualifier with the extern prefix pragma.  This provisional
+ * hack circumvents this prefix pragma problem in previous 
+ * precompilers.
+ */
+#if defined(__VMS_VER) && __VMS_VER >= 70000000 
+#  if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
+#    pragma __extern_prefix save
+#    pragma __extern_prefix ""  /* set to empty to prevent prefixing */
+#    define gmtime decc$__utctz_gmtime
+#    define localtime decc$__utctz_localtime
+#    define time decc$__utc_time
+#    pragma __extern_prefix restore
+
+     struct tm *gmtime(), *localtime();   
+
+#  endif
+#endif
+
+
 static time_t toutc_dst(time_t loc) {
   struct tm *rsltmp;
 
@@ -3974,7 +4000,7 @@ static time_t toutc_dst(time_t loc) {
   if (rsltmp->tm_isdst) loc -= 3600;
   return loc;
 }
-#define _toutc(secs)  ((secs) == -1 ? -1 : \
+#define _toutc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
        ((gmtime_emulation_type || my_time(NULL)), \
        (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
        ((secs) - utc_offset_secs))))
@@ -3987,7 +4013,7 @@ static time_t toloc_dst(time_t utc) {
   if (rsltmp->tm_isdst) utc += 3600;
   return utc;
 }
-#define _toloc(secs)  ((secs) == -1 ? -1 : \
+#define _toloc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
        ((gmtime_emulation_type || my_time(NULL)), \
        (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
        ((secs) + utc_offset_secs))))
@@ -4396,9 +4422,8 @@ is_null_device(name)
 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
  * subset of the applicable information.
  */
-/*{{{I32 cando(I32 bit, I32 effective, struct stat *statbufp)*/
-I32
-Perl_cando(pTHX_ I32 bit, I32 effective, Stat_t *statbufp)
+bool
+Perl_cando(pTHX_ Mode_t bit, Uid_t effective, Stat_t *statbufp)
 {
   if (statbufp == &PL_statcache) return cando_by_name(bit,effective,namecache);
   else {
@@ -4431,9 +4456,9 @@ Perl_cando(pTHX_ I32 bit, I32 effective, Stat_t *statbufp)
 /*}}}*/
 
 
-/*{{{I32 cando_by_name(I32 bit, I32 effective, char *fname)*/
+/*{{{I32 cando_by_name(I32 bit, Uid_t effective, char *fname)*/
 I32
-cando_by_name(I32 bit, I32 effective, char *fname)
+cando_by_name(I32 bit, Uid_t effective, char *fname)
 {
   static char usrname[L_cuserid];
   static struct dsc$descriptor_s usrdsc =
@@ -5030,6 +5055,12 @@ init_os_extras()
 {
   char* file = __FILE__;
   dTHX;
+  char temp_buff[512];
+  if (my_trnlnm("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", temp_buff, 0)) {
+    no_translate_barewords = TRUE;
+  } else {
+    no_translate_barewords = FALSE;
+  }
 
   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");