Import Upstream version 5b3upstream/5b3

1 files changed, 384 insertions, 0 deletions

diff --git a/script.c b/script.c
new file mode 100644
index 0000000..e1a63f1
--- /dev/null
+++ b/script.c
@@ -0,0 +1,384 @@
+/* Copyright (C) 1994, 1995, 1996, 1997 Free Software Foundation, Inc.
+ * 
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ * 
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU General Public License for more details.
+ * 
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING.  If not, write to
+ * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE.  If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way.  To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.  
+ */
+
+/* "script.c" argv tricks for `#!' scripts.
+   Author: Aubrey Jaffer */
+
+#include <ctype.h>
+#include "scm.h"
+
+#ifdef __IBMC__
+# include <io.h>
+#endif /* def __IBMC__ */
+
+#ifdef linux
+# include <unistd.h>     /* for X_OK define */
+#endif /* def linux */
+#ifdef __svr4__
+# include <unistd.h>     /* for X_OK define */
+#else
+# ifdef __sgi__
+#  include <unistd.h>     /* for X_OK define */
+# endif /* def __sgi__ */
+#endif /* def __svr4__ */
+
+/* Concatentate str2 onto str1 at position n and return concatenated
+   string if file exists; 0 otherwise. */
+
+char *scm_cat_path(str1, str2, n)
+     char *str1;
+     const char *str2;
+     long n;
+{
+  if (!n) n = strlen(str2);
+  if (str1)
+    {
+      long len = strlen(str1);
+      str1 = (char *)realloc(str1, (sizet)(len + n + 1));
+      if (!str1) return 0L;
+      strncat(str1 + len, str2, n);
+      return str1;
+    }
+  str1 = (char *)malloc((sizet)(n + 1));
+  if (!str1) return 0L;
+  str1[0] = 0;
+  strncat(str1, str2, n);
+  return str1;
+}
+
+char *scm_try_path(path)
+     char *path;
+{
+  FILE *f;
+  /* fprintf(stderr, "Trying %s\n", path);fflush(stderr); */
+  if (!path) return 0L;
+  SYSCALL(f = fopen(path, "r"););
+  if (f) {
+    fclose(f);
+    return path;
+  }
+  free(path);
+  return 0L;
+}
+
+char *scm_sep_init_try(path, sep, initname)
+     char *path;
+     const char *sep, *initname;
+{
+  if (path) path = scm_cat_path(path, sep, 0L);
+  if (path) path = scm_cat_path(path, initname, 0L);
+  return scm_try_path(path);
+}
+
+#ifndef LINE_INCREMENTORS
+# define LINE_INCREMENTORS  '\n'
+# ifdef MSDOS
+#  define WHITE_SPACES  ' ':case '\t':case '\r':case '\f':case 26
+# else
+#  define WHITE_SPACES  ' ':case '\t':case '\r':case '\f'
+# endif /* def MSDOS */
+#endif /* ndef LINE_INCREMENTORS */
+
+#ifndef MAXPATHLEN
+# define MAXPATHLEN 80
+#endif /* ndef MAXPATHLEN */
+#ifndef X_OK
+# define X_OK 1
+#endif /* ndef X_OK */
+
+#ifdef unix
+# include <stdio.h>
+
+char *script_find_executable(name)
+     const char *name;
+{
+  char tbuf[MAXPATHLEN];
+  int i = 0;
+  FILE *f;
+
+  /* fprintf(stderr, "s_f_e checking access %s ->%d\n", name, access(name, X_OK)); fflush(stderr); */
+  if (access(name, X_OK)) return 0L;
+  f = fopen(name, "r");
+  if (!f) return 0L;
+  if ((fgetc(f)=='#') && (fgetc(f)=='!')) {
+    while (1) switch (tbuf[i++] = fgetc(f)) {
+    case /*WHITE_SPACES*/ ' ':case '\t':case '\r':case '\f':
+    case EOF:
+      tbuf[--i] = 0;
+      fclose(f);
+      return scm_cat_path(0L, tbuf, 0L);
+    }
+  }
+  fclose(f);
+  return scm_cat_path(0L, name, 0L);
+}
+#endif /* unix */
+
+#ifdef MSDOS
+
+# define DEFAULT_PATH "C:\\DOS"
+# define PATH_DELIMITER ';'
+# define ABSOLUTE_FILENAME_P(fname) ((fname[0] == '\\') \
+				     || (fname[0] && (fname[1] == ':')))
+
+char *dld_find_executable(file)
+     const char *file;
+{
+  /* fprintf(stderr, "dld_find_executable %s -> %s\n", file, scm_cat_path(0L, file, 0L)); fflush(stderr); */
+  return scm_cat_path(0L, file, 0L);
+}
+#endif /* def MSDOS */
+
+/* Given dld_find_executable()'s best guess for the pathname of this
+   executable, find (and verify the existence of) initname in the
+   implementation-vicinity of this program.  Returns a newly allocated
+   string if successful, 0 if not */
+
+char *scm_find_impl_file(exec_path, generic_name, initname, sep)
+     char *exec_path;
+     const char *generic_name, *initname, *sep;
+{
+  char *sepptr = strrchr(exec_path, sep[0]);
+  char *extptr = exec_path + strlen(exec_path);
+  char *path = 0;
+  /* fprintf(stderr, "dld_find_e %s\n", exec_path); fflush(stderr); */
+  if (sepptr) {
+    long sepind = sepptr - exec_path + 1L;
+
+    /* In case exec_path is in the source directory, look first in
+       exec_path's directory. */
+    path = scm_cat_path(0L, exec_path, sepind - 1L);
+    path = scm_sep_init_try(path, sep, initname);
+    if (path) return path;
+
+#ifdef MSDOS
+    if (!strcmp(extptr - 4, ".exe") || !strcmp(extptr - 4, ".com") ||
+	!strcmp(extptr - 4, ".EXE") || !strcmp(extptr - 4, ".COM"))
+      extptr = extptr - 4;
+#endif /* def MSDOS */
+
+    if (generic_name &&
+	!strncmp(exec_path + sepind, generic_name, extptr - exec_path))
+      generic_name = 0;
+
+    /* If exec_path is in directory "exe" or "bin": */
+    path = scm_cat_path(0L, exec_path, sepind - 1L);
+    sepptr = path + sepind - 4;
+    if (!strcmp(sepptr, "exe") || !strcmp(sepptr, "bin") ||
+	!strcmp(sepptr, "EXE") || !strcmp(sepptr, "BIN")) {
+      char *peer;
+
+      /* Look for initname in peer directory "lib". */
+      if (path) {
+	strncpy(sepptr, "lib", 3);
+	path = scm_sep_init_try(path, sep, initname);
+	if (path) return path;
+      }
+
+      /* Look for initname in peer directories "lib" and "src" in
+	 subdirectory with the name of the executable (sans any type
+	 extension like .EXE). */
+      for(peer="lib";!0;peer="src") {
+	path = scm_cat_path(0L, exec_path, extptr - exec_path + 0L);
+	if (path) {
+	  strncpy(path + sepind - 4, peer, 3);
+	  path[extptr - exec_path] = 0;
+	  path = scm_sep_init_try(path, sep, initname);
+	  if (path) return path;
+	}
+	if (!strcmp(peer,"src")) break;
+      }
+
+      if (generic_name) {
+
+	/* Look for initname in peer directories "lib" and "src" in
+	   subdirectory with the generic name. */
+	for(peer="lib";!0;peer="src") {
+	  path = scm_cat_path(0L, exec_path, sepind);
+	  if (path) {
+	    strncpy(path + sepind - 4, "lib", 3);
+	    path = scm_cat_path(path, generic_name, 0L);
+	    path = scm_sep_init_try(path, sep, initname);
+	    if (path) return path;
+	  }
+	  if (!strcmp(peer,"src")) break;
+	}}}
+
+#ifdef MSDOS
+    if (strlen(extptr)) {
+      /* If exec_path has type extension, look in a subdirectory with
+	 the name of the executable sans the executable file's type
+	 extension. */
+      path = scm_cat_path(0L, exec_path, extptr - exec_path + 0L);
+      path = scm_sep_init_try(path, sep, initname);
+      if (path) return path;
+
+      if (generic_name) {
+
+	/* Also look in generic_name subdirectory. */
+	path = scm_cat_path(0L, exec_path, sepind);
+	if (path) path = scm_cat_path(path, generic_name, 0L);
+	path = scm_sep_init_try(path, sep, initname);
+	if (path) return path;
+      }}
+#endif /* def MSDOS */
+  }
+  else {
+
+    /* We don't have a parse-able exec_path.  The only path to try is
+       just initname. */
+    path = scm_cat_path(0L, initname, 0L);
+    if (path) path = scm_try_path(path);
+    if (path) return path;
+  }
+  return 0L;
+}
+
+char *script_read_arg(f)
+     FILE *f;
+{
+  sizet tlen = 1;
+  int tind = 0, qted = 0, chr;
+  char *tbuf = (char *)malloc((1 + tlen) * sizeof(char));
+  if (!tbuf) return 0L;
+  while (1) switch (chr = getc(f)) {
+  case WHITE_SPACES:
+    continue;
+  case LINE_INCREMENTORS:
+  case EOF:
+    free(tbuf);
+    return 0L;
+  default:
+    goto morearg;
+  }
+morearg:
+  while (1) {
+    switch (tbuf[tind++] = chr) {
+    case WHITE_SPACES:
+    case LINE_INCREMENTORS:
+      if (qted) break;
+    case EOF: goto endarg;
+    case '!':
+      if (qted) break;
+      switch (chr = getc(f)) {
+      case '#':
+	if (1==tind) return 0L;
+	goto endarg;
+      default: tbuf[tind++] = chr; break;
+      }
+      break;
+    case '"': qted = !qted; tind--; break;
+    case '\\':
+      switch (tbuf[tind - 1] = getc(f)) {
+      case '\n': --tind; break;
+      case 'n': tbuf[tind - 1] = '\n'; break;
+      case 'r': tbuf[tind - 1] = '\r'; break;
+      case 't': tbuf[tind - 1] = '\t'; break;
+      case 'b': tbuf[tind - 1] = '\b'; break;
+	/* case '0': tbuf[tind - 1] = '\0'; break; */
+      default:;
+      }
+    default:;
+    }
+    if (tind >= tlen) {
+      tbuf = (char *)realloc(tbuf, (1 + (2 * tlen)) * sizeof(char));
+      if (!tbuf) return 0L;
+      tlen = 2 * tlen;
+    }
+    chr = getc(f);
+  }
+endarg:
+  tbuf[--tind] = 0;
+  return tbuf;
+}
+
+int script_meta_arg_P(arg)
+     char *arg;
+{
+  if ('\\' != arg[0]) return 0L;
+#ifdef MSDOS
+  return !arg[1];
+#else
+  switch (arg[1]) {
+  case 0:
+  case '%':
+  case WHITE_SPACES: return !0;
+  default: return 0L;}
+#endif
+}
+
+char **script_process_argv(argc, argv)
+     int argc;
+     char **argv;
+{
+  int nargc = argc, argi = 1, nargi = 1;
+  char *narg, **nargv;
+  if (!(argc > 2 && script_meta_arg_P(argv[1]))) return 0L;
+  if (!(nargv = (char **)malloc((1 + nargc) * sizeof(char*)))) return 0L;
+  nargv[0] = argv[0];
+  while (((argi+1) < argc) && (script_meta_arg_P(argv[argi]))) {
+    FILE *f = fopen(argv[++argi], "r");
+    if (f) {
+      nargc--;		/* to compensate for replacement of '\\' */
+      while (1) switch (getc(f)) {
+      case EOF: return 0L;
+      default: continue;
+      case '\n': goto found_args;
+      }
+    found_args: while ((narg = script_read_arg(f)))
+      if (!(nargv = (char **)realloc(nargv, (1 + ++nargc) * sizeof(char*))))
+	return 0L;
+      else nargv[nargi++] = narg;
+    fclose(f);
+    nargv[nargi++] = argv[argi++];
+    }
+  }
+  while (argi <= argc) nargv[nargi++] = argv[argi++];
+  return nargv;
+}
+
+int script_count_argv(argv)
+     char **argv;
+{
+  int argc = 0;
+  while (argv[argc]) argc++;
+  return argc;
+}