symlink() wrapper for VMS that prevents the creation of symlinks

with zero-length names.  The standards disallow that and the test
suite gets indigestion.

p4raw-id: //depot/perl@32037

2 files changed, 26 insertions, 2 deletions

diff --git a/vms/vms.c b/vms/vms.c
index 40e80a2f7d..01fb23534a 100644
--- a/vms/vms.c
+++ b/vms/vms.c
@@ -12721,7 +12721,22 @@ vms_realpath_fromperl(pTHX_ CV *cv)
     Safefree(rslt_spec);
   XSRETURN(1);
 }
-#endif
+
+/*
+ * A thin wrapper around decc$symlink to make sure we follow the 
+ * standard and do not create a symlink with a zero-length name.
+ */
+/*{{{ int my_symlink(const char *path1, const char *path2)*/
+int my_symlink(const char *path1, const char *path2) {
+  if (!path2 || !*path2) {
+    SETERRNO(ENOENT, SS$_NOSUCHFILE);
+    return -1;
+  }
+  return symlink(path1, path2);
+}
+/*}}}*/
+
+#endif /* HAS_SYMLINK */
 
 #if __CRTL_VER >= 70301000 && !defined(__VAX)
 int do_vms_case_tolerant(void);
diff --git a/vms/vmsish.h b/vms/vmsish.h
index a0a52a3f86..178934e1bb 100644
--- a/vms/vmsish.h
+++ b/vms/vmsish.h
@@ -274,6 +274,9 @@
 #define my_getpwent()		Perl_my_getpwent(aTHX)
 #define my_endpwent()		Perl_my_endpwent(aTHX)
 #define my_getlogin		Perl_my_getlogin
+#ifdef HAS_SYMLINK
+#  define my_symlink		Perl_my_symlink
+#endif
 #define init_os_extras		Perl_init_os_extras
 #define vms_realpath(a, b, c)	Perl_vms_realpath(aTHX_ a,b,c)
 #define vms_case_tolerant(a)	Perl_vms_case_tolerant(a)
@@ -507,6 +510,9 @@ struct interp_intern {
 #  define fwrite my_fwrite     /* for PerlSIO_fwrite */
 #  define fdopen my_fdopen
 #  define fclose my_fclose
+#ifdef HAS_SYMLINK
+#  define symlink my_symlink
+#endif
 #endif
 
 
@@ -958,7 +964,10 @@ unsigned long int	Perl_do_aspawn (pTHX_ void *, void **, void **);
 unsigned long int	Perl_do_spawn (pTHX_ const char *);
 FILE *  my_fdopen (int, const char *);
 int     my_fclose (FILE *);
-int    my_fwrite (const void *, size_t, size_t, FILE *);
+int     my_fwrite (const void *, size_t, size_t, FILE *);
+#ifdef HAS_SYMLINK
+int     my_symlink(const char *path1, const char *path2);
+#endif
 int	Perl_my_flush (pTHX_ FILE *);
 struct passwd *	Perl_my_getpwnam (pTHX_ const char *name);
 struct passwd *	Perl_my_getpwuid (pTHX_ Uid_t uid);