diff options
| author | John Malmberg <wb8tyw@gmail.com> | 2009-02-09 08:50:29 -0600 |
|---|---|---|
| committer | David Mitchell <davem@iabyn.com> | 2009-04-14 21:02:25 +0100 |
| commit | 96f7d43c0ca33a841d89626b735b672a9e2f2018 (patch) | |
| tree | 7de21a31288616a35b2fbb244d9e13fd2ebe8378 /vms | |
| parent | ce90b8a70b6d2e93d9c8776007366b6228c4239a (diff) | |
| download | perl-96f7d43c0ca33a841d89626b735b672a9e2f2018.tar.gz | |
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>
(cherry picked from commit bf8d1304d513f823735f8a2983c62ad285a21568)
Diffstat (limited to 'vms')
| -rw-r--r-- | vms/vms.c | 30 | ||||
| -rw-r--r-- | vms/vmsish.h | 3 |
2 files changed, 32 insertions, 1 deletions
@@ -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 ac7dc56636..3c5b823217 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 |