X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=vms%2Fvms.c;h=27214f7ad63d390ef50567c9f7d6156e2d742aa7;hb=5c4d031a9f33835f94f9c1d101c900979c2aca6e;hp=ec8ecfdbc22bb5138d7db0dd7784b644be6b1c04;hpb=858aded60ee6734d89d26bf30a53506b3f77e784;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/vms/vms.c b/vms/vms.c
index ec8ecfd..27214f7 100644
--- a/vms/vms.c
+++ b/vms/vms.c
@@ -419,7 +419,7 @@ int utf8_flag;
 	    }
 	}
 
-	/* High bit set, but not a unicode character! */
+	/* High bit set, but not a Unicode character! */
 
 	/* Non printing DECMCS or ISO Latin-1 character? */
 	if (*inspec <= 0x9F) {
@@ -521,6 +521,16 @@ int utf8_flag;
     case ']':
     case '%':
     case '^':
+        /* Don't escape again if following character is 
+         * already something we escape.
+         */
+        if (strchr(".~!#&\'`()+@{},;[]%^=_", *(inspec+1))) {
+	    *outspec = *inspec;
+	    *output_cnt = 1;
+	    return 1;
+	    break;
+        }
+        /* But otherwise fall through and escape it. */
     case '=':
 	/* Assume that this is to be escaped */
 	outspec[0] = '^';
@@ -564,17 +574,26 @@ int scnt;
     if (*inspec == '^') {
 	inspec++;
 	switch (*inspec) {
+        /* Spaces and non-trailing dots should just be passed through, 
+         * but eat the escape character.
+         */
 	case '.':
-	    /* Non trailing dots should just be passed through, but eat the escape */
 	    *outspec = *inspec;
-	    count++;
+	    count += 2;
+	    (*output_cnt)++;
 	    break;
 	case '_': /* space */
 	    *outspec = ' ';
-	    inspec++;
-	    count++;
+	    count += 2;
 	    (*output_cnt)++;
 	    break;
+	case '^':
+            /* Hmm.  Better leave the escape escaped. */
+            outspec[0] = '^';
+            outspec[1] = '^';
+	    count += 2;
+	    (*output_cnt) += 2;
+	    break;
 	case 'U': /* Unicode - FIX-ME this is wrong. */
 	    inspec++;
 	    count++;
@@ -2823,14 +2842,20 @@ pipe_exit_routine(pTHX)
     unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
     int sts, did_stuff, need_eof, j;
 
-    /* 
-        flush any pending i/o
+   /* 
+    * Flush any pending i/o, but since we are in process run-down, be
+    * careful about referencing PerlIO structures that may already have
+    * been deallocated.  We may not even have an interpreter anymore.
     */
     info = open_pipes;
     while (info) {
         if (info->fp) {
-           if (!info->useFILE) 
-               PerlIO_flush(info->fp);   /* first, flush data */
+           if (!info->useFILE
+#if defined(USE_ITHREADS)
+             && my_perl
+#endif
+             && PL_perlio_fd_refcnt) 
+               PerlIO_flush(info->fp);
            else 
                fflush((FILE *)info->fp);
         }
@@ -4377,8 +4402,12 @@ I32 Perl_my_pclose(pTHX_ PerlIO *fp)
      *  the first EOF closing the pipe (and DASSGN'ing the channel)...
      */
      if (info->fp) {
-        if (!info->useFILE) 
-            PerlIO_flush(info->fp);   /* first, flush data */
+        if (!info->useFILE
+#if defined(USE_ITHREADS)
+          && my_perl
+#endif
+          && PL_perlio_fd_refcnt) 
+            PerlIO_flush(info->fp);
         else 
             fflush((FILE *)info->fp);
     }
@@ -4400,7 +4429,11 @@ I32 Perl_my_pclose(pTHX_ PerlIO *fp)
                            0, 0, 0, 0, 0, 0));
     _ckvmssts(sys$setast(1));
     if (info->fp) {
-     if (!info->useFILE) 
+     if (!info->useFILE
+#if defined(USE_ITHREADS)
+         && my_perl
+#endif
+         && PL_perlio_fd_refcnt) 
         PerlIO_close(info->fp);
      else 
         fclose((FILE *)info->fp);
@@ -6077,7 +6110,7 @@ static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * u
     }
     if ((*cp2 == '^')) {
 	/* EFS file escape, pass the next character as is */
-	/* Fix me: HEX encoding for UNICODE not implemented */
+	/* Fix me: HEX encoding for Unicode not implemented */
 	cp2++;
     }
     else if ( *cp2 == '.') {
@@ -6092,7 +6125,7 @@ static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * u
   for (; cp2 <= dirend; cp2++) {
     if ((*cp2 == '^')) {
 	/* EFS file escape, pass the next character as is */
-	/* Fix me: HEX encoding for UNICODE not implemented */
+	/* Fix me: HEX encoding for Unicode not implemented */
 	*(cp1++) = *(++cp2);
         /* An escaped dot stays as is -- don't convert to slash */
         if (*cp2 == '.') cp2++;
@@ -7545,6 +7578,14 @@ static char *mp_do_tovmsspec
     case '#':
     case '%':
     case '^':
+        /* Don't escape again if following character is 
+         * already something we escape.
+         */
+        if (strchr("\"~`!#%^&()=+\'@[]{}:\\|<>_.", *(cp2+1))) {
+	    *(cp1++) = *(cp2++);
+	    break;
+        }
+        /* But otherwise fall through and escape it. */
     case '&':
     case '(':
     case ')':
@@ -8745,9 +8786,6 @@ Perl_opendir(pTHX_ const char *name)
     DIR *dd;
     char *dir;
     Stat_t sb;
-    int unix_flag = 0;
-
-    unix_flag = is_unix_filespec(name);
 
     Newx(dir, VMS_MAXRSS, char);
     if (do_tovmspath(name,dir,0,NULL) == NULL) {
@@ -8778,8 +8816,12 @@ Perl_opendir(pTHX_ const char *name)
     dd->context = 0;
     dd->count = 0;
     dd->flags = 0;
-    if (unix_flag)
-	dd->flags = PERL_VMSDIR_M_UNIXSPECS;
+    /* By saying we always want the result of readdir() in unix format, we 
+     * are really saying we want all the escapes removed.  Otherwise the caller,
+     * having no way to know whether it's already in VMS format, might send it
+     * through tovmsspec again, thus double escaping.
+     */
+    dd->flags = PERL_VMSDIR_M_UNIXSPECS;
     dd->pat.dsc$a_pointer = dd->pattern;
     dd->pat.dsc$w_length = strlen(dd->pattern);
     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
@@ -8979,7 +9021,7 @@ Perl_readdir(pTHX_ DIR *dd)
     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
 
 	/* Translate the encoded characters. */
-	/* Fixme: unicode handling could result in embedded 0 characters */
+	/* Fixme: Unicode handling could result in embedded 0 characters */
 	if (strchr(dd->entry.d_name, '^') != NULL) {
 	    char new_name[256];
 	    char * q;
@@ -8993,7 +9035,7 @@ Perl_readdir(pTHX_ DIR *dd)
 		/* fix-me */
 		/* if outchars_added > 1, then this is a wide file specification */
 		/* Wide file specifications need to be passed in Perl */
-		/* counted strings apparently with a unicode flag */
+		/* counted strings apparently with a Unicode flag */
 	    }
 	    *q = 0;
 	    strcpy(dd->entry.d_name, new_name);
@@ -12118,7 +12160,8 @@ Perl_vms_start_glob
 
 #ifdef HAS_SYMLINK
 static char *
-mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec, const int *utf8_fl);
+mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec,
+		   const int *utf8_fl);
 
 void
 vms_realpath_fromperl(pTHX_ CV *cv)
@@ -12231,7 +12274,8 @@ char *realpath(const char *file_name, char * resolved_name, ...);
  * on OpenVMS.
  */
 static char *
-mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
+mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf,
+		   const int *utf8_fl)
 {
     return realpath(filespec, outbuf);
 }
@@ -12366,7 +12410,7 @@ static int set_features
 	 vms_debug_on_exception = 0;
     }
 
-    /* Create VTF-7 filenames from UNICODE instead of UTF-8 */
+    /* Create VTF-7 filenames from Unicode instead of UTF-8 */
     vms_vtf7_filenames = 0;
     status = sys_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
     if ($VMS_STATUS_SUCCESS(status)) {