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