From 644ef0aa848c2cef6621e0ae6be8b14322b015d0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Mon, 11 Sep 2023 00:30:49 +0200 Subject: Change how entry point is handled. Replaces the old main sh bootstrap entry point to one written in C. The reasons are in the C file, but in short, Guile's command line is less than ideal. --- .gitignore | 2 + Makefile | 19 +++- calp.c | 176 ++++++++++++++++++++++++++++++++++ env | 17 ---- main | 8 -- production-main | 3 - start | 2 +- tests/run-tests.scm | 9 +- tests/validate-html/run-validator.scm | 8 +- 9 files changed, 207 insertions(+), 37 deletions(-) create mode 100644 calp.c delete mode 100644 env delete mode 100755 main delete mode 100644 production-main diff --git a/.gitignore b/.gitignore index b92e0bcf..b7cea985 100644 --- a/.gitignore +++ b/.gitignore @@ -3,3 +3,5 @@ coverage obj-* localization +calp +calp-release diff --git a/Makefile b/Makefile index aab3c17a..8e5dbea6 100644 --- a/Makefile +++ b/Makefile @@ -25,6 +25,11 @@ GUILE_C_FLAGS = -Lmodule \ -Wmacro-use-before-definition -Warity-mismatch \ -Wduplicate-case-datum -Wbad-case-datum +CLIBS = guile-3.0 +CFLAGS = -Wall -pedantic -std=c11 $(shell pkg-config --cflags $(CLIBS)) +LDLIBS = $(shell pkg-config --libs $(CLIBS)) +LDFLAGS = -lrt + # All po-files inside po/, except new.po, and hidden files PO_FILES = $(shell find po -type f -name \*.po -and -not -name new.po -and -not -name .\*) LOCALIZATIONS = $(PO_FILES:po/%.po=localization/%/LC_MESSAGES/calp.mo) @@ -34,9 +39,15 @@ LIMIT_FILES=$(LIMIT:%=--only %) # Skip these files when testing SKIP=--skip $(PWD)/tests/test/web-server.scm -all: go_files static $(LOCALIZATIONS) +all: calp go_files static $(LOCALIZATIONS) $(MAKE) -C doc/ref +calp: calp.c + $(CC) -ggdb $(CFLAGS) -DBUILD_ENV $(LDFLAGS) -o $@ $< $(LDLIBS) + +calp-release: calp.c + $(CC) -O2 $(CFLAGS) $(LDFLAGS) -o $@ $< $(LDLIBS) + XGETTEXT_FLAGS = --from-code=UTF-8 --add-comments --indent -kG_ static: @@ -63,8 +74,10 @@ localization/%/LC_MESSAGES/calp.mo: po/%.po clean: -$(MAKE) -C static clean -rm -r obj-* + -rm calp + -rm calp-release -install: all +install: all calp-release install -d $(DESTDIR)$(GUILE_SITE_DIR) $(DESTDIR)$(GUILE_CCACHE_DIR) rsync -a module/ $(DESTDIR)$(GUILE_SITE_DIR) rsync -a obj-$(GUILE_VERSION)/ $(DESTDIR)$(GUILE_CCACHE_DIR) @@ -73,7 +86,7 @@ install: all $(MAKE) -C doc/ref install install -m 644 -D -t $(DESTDIR)/usr/share/doc/calp README.md install -m 755 -D -t $(DESTDIR)/usr/lib/calp/ scripts/tzget - install -m755 -D production-main $(DESTDIR)/usr/bin/calp + install -m755 -D calp-release $(DESTDIR)/usr/bin/calp lcov.info: $(GO_FILES) env DEBUG=0 tests/run-tests.scm --coverage=$@ $(if $(VERBOSE),--verbose) $(SKIP) $(LIMIT_FILES) diff --git a/calp.c b/calp.c new file mode 100644 index 00000000..98d883f5 --- /dev/null +++ b/calp.c @@ -0,0 +1,176 @@ +#define _XOPEN_SOURCE 500 +#define _POSIX_C_SOURCE 200112L + +/** + * Primary entry point for calp. + * + * This is a C file, rather than a shellscript for 2 reasons: + * 1. It makes the binary show up with the proper name in process + * listings + * 2. Guile's default command line handling leaves a lot to be + * desired. + * + * The following pre-processor variables are checked during compilation: + * + * BUILD_ENV + * If defined then the environment is fetched from where the file + * resides. This is for development when all dependencies are in the + * repo alongside this file. + * MAIN_MODULE + * Guile module containing the programs entry point. Note that it + * should be given without parenthesis. + * + * Defaults to "calp main" + * MAIN_PROC + * Procedure within the MAIN_MODULE which is the programs entry + * point. + * + * Default to "main" + * + * During runtime, the environment variable "__PRINT_ENVIRONMENT" is + * checked, and if its set then a environment variables suitable for + * guile is printed instead of running anything. This is mainly used + * by the test runners. + * + * Parts of this file is noted as being "borrowed from Guile". Guile + * is covered under LGPL3, this file is covered under AGPL, which + * means it is ok. + */ + +#ifndef MAIN_MODULE +#define MAIN_MODULE "calp main" +#endif + +#ifndef MAIN_PROC +#define MAIN_PROC "main" +#endif + +#include + +#include +#include +#include +#include +#include +#include + +/** Definitions to ensure each instance is correctly spelled below */ +#define GUILE_LOAD_PATH "GUILE_LOAD_PATH" +#define GUILE_LOAD_COMPILED_PATH "GUILE_LOAD_COMPILED_PATH" +#define GUILE_AUTO_COMPILE "GUILE_AUTO_COMPILE" + +#define PRINT_ENVIRONMENT "__PRINT_ENVIRONMENT" + +/** Borrowed from Guile 3.0.9 libguile/guile.c */ +static int +get_integer_from_environment (const char *var, int def) +{ + char *end = 0; + char *val = getenv (var); + long res = def; + if (!val) + return def; + res = strtol (val, &end, 10); + if (end == val) + { + fprintf (stderr, "guile: warning: invalid %s: %s\n", var, val); + return def; + } + return res; +} + +static void inner_main (void *closure, int argc, char **argv) { + SCM main = scm_c_public_ref(MAIN_MODULE, MAIN_PROC); + SCM scm_args = scm_c_make_vector (argc, SCM_UNDEFINED); + for (size_t i = 0; i < (size_t) argc; i++) { + scm_c_vector_set_x (scm_args, i, scm_from_locale_string(argv[i])); + } + scm_call_1(main, scm_vector_to_list(scm_args)); +} + +/** Procedure marked unused since GCC dosen't understand function + * pointers when checking usage */ +__attribute__((__unused__)) +static void *get_guile_version (void *data) { + (void) data; + return scm_to_locale_string(scm_version()); +} + + +static void export (const char *key, const char *val) { + printf("export %s=%s;\n", key, val); +} + + +int main(int argc, char *argv[]) { + + /* Locale initialization code borrowed from Guile 3.0.9 libguile/guile.c */ + if (get_integer_from_environment("GUILE_INSTALL_LOCALE", 1) && setlocale(LC_ALL, "") == NULL) { + fprintf(stderr, "calp: warning: failed to install locale\n"); + } + +#ifdef BUILD_ENV + + char *bin_path = realpath(argv[0], NULL); + if (bin_path == NULL) { + fprintf(stderr, "%s\n", strerror(errno)); + return 1; + } + char *here = dirname(bin_path); + + { + const char *load_path = getenv(GUILE_LOAD_PATH); + size_t len = PATH_MAX + strlen("module") + 1; + if (load_path) len += strlen(load_path); + + char *buf = malloc(len); + + if (load_path) { + sprintf(buf, "%s:%s/module", load_path, here); + } else { + sprintf(buf, "%s/module", here); + } + + setenv(GUILE_LOAD_PATH, buf, 1); + + free(buf); + } + + { + char *version = scm_with_guile(&get_guile_version, NULL); + + const char *load_path = getenv(GUILE_LOAD_COMPILED_PATH); + size_t len = PATH_MAX + strlen("module") + strlen(version) + 1; + if (load_path) len += strlen(load_path); + + char *buf = malloc(len); + + if (load_path) { + sprintf(buf, "%s:%s/obj-%s", load_path, here, version); + } else { + sprintf(buf, "%s/obj-%s", here, version); + } + + setenv(GUILE_LOAD_COMPILED_PATH, buf, 1); + + free(buf); + free(version); + } + + setenv(GUILE_AUTO_COMPILE, "0", 1); + + free(bin_path); +#endif + + if (getenv(PRINT_ENVIRONMENT)) { + export(GUILE_LOAD_PATH, getenv(GUILE_LOAD_PATH)); + export(GUILE_LOAD_COMPILED_PATH, getenv(GUILE_LOAD_COMPILED_PATH)); + export(GUILE_AUTO_COMPILE, "0"); + export("GUILE", "${GUILE:-guile}"); + export("CALP_TEST_ENVIRONMENT", "1"); + return 0; + } + + scm_boot_guile (argc, argv, inner_main, 0); + return 0; /* never reacher */ +} diff --git a/env b/env deleted file mode 100644 index 31ff2281..00000000 --- a/env +++ /dev/null @@ -1,17 +0,0 @@ -# -*- mode: sh -*- - -_here=$(dirname "$(realpath "${BASH_SOURCE[0]}")") - -export GUILE=${GUILE:-guile} -guile_version=$($GUILE -c '(display (version))') - -export GUILE_LOAD_COMPILED_PATH=${_here}/obj-${guile_version}:${GUILE_LOAD_COMPILED_PATH} -export GUILE_LOAD_PATH=${_here}/module:${GUILE_LOAD_PATH} -export GUILE_AUTO_COMPILE=0 - -# TODO why is this set? -export LIBEXEC=${_here}/scripts/ - -#export GUILE_AUTO_COMPILE=0 - -# exec "$@" diff --git a/main b/main deleted file mode 100755 index fb3a1e03..00000000 --- a/main +++ /dev/null @@ -1,8 +0,0 @@ -#!/bin/bash - -here=$(dirname $(realpath $0)) -. $here/env - -make GUILE="$GUILE" go_files - -exec $GUILE -e '(@ (calp main) main)' "$@" diff --git a/production-main b/production-main deleted file mode 100644 index 69939def..00000000 --- a/production-main +++ /dev/null @@ -1,3 +0,0 @@ -#!/bin/bash -GUILE=${GUILE:-guile} -exec "$GUILE" -e '(@ (calp main) main)' "$@" diff --git a/start b/start index 2363d428..48d2c0e0 100755 --- a/start +++ b/start @@ -19,7 +19,7 @@ port=`find_port {8080..9000}` echo "Starting on $port" -$(dirname $(realpath $0))/main \ +$(dirname $(realpath $0))/calp \ --repl=$XDG_RUNTIME_DIR/calp \ --debug \ --edit-mode \ diff --git a/tests/run-tests.scm b/tests/run-tests.scm index ca8f9de4..4bb34ce8 100755 --- a/tests/run-tests.scm +++ b/tests/run-tests.scm @@ -1,9 +1,8 @@ #!/usr/bin/env bash # -*- mode: scheme; geiser-scheme-implementation: guile -*- -here=$(dirname $(realpath $0)) - -. "$(dirname "$here")/env" +root=$(dirname "$(dirname "$(realpath "$0")")") +eval "$(env __PRINT_ENVIRONMENT=1 ${root}/calp)" if [ "$DEBUG" = '' ]; then exec $GUILE -s "$0" "$@" @@ -12,6 +11,10 @@ else fi !# +(unless (getenv "CALP_TEST_ENVIRONMENT") + (format (current-error-port) "Not running in test environment, abandoning~%") + (exit 1)) + (format #t "current-filename = ~s~%" (current-filename)) (define here (dirname (current-filename))) diff --git a/tests/validate-html/run-validator.scm b/tests/validate-html/run-validator.scm index 0c4ee0bc..b363e3ea 100755 --- a/tests/validate-html/run-validator.scm +++ b/tests/validate-html/run-validator.scm @@ -1,12 +1,16 @@ #!/usr/bin/bash # -*- mode: scheme; geiser-scheme-implementation: guile -*- -here=$(dirname $(realpath $0)) +root=$(dirname "$(dirname "$(dirname "$(realpath "$0")")")") -. "$(dirname "$(dirname "$here")")/env" +eval "$(env __PRINT_ENVIRONMENT=1 ${root}/calp)" exec $GUILE -e main -s "$0" -- "$@" !# +(unless (getenv "CALP_TEST_ENVIRONMENT") + (format (current-error-port) "Not running in test environment, abandoning~%") + (exit 1)) + (use-modules (sxml simple) ((sxml xpath) :select (sxpath)) (sxml match) -- cgit v1.2.3