| 1 | /* Copyright (C) 1994-1998, 2000-2011, 2013 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 <localcharset.h> |
| 26 | #include <stdlib.h> |
| 27 | #include <stdio.h> |
| 28 | #include <errno.h> |
| 29 | #include <ctype.h> |
| 30 | #include <uniconv.h> |
| 31 | |
| 32 | #include "libguile/_scm.h" |
| 33 | #include "libguile/eval.h" |
| 34 | #include "libguile/feature.h" |
| 35 | #include "libguile/load.h" |
| 36 | #include "libguile/read.h" |
| 37 | #include "libguile/script.h" |
| 38 | #include "libguile/strings.h" |
| 39 | #include "libguile/strports.h" |
| 40 | #include "libguile/validate.h" |
| 41 | #include "libguile/version.h" |
| 42 | #include "libguile/vm.h" |
| 43 | |
| 44 | #ifdef HAVE_STRING_H |
| 45 | #include <string.h> |
| 46 | #endif |
| 47 | |
| 48 | #ifdef HAVE_UNISTD_H |
| 49 | #include <unistd.h> /* for X_OK define */ |
| 50 | #endif |
| 51 | |
| 52 | #ifdef HAVE_IO_H |
| 53 | #include <io.h> |
| 54 | #endif |
| 55 | |
| 56 | /* Concatentate str2 onto str1 at position n and return concatenated |
| 57 | string if file exists; 0 otherwise. */ |
| 58 | |
| 59 | static char * |
| 60 | scm_cat_path (char *str1, const char *str2, long n) |
| 61 | { |
| 62 | if (!n) |
| 63 | n = strlen (str2); |
| 64 | if (str1) |
| 65 | { |
| 66 | size_t len = strlen (str1); |
| 67 | str1 = (char *) realloc (str1, (size_t) (len + n + 1)); |
| 68 | if (!str1) |
| 69 | return 0L; |
| 70 | strncat (str1 + len, str2, n); |
| 71 | return str1; |
| 72 | } |
| 73 | str1 = (char *) scm_malloc ((size_t) (n + 1)); |
| 74 | if (!str1) |
| 75 | return 0L; |
| 76 | str1[0] = 0; |
| 77 | strncat (str1, str2, n); |
| 78 | return str1; |
| 79 | } |
| 80 | |
| 81 | #if 0 |
| 82 | static char * |
| 83 | scm_try_path (char *path) |
| 84 | { |
| 85 | FILE *f; |
| 86 | /* fprintf(stderr, "Trying %s\n", path);fflush(stderr); */ |
| 87 | if (!path) |
| 88 | return 0L; |
| 89 | SCM_SYSCALL (f = fopen (path, "r"); |
| 90 | ); |
| 91 | if (f) |
| 92 | { |
| 93 | fclose (f); |
| 94 | return path; |
| 95 | } |
| 96 | free (path); |
| 97 | return 0L; |
| 98 | } |
| 99 | |
| 100 | static char * |
| 101 | scm_sep_init_try (char *path, const char *sep, const char *initname) |
| 102 | { |
| 103 | if (path) |
| 104 | path = scm_cat_path (path, sep, 0L); |
| 105 | if (path) |
| 106 | path = scm_cat_path (path, initname, 0L); |
| 107 | return scm_try_path (path); |
| 108 | } |
| 109 | #endif |
| 110 | |
| 111 | #ifndef LINE_INCREMENTORS |
| 112 | #define LINE_INCREMENTORS '\n' |
| 113 | #ifdef MSDOS |
| 114 | #define WHITE_SPACES ' ':case '\t':case '\r':case '\f':case 26 |
| 115 | #else |
| 116 | #define WHITE_SPACES ' ':case '\t':case '\r':case '\f' |
| 117 | #endif /* def MSDOS */ |
| 118 | #endif /* ndef LINE_INCREMENTORS */ |
| 119 | |
| 120 | #ifndef MAXPATHLEN |
| 121 | #define MAXPATHLEN 80 |
| 122 | #endif /* ndef MAXPATHLEN */ |
| 123 | #ifndef X_OK |
| 124 | #define X_OK 1 |
| 125 | #endif /* ndef X_OK */ |
| 126 | |
| 127 | char * |
| 128 | scm_find_executable (const char *name) |
| 129 | { |
| 130 | char tbuf[MAXPATHLEN]; |
| 131 | int i = 0, c; |
| 132 | FILE *f; |
| 133 | |
| 134 | /* fprintf(stderr, "s_f_e checking access %s ->%d\n", name, access(name, X_OK)); fflush(stderr); */ |
| 135 | if (access (name, X_OK)) |
| 136 | return 0L; |
| 137 | f = fopen (name, "r"); |
| 138 | if (!f) |
| 139 | return 0L; |
| 140 | if ((fgetc (f) == '#') && (fgetc (f) == '!')) |
| 141 | { |
| 142 | while (1) |
| 143 | switch (c = fgetc (f)) |
| 144 | { |
| 145 | case /*WHITE_SPACES */ ' ': |
| 146 | case '\t': |
| 147 | case '\r': |
| 148 | case '\f': |
| 149 | case EOF: |
| 150 | tbuf[i] = 0; |
| 151 | fclose (f); |
| 152 | return scm_cat_path (0L, tbuf, 0L); |
| 153 | default: |
| 154 | tbuf[i++] = c; |
| 155 | break; |
| 156 | } |
| 157 | } |
| 158 | fclose (f); |
| 159 | return scm_cat_path (0L, name, 0L); |
| 160 | } |
| 161 | |
| 162 | |
| 163 | /* Read a \nnn-style escape. We've just read the backslash. */ |
| 164 | static int |
| 165 | script_get_octal (FILE *f) |
| 166 | #define FUNC_NAME "script_get_octal" |
| 167 | { |
| 168 | int i; |
| 169 | int value = 0; |
| 170 | |
| 171 | for (i = 0; i < 3; i++) |
| 172 | { |
| 173 | int c = getc (f); |
| 174 | if ('0' <= c && c <= '7') |
| 175 | value = (value * 8) + (c - '0'); |
| 176 | else |
| 177 | SCM_MISC_ERROR ("malformed script: bad octal backslash escape", |
| 178 | SCM_EOL); |
| 179 | } |
| 180 | return value; |
| 181 | } |
| 182 | #undef FUNC_NAME |
| 183 | |
| 184 | |
| 185 | static int |
| 186 | script_get_backslash (FILE *f) |
| 187 | #define FUNC_NAME "script_get_backslash" |
| 188 | { |
| 189 | int c = getc (f); |
| 190 | |
| 191 | switch (c) |
| 192 | { |
| 193 | case 'a': return '\a'; |
| 194 | case 'b': return '\b'; |
| 195 | case 'f': return '\f'; |
| 196 | case 'n': return '\n'; |
| 197 | case 'r': return '\r'; |
| 198 | case 't': return '\t'; |
| 199 | case 'v': return '\v'; |
| 200 | |
| 201 | case '\\': |
| 202 | case ' ': |
| 203 | case '\t': |
| 204 | case '\n': |
| 205 | return c; |
| 206 | |
| 207 | case '0': case '1': case '2': case '3': |
| 208 | case '4': case '5': case '6': case '7': |
| 209 | ungetc (c, f); |
| 210 | return script_get_octal (f); |
| 211 | |
| 212 | case EOF: |
| 213 | SCM_MISC_ERROR ("malformed script: backslash followed by EOF", SCM_EOL); |
| 214 | return 0; /* not reached? */ |
| 215 | |
| 216 | default: |
| 217 | SCM_MISC_ERROR ("malformed script: bad backslash sequence", SCM_EOL); |
| 218 | return 0; /* not reached? */ |
| 219 | } |
| 220 | } |
| 221 | #undef FUNC_NAME |
| 222 | |
| 223 | |
| 224 | static char * |
| 225 | script_read_arg (FILE *f) |
| 226 | #define FUNC_NAME "script_read_arg" |
| 227 | { |
| 228 | size_t size = 7; |
| 229 | char *buf = scm_malloc (size + 1); |
| 230 | size_t len = 0; |
| 231 | |
| 232 | if (! buf) |
| 233 | return 0; |
| 234 | |
| 235 | for (;;) |
| 236 | { |
| 237 | int c = getc (f); |
| 238 | switch (c) |
| 239 | { |
| 240 | case '\\': |
| 241 | c = script_get_backslash (f); |
| 242 | /* The above produces a new character to add to the argument. |
| 243 | Fall through. */ |
| 244 | default: |
| 245 | if (len >= size) |
| 246 | { |
| 247 | size = (size + 1) * 2; |
| 248 | buf = realloc (buf, size); |
| 249 | if (! buf) |
| 250 | return 0; |
| 251 | } |
| 252 | buf[len++] = c; |
| 253 | break; |
| 254 | |
| 255 | case '\n': |
| 256 | /* This may terminate an arg now, but it will terminate the |
| 257 | entire list next time through. */ |
| 258 | ungetc ('\n', f); |
| 259 | case EOF: |
| 260 | if (len == 0) |
| 261 | { |
| 262 | free (buf); |
| 263 | return 0; |
| 264 | } |
| 265 | /* Otherwise, those characters terminate the argument; fall |
| 266 | through. */ |
| 267 | case ' ': |
| 268 | buf[len] = '\0'; |
| 269 | return buf; |
| 270 | |
| 271 | case '\t': |
| 272 | free (buf); |
| 273 | SCM_MISC_ERROR ("malformed script: TAB in meta-arguments", SCM_EOL); |
| 274 | return 0; /* not reached? */ |
| 275 | } |
| 276 | } |
| 277 | } |
| 278 | #undef FUNC_NAME |
| 279 | |
| 280 | |
| 281 | static int |
| 282 | script_meta_arg_P (char *arg) |
| 283 | { |
| 284 | if ('\\' != arg[0]) |
| 285 | return 0L; |
| 286 | #ifdef MSDOS |
| 287 | return !arg[1]; |
| 288 | #else |
| 289 | switch (arg[1]) |
| 290 | { |
| 291 | case 0: |
| 292 | case '%': |
| 293 | case WHITE_SPACES: |
| 294 | return !0; |
| 295 | default: |
| 296 | return 0L; |
| 297 | } |
| 298 | #endif |
| 299 | } |
| 300 | |
| 301 | char ** |
| 302 | scm_get_meta_args (int argc, char **argv) |
| 303 | { |
| 304 | int nargc = argc, argi = 1, nargi = 1; |
| 305 | char *narg, **nargv; |
| 306 | if (!(argc > 2 && script_meta_arg_P (argv[1]))) |
| 307 | return 0L; |
| 308 | if (!(nargv = (char **) scm_malloc ((1 + nargc) * sizeof (char *)))) |
| 309 | return 0L; |
| 310 | nargv[0] = argv[0]; |
| 311 | while (((argi + 1) < argc) && (script_meta_arg_P (argv[argi]))) |
| 312 | { |
| 313 | FILE *f = fopen (argv[++argi], "r"); |
| 314 | if (f) |
| 315 | { |
| 316 | nargc--; /* to compensate for replacement of '\\' */ |
| 317 | while (1) |
| 318 | switch (getc (f)) |
| 319 | { |
| 320 | case EOF: |
| 321 | free (nargv); |
| 322 | return 0L; |
| 323 | default: |
| 324 | continue; |
| 325 | case '\n': |
| 326 | goto found_args; |
| 327 | } |
| 328 | found_args: |
| 329 | /* FIXME: we leak the result of calling script_read_arg. */ |
| 330 | while ((narg = script_read_arg (f))) |
| 331 | if (!(nargv = (char **) realloc (nargv, |
| 332 | (1 + ++nargc) * sizeof (char *)))) |
| 333 | return 0L; |
| 334 | else |
| 335 | nargv[nargi++] = narg; |
| 336 | fclose (f); |
| 337 | nargv[nargi++] = argv[argi++]; |
| 338 | } |
| 339 | } |
| 340 | while (argi <= argc) |
| 341 | nargv[nargi++] = argv[argi++]; |
| 342 | return nargv; |
| 343 | } |
| 344 | |
| 345 | int |
| 346 | scm_count_argv (char **argv) |
| 347 | { |
| 348 | int argc = 0; |
| 349 | while (argv[argc]) |
| 350 | argc++; |
| 351 | return argc; |
| 352 | } |
| 353 | |
| 354 | |
| 355 | /* For use in error messages. */ |
| 356 | char *scm_usage_name = 0; |
| 357 | |
| 358 | void |
| 359 | scm_shell_usage (int fatal, char *message) |
| 360 | { |
| 361 | scm_call_3 (scm_c_private_ref ("ice-9 command-line", |
| 362 | "shell-usage"), |
| 363 | (scm_usage_name |
| 364 | ? scm_from_locale_string (scm_usage_name) |
| 365 | : scm_from_latin1_string ("guile")), |
| 366 | scm_from_bool (fatal), |
| 367 | (message |
| 368 | ? scm_from_locale_string (message) |
| 369 | : SCM_BOOL_F)); |
| 370 | } |
| 371 | |
| 372 | /* Return a list of strings from ARGV, which contains ARGC strings |
| 373 | assumed to be encoded in the current locale. Use |
| 374 | `environ_locale_charset' instead of relying on |
| 375 | `scm_from_locale_string' because the user hasn't had a change to call |
| 376 | (setlocale LC_ALL "") yet. |
| 377 | |
| 378 | XXX: This hack is for 2.0 and will be removed in the next stable |
| 379 | series where the `setlocale' call will be implicit. See |
| 380 | <http://lists.gnu.org/archive/html/guile-devel/2011-11/msg00040.html> |
| 381 | for details. */ |
| 382 | static SCM |
| 383 | locale_arguments_to_string_list (int argc, char **const argv) |
| 384 | { |
| 385 | int i; |
| 386 | SCM lst; |
| 387 | const char *encoding; |
| 388 | |
| 389 | encoding = environ_locale_charset (); |
| 390 | for (i = argc - 1, lst = SCM_EOL; |
| 391 | i >= 0; |
| 392 | i--) |
| 393 | lst = scm_cons (scm_from_stringn (argv[i], (size_t) -1, encoding, |
| 394 | SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE), |
| 395 | lst); |
| 396 | |
| 397 | return lst; |
| 398 | } |
| 399 | |
| 400 | /* Set the value returned by `program-arguments', given ARGC and ARGV. */ |
| 401 | void |
| 402 | scm_i_set_boot_program_arguments (int argc, char *argv[]) |
| 403 | { |
| 404 | scm_fluid_set_x (scm_program_arguments_fluid, |
| 405 | locale_arguments_to_string_list (argc, argv)); |
| 406 | } |
| 407 | |
| 408 | /* Given an array of command-line switches, return a Scheme expression |
| 409 | to carry out the actions specified by the switches. |
| 410 | */ |
| 411 | |
| 412 | SCM |
| 413 | scm_compile_shell_switches (int argc, char **argv) |
| 414 | { |
| 415 | return scm_call_2 (scm_c_public_ref ("ice-9 command-line", |
| 416 | "compile-shell-switches"), |
| 417 | locale_arguments_to_string_list (argc, argv), |
| 418 | (scm_usage_name |
| 419 | ? scm_from_locale_string (scm_usage_name) |
| 420 | : scm_from_latin1_string ("guile"))); |
| 421 | } |
| 422 | |
| 423 | |
| 424 | void |
| 425 | scm_shell (int argc, char **argv) |
| 426 | { |
| 427 | /* If present, add SCSH-style meta-arguments from the top of the |
| 428 | script file to the argument vector. See the SCSH manual: "The |
| 429 | meta argument" for more details. */ |
| 430 | { |
| 431 | char **new_argv = scm_get_meta_args (argc, argv); |
| 432 | |
| 433 | if (new_argv) |
| 434 | { |
| 435 | argv = new_argv; |
| 436 | argc = scm_count_argv (new_argv); |
| 437 | } |
| 438 | } |
| 439 | |
| 440 | exit (scm_exit_status (scm_eval_x (scm_compile_shell_switches (argc, argv), |
| 441 | scm_current_module ()))); |
| 442 | } |
| 443 | |
| 444 | |
| 445 | void |
| 446 | scm_init_script () |
| 447 | { |
| 448 | #include "libguile/script.x" |
| 449 | } |
| 450 | |
| 451 | /* |
| 452 | Local Variables: |
| 453 | c-file-style: "gnu" |
| 454 | End: |
| 455 | */ |