libguile/script.c

   1 /* Copyright (C) 1994-1998, 2000-2011 Free Software Foundation, Inc.
   2  * This library is free software; you can redistribute it and/or
   3  * modify it under the terms of the GNU Lesser General Public License
   4  * as published by the Free Software Foundation; either version 3 of
   5  * the License, or (at your option) any later version.
   6  *
   7  * This library is distributed in the hope that it will be useful, but
   8  * WITHOUT ANY WARRANTY; without even the implied warranty of
   9  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  10  * Lesser General Public License for more details.
  11  *
  12  * You should have received a copy of the GNU Lesser General Public
  13  * License along with this library; if not, write to the Free Software
  14  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  15  * 02110-1301 USA
  16  */
  17
  18 /* "script.c" argv tricks for `#!' scripts.
  19    Authors: Aubrey Jaffer and Jim Blandy */
  20
  21 #ifdef HAVE_CONFIG_H
  22 #  include <config.h>
  23 #endif
  24
  25 #include <stdlib.h>
  26 #include <stdio.h>
  27 #include <errno.h>
  28 #include <ctype.h>
  29
  30 #include "libguile/_scm.h"
  31 #include "libguile/eval.h"
  32 #include "libguile/feature.h"
  33 #include "libguile/load.h"
  34 #include "libguile/private-gc.h" /* scm_getenv_int */
  35 #include "libguile/read.h"
  36 #include "libguile/script.h"
  37 #include "libguile/strings.h"
  38 #include "libguile/strports.h"
  39 #include "libguile/validate.h"
  40 #include "libguile/version.h"
  41 #include "libguile/vm.h"
  42
  43 #ifdef HAVE_STRING_H
  44 #include <string.h>
  45 #endif
  46
  47 #ifdef HAVE_UNISTD_H
  48 #include <unistd.h>             /* for X_OK define */
  49 #endif
  50
  51 #ifdef HAVE_IO_H
  52 #include <io.h>
  53 #endif
  54
  55 /* Concatentate str2 onto str1 at position n and return concatenated
  56    string if file exists; 0 otherwise. */
  57
  58 static char *
  59 scm_cat_path (char *str1, const char *str2, long n)
  60 {
  61   if (!n)
  62     n = strlen (str2);
  63   if (str1)
  64     {
  65       size_t len = strlen (str1);
  66       str1 = (char *) realloc (str1, (size_t) (len + n + 1));
  67       if (!str1)
  68         return 0L;
  69       strncat (str1 + len, str2, n);
  70       return str1;
  71     }
  72   str1 = (char *) scm_malloc ((size_t) (n + 1));
  73   if (!str1)
  74     return 0L;
  75   str1[0] = 0;
  76   strncat (str1, str2, n);
  77   return str1;
  78 }
  79
  80 #if 0
  81 static char *
  82 scm_try_path (char *path)
  83 {
  84   FILE *f;
  85   /* fprintf(stderr, "Trying %s\n", path);fflush(stderr); */
  86   if (!path)
  87     return 0L;
  88   SCM_SYSCALL (f = fopen (path, "r");
  89     );
  90   if (f)
  91     {
  92       fclose (f);
  93       return path;
  94     }
  95   free (path);
  96   return 0L;
  97 }
  98
  99 static char *
 100 scm_sep_init_try (char *path, const char *sep, const char *initname)
 101 {
 102   if (path)
 103     path = scm_cat_path (path, sep, 0L);
 104   if (path)
 105     path = scm_cat_path (path, initname, 0L);
 106   return scm_try_path (path);
 107 }
 108 #endif
 109
 110 #ifndef LINE_INCREMENTORS
 111 #define LINE_INCREMENTORS  '\n'
 112 #ifdef MSDOS
 113 #define WHITE_SPACES  ' ':case '\t':case '\r':case '\f':case 26
 114 #else
 115 #define WHITE_SPACES  ' ':case '\t':case '\r':case '\f'
 116 #endif /* def MSDOS */
 117 #endif /* ndef LINE_INCREMENTORS */
 118
 119 #ifndef MAXPATHLEN
 120 #define MAXPATHLEN 80
 121 #endif /* ndef MAXPATHLEN */
 122 #ifndef X_OK
 123 #define X_OK 1
 124 #endif /* ndef X_OK */
 125
 126 char *
 127 scm_find_executable (const char *name)
 128 {
 129   char tbuf[MAXPATHLEN];
 130   int i = 0, c;
 131   FILE *f;
 132
 133   /* fprintf(stderr, "s_f_e checking access %s ->%d\n", name, access(name, X_OK)); fflush(stderr); */
 134   if (access (name, X_OK))
 135     return 0L;
 136   f = fopen (name, "r");
 137   if (!f)
 138     return 0L;
 139   if ((fgetc (f) == '#') && (fgetc (f) == '!'))
 140     {
 141       while (1)
 142         switch (c = fgetc (f))
 143           {
 144           case /*WHITE_SPACES */ ' ':
 145           case '\t':
 146           case '\r':
 147           case '\f':
 148           case EOF:
 149             tbuf[i] = 0;
 150             fclose (f);
 151             return scm_cat_path (0L, tbuf, 0L);
 152           default:
 153             tbuf[i++] = c;
 154             break;
 155           }
 156     }
 157   fclose (f);
 158   return scm_cat_path (0L, name, 0L);
 159 }
 160
 161
 162 /* Read a \nnn-style escape.  We've just read the backslash.  */
 163 static int
 164 script_get_octal (FILE *f)
 165 #define FUNC_NAME "script_get_octal"
 166 {
 167   int i;
 168   int value = 0;
 169
 170   for (i = 0; i < 3; i++)
 171     {
 172       int c = getc (f);
 173       if ('0' <= c && c <= '7')
 174         value = (value * 8) + (c - '0');
 175       else
 176         SCM_MISC_ERROR ("malformed script: bad octal backslash escape",
 177                         SCM_EOL);
 178     }
 179   return value;
 180 }
 181 #undef FUNC_NAME
 182
 183
 184 static int
 185 script_get_backslash (FILE *f)
 186 #define FUNC_NAME "script_get_backslash"
 187 {
 188   int c = getc (f);
 189
 190   switch (c)
 191     {
 192     case 'a': return '\a';
 193     case 'b': return '\b';
 194     case 'f': return '\f';
 195     case 'n': return '\n';
 196     case 'r': return '\r';
 197     case 't': return '\t';
 198     case 'v': return '\v';
 199
 200     case '\\':
 201     case ' ':
 202     case '\t':
 203     case '\n':
 204       return c;
 205
 206     case '0': case '1': case '2': case '3':
 207     case '4': case '5': case '6': case '7':
 208       ungetc (c, f);
 209       return script_get_octal (f);
 210
 211     case EOF:
 212       SCM_MISC_ERROR ("malformed script: backslash followed by EOF", SCM_EOL);
 213       return 0; /* not reached? */
 214
 215     default:
 216       SCM_MISC_ERROR ("malformed script: bad backslash sequence", SCM_EOL);
 217       return 0; /* not reached? */
 218     }
 219 }
 220 #undef FUNC_NAME
 221
 222
 223 static char *
 224 script_read_arg (FILE *f)
 225 #define FUNC_NAME "script_read_arg"
 226 {
 227   size_t size = 7;
 228   char *buf = scm_malloc (size + 1);
 229   size_t len = 0;
 230
 231   if (! buf)
 232     return 0;
 233
 234   for (;;)
 235     {
 236       int c = getc (f);
 237       switch (c)
 238         {
 239         case '\\':
 240           c = script_get_backslash (f);
 241           /* The above produces a new character to add to the argument.
 242              Fall through.  */
 243         default:
 244           if (len >= size)
 245             {
 246               size = (size + 1) * 2;
 247               buf = realloc (buf, size);
 248               if (! buf)
 249                 return 0;
 250             }
 251           buf[len++] = c;
 252           break;
 253
 254         case '\n':
 255           /* This may terminate an arg now, but it will terminate the
 256              entire list next time through.  */
 257           ungetc ('\n', f);
 258         case EOF:
 259           if (len == 0)
 260             {
 261               free (buf);
 262               return 0;
 263             }
 264           /* Otherwise, those characters terminate the argument; fall
 265              through.  */
 266         case ' ':
 267           buf[len] = '\0';
 268           return buf;
 269
 270         case '\t':
 271           free (buf);
 272           SCM_MISC_ERROR ("malformed script: TAB in meta-arguments", SCM_EOL);
 273           return 0; /* not reached? */
 274         }
 275     }
 276 }
 277 #undef FUNC_NAME
 278
 279
 280 static int
 281 script_meta_arg_P (char *arg)
 282 {
 283   if ('\\' != arg[0])
 284     return 0L;
 285 #ifdef MSDOS
 286   return !arg[1];
 287 #else
 288   switch (arg[1])
 289     {
 290     case 0:
 291     case '%':
 292     case WHITE_SPACES:
 293       return !0;
 294     default:
 295       return 0L;
 296     }
 297 #endif
 298 }
 299
 300 char **
 301 scm_get_meta_args (int argc, char **argv)
 302 {
 303   int nargc = argc, argi = 1, nargi = 1;
 304   char *narg, **nargv;
 305   if (!(argc > 2 && script_meta_arg_P (argv[1])))
 306     return 0L;
 307   if (!(nargv = (char **) scm_malloc ((1 + nargc) * sizeof (char *))))
 308       return 0L;
 309   nargv[0] = argv[0];
 310   while (((argi + 1) < argc) && (script_meta_arg_P (argv[argi])))
 311     {
 312       FILE *f = fopen (argv[++argi], "r");
 313       if (f)
 314         {
 315           nargc--;              /* to compensate for replacement of '\\' */
 316           while (1)
 317             switch (getc (f))
 318               {
 319               case EOF:
 320                 return 0L;
 321               default:
 322                 continue;
 323               case '\n':
 324                 goto found_args;
 325               }
 326         found_args:
 327           while ((narg = script_read_arg (f)))
 328             if (!(nargv = (char **) realloc (nargv,
 329                                              (1 + ++nargc) * sizeof (char *))))
 330                 return 0L;
 331             else
 332               nargv[nargi++] = narg;
 333           fclose (f);
 334           nargv[nargi++] = argv[argi++];
 335         }
 336     }
 337   while (argi <= argc)
 338     nargv[nargi++] = argv[argi++];
 339   return nargv;
 340 }
 341
 342 int
 343 scm_count_argv (char **argv)
 344 {
 345   int argc = 0;
 346   while (argv[argc])
 347     argc++;
 348   return argc;
 349 }
 350
 351
 352 /* For use in error messages.  */
 353 char *scm_usage_name = 0;
 354
 355 void
 356 scm_shell_usage (int fatal, char *message)
 357 {
 358   scm_call_3 (scm_c_private_ref ("ice-9 command-line",
 359                                  "shell-usage"),
 360               (scm_usage_name
 361                ? scm_from_locale_string (scm_usage_name)
 362                : scm_from_latin1_string ("guile")),
 363               scm_from_bool (fatal),
 364               (message
 365                ? scm_from_locale_string (message)
 366                : SCM_BOOL_F));
 367 }
 368
 369
 370 /* Given an array of command-line switches, return a Scheme expression
 371    to carry out the actions specified by the switches.
 372  */
 373
 374 SCM
 375 scm_compile_shell_switches (int argc, char **argv)
 376 {
 377   return scm_call_2 (scm_c_public_ref ("ice-9 command-line",
 378                                        "compile-shell-switches"),
 379                      scm_makfromstrs (argc, argv),
 380                      (scm_usage_name
 381                       ? scm_from_locale_string (scm_usage_name)
 382                       : scm_from_latin1_string ("guile")));
 383 }
 384
 385
 386 void
 387 scm_shell (int argc, char **argv)
 388 {
 389   /* If present, add SCSH-style meta-arguments from the top of the
 390      script file to the argument vector.  See the SCSH manual: "The
 391      meta argument" for more details.  */
 392   {
 393     char **new_argv = scm_get_meta_args (argc, argv);
 394
 395     if (new_argv)
 396       {
 397         argv = new_argv;
 398         argc = scm_count_argv (new_argv);
 399       }
 400   }
 401
 402   exit (scm_exit_status (scm_eval_x (scm_compile_shell_switches (argc, argv),
 403                                      scm_current_module ())));
 404 }
 405
 406
 407 void
 408 scm_init_script ()
 409 {
 410 #include "libguile/script.x"
 411 }
 412
 413 /*
 414   Local Variables:
 415   c-file-style: "gnu"
 416   End:
 417 */