1 /* Copyright (C) 1994-1998, 2000-2011, 2013, 2014 Free Software Foundation, Inc.
3 * This library is free software; you can redistribute it and/or
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.
8 * This library is distributed in the hope that it will be useful, but
9 * WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
11 * Lesser General Public License for more details.
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
15 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
19 /* "script.c" argv tricks for `#!' scripts.
20 Authors: Aubrey Jaffer and Jim Blandy */
26 #include <localcharset.h>
33 #include "libguile/_scm.h"
34 #include "libguile/eval.h"
35 #include "libguile/feature.h"
36 #include "libguile/load.h"
37 #include "libguile/read.h"
38 #include "libguile/script.h"
39 #include "libguile/strings.h"
40 #include "libguile/strports.h"
41 #include "libguile/validate.h"
42 #include "libguile/version.h"
43 #include "libguile/vm.h"
49 #include <unistd.h> /* for X_OK define */
55 /* Concatentate str2 onto str1 at position n and return concatenated
56 string if file exists; 0 otherwise. */
59 scm_cat_path (char *str1
, const char *str2
, long n
)
65 size_t len
= strlen (str1
);
66 str1
= (char *) realloc (str1
, (size_t) (len
+ n
+ 1));
69 strncat (str1
+ len
, str2
, n
);
72 str1
= (char *) scm_malloc ((size_t) (n
+ 1));
76 strncat (str1
, str2
, n
);
82 scm_try_path (char *path
)
85 /* fprintf(stderr, "Trying %s\n", path);fflush(stderr); */
88 SCM_SYSCALL (f
= fopen (path
, "r");
100 scm_sep_init_try (char *path
, const char *sep
, const char *initname
)
103 path
= scm_cat_path (path
, sep
, 0L);
105 path
= scm_cat_path (path
, initname
, 0L);
106 return scm_try_path (path
);
110 #ifndef LINE_INCREMENTORS
111 #define LINE_INCREMENTORS '\n'
113 #define WHITE_SPACES ' ':case '\t':case '\r':case '\f':case 26
115 #define WHITE_SPACES ' ':case '\t':case '\r':case '\f'
116 #endif /* def MSDOS */
117 #endif /* ndef LINE_INCREMENTORS */
120 #define MAXPATHLEN 80
121 #endif /* ndef MAXPATHLEN */
124 #endif /* ndef X_OK */
127 scm_find_executable (const char *name
)
129 char tbuf
[MAXPATHLEN
];
133 /* fprintf(stderr, "s_f_e checking access %s ->%d\n", name, access(name, X_OK)); fflush(stderr); */
134 if (access (name
, X_OK
))
136 f
= fopen (name
, "r");
139 if ((fgetc (f
) == '#') && (fgetc (f
) == '!'))
142 switch (c
= fgetc (f
))
144 case /*WHITE_SPACES */ ' ':
151 return scm_cat_path (0L, tbuf
, 0L);
158 return scm_cat_path (0L, name
, 0L);
162 /* Read a \nnn-style escape. We've just read the backslash. */
164 script_get_octal (FILE *f
)
165 #define FUNC_NAME "script_get_octal"
170 for (i
= 0; i
< 3; i
++)
173 if ('0' <= c
&& c
<= '7')
174 value
= (value
* 8) + (c
- '0');
176 SCM_MISC_ERROR ("malformed script: bad octal backslash escape",
185 script_get_backslash (FILE *f
)
186 #define FUNC_NAME "script_get_backslash"
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';
206 case '0': case '1': case '2': case '3':
207 case '4': case '5': case '6': case '7':
209 return script_get_octal (f
);
212 SCM_MISC_ERROR ("malformed script: backslash followed by EOF", SCM_EOL
);
213 return 0; /* not reached? */
216 SCM_MISC_ERROR ("malformed script: bad backslash sequence", SCM_EOL
);
217 return 0; /* not reached? */
223 * Like `realloc', but free memory on failure;
224 * unlike `scm_realloc', return NULL, not aborts.
227 realloc0 (void *ptr
, size_t size
)
229 void *new_ptr
= realloc (ptr
, size
);
239 script_read_arg (FILE *f
)
240 #define FUNC_NAME "script_read_arg"
243 char *buf
= scm_malloc (size
+ 1);
255 c
= script_get_backslash (f
);
256 /* The above produces a new character to add to the argument.
261 size
= (size
+ 1) * 2;
262 buf
= realloc0 (buf
, size
);
270 /* This may terminate an arg now, but it will terminate the
271 entire list next time through. */
279 /* Otherwise, those characters terminate the argument; fall
287 SCM_MISC_ERROR ("malformed script: TAB in meta-arguments", SCM_EOL
);
288 return 0; /* not reached? */
296 script_meta_arg_P (char *arg
)
316 scm_get_meta_args (int argc
, char **argv
)
318 int nargc
= argc
, argi
= 1, nargi
= 1;
320 if (!(argc
> 2 && script_meta_arg_P (argv
[1])))
322 if (!(nargv
= (char **) scm_malloc ((1 + nargc
) * sizeof (char *))))
325 while (((argi
+ 1) < argc
) && (script_meta_arg_P (argv
[argi
])))
327 FILE *f
= fopen (argv
[++argi
], "r");
330 nargc
--; /* to compensate for replacement of '\\' */
343 /* FIXME: we leak the result of calling script_read_arg. */
344 while ((narg
= script_read_arg (f
)))
345 if (!(nargv
= (char **) realloc0 (nargv
,
346 (1 + ++nargc
) * sizeof (char *))))
349 nargv
[nargi
++] = narg
;
351 nargv
[nargi
++] = argv
[argi
++];
355 nargv
[nargi
++] = argv
[argi
++];
360 scm_count_argv (char **argv
)
369 /* For use in error messages. */
370 char *scm_usage_name
= 0;
373 scm_shell_usage (int fatal
, char *message
)
375 scm_call_3 (scm_c_private_ref ("ice-9 command-line",
378 ? scm_from_locale_string (scm_usage_name
)
379 : scm_from_latin1_string ("guile")),
380 scm_from_bool (fatal
),
382 ? scm_from_locale_string (message
)
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.
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>
397 locale_arguments_to_string_list (int argc
, char **const argv
)
401 const char *encoding
;
403 encoding
= environ_locale_charset ();
404 for (i
= argc
- 1, lst
= SCM_EOL
;
407 lst
= scm_cons (scm_from_stringn (argv
[i
], (size_t) -1, encoding
,
408 SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE
),
414 /* Set the value returned by `program-arguments', given ARGC and ARGV. */
416 scm_i_set_boot_program_arguments (int argc
, char *argv
[])
418 scm_fluid_set_x (scm_program_arguments_fluid
,
419 locale_arguments_to_string_list (argc
, argv
));
422 /* Given an array of command-line switches, return a Scheme expression
423 to carry out the actions specified by the switches.
427 scm_compile_shell_switches (int argc
, char **argv
)
429 return scm_call_2 (scm_c_public_ref ("ice-9 command-line",
430 "compile-shell-switches"),
431 locale_arguments_to_string_list (argc
, argv
),
433 ? scm_from_locale_string (scm_usage_name
)
434 : scm_from_latin1_string ("guile")));
439 scm_shell (int argc
, char **argv
)
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. */
445 char **new_argv
= scm_get_meta_args (argc
, argv
);
450 argc
= scm_count_argv (new_argv
);
454 exit (scm_exit_status (scm_eval_x (scm_compile_shell_switches (argc
, argv
),
455 scm_current_module ())));
462 #include "libguile/script.x"