From: John Malmberg <wb8tyw@gmail.com>
Date: Mon, 9 Feb 2009 14:50:29 +0000 (-0600)
Subject: vms fgetname wrapper.
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=bf8d1304d513f823735f8a2983c62ad285a21568;p=p5sagit%2Fp5-mst-13.2.git

vms fgetname wrapper.

fgetname() does not always return the correct Unix format file
specification when the decc$filename_unix_report feature is active and
is ignoring the decc$readdir_dropdot_notype setting.

So always have fgetname() return a VMS format file specification.  When
decc$filename_unix_report is active, use unixify() to convert it to the
expected syntax.

This bug shows up doing rename tests on an open file that has no file
extension with decc$filename_unix_report and decc$readdir_dropdot_notype
both active.

Message-ID: <499042B5.4030803@gmail.com>
---

diff --git a/vms/vms.c b/vms/vms.c
index 7d208ba..b970bf7 100644
--- a/vms/vms.c
+++ b/vms/vms.c
@@ -9397,7 +9397,7 @@ mp_getredirection(pTHX_ int *ac, char ***av)
 	/* Input from a pipe, reopen it in binary mode to disable	*/
 	/* carriage control processing.	 				*/
 
-	fgetname(stdin, mbxname);
+	fgetname(stdin, mbxname, 1);
 	mbxnam.dsc$a_pointer = mbxname;
 	mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);	
 	lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
@@ -11328,6 +11328,34 @@ Perl_my_flush(pTHX_ FILE *fp)
 }
 /*}}}*/
 
+/* fgetname() is not returning the correct file specifications when
+ * decc_filename_unix_report mode is active.  So we have to have it
+ * aways return filenames in VMS mode and convert it ourselves.
+ */
+
+/*{{{ char * my_fgetname(FILE *fp, buf)*/
+char *
+Perl_my_fgetname(FILE *fp, char * buf) {
+    char * retname;
+    char * vms_name;
+
+    retname = fgetname(fp, buf, 1);
+
+    /* If we are in VMS mode, then we are done */
+    if (!decc_filename_unix_report || (retname == NULL)) {
+       return retname;
+    }
+
+    /* Convert this to Unix format */
+    vms_name = PerlMem_malloc(VMS_MAXRSS + 1);
+    strcpy(vms_name, retname);
+    retname = int_tounixspec(vms_name, buf, NULL);
+    PerlMem_free(vms_name);
+
+    return retname;
+}
+/*}}}*/
+
 /*
  * Here are replacements for the following Unix routines in the VMS environment:
  *      getpwuid    Get information for a particular UIC or UID
diff --git a/vms/vmsish.h b/vms/vmsish.h
index ac7dc56..3c5b823 100644
--- a/vms/vmsish.h
+++ b/vms/vmsish.h
@@ -133,6 +133,7 @@
 #define vms_image_init	Perl_vms_image_init
 #define my_tmpfile		Perl_my_tmpfile
 #define vmstrnenv           	Perl_vmstrnenv            
+#define my_fgetname(a, b)	Perl_my_fgetname(a, b)
 #if !defined(PERL_IMPLICIT_CONTEXT)
 #define my_getenv_len		Perl_my_getenv_len
 #define vmssetenv		Perl_vmssetenv
@@ -520,6 +521,7 @@ struct interp_intern {
 #  define fwrite my_fwrite     /* for PerlSIO_fwrite */
 #  define fdopen my_fdopen
 #  define fclose my_fclose
+#  define fgetname(a, b) my_fgetname(a, b)
 #ifdef HAS_SYMLINK
 #  define symlink my_symlink
 #endif
@@ -973,6 +975,7 @@ bool	Perl_vms_do_exec (pTHX_ const char *);
 FILE *  my_fdopen (int, const char *);
 int     my_fclose (FILE *);
 int     my_fwrite (const void *, size_t, size_t, FILE *);
+char *  Perl_my_fgetname (FILE *fp, char *buf);
 #ifdef HAS_SYMLINK
 int     Perl_my_symlink(pTHX_ const char *path1, const char *path2);
 #endif