From 3081de53d1d677a5164f5cf9310d6c82569a481c Mon Sep 17 00:00:00 2001
From: John Malmberg <wb8tyw@qsl.net>
Date: Wed, 14 May 2014 22:23:10 -0500
Subject: [PATCH] Fix archive support for VMS take 2

Bug 41758: Fix archive support for VMS.

* ar.c: (struct ar_glob_state): Add member to save suffix for VMS.
  (ar_glob_match): Use saved suffix on VMS.
  (ar_glob): Save suffix for VMS.
* arcan.c: VMS variable names now match usage.  Use VMS supplied
  constants and macros for VMS specific code.  Comments and code
  also now match what the Unix specific methods are doing.
  Quick fix to build as standalone image with TEST macro set, this
  was not a VMS specific issue.
  (VMS_get_member_info): Handles saved arg parameter correctly,
  Use some constants to better document the paramters including
  the ones currently unused by GNU make.
  Remove #if __DECC test, GCC should use the same RTL as DECC
  for VMS 5.5-2 and later, and build procedure will not support
  that old of a version.
  (ar_scan VMS variant): Convert library path to VMS format,
  Correct return codes.
  (ar_name_equal): Ignore vms suffix on compare.
* default.c: (char default_suffixes): VMS should have almost all Unix
  suffixes + VMS ones.
  (struct pspec default_pattern_rules): Fix VMS archive rules to
  create library if not existing.
  (struct pspec default_terminal_rules): Fix RCCS VMS specific rules.
  (char *default_suffix_rules): VMS should have almost all Unix suffixes +
  VMS ones.
  (char *default_variables): VMS missing .LIBPATTERNS.
* tests/scripts/features/archives: Fix tests to use VMS rules and
  answers when running on VMS and using DCL as a shell.
* tests/scripts/features/vpath3: Fix epected answer on test when
  run on VMS.
* tests/scripts/vms/library: (New) Test the VMS library rules that
  are not tested by existing tests.
---
 ar.c                            |   55 ++++++++-
 arscan.c                        |  265 +++++++++++++++++++++++++++------------
 default.c                       |   62 ++++++++--
 tests/scripts/features/archives |  146 ++++++++++++++++++---
 tests/scripts/features/vpath3   |   14 ++-
 tests/scripts/vms/library       |   81 ++++++++++++
 6 files changed, 506 insertions(+), 117 deletions(-)
 create mode 100644 tests/scripts/vms/library

diff --git a/ar.c b/ar.c
index 5d2f000..79e49f6 100644
--- a/ar.c
+++ b/ar.c
@@ -176,6 +176,9 @@ struct ar_glob_state
   {
     const char *arname;
     const char *pattern;
+#ifdef VMS
+    char *suffix; /* VMS modules do not have suffixes, so fake */
+#endif
     unsigned int size;
     struct nameseq *chain;
     unsigned int n;
@@ -196,7 +199,22 @@ ar_glob_match (int desc UNUSED, const char *mem, int truncated UNUSED,
     {
       /* We have a match.  Add it to the chain.  */
       struct nameseq *new = xcalloc (state->size);
-      new->name = strcache_add (concat (4, state->arname, "(", mem, ")"));
+#ifdef VMS
+      if (state->suffix)
+        {
+           /* On VMS, the library module names do not have suffixes.
+            * The source module suffix is saved and added on to make
+            * it look like a suffix was present os that compares will
+            * work correctly.
+            */
+           new->name = strcache_add (concat (5,
+                                             state->arname, "(",
+                                             mem, state->suffix, ")"));
+        }
+      else
+#endif
+        new->name = strcache_add (concat (4, state->arname, "(", mem, ")"));
+
       new->next = state->chain;
       state->chain = new;
       ++state->n;
@@ -248,7 +266,9 @@ ar_glob (const char *arname, const char *member_pattern, unsigned int size)
   struct nameseq *n;
   const char **names;
   unsigned int i;
-
+#ifdef VMS
+  char * vms_member_pattern;
+#endif
   if (! glob_pattern_p (member_pattern, 1))
     return 0;
 
@@ -256,11 +276,42 @@ ar_glob (const char *arname, const char *member_pattern, unsigned int size)
      ar_glob_match will accumulate them in STATE.chain.  */
   state.arname = arname;
   state.pattern = member_pattern;
+#ifdef VMS
+  {
+    /* For VMS the library member has no suffix.
+     * Save the one in the pattern to be added back in if the
+     * module name matches.
+     */
+    char * lastdot;
+    vms_member_pattern = strdup (member_pattern);
+    /* Find . suffix */
+    lastdot = strrchr (vms_member_pattern, '.');
+    state.suffix = lastdot;
+    if (lastdot)
+      {
+        /* The VMS library modules do not have suffixes.
+         * The pattern must also not have suffixes.
+         */
+        state.suffix = strdup (lastdot);
+        *lastdot = 0;
+      }
+    state.pattern = vms_member_pattern;
+  }
+#endif
   state.size = size;
   state.chain = 0;
   state.n = 0;
   ar_scan (arname, ar_glob_match, &state);
 
+#ifdef VMS
+  /* Clean up the VMS specific varialbles */
+  free (vms_member_pattern);
+  if (state.suffix)
+    {
+      free(state.suffix);
+    }
+#endif
+
   if (state.chain == 0)
     return 0;
 
diff --git a/arscan.c b/arscan.c
index e49137b..3951200 100644
--- a/arscan.c
+++ b/arscan.c
@@ -16,6 +16,11 @@ this program.  If not, see <http://www.gnu.org/licenses/>.  */
 
 #include "makeint.h"
 
+#ifdef TEST
+/* Hack, the real error() routine eventually pulls in die from main.c */
+#define error(a, b, c, d)
+#endif
+
 #ifdef HAVE_FCNTL_H
 #include <fcntl.h>
 #else
@@ -30,39 +35,97 @@ this program.  If not, see <http://www.gnu.org/licenses/>.  */
 #include <credef.h>
 #include <descrip.h>
 #include <ctype.h>
+#include <ssdef.h>
+#include <stsdef.h>
+#include <lbrdef.h>
+#define LIB_W_HDRTRUNC 2525184
+#include <rmsdef.h>
+
 #if __DECC
 #include <unixlib.h>
 #include <lbr$routines.h>
 #endif
+const char *
+vmsify (const char *name, int type);
 
-static void *VMS_lib_idx;
+/* Time conversion from VMS to Unix */
+static time_t vms_time_to_unix(void * vms_time)
+{
+  struct tm *tmp;
+  time_t unix_time;
 
-static const char *VMS_saved_memname;
+  unix_time = decc$fix_time (vms_time);
 
-static time_t VMS_member_date;
+  /*
+   * Conversion from local time (stored in library) to GMT (needed for gmake)
+   * Note: The tm_gmtoff element is a VMS extension to the ANSI standard.
+   */
+  tmp = localtime (&unix_time);
+  unix_time -= tmp->tm_gmtoff;
+
+  return unix_time;
+}
+
+
+/* VMS library routines need static variables for callback */
+static void *VMS_lib_idx;
+
+static const void *VMS_saved_arg;
 
 static long int (*VMS_function) ();
 
+static long int VMS_function_ret;
+
+
+/* This is a callback procedure for lib$get_index */
 static int
 VMS_get_member_info (struct dsc$descriptor_s *module, unsigned long *rfa)
 {
   int status, i;
-  long int fnval;
-
-  time_t val;
+  const int truncated = 0;       /* Member name may be truncated */
+  time_t member_date;            /* Member date */
+  char *filename;
+  unsigned short buffer_length;  /* Actual buffer length */
+
+  /* Unused constants - Make does not actually use most of these */
+  const int file_desc = -1; /* archive file descriptor for reading the data */
+  const int header_position = 0; /* Header position */
+  const int data_position = 0;   /* Data position in file */
+  const int data_size = 0;       /* Data size */
+  const int uid = 0;             /* member gid */
+  const int gid = 0;             /* member gid */
+  const int mode = 0;            /* member protection mode */
+  /* End of unused constants */
 
   static struct dsc$descriptor_s bufdesc =
     { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL };
 
+  /* Only need the module definition */
   struct mhddef *mhd;
-  char filename[128];
 
-  bufdesc.dsc$a_pointer = filename;
-  bufdesc.dsc$w_length = sizeof (filename);
+  /* If a previous callback is non-zero, just return that status */
+  if (VMS_function_ret)
+    {
+      return SS$_NORMAL;
+    }
+
+  /* Bug: On VAX/VMS 7.3, lbr_set_mdoule is ignoring the buffer length
+   * and returning at least 49 bytes.  The mhddef is only 18 bytes long.
+   * Defensive programming is to use the LBR$C_MAXHDRSIZ constant to
+   * grab the header.
+   */
+  mhd = malloc(LBR$C_MAXHDRSIZ);
+  bufdesc.dsc$a_pointer = (char *)mhd;
+  bufdesc.dsc$w_length = LBR$C_MAXHDRSIZ;
 
   status = lbr$set_module (&VMS_lib_idx, rfa, &bufdesc,
-                           &bufdesc.dsc$w_length, 0);
-  if (! (status & 1))
+                           &buffer_length, 0);
+
+  /* If the request is too small, a buffer truncated warning is issued so
+   * it can be reissued with a larger buffer.
+   * We do not care if the buffer is truncated, so that is still a success.
+   */
+  if ((status != LIB_W_HDRTRUNC) && !$VMS_STATUS_SUCCESS (status))
     {
       ON (error, NILF,
           _("lbr$set_module() failed to extract module info, status = %d"),
@@ -70,60 +133,55 @@ VMS_get_member_info (struct dsc$descriptor_s *module, unsigned long *rfa)
 
       lbr$close (&VMS_lib_idx);
 
-      return 0;
+      return status;
     }
 
-  mhd = (struct mhddef *) filename;
+#ifdef TEST
+  /* When testing this code, it is useful to know the length returned */
+  printf("Input length = %d, actual = %d\n",
+         bufdesc.dsc$w_length, buffer_length);
+#endif
 
-#ifdef __DECC
-  /* John Fowler <jfowler@nyx.net> writes this is needed in his environment,
-   * but that decc$fix_time() isn't documented to work this way.  Let me
-   * know if this causes problems in other VMS environments.
+  /* Conversion from VMS time to C time */
+  /* Bug - mhddef is wrong, has a 32 bit longword and a 32 bit fill
+   * instead of two longwords, or equivalent
    */
-  {
-    /* Modified by M. Gehre at 11-JAN-2008 because old formula is wrong:
-     * val = decc$fix_time (&mhd->mhd$l_datim) + timezone - daylight*3600;
-     * a) daylight specifies, if the timezone has daylight saving enabled, not
-     *    if it is active
-     * b) what we need is the information, if daylight saving was active, if
-     *    the library module was replaced. This information we get using the
-     *    localtime function
-     */
-
-    struct tm *tmp;
-
-    /* Conversion from VMS time to C time */
-    val = decc$fix_time (&mhd->mhd$l_datim);
-
-    /*
-     * Conversion from local time (stored in library) to GMT (needed for gmake)
-     * Note: The tm_gmtoff element is a VMS extension to the ANSI standard.
-     */
-    tmp = localtime (&val);
-    val -= tmp->tm_gmtoff;
-  }
-#endif
+  member_date = vms_time_to_unix(&mhd->mhd$l_datim);
+  free(mhd);
+
+  /* Here we have a problem.  The module name on VMS does not have
+   * a file type, but the filename pattern in the "VMS_saved_arg"
+   * may have one.
+   * But only the method being called knows how to interpret the
+   * filename pattern.
+   * There are currently two different formats being used.
+   * This means that we need a VMS specific code in those methods
+   * to handle it.
+   */
+  filename = malloc (module->dsc$w_length + 1);
 
+  /* TODO: We may need an option to preserve the case of the module */
+  /* For now force the module name to lower case */
   for (i = 0; i < module->dsc$w_length; i++)
     filename[i] = _tolower ((unsigned char)module->dsc$a_pointer[i]);
 
   filename[i] = '\0';
 
-  VMS_member_date = (time_t) -1;
-
-  fnval =
-    (*VMS_function) (-1, filename, 0, 0, 0, 0, val, 0, 0, 0,
-                     VMS_saved_memname);
-
-  if (fnval)
-    {
-      VMS_member_date = fnval;
-      return 0;
-    }
-  else
-    return 1;
+  VMS_function_ret =
+    (*VMS_function) (file_desc,
+                     filename,
+                     truncated,
+                     header_position, data_position,
+                     data_size,
+                     member_date,
+                     uid, gid, mode,
+                     VMS_saved_arg);
+
+  free (filename);
+  return SS$_NORMAL;
 }
 
+
 /* Takes three arguments ARCHIVE, FUNCTION and ARG.
 
    Open the archive named ARCHIVE, find its members one by one,
@@ -156,59 +214,91 @@ VMS_get_member_info (struct dsc$descriptor_s *module, unsigned long *rfa)
 long int
 ar_scan (const char *archive, ar_member_func_t function, const void *varg)
 {
-  char *p;
-  const char *arg = varg;
+  char * vms_archive;
 
   static struct dsc$descriptor_s libdesc =
     { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL };
 
-  unsigned long func = LBR$C_READ;
-  unsigned long type = LBR$C_TYP_UNK;
-  unsigned long index = 1;
-
+  const unsigned long func = LBR$C_READ;
+  const unsigned long type = LBR$C_TYP_UNK;
+  const unsigned long index = 1;
+  unsigned long lib_idx;
   int status;
 
+  VMS_saved_arg = varg;
+
+  /* Null archive string can show up in test and cause an access violation */
+  if (archive == NULL)
+    {
+      /* Null filenames do not exist */
+      return -1;
+    }
+
+  /* archive path name must be in VMS format */
+  vms_archive = (char *)vmsify(archive, 0);
+
   status = lbr$ini_control (&VMS_lib_idx, &func, &type, 0);
 
-  if (! (status & 1))
+  if (!$VMS_STATUS_SUCCESS (status))
     {
       ON (error, NILF, _("lbr$ini_control() failed with status = %d"), status);
       return -2;
     }
 
-  /* there is no such descriptor with "const char *dsc$a_pointer" */
-  libdesc.dsc$a_pointer = (char *)archive;
-  libdesc.dsc$w_length = strlen (archive);
+  libdesc.dsc$a_pointer = vms_archive;
+  libdesc.dsc$w_length = strlen (vms_archive);
 
-  status = lbr$open (&VMS_lib_idx, &libdesc, 0, 0, 0, 0, 0);
+  status = lbr$open (&VMS_lib_idx, &libdesc, 0, NULL, 0, NULL, 0);
 
-  if (! (status & 1))
+  if (!$VMS_STATUS_SUCCESS (status))
     {
-      OSS (error, NILF, _("unable to open library '%s' to lookup member '%s'"),
-           archive, arg);
-      return -1;
-    }
 
-  VMS_saved_memname = arg;
+      /* TODO: A library format failure could mean that this is a file
+         generated by the GNU AR utility and in that case, we need to
+         take the UNIX codepath.  This will also take a change to the
+         GNV AR wrapper program.
+       */
 
-  /* For comparison, delete .obj from arg name.  */
-
-  p = strrchr (VMS_saved_memname, '.');
-  if (p)
-    *p = '\0';
+      switch(status)
+        {
+        case RMS$_FNF:
+            /* Archive does not exist */
+            return -1;
+        default:
+#ifndef TEST
+            OSN (error, NILF,
+                 _("unable to open library '%s' to lookup member status %d"),
+                 archive, status);
+#endif
+            /* For library format errors, specification says to return -2 */
+            return -2;
+        }
+    }
 
   VMS_function = function;
 
-  VMS_member_date = (time_t) -1;
-  lbr$get_index (&VMS_lib_idx, &index, VMS_get_member_info, 0);
+  /* Clear the return status, as we are supposed to stop calling the
+   * callback function if it becomes non-zero, and this is a static
+   * variable.
+   */
+  VMS_function_ret = 0;
 
-  /* Undo the damage.  */
-  if (p)
-    *p = '.';
+  status = lbr$get_index (&VMS_lib_idx, &index, VMS_get_member_info, NULL, 0);
 
   lbr$close (&VMS_lib_idx);
 
-  return VMS_member_date > 0 ? VMS_member_date : 0;
+  /* Unless a failure occurred in the lbr$ routines, return the
+   * the status from the 'function' routine.
+   */
+  if ($VMS_STATUS_SUCCESS (status))
+    {
+      return VMS_function_ret;
+    }
+
+  /* This must be something wrong with the library and an error
+   * message should already have been printed.
+   */
+  return -2;
 }
 
 #else /* !VMS */
@@ -753,9 +843,20 @@ ar_name_equal (const char *name, const char *mem, int truncated)
 #endif /* !__hpux && !cray */
 #endif /* !AIAMAG */
     }
-#endif /* !VMS */
 
   return !strcmp (name, mem);
+#else
+  /* VMS members do not have suffixes */
+  /* Do we need to strip VMS disk/directory format paths? */
+  {
+    int len;
+    len = strlen(mem);
+    /* VMS by default is case insensitive.
+     * We may need to have a case sensitive mode.
+     */
+    return !strncasecmp(name, mem, len);
+  }
+#endif /* !VMS */
 }
 
 #ifndef VMS
diff --git a/default.c b/default.c
index d6c08a5..c19397a 100644
--- a/default.c
+++ b/default.c
@@ -38,9 +38,11 @@ this program.  If not, see <http://www.gnu.org/licenses/>.  */
 
 static char default_suffixes[]
 #ifdef VMS
-  = ".exe .olb .ln .obj .c .cxx .cc .pas .p .for .f .r .y .l .mar \
-.s .ss .i .ii .mod .sym .def .h .info .dvi .tex .texinfo .texi .txinfo \
-.w .ch .cweb .web .com .sh .elc .el";
+  /* VMS should include all UNIX/POSIX + some VMS extensions */
+  = ".out .exe .a .olb .hlb .tlb .mlb .ln .o .obj .c .cxx .cc .cpp .pas .p \
+.for .f .r .y .l .ym .yl .mar .s .ss .i .ii .mod .sym .def .h .info .dvi \
+.tex .texinfo .texi .txinfo .mem .hlp .brn .rnh .rno .rnt .rnx .w .ch .cweb \
+.web .com .sh .elc .el";
 #elif defined(__EMX__)
   = ".out .a .ln .o .c .cc .C .cpp .p .f .F .m .r .y .l .ym .yl .s .S \
 .mod .sym .def .h .info .dvi .tex .texinfo .texi .txinfo \
@@ -53,19 +55,34 @@ static char default_suffixes[]
 
 static struct pspec default_pattern_rules[] =
   {
+#ifdef VMS
     { "(%)", "%",
+      "@if f$$search(\"$@\") .eqs. \"\" then $(LIBRARY)/CREATE/"
+      "$(or "
+        "$(patsubst %,TEXT,$(filter %.tlb %.TLB,$@)),"
+        "$(patsubst %,HELP,$(filter %.hlb %.HLB,$@)),"
+        "$(patsubst %,MACRO,$(filter %.mlb %.MLB,$@)),"
+        "$(and "
+         "$(patsubst %,SHARE,$(filter %.olb %.OLB,$@)),"
+         "$(patsubst %,SHARE,$(filter %.exe %.EXE,$<))),"
+        "OBJECT)"
+        " $@\n"
         "$(AR) $(ARFLAGS) $@ $<" },
-
+#else
+    { "(%)", "%",
+        "$(AR) $(ARFLAGS) $@ $<" },
+#endif
     /* The X.out rules are only in BSD's default set because
        BSD Make has no null-suffix rules, so 'foo.out' and
        'foo' are the same thing.  */
 #ifdef VMS
     { "%.exe", "%",
-        "copy $< $@" },
-#else
+        "$(CP) $< $@" },
+
+#endif
     { "%.out", "%",
         "@rm -f $@ \n cp $< $@" },
-#endif
+
     /* Syntax is "ctangle foo.w foo.ch foo.c".  */
     { "%.c", "%.w %.ch",
         "$(CTANGLE) $^ $@" },
@@ -78,18 +95,20 @@ static struct pspec default_pattern_rules[] =
 static struct pspec default_terminal_rules[] =
   {
 #ifdef VMS
+
     /* RCS.  */
     { "%", "%$$5lv", /* Multinet style */
-        "if f$$search($@) .nes. \"\" then +$(CHECKOUT,v)" },
+        "if f$$search(\"$@\") .nes. \"\" then +$(CHECKOUT,v)" },
     { "%", "[.$$rcs]%$$5lv", /* Multinet style */
-        "if f$$search($@) .nes. \"\" then +$(CHECKOUT,v)" },
+        "if f$$search(\"$@\") .nes. \"\" then +$(CHECKOUT,v)" },
     { "%", "%_v", /* Normal style */
-        "if f$$search($@) .nes. \"\" then +$(CHECKOUT,v)" },
+        "if f$$search(\"$@\") .nes. \"\" then +$(CHECKOUT,v)" },
     { "%", "[.rcs]%_v", /* Normal style */
-        "if f$$search($@) .nes. \"\" then +$(CHECKOUT,v)" },
+        "if f$$search(\"$@\") .nes. \"\" then +$(CHECKOUT,v)" },
 
     /* SCCS.  */
         /* ain't no SCCS on vms */
+
 #else
     /* RCS.  */
     { "%", "%,v",
@@ -149,6 +168,8 @@ static char *default_suffix_rules[] =
     "$(COMPILE.c)/noprep/noobj/machine /list=$@ $<",
     ".c.obj",
     "$(COMPILE.c) /obj=$@ $<",
+    ".c.o",
+    "$(COMPILE.c) /obj=$@ $<",
     ".cc.ii",
     "$(COMPILE.cc)/prep /list=$@ $<",
     ".cc.ss",
@@ -157,12 +178,20 @@ static char *default_suffix_rules[] =
     "$(COMPILE.cc)/noprep/noobj/machine /list=$@ $<",
     ".cc.obj",
     "$(COMPILE.cc) /obj=$@ $<",
+    ".cc.o",
+    "$(COMPILE.cc) /obj=$@ $<",
     ".cxx.obj",
     "$(COMPILE.cxx) /obj=$@ $<",
+    ".cxx.o",
+    "$(COMPILE.cxx) /obj=$@ $<",
     ".for.obj",
     "$(COMPILE.for) /obj=$@ $<",
+    ".for.o",
+    "$(COMPILE.for) /obj=$@ $<",
     ".pas.obj",
     "$(COMPILE.pas) /obj=$@ $<",
+    ".pas.o",
+    "$(COMPILE.pas) /obj=$@ $<",
 
     ".y.c",
     "$(YACC.y) $< \n rename y_tab.c $@",
@@ -322,7 +351,8 @@ static const char *default_variables[] =
 #ifdef __VAX
     "ARCH", "VAX",
 #endif
-    "AR", "library/obj",
+    "AR", "library",
+    "LIBRARY", "library",
     "ARFLAGS", "/replace",
     "AS", "macro",
     "MACRO", "macro",
@@ -340,7 +370,14 @@ static const char *default_variables[] =
 #else
     "C++", "cxx",
     "CXX", "cxx",
+#ifndef __ia64
     "CXXLD", "cxxlink",
+    "CXXLINK", "cxxlink",
+#else
+    /* CXXLINK is not used on VMS/IA64 */
+    "CXXLD", "link",
+    "CXXLINK", "link",
+#endif
 #endif
     "CO", "co",
     "CPP", "$(CC) /preprocess_only",
@@ -393,6 +430,7 @@ static const char *default_variables[] =
 
     "MV", "rename/new_version",
     "CP", "copy",
+    ".LIBPATTERNS", "%.olb lib%.a",
 
 #else /* !VMS */
 
diff --git a/tests/scripts/features/archives b/tests/scripts/features/archives
index a7ec881..d0cdf64 100644
--- a/tests/scripts/features/archives
+++ b/tests/scripts/features/archives
@@ -8,60 +8,150 @@ This only works on systems that support it.";
 # If this instance of make doesn't support archives, skip it
 exists $FEATURES{archives} or return -1;
 
+# VMS specific note:
+# $^O eq 'VMS' is for a behavior always neeeded for VMS
+# $vms_dcl is for VMS using DCL instead of the GNV Bash shell.
+
+$vms_dcl = 0;
+$vms_dcl = 1 if ($^O eq 'VMS' && !defined $ENV{"SHELL"});
+
 # Create some .o files to work with
-utouch(-60, qw(a1.o a2.o a3.o));
+if ($^O eq 'VMS') {
+  use Cwd;
+  my $pwd = getcwd;
+  # VMS AR needs real object files at this time.
+  foreach $afile ('a1', 'a2', 'a3') {
+    # Use non-standard extension to prevent implicit rules from recreating
+    # objects when the test tampers with the timestamp.
+    1 while unlink "$afile.c1";
+    1 while unlink "$afile.o";
+    open (MYFILE, ">$afile.c1");
+    print MYFILE "int $afile(void) {return 1;}\n";
+    close MYFILE;
+    system("cc $afile.c1 /object=$afile.o");
+  }
+} else {
+  utouch(-60, qw(a1.o a2.o a3.o));
+}
+
+my $redir = " 2>&1";
+$redir = "" if $^O eq 'VMS';
 
 # Some versions of ar print different things on creation.  Find out.
-my $created = `ar rv libxx.a a1.o 2>&1`;
+my $created = `ar rv libxx.a a1.o $redir`;
 
 # Some versions of ar print different things on add.  Find out.
-my $add = `ar rv libxx.a a2.o 2>&1`;
+my $add = `ar rv libxx.a a2.o $redir`;
 $add =~ s/a2\.o/#OBJECT#/g;
 
 # Some versions of ar print different things on replacement.  Find out.
-my $repl = `ar rv libxx.a a2.o 2>&1`;
+my $repl = `ar rv libxx.a a2.o $redir`;
 $repl =~ s/a2\.o/#OBJECT#/g;
 
 unlink('libxx.a');
 
 # Very simple
+my $answer = "ar rv libxx.a a1.o\n$created";
+if ($vms_dcl) {
+  $answer = 'library /replace libxx.a a1.o';
+}
 run_make_test('all: libxx.a(a1.o)',
-              '', "ar rv libxx.a a1.o\n$created");
+              '', $answer);
 
 # Multiple .o's.  Add a new one to the existing library
 ($_ = $add) =~ s/#OBJECT#/a2.o/g;
+
+$answer = "ar rv libxx.a a2.o\n$_";
+if ($vms_dcl) {
+  $answer = 'library /replace libxx.a a2.o';
+}
 run_make_test('all: libxx.a(a1.o a2.o)',
-              '', "ar rv libxx.a a2.o\n$_");
+              '', $answer);
 
 # Touch one of the .o's so it's rebuilt
-utouch(-40, 'a1.o');
+if ($vms_dcl) {
+  # utouch is not changing what VMS library compare is testing for.
+  # So do a real change by regenerating the file.
+  1 while unlink('a1.o');
+  # Later time stamp than last insertion.
+  sleep(2);
+  system('cc a1.c1 /object=a1.o');
+  # Next insertion will have a later timestamp.
+  sleep(2);
+} else {
+  utouch(-40, 'a1.o');
+}
+
 ($_ = $repl) =~ s/#OBJECT#/a1.o/g;
-run_make_test(undef, '', "ar rv libxx.a a1.o\n$_");
+$answer = "ar rv libxx.a a1.o\n$_";
+if ($vms_dcl) {
+  $answer = 'library /replace libxx.a a1.o';
+}
+run_make_test(undef, '', $answer);
 
 # Use wildcards
+$answer = "#MAKE#: Nothing to be done for 'all'.\n";
 run_make_test('all: libxx.a(*.o)',
-              '', "#MAKE#: Nothing to be done for 'all'.\n");
+              '', $answer);
 
 # Touch one of the .o's so it's rebuilt
-utouch(-30, 'a1.o');
+if ($vms_dcl) {
+  # utouch is not changing what VMS library compare is testing for.
+  # So do a real change by regenerating the file.
+  1 while unlink('a1.o');
+  # Make timestamp later than last insertion.
+  sleep(2);
+  system('cc a1.c1 /object=a1.o');
+} else {
+  utouch(-30, 'a1.o');
+}
 ($_ = $repl) =~ s/#OBJECT#/a1.o/g;
-run_make_test(undef, '', "ar rv libxx.a a1.o\n$_");
+$answer = "ar rv libxx.a a1.o\n$_";
+if ($vms_dcl) {
+  $answer = 'library /replace libxx.a a1.o';
+}
+run_make_test(undef, '', $answer);
 
 # Use both wildcards and simple names
-utouch(-50, 'a2.o');
+if ($vms_dcl) {
+  # utouch is not changing what VMS library compare is testing for.
+  # So do a real change by regenerating the file.
+  1 while unlink('a2.o');
+  sleep(2);
+  system('cc a2.c1 /object=a2.o');
+} else {
+  utouch(-50, 'a2.o');
+}
 ($_ = $add) =~ s/#OBJECT#/a3.o/g;
 $_ .= "ar rv libxx.a a2.o\n";
 ($_ .= $repl) =~ s/#OBJECT#/a2.o/g;
+$answer = "ar rv libxx.a a3.o\n$_";
+if ($vms_dcl) {
+  $answer = 'library /replace libxx.a a3.o';
+}
+
 run_make_test('all: libxx.a(a3.o *.o)', '',
-              "ar rv libxx.a a3.o\n$_");
+              $answer);
 
 # Check whitespace handling
-utouch(-40, 'a2.o');
+if ($vms_dcl) {
+  # utouch is not changing what VMS library compare is testing for.
+  # So do a real change by regenerating the file.
+  1 while unlink('a2.o');
+  sleep(2);
+  system('cc a2.c1 /object=a2.o');
+} else {
+  utouch(-40, 'a2.o');
+}
 ($_ = $repl) =~ s/#OBJECT#/a2.o/g;
+$answer = "ar rv libxx.a a2.o\n$_";
+if ($vms_dcl) {
+  $answer = 'library /replace libxx.a a2.o';
+}
 run_make_test('all: libxx.a(  a3.o    *.o     )', '',
-              "ar rv libxx.a a2.o\n$_");
+              $answer);
 
-rmfiles(qw(a1.o a2.o a3.o libxx.a));
+rmfiles(qw(a1.c1 a2.c1 a3.c1 a1.o a2.o a3.o libxx.a));
 
 # Check non-archive targets
 # See Savannah bug #37878
@@ -76,20 +166,36 @@ foo(bar).baz: ; @echo '$@'
 
 mkdir('artest', 0777);
 touch('foo.vhd');
-
-run_make_test(q!
+$mk_string = q!
 DIR = artest
 vpath % $(DIR)
 default: lib(foo)
 (%): %.vhd ; @cd $(DIR) && touch $(*F) && $(AR) $(ARFLAGS) $@ $(*F) >/dev/null 2>&1 && rm $(*F)
 .PHONY: default
-!,
+!;
+if ($vms_dcl) {
+  $mk_string =~ s#= artest#= sys\$\$disk:\[.artest\]#;
+  $mk_string =~ s#lib\(foo\)#lib.tlb\(foo\)#;
+  $mk_string =~ s#; \@cd#; pipe SET DEFAULT#;
+  $mk_string =~
+    s#touch \$\(\*F\)#touch \$\(\*F\) && library/create/text sys\$\$disk:\$\@#;
+  $mk_string =~
+    s#library#if f\$\$search(\"\$\@\") \.eqs\. \"\" then library#;
+  # VMS needs special handling for null extension
+  $mk_string =~ s#\@ \$\(\*F\)#\@ \$\(\*F\)\.#;
+  $mk_string =~ s#>/dev/null 2>&1 ##;
+}
+run_make_test($mk_string,
               '', "");
 
 run_make_test(undef, '', "#MAKE#: Nothing to be done for 'default'.\n");
 
 unlink('foo.vhd');
-remove_directory_tree('artest');
+if ($^O eq 'VMS') {
+  remove_directory_tree("$pwd/artest");
+} else {
+  remove_directory_tree('artest');
+}
 
 # This tells the test driver that the perl test script executed properly.
 1;
diff --git a/tests/scripts/features/vpath3 b/tests/scripts/features/vpath3
index c6ede28..08d8044 100644
--- a/tests/scripts/features/vpath3
+++ b/tests/scripts/features/vpath3
@@ -3,6 +3,12 @@
 $description = "Test the interaction of the -lfoo feature and vpath";
 $details = "";
 
+# VMS specific note:
+# $^O eq 'VMS' is for a behavior always neeeded for VMS
+# $vms_dcl is for VMS using DCL instead of the GNV Bash shell.
+$vms_dcl = 0;
+$vms_dcl = 1 if ($^O eq 'VMS' && !defined $ENV{"SHELL"});
+
 my @dirs_to_make = qw(a1 b1 a2 b2 b3);
 for my $d (@dirs_to_make) {
     mkdir($d, 0777);
@@ -17,6 +23,12 @@ my @files_to_touch = ("a1${pathsep}lib1.a",
                       "b3${pathsep}lib3.so");
 &touch(@files_to_touch);
 
+my $answer = "a1${pathsep}lib1.a a1${pathsep}libc.a " .
+             "a2${pathsep}lib2.a lib3.a\n";
+if ($vms_dcl) {
+    $answer = "[.a1]lib1.a [.a1]libc.a [.a2]lib2.a lib3.a\n";
+}
+
 run_make_test('
 vpath %.h b3
 vpath %.a a1
@@ -25,7 +37,7 @@ vpath % a2 b2
 vpath % b3
 all: -l1 -lc -l2 -l3; @echo $^
 ',
-              '', "a1${pathsep}lib1.a a1${pathsep}libc.a a2${pathsep}lib2.a lib3.a\n");
+              '', $answer);
 
 unlink(@files_to_touch);
 for my $d (@dirs_to_make) {
diff --git a/tests/scripts/vms/library b/tests/scripts/vms/library
new file mode 100644
index 0000000..cee8ac2
--- /dev/null
+++ b/tests/scripts/vms/library
@@ -0,0 +1,81 @@
+#                                                              -*-mode: perl-*-
+
+$description = "Test GNU make's VMS Library management features.";
+
+$details = "\
+This only works on VMS systems.";
+
+return -1 if $^O ne 'VMS';
+
+
+# VMS specific note:
+# $^O eq 'VMS' is for a behavior always neeeded for VMS
+# $vms_dcl is for VMS using DCL instead of the GNV Bash shell.
+
+$vms_dcl = 0;
+$vms_dcl = 1 if ($^O eq 'VMS' && !defined $ENV{"SHELL"});
+
+
+# Help library
+$mk_string = "help : help.hlb(file1.hlp)\n\n" .
+"file1.hlp :\n" .
+"\t\@pipe open/write xxx file1.hlp ; write xxx \"1 help\" ; close xxx\n";
+
+my $answer = "library /replace help.hlb file1.hlp";
+
+run_make_test($mk_string,
+              '', $answer);
+
+unlink('help.hlb');
+unlink('file1.hlp');
+
+#Text library
+$mk_string = "text : text.tlb(file1.txt)\n\n" .
+"file1.txt :\n" .
+"\t\@pipe open/write xxx file1.txt ; write xxx \"text file\" ; close xxx\n";
+
+my $answer = "library /replace text.tlb file1.txt";
+
+run_make_test($mk_string,
+              '', $answer);
+
+unlink('text.tlb');
+unlink('file1.txt');
+
+
+#Macro library
+$mk_string = "macro : macro.mlb(file1.mar)\n\n" .
+"file1.mar :\n" .
+"\t\@pipe open/write xxx file1.mar ; write xxx \"macro file\" ; close xxx\n";
+
+my $answer = "library /replace macro.mlb file1.mar";
+
+run_make_test($mk_string,
+              '', $answer);
+
+unlink('macro.mlb');
+unlink('file1.mar');
+
+$mk_string =
+"all:imagelib.olb(file2.exe)\n" .
+"file2.exe : file2.obj file2.opt\n" .
+"\t\@link /share=\$\@ \$\*,\$\*/opt\n\n" .
+"file2.opt :\n" .
+"\t\@pipe open/write xxx file2.opt ; " .
+"write xxx \"universal=file2\" ; close xxx\n" .
+"file2.c :\n" .
+"\t\@pipe open/write xxx file2.c ; write xxx \"file2(){}\" ; close xxx\n";
+
+my $answer = "library /replace imagelib.olb file2.exe";
+
+run_make_test($mk_string,
+              '', $answer);
+
+unlink('imagelib.olb');
+unlink('file2.c');
+unlink('file2.obj');
+unlink('file2.exe');
+unlink('file2.opt');
+
+# This tells the test driver that the perl test script executed properly.
+1;
-- 
1.7.9

