Commit | Line | Data |
---|---|---|
87fc4596 | 1 | /* Copyright (C) 1994-1998, 2000-2011, 2013 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" |
89bc270d | 36 | #include "libguile/read.h" |
a0599745 | 37 | #include "libguile/script.h" |
89bc270d HWN |
38 | #include "libguile/strings.h" |
39 | #include "libguile/strports.h" | |
40 | #include "libguile/validate.h" | |
41 | #include "libguile/version.h" | |
97b18a66 | 42 | #include "libguile/vm.h" |
224c49f9 | 43 | |
bd9e24b3 GH |
44 | #ifdef HAVE_STRING_H |
45 | #include <string.h> | |
46 | #endif | |
47 | ||
d3be4a7a | 48 | #ifdef HAVE_UNISTD_H |
224c49f9 | 49 | #include <unistd.h> /* for X_OK define */ |
224c49f9 JB |
50 | #endif |
51 | ||
7beabedb MG |
52 | #ifdef HAVE_IO_H |
53 | #include <io.h> | |
54 | #endif | |
55 | ||
224c49f9 JB |
56 | /* Concatentate str2 onto str1 at position n and return concatenated |
57 | string if file exists; 0 otherwise. */ | |
58 | ||
59 | static char * | |
6e8d25a6 | 60 | scm_cat_path (char *str1, const char *str2, long n) |
224c49f9 JB |
61 | { |
62 | if (!n) | |
63 | n = strlen (str2); | |
64 | if (str1) | |
65 | { | |
1be6b49c ML |
66 | size_t len = strlen (str1); |
67 | str1 = (char *) realloc (str1, (size_t) (len + n + 1)); | |
224c49f9 JB |
68 | if (!str1) |
69 | return 0L; | |
70 | strncat (str1 + len, str2, n); | |
71 | return str1; | |
72 | } | |
67329a9e | 73 | str1 = (char *) scm_malloc ((size_t) (n + 1)); |
224c49f9 JB |
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 * | |
6e8d25a6 | 83 | scm_try_path (char *path) |
224c49f9 JB |
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 * | |
6e8d25a6 | 101 | scm_sep_init_try (char *path, const char *sep, const char *initname) |
224c49f9 JB |
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 | ||
224c49f9 | 127 | char * |
d3be4a7a | 128 | scm_find_executable (const char *name) |
224c49f9 JB |
129 | { |
130 | char tbuf[MAXPATHLEN]; | |
d9c36d2a | 131 | int i = 0, c; |
224c49f9 JB |
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) | |
d9c36d2a | 143 | switch (c = fgetc (f)) |
224c49f9 JB |
144 | { |
145 | case /*WHITE_SPACES */ ' ': | |
146 | case '\t': | |
147 | case '\r': | |
148 | case '\f': | |
149 | case EOF: | |
d9c36d2a | 150 | tbuf[i] = 0; |
224c49f9 JB |
151 | fclose (f); |
152 | return scm_cat_path (0L, tbuf, 0L); | |
d9c36d2a MV |
153 | default: |
154 | tbuf[i++] = c; | |
155 | break; | |
224c49f9 JB |
156 | } |
157 | } | |
158 | fclose (f); | |
159 | return scm_cat_path (0L, name, 0L); | |
160 | } | |
224c49f9 | 161 | |
224c49f9 JB |
162 | |
163 | /* Read a \nnn-style escape. We've just read the backslash. */ | |
164 | static int | |
6e8d25a6 | 165 | script_get_octal (FILE *f) |
db4b4ca6 | 166 | #define FUNC_NAME "script_get_octal" |
224c49f9 JB |
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 | |
db4b4ca6 DH |
177 | SCM_MISC_ERROR ("malformed script: bad octal backslash escape", |
178 | SCM_EOL); | |
224c49f9 JB |
179 | } |
180 | return value; | |
181 | } | |
db4b4ca6 | 182 | #undef FUNC_NAME |
224c49f9 JB |
183 | |
184 | ||
185 | static int | |
6e8d25a6 | 186 | script_get_backslash (FILE *f) |
db4b4ca6 | 187 | #define FUNC_NAME "script_get_backslash" |
224c49f9 JB |
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); | |
db4b4ca6 | 211 | |
224c49f9 | 212 | case EOF: |
db4b4ca6 | 213 | SCM_MISC_ERROR ("malformed script: backslash followed by EOF", SCM_EOL); |
224c49f9 JB |
214 | return 0; /* not reached? */ |
215 | ||
216 | default: | |
db4b4ca6 | 217 | SCM_MISC_ERROR ("malformed script: bad backslash sequence", SCM_EOL); |
224c49f9 JB |
218 | return 0; /* not reached? */ |
219 | } | |
220 | } | |
db4b4ca6 | 221 | #undef FUNC_NAME |
224c49f9 JB |
222 | |
223 | ||
224 | static char * | |
6e8d25a6 | 225 | script_read_arg (FILE *f) |
db4b4ca6 | 226 | #define FUNC_NAME "script_read_arg" |
224c49f9 | 227 | { |
1be6b49c | 228 | size_t size = 7; |
67329a9e | 229 | char *buf = scm_malloc (size + 1); |
1be6b49c | 230 | size_t len = 0; |
224c49f9 JB |
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); | |
db4b4ca6 | 273 | SCM_MISC_ERROR ("malformed script: TAB in meta-arguments", SCM_EOL); |
224c49f9 JB |
274 | return 0; /* not reached? */ |
275 | } | |
276 | } | |
277 | } | |
db4b4ca6 | 278 | #undef FUNC_NAME |
224c49f9 JB |
279 | |
280 | ||
281 | static int | |
6e8d25a6 | 282 | script_meta_arg_P (char *arg) |
224c49f9 JB |
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 ** | |
6e8d25a6 | 302 | scm_get_meta_args (int argc, char **argv) |
224c49f9 JB |
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; | |
67329a9e | 308 | if (!(nargv = (char **) scm_malloc ((1 + nargc) * sizeof (char *)))) |
224c49f9 JB |
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: | |
2700aa43 | 321 | free (nargv); |
224c49f9 JB |
322 | return 0L; |
323 | default: | |
324 | continue; | |
325 | case '\n': | |
326 | goto found_args; | |
327 | } | |
328 | found_args: | |
2700aa43 | 329 | /* FIXME: we leak the result of calling script_read_arg. */ |
224c49f9 JB |
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 | |
6e8d25a6 | 346 | scm_count_argv (char **argv) |
224c49f9 JB |
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 | { | |
1693983a AW |
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)); | |
224c49f9 JB |
370 | } |
371 | ||
ed4c3739 LC |
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 | } | |
224c49f9 | 407 | |
224c49f9 JB |
408 | /* Given an array of command-line switches, return a Scheme expression |
409 | to carry out the actions specified by the switches. | |
ac16426b | 410 | */ |
224c49f9 JB |
411 | |
412 | SCM | |
413 | scm_compile_shell_switches (int argc, char **argv) | |
414 | { | |
1693983a AW |
415 | return scm_call_2 (scm_c_public_ref ("ice-9 command-line", |
416 | "compile-shell-switches"), | |
ed4c3739 | 417 | locale_arguments_to_string_list (argc, argv), |
1693983a AW |
418 | (scm_usage_name |
419 | ? scm_from_locale_string (scm_usage_name) | |
420 | : scm_from_latin1_string ("guile"))); | |
224c49f9 JB |
421 | } |
422 | ||
423 | ||
424 | void | |
6e8d25a6 | 425 | scm_shell (int argc, char **argv) |
224c49f9 JB |
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 | ||
b3138544 | 440 | exit (scm_exit_status (scm_eval_x (scm_compile_shell_switches (argc, argv), |
deec8fc2 | 441 | scm_current_module ()))); |
224c49f9 JB |
442 | } |
443 | ||
444 | ||
445 | void | |
446 | scm_init_script () | |
447 | { | |
a0599745 | 448 | #include "libguile/script.x" |
224c49f9 | 449 | } |
89e00824 ML |
450 | |
451 | /* | |
452 | Local Variables: | |
453 | c-file-style: "gnu" | |
454 | End: | |
455 | */ |