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