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 | |
93003b16 | 25 | #include <stdlib.h> |
224c49f9 | 26 | #include <stdio.h> |
e6e2e95a | 27 | #include <errno.h> |
224c49f9 | 28 | #include <ctype.h> |
e6e2e95a | 29 | |
a0599745 | 30 | #include "libguile/_scm.h" |
89bc270d HWN |
31 | #include "libguile/eval.h" |
32 | #include "libguile/feature.h" | |
a0599745 | 33 | #include "libguile/load.h" |
ee001750 | 34 | #include "libguile/private-gc.h" /* scm_getenv_int */ |
89bc270d | 35 | #include "libguile/read.h" |
a0599745 | 36 | #include "libguile/script.h" |
89bc270d HWN |
37 | #include "libguile/strings.h" |
38 | #include "libguile/strports.h" | |
39 | #include "libguile/validate.h" | |
40 | #include "libguile/version.h" | |
97b18a66 | 41 | #include "libguile/vm.h" |
224c49f9 | 42 | |
bd9e24b3 GH |
43 | #ifdef HAVE_STRING_H |
44 | #include <string.h> | |
45 | #endif | |
46 | ||
d3be4a7a | 47 | #ifdef HAVE_UNISTD_H |
224c49f9 | 48 | #include <unistd.h> /* for X_OK define */ |
224c49f9 JB |
49 | #endif |
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 JB |
221 | |
222 | ||
223 | static char * | |
6e8d25a6 | 224 | script_read_arg (FILE *f) |
db4b4ca6 | 225 | #define FUNC_NAME "script_read_arg" |
224c49f9 | 226 | { |
1be6b49c | 227 | size_t size = 7; |
67329a9e | 228 | char *buf = scm_malloc (size + 1); |
1be6b49c | 229 | size_t len = 0; |
224c49f9 JB |
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); | |
db4b4ca6 | 272 | SCM_MISC_ERROR ("malformed script: TAB in meta-arguments", SCM_EOL); |
224c49f9 JB |
273 | return 0; /* not reached? */ |
274 | } | |
275 | } | |
276 | } | |
db4b4ca6 | 277 | #undef FUNC_NAME |
224c49f9 JB |
278 | |
279 | ||
280 | static int | |
6e8d25a6 | 281 | script_meta_arg_P (char *arg) |
224c49f9 JB |
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 ** | |
6e8d25a6 | 301 | scm_get_meta_args (int argc, char **argv) |
224c49f9 JB |
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; | |
67329a9e | 307 | if (!(nargv = (char **) scm_malloc ((1 + nargc) * sizeof (char *)))) |
224c49f9 JB |
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 | |
6e8d25a6 | 343 | scm_count_argv (char **argv) |
224c49f9 JB |
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 | { | |
1693983a AW |
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)); | |
224c49f9 JB |
367 | } |
368 | ||
369 | ||
224c49f9 JB |
370 | /* Given an array of command-line switches, return a Scheme expression |
371 | to carry out the actions specified by the switches. | |
ac16426b | 372 | */ |
224c49f9 JB |
373 | |
374 | SCM | |
375 | scm_compile_shell_switches (int argc, char **argv) | |
376 | { | |
1693983a AW |
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"))); | |
224c49f9 JB |
383 | } |
384 | ||
385 | ||
386 | void | |
6e8d25a6 | 387 | scm_shell (int argc, char **argv) |
224c49f9 JB |
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 | ||
b3138544 | 402 | exit (scm_exit_status (scm_eval_x (scm_compile_shell_switches (argc, argv), |
deec8fc2 | 403 | scm_current_module ()))); |
224c49f9 JB |
404 | } |
405 | ||
406 | ||
407 | void | |
408 | scm_init_script () | |
409 | { | |
a0599745 | 410 | #include "libguile/script.x" |
224c49f9 | 411 | } |
89e00824 ML |
412 | |
413 | /* | |
414 | Local Variables: | |
415 | c-file-style: "gnu" | |
416 | End: | |
417 | */ |