| 1 | /* Copyright (C) 1995,1996,1998,1999,2000,2001, 2004 Free Software Foundation, Inc. |
| 2 | * |
| 3 | * This library is free software; you can redistribute it and/or |
| 4 | * modify it under the terms of the GNU Lesser General Public |
| 5 | * License as published by the Free Software Foundation; either |
| 6 | * version 2.1 of the License, or (at your option) any later version. |
| 7 | * |
| 8 | * This library is distributed in the hope that it will be useful, |
| 9 | * but 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. |
| 12 | * |
| 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 02110-1301 USA |
| 16 | */ |
| 17 | |
| 18 | |
| 19 | \f |
| 20 | |
| 21 | #if HAVE_CONFIG_H |
| 22 | # include <config.h> |
| 23 | #endif |
| 24 | |
| 25 | #include <string.h> |
| 26 | #include <stdio.h> |
| 27 | |
| 28 | #include "libguile/_scm.h" |
| 29 | #include "libguile/libpath.h" |
| 30 | #include "libguile/fports.h" |
| 31 | #include "libguile/read.h" |
| 32 | #include "libguile/eval.h" |
| 33 | #include "libguile/throw.h" |
| 34 | #include "libguile/alist.h" |
| 35 | #include "libguile/dynwind.h" |
| 36 | #include "libguile/root.h" |
| 37 | #include "libguile/strings.h" |
| 38 | #include "libguile/modules.h" |
| 39 | #include "libguile/lang.h" |
| 40 | #include "libguile/chars.h" |
| 41 | #include "libguile/srfi-13.h" |
| 42 | |
| 43 | #include "libguile/validate.h" |
| 44 | #include "libguile/load.h" |
| 45 | #include "libguile/fluids.h" |
| 46 | |
| 47 | #include <sys/types.h> |
| 48 | #include <sys/stat.h> |
| 49 | |
| 50 | #ifdef HAVE_UNISTD_H |
| 51 | #include <unistd.h> |
| 52 | #endif /* HAVE_UNISTD_H */ |
| 53 | |
| 54 | #ifndef R_OK |
| 55 | #define R_OK 4 |
| 56 | #endif |
| 57 | |
| 58 | \f |
| 59 | /* Loading a file, given an absolute filename. */ |
| 60 | |
| 61 | /* Hook to run when we load a file, perhaps to announce the fact somewhere. |
| 62 | Applied to the full name of the file. */ |
| 63 | static SCM *scm_loc_load_hook; |
| 64 | |
| 65 | /* The current reader (a fluid). */ |
| 66 | static SCM the_reader = SCM_BOOL_F; |
| 67 | static size_t the_reader_fluid_num = 0; |
| 68 | |
| 69 | SCM_DEFINE (scm_primitive_load, "primitive-load", 1, 0, 0, |
| 70 | (SCM filename), |
| 71 | "Load the file named @var{filename} and evaluate its contents in\n" |
| 72 | "the top-level environment. The load paths are not searched;\n" |
| 73 | "@var{filename} must either be a full pathname or be a pathname\n" |
| 74 | "relative to the current directory. If the variable\n" |
| 75 | "@code{%load-hook} is defined, it should be bound to a procedure\n" |
| 76 | "that will be called before any code is loaded. See the\n" |
| 77 | "documentation for @code{%load-hook} later in this section.") |
| 78 | #define FUNC_NAME s_scm_primitive_load |
| 79 | { |
| 80 | SCM hook = *scm_loc_load_hook; |
| 81 | SCM_VALIDATE_STRING (1, filename); |
| 82 | if (scm_is_true (hook) && scm_is_false (scm_procedure_p (hook))) |
| 83 | SCM_MISC_ERROR ("value of %load-hook is neither a procedure nor #f", |
| 84 | SCM_EOL); |
| 85 | |
| 86 | if (!scm_is_false (hook)) |
| 87 | scm_call_1 (hook, filename); |
| 88 | |
| 89 | { /* scope */ |
| 90 | SCM port = scm_open_file (filename, scm_from_locale_string ("r")); |
| 91 | scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE); |
| 92 | scm_i_dynwind_current_load_port (port); |
| 93 | |
| 94 | while (1) |
| 95 | { |
| 96 | SCM reader, form; |
| 97 | |
| 98 | /* Lookup and use the current reader to read the next |
| 99 | expression. */ |
| 100 | reader = SCM_FAST_FLUID_REF (the_reader_fluid_num); |
| 101 | if (reader == SCM_BOOL_F) |
| 102 | form = scm_read (port); |
| 103 | else |
| 104 | form = scm_call_1 (reader, port); |
| 105 | |
| 106 | if (SCM_EOF_OBJECT_P (form)) |
| 107 | break; |
| 108 | |
| 109 | scm_primitive_eval_x (form); |
| 110 | } |
| 111 | |
| 112 | scm_dynwind_end (); |
| 113 | scm_close_port (port); |
| 114 | } |
| 115 | return SCM_UNSPECIFIED; |
| 116 | } |
| 117 | #undef FUNC_NAME |
| 118 | |
| 119 | SCM |
| 120 | scm_c_primitive_load (const char *filename) |
| 121 | { |
| 122 | return scm_primitive_load (scm_from_locale_string (filename)); |
| 123 | } |
| 124 | |
| 125 | \f |
| 126 | /* Builtin path to scheme library files. */ |
| 127 | #ifdef SCM_PKGDATA_DIR |
| 128 | SCM_DEFINE (scm_sys_package_data_dir, "%package-data-dir", 0, 0, 0, |
| 129 | (), |
| 130 | "Return the name of the directory where Scheme packages, modules and\n" |
| 131 | "libraries are kept. On most Unix systems, this will be\n" |
| 132 | "@samp{/usr/local/share/guile}.") |
| 133 | #define FUNC_NAME s_scm_sys_package_data_dir |
| 134 | { |
| 135 | return scm_from_locale_string (SCM_PKGDATA_DIR); |
| 136 | } |
| 137 | #undef FUNC_NAME |
| 138 | #endif /* SCM_PKGDATA_DIR */ |
| 139 | |
| 140 | #ifdef SCM_LIBRARY_DIR |
| 141 | SCM_DEFINE (scm_sys_library_dir, "%library-dir", 0,0,0, |
| 142 | (), |
| 143 | "Return the directory where the Guile Scheme library files are installed.\n" |
| 144 | "E.g., may return \"/usr/share/guile/1.3.5\".") |
| 145 | #define FUNC_NAME s_scm_sys_library_dir |
| 146 | { |
| 147 | return scm_from_locale_string (SCM_LIBRARY_DIR); |
| 148 | } |
| 149 | #undef FUNC_NAME |
| 150 | #endif /* SCM_LIBRARY_DIR */ |
| 151 | |
| 152 | #ifdef SCM_SITE_DIR |
| 153 | SCM_DEFINE (scm_sys_site_dir, "%site-dir", 0,0,0, |
| 154 | (), |
| 155 | "Return the directory where the Guile site files are installed.\n" |
| 156 | "E.g., may return \"/usr/share/guile/site\".") |
| 157 | #define FUNC_NAME s_scm_sys_site_dir |
| 158 | { |
| 159 | return scm_from_locale_string (SCM_SITE_DIR); |
| 160 | } |
| 161 | #undef FUNC_NAME |
| 162 | #endif /* SCM_SITE_DIR */ |
| 163 | |
| 164 | |
| 165 | |
| 166 | \f |
| 167 | /* Initializing the load path, and searching it. */ |
| 168 | |
| 169 | /* List of names of directories we search for files to load. */ |
| 170 | static SCM *scm_loc_load_path; |
| 171 | |
| 172 | /* List of extensions we try adding to the filenames. */ |
| 173 | static SCM *scm_loc_load_extensions; |
| 174 | |
| 175 | |
| 176 | SCM_DEFINE (scm_parse_path, "parse-path", 1, 1, 0, |
| 177 | (SCM path, SCM tail), |
| 178 | "Parse @var{path}, which is expected to be a colon-separated\n" |
| 179 | "string, into a list and return the resulting list with\n" |
| 180 | "@var{tail} appended. If @var{path} is @code{#f}, @var{tail}\n" |
| 181 | "is returned.") |
| 182 | #define FUNC_NAME s_scm_parse_path |
| 183 | { |
| 184 | #ifdef __MINGW32__ |
| 185 | SCM sep = SCM_MAKE_CHAR (';'); |
| 186 | #else |
| 187 | SCM sep = SCM_MAKE_CHAR (':'); |
| 188 | #endif |
| 189 | |
| 190 | if (SCM_UNBNDP (tail)) |
| 191 | tail = SCM_EOL; |
| 192 | return (scm_is_false (path) |
| 193 | ? tail |
| 194 | : scm_append_x (scm_list_2 (scm_string_split (path, sep), tail))); |
| 195 | } |
| 196 | #undef FUNC_NAME |
| 197 | |
| 198 | |
| 199 | /* Initialize the global variable %load-path, given the value of the |
| 200 | SCM_SITE_DIR and SCM_LIBRARY_DIR preprocessor symbols and the |
| 201 | GUILE_LOAD_PATH environment variable. */ |
| 202 | void |
| 203 | scm_init_load_path () |
| 204 | { |
| 205 | char *env; |
| 206 | SCM path = SCM_EOL; |
| 207 | |
| 208 | #ifdef SCM_LIBRARY_DIR |
| 209 | path = scm_list_3 (scm_from_locale_string (SCM_SITE_DIR), |
| 210 | scm_from_locale_string (SCM_LIBRARY_DIR), |
| 211 | scm_from_locale_string (SCM_PKGDATA_DIR)); |
| 212 | #endif /* SCM_LIBRARY_DIR */ |
| 213 | |
| 214 | env = getenv ("GUILE_LOAD_PATH"); |
| 215 | if (env) |
| 216 | path = scm_parse_path (scm_from_locale_string (env), path); |
| 217 | |
| 218 | *scm_loc_load_path = path; |
| 219 | } |
| 220 | |
| 221 | SCM scm_listofnullstr; |
| 222 | |
| 223 | /* Utility functions for assembling C strings in a buffer. |
| 224 | */ |
| 225 | |
| 226 | struct stringbuf { |
| 227 | char *buf, *ptr; |
| 228 | size_t buf_len; |
| 229 | }; |
| 230 | |
| 231 | static void |
| 232 | stringbuf_free (void *data) |
| 233 | { |
| 234 | struct stringbuf *buf = (struct stringbuf *)data; |
| 235 | free (buf->buf); |
| 236 | } |
| 237 | |
| 238 | static void |
| 239 | stringbuf_grow (struct stringbuf *buf) |
| 240 | { |
| 241 | size_t ptroff = buf->ptr - buf->buf; |
| 242 | buf->buf_len *= 2; |
| 243 | buf->buf = scm_realloc (buf->buf, buf->buf_len); |
| 244 | buf->ptr = buf->buf + ptroff; |
| 245 | } |
| 246 | |
| 247 | static void |
| 248 | stringbuf_cat_locale_string (struct stringbuf *buf, SCM str) |
| 249 | { |
| 250 | size_t max_len = buf->buf_len - (buf->ptr - buf->buf) - 1; |
| 251 | size_t len = scm_to_locale_stringbuf (str, buf->ptr, max_len); |
| 252 | if (len > max_len) |
| 253 | { |
| 254 | /* buffer is too small, double its size and try again. |
| 255 | */ |
| 256 | stringbuf_grow (buf); |
| 257 | stringbuf_cat_locale_string (buf, str); |
| 258 | } |
| 259 | else |
| 260 | { |
| 261 | /* string fits, terminate it and check for embedded '\0'. |
| 262 | */ |
| 263 | buf->ptr[len] = '\0'; |
| 264 | if (strlen (buf->ptr) != len) |
| 265 | scm_misc_error (NULL, |
| 266 | "string contains #\\nul character: ~S", |
| 267 | scm_list_1 (str)); |
| 268 | buf->ptr += len; |
| 269 | } |
| 270 | } |
| 271 | |
| 272 | static void |
| 273 | stringbuf_cat (struct stringbuf *buf, char *str) |
| 274 | { |
| 275 | size_t max_len = buf->buf_len - (buf->ptr - buf->buf) - 1; |
| 276 | size_t len = strlen (str); |
| 277 | if (len > max_len) |
| 278 | { |
| 279 | /* buffer is too small, double its size and try again. |
| 280 | */ |
| 281 | stringbuf_grow (buf); |
| 282 | stringbuf_cat (buf, str); |
| 283 | } |
| 284 | else |
| 285 | { |
| 286 | /* string fits, copy it into buffer. |
| 287 | */ |
| 288 | strcpy (buf->ptr, str); |
| 289 | buf->ptr += len; |
| 290 | } |
| 291 | } |
| 292 | |
| 293 | |
| 294 | /* Search PATH for a directory containing a file named FILENAME. |
| 295 | The file must be readable, and not a directory. |
| 296 | If we find one, return its full filename; otherwise, return #f. |
| 297 | If FILENAME is absolute, return it unchanged. |
| 298 | If given, EXTENSIONS is a list of strings; for each directory |
| 299 | in PATH, we search for FILENAME concatenated with each EXTENSION. */ |
| 300 | SCM_DEFINE (scm_search_path, "search-path", 2, 1, 0, |
| 301 | (SCM path, SCM filename, SCM extensions), |
| 302 | "Search @var{path} for a directory containing a file named\n" |
| 303 | "@var{filename}. The file must be readable, and not a directory.\n" |
| 304 | "If we find one, return its full filename; otherwise, return\n" |
| 305 | "@code{#f}. If @var{filename} is absolute, return it unchanged.\n" |
| 306 | "If given, @var{extensions} is a list of strings; for each\n" |
| 307 | "directory in @var{path}, we search for @var{filename}\n" |
| 308 | "concatenated with each @var{extension}.") |
| 309 | #define FUNC_NAME s_scm_search_path |
| 310 | { |
| 311 | struct stringbuf buf; |
| 312 | char *filename_chars; |
| 313 | size_t filename_len; |
| 314 | SCM result = SCM_BOOL_F; |
| 315 | |
| 316 | if (SCM_UNBNDP (extensions)) |
| 317 | extensions = SCM_EOL; |
| 318 | |
| 319 | scm_dynwind_begin (0); |
| 320 | |
| 321 | filename_chars = scm_to_locale_string (filename); |
| 322 | filename_len = strlen (filename_chars); |
| 323 | scm_dynwind_free (filename_chars); |
| 324 | |
| 325 | /* If FILENAME is absolute, return it unchanged. */ |
| 326 | #ifdef __MINGW32__ |
| 327 | if (((filename_len >= 1) && |
| 328 | (filename_chars[0] == '/' || filename_chars[0] == '\\')) || |
| 329 | ((filename_len >= 3) && filename_chars[1] == ':' && |
| 330 | ((filename_chars[0] >= 'a' && filename_chars[0] <= 'z') || |
| 331 | (filename_chars[0] >= 'A' && filename_chars[0] <= 'Z')) && |
| 332 | (filename_chars[2] == '/' || filename_chars[2] == '\\'))) |
| 333 | #else |
| 334 | if (filename_len >= 1 && filename_chars[0] == '/') |
| 335 | #endif |
| 336 | { |
| 337 | scm_dynwind_end (); |
| 338 | return filename; |
| 339 | } |
| 340 | |
| 341 | /* If FILENAME has an extension, don't try to add EXTENSIONS to it. */ |
| 342 | { |
| 343 | char *endp; |
| 344 | |
| 345 | for (endp = filename_chars + filename_len - 1; |
| 346 | endp >= filename_chars; |
| 347 | endp--) |
| 348 | { |
| 349 | if (*endp == '.') |
| 350 | { |
| 351 | /* This filename already has an extension, so cancel the |
| 352 | list of extensions. */ |
| 353 | extensions = SCM_EOL; |
| 354 | break; |
| 355 | } |
| 356 | #ifdef __MINGW32__ |
| 357 | else if (*endp == '/' || *endp == '\\') |
| 358 | #else |
| 359 | else if (*endp == '/') |
| 360 | #endif |
| 361 | /* This filename has no extension, so keep the current list |
| 362 | of extensions. */ |
| 363 | break; |
| 364 | } |
| 365 | } |
| 366 | |
| 367 | /* This simplifies the loop below a bit. |
| 368 | */ |
| 369 | if (scm_is_null (extensions)) |
| 370 | extensions = scm_listofnullstr; |
| 371 | |
| 372 | buf.buf_len = 512; |
| 373 | buf.buf = scm_malloc (buf.buf_len); |
| 374 | scm_dynwind_unwind_handler (stringbuf_free, &buf, SCM_F_WIND_EXPLICITLY); |
| 375 | |
| 376 | /* Try every path element. |
| 377 | */ |
| 378 | for (; scm_is_pair (path); path = SCM_CDR (path)) |
| 379 | { |
| 380 | SCM dir = SCM_CAR (path); |
| 381 | SCM exts; |
| 382 | size_t sans_ext_len; |
| 383 | |
| 384 | buf.ptr = buf.buf; |
| 385 | stringbuf_cat_locale_string (&buf, dir); |
| 386 | |
| 387 | /* Concatenate the path name and the filename. */ |
| 388 | |
| 389 | #ifdef __MINGW32__ |
| 390 | if ((buf.ptr > buf.buf) && (buf.ptr[-1] != '/') && (buf.ptr[-1] != '\\')) |
| 391 | #else |
| 392 | if ((buf.ptr > buf.buf) && (buf.ptr[-1] != '/')) |
| 393 | #endif |
| 394 | stringbuf_cat (&buf, "/"); |
| 395 | |
| 396 | stringbuf_cat (&buf, filename_chars); |
| 397 | sans_ext_len = buf.ptr - buf.buf; |
| 398 | |
| 399 | /* Try every extension. */ |
| 400 | for (exts = extensions; scm_is_pair (exts); exts = SCM_CDR (exts)) |
| 401 | { |
| 402 | SCM ext = SCM_CAR (exts); |
| 403 | struct stat mode; |
| 404 | |
| 405 | buf.ptr = buf.buf + sans_ext_len; |
| 406 | stringbuf_cat_locale_string (&buf, ext); |
| 407 | |
| 408 | /* If the file exists at all, we should return it. If the |
| 409 | file is inaccessible, then that's an error. */ |
| 410 | |
| 411 | if (stat (buf.buf, &mode) == 0 |
| 412 | && ! (mode.st_mode & S_IFDIR)) |
| 413 | { |
| 414 | result = scm_from_locale_string (buf.buf); |
| 415 | goto end; |
| 416 | } |
| 417 | } |
| 418 | |
| 419 | if (!SCM_NULL_OR_NIL_P (exts)) |
| 420 | scm_wrong_type_arg_msg (NULL, 0, extensions, "proper list"); |
| 421 | } |
| 422 | |
| 423 | if (!SCM_NULL_OR_NIL_P (path)) |
| 424 | scm_wrong_type_arg_msg (NULL, 0, path, "proper list"); |
| 425 | |
| 426 | end: |
| 427 | scm_dynwind_end (); |
| 428 | return result; |
| 429 | } |
| 430 | #undef FUNC_NAME |
| 431 | |
| 432 | |
| 433 | /* Search %load-path for a directory containing a file named FILENAME. |
| 434 | The file must be readable, and not a directory. |
| 435 | If we find one, return its full filename; otherwise, return #f. |
| 436 | If FILENAME is absolute, return it unchanged. */ |
| 437 | SCM_DEFINE (scm_sys_search_load_path, "%search-load-path", 1, 0, 0, |
| 438 | (SCM filename), |
| 439 | "Search @var{%load-path} for the file named @var{filename},\n" |
| 440 | "which must be readable by the current user. If @var{filename}\n" |
| 441 | "is found in the list of paths to search or is an absolute\n" |
| 442 | "pathname, return its full pathname. Otherwise, return\n" |
| 443 | "@code{#f}. Filenames may have any of the optional extensions\n" |
| 444 | "in the @code{%load-extensions} list; @code{%search-load-path}\n" |
| 445 | "will try each extension automatically.") |
| 446 | #define FUNC_NAME s_scm_sys_search_load_path |
| 447 | { |
| 448 | SCM path = *scm_loc_load_path; |
| 449 | SCM exts = *scm_loc_load_extensions; |
| 450 | SCM_VALIDATE_STRING (1, filename); |
| 451 | |
| 452 | if (scm_ilength (path) < 0) |
| 453 | SCM_MISC_ERROR ("%load-path is not a proper list", SCM_EOL); |
| 454 | if (scm_ilength (exts) < 0) |
| 455 | SCM_MISC_ERROR ("%load-extension list is not a proper list", SCM_EOL); |
| 456 | return scm_search_path (path, filename, exts); |
| 457 | } |
| 458 | #undef FUNC_NAME |
| 459 | |
| 460 | |
| 461 | SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 1, 0, 0, |
| 462 | (SCM filename), |
| 463 | "Search @var{%load-path} for the file named @var{filename} and\n" |
| 464 | "load it into the top-level environment. If @var{filename} is a\n" |
| 465 | "relative pathname and is not found in the list of search paths,\n" |
| 466 | "an error is signalled.") |
| 467 | #define FUNC_NAME s_scm_primitive_load_path |
| 468 | { |
| 469 | SCM full_filename; |
| 470 | |
| 471 | full_filename = scm_sys_search_load_path (filename); |
| 472 | |
| 473 | if (scm_is_false (full_filename)) |
| 474 | SCM_MISC_ERROR ("Unable to find file ~S in load path", |
| 475 | scm_list_1 (filename)); |
| 476 | |
| 477 | return scm_primitive_load (full_filename); |
| 478 | } |
| 479 | #undef FUNC_NAME |
| 480 | |
| 481 | SCM |
| 482 | scm_c_primitive_load_path (const char *filename) |
| 483 | { |
| 484 | return scm_primitive_load_path (scm_from_locale_string (filename)); |
| 485 | } |
| 486 | |
| 487 | \f |
| 488 | /* Information about the build environment. */ |
| 489 | |
| 490 | /* Initialize the scheme variable %guile-build-info, based on data |
| 491 | provided by the Makefile, via libpath.h. */ |
| 492 | static void |
| 493 | init_build_info () |
| 494 | { |
| 495 | static struct { char *name; char *value; } info[] = SCM_BUILD_INFO; |
| 496 | SCM *loc = SCM_VARIABLE_LOC (scm_c_define ("%guile-build-info", SCM_EOL)); |
| 497 | unsigned long i; |
| 498 | |
| 499 | for (i = 0; i < (sizeof (info) / sizeof (info[0])); i++) |
| 500 | { |
| 501 | SCM key = scm_from_locale_symbol (info[i].name); |
| 502 | SCM val = scm_from_locale_string (info[i].value); |
| 503 | *loc = scm_acons (key, val, *loc); |
| 504 | } |
| 505 | } |
| 506 | |
| 507 | \f |
| 508 | void |
| 509 | scm_init_load () |
| 510 | { |
| 511 | scm_listofnullstr = scm_permanent_object (scm_list_1 (scm_nullstr)); |
| 512 | scm_loc_load_path = SCM_VARIABLE_LOC (scm_c_define ("%load-path", SCM_EOL)); |
| 513 | scm_loc_load_extensions |
| 514 | = SCM_VARIABLE_LOC (scm_c_define ("%load-extensions", |
| 515 | scm_list_2 (scm_from_locale_string (".scm"), |
| 516 | scm_nullstr))); |
| 517 | scm_loc_load_hook = SCM_VARIABLE_LOC (scm_c_define ("%load-hook", SCM_BOOL_F)); |
| 518 | |
| 519 | the_reader = scm_make_fluid (); |
| 520 | the_reader_fluid_num = SCM_FLUID_NUM (the_reader); |
| 521 | SCM_FAST_FLUID_SET_X (the_reader_fluid_num, SCM_BOOL_F); |
| 522 | scm_c_define("current-reader", the_reader); |
| 523 | |
| 524 | init_build_info (); |
| 525 | |
| 526 | #include "libguile/load.x" |
| 527 | } |
| 528 | |
| 529 | /* |
| 530 | Local Variables: |
| 531 | c-file-style: "gnu" |
| 532 | End: |
| 533 | */ |