From 79352e968329ba0c5972dadca99cf5744c024e09 Mon Sep 17 00:00:00 2001 From: Linas Vepstas Date: Wed, 4 Nov 1998 06:14:45 +0000 Subject: [PATCH] merge in patches from rob browning git-svn-id: svn+ssh://svn.gnucash.org/repo/gnucash/trunk@1374 57a11ea4-9604-0410-9ed3-97b8803252fd --- Makefile.in | 2 +- configure | 4 +- configure.in | 2 +- gnucash | 2 +- src/scm/startup-design.txt | 9 +- src/scm/startup.scm.in | 572 ------------------------------- src/scm/startup/command-line.scm | 93 +++++ src/scm/startup/config-var.scm | 57 +++ src/scm/startup/init.scm.in | 37 ++ src/scm/startup/main.scm | 51 +++ src/scm/startup/path.scm | 124 +++++++ src/scm/startup/prefs.scm | 152 ++++++++ src/scm/startup/utilities.scm | 76 ++++ 13 files changed, 601 insertions(+), 580 deletions(-) delete mode 100644 src/scm/startup.scm.in create mode 100644 src/scm/startup/command-line.scm create mode 100644 src/scm/startup/config-var.scm create mode 100644 src/scm/startup/init.scm.in create mode 100644 src/scm/startup/main.scm create mode 100644 src/scm/startup/path.scm create mode 100644 src/scm/startup/prefs.scm create mode 100644 src/scm/startup/utilities.scm diff --git a/Makefile.in b/Makefile.in index e52d4860d0..e174bcd591 100644 --- a/Makefile.in +++ b/Makefile.in @@ -56,7 +56,7 @@ build-flavor: @cd src; $(MAKE) ${FLAVOR} ln -sf gnucash.${FLAVOR} gnucash.bin ln -sf gnucash.${FLAVOR} gnucash-shell - (cd share && ln -sf ../src/scm scm) + (cd share && rm -f scm && ln -sf ../src/scm scm) motif: ${MAKE} FLAVOR=motif build-flavor diff --git a/configure b/configure index 2fa4311c75..546c72354a 100755 --- a/configure +++ b/configure @@ -2618,7 +2618,7 @@ trap 'rm -fr `echo "Makefile src/guile/Makefile src/guile/gnucash.h src/scm/Makefile - src/scm/startup.scm + src/scm/startup/init.scm src/gnome/Makefile src/motif/Makefile src/qt/Makefile @@ -2731,7 +2731,7 @@ CONFIG_FILES=\${CONFIG_FILES-"Makefile src/guile/Makefile src/guile/gnucash.h src/scm/Makefile - src/scm/startup.scm + src/scm/startup/init.scm src/gnome/Makefile src/motif/Makefile src/qt/Makefile diff --git a/configure.in b/configure.in index 2114df61ed..fa80705bed 100644 --- a/configure.in +++ b/configure.in @@ -233,7 +233,7 @@ AC_OUTPUT(Makefile src/guile/Makefile src/guile/gnucash.h src/scm/Makefile - src/scm/startup.scm + src/scm/startup/init.scm src/gnome/Makefile src/motif/Makefile src/qt/Makefile diff --git a/gnucash b/gnucash index 16b37c5c54..0836645829 100755 --- a/gnucash +++ b/gnucash @@ -1,7 +1,7 @@ #! /bin/sh GNC_ARGS="${GNC_ARGS} --debug" -GNC_ARGS="${GNC_ARGS} --startup-file ./share/scm/startup.scm" +GNC_ARGS="${GNC_ARGS} --startup-dir ./share/scm/startup" GNC_ARGS="${GNC_ARGS} --share-dir ./share" GNC_ARGS="${GNC_ARGS} --config-dir ./etc" GNC_ARGS="${GNC_ARGS} --load-path (\"(./share/scm)\")" diff --git a/src/scm/startup-design.txt b/src/scm/startup-design.txt index 834671cb37..d477eaf4f4 100644 --- a/src/scm/startup-design.txt +++ b/src/scm/startup-design.txt @@ -1,10 +1,13 @@ The startup process looks like this right now: 1) (at the C level) search args from right to left to see if there's - any --startup-file override, use it if there is. + any --startup-dir override, use it if there is. - 2) load the desired startup.scm (either the default or the override) - -- all the rest of the steps happen from startup.scm + 2) load the desired /init.scm (either the default or + the override) -- all the rest of the steps happen from init.scm + and files loaded from there. Any files in / cannot be + overridden by --load-path because they'll be loaded before the + load-path mechanism is operational. 3) setup the default config-vars (including the ones that represent the command-line options). diff --git a/src/scm/startup.scm.in b/src/scm/startup.scm.in deleted file mode 100644 index 5bb4caa2b1..0000000000 --- a/src/scm/startup.scm.in +++ /dev/null @@ -1,572 +0,0 @@ -;;;; startup.scm -*-scheme-*- -;; -;; Minimal startup code. This file should just contain enough code to -;; get the arguments parsed and things like gnc:*load-path* set up. -;; After that *everything* should be loaded via gnc:load. - -;; This load should go away when guile gets fixed. as of guile1.3, -;; it's not. You have to do this manually, unless you call scm_shell, -;; which we can't. -(let ((boot-file (if (assoc 'prefix %guile-build-info) - (string-append (cdr (assoc 'prefix %guile-build-info)) - "/share/guile/" - (version) - "/ice-9/boot-9.scm") - "/usr/share/guile/1.3a/ice-9/boot-9.scm"))) - (primitive-load boot-file)) - -;; Automatically generated defaults... -(define gnc:_config-dir-default_ "@GNC_RUNTIME_CONFIGDIR@") -(define gnc:_share-dir-default_ "@GNC_RUNTIME_SHAREDIR@") - -(define gnc:*command-line-files* #f) - -;;;; Warning functions... - -(define (gnc:warn . items) - (display "gnucash: [W] ") - (for-each (lambda (i) (display i)) items) - (newline)) - -(define (gnc:error . items) - (display "gnucash: [E] ") - (for-each (lambda (i) (display i)) items) - (newline)) - -(define (gnc:msg . items) - (display "gnucash: [M] ") - (for-each (lambda (i) (display i)) items) - (newline)) - -(define (gnc:debug . items) - (if (gnc:config-var-value-get gnc:*debugging?*) - (begin - (display "gnucash: [D] ") - (for-each (lambda (i) (display i)) items) - (newline)))) - -(define (gnc:startup) - (gnc:debug "starting up.") - #t) - -(define (gnc:shutdown exit-status) - (gnc:debug "Shutdown -- exit-status: " exit-status) - - (gnc:hook-run-danglers gnc:*shutdown-hook*) - (_gnc_shutdown_ exit-status) - (exit exit-status)) - -(define gnc:*user-config-loaded?* #f) - -(define (gnc:load-user-config) - (gnc:debug "loading user configuration") - - (let ((user-file - (string-append (getenv "HOME") "/.gnucash/config.user")) - (auto-file - (string-append (getenv "HOME") "/.gnucash/config.auto"))) - - (if (access? user-file F_OK) - (if (false-if-exception (primitive-load user-file)) - (set! gnc:user-config-loaded #t) - (begin - (gnc:warn "failure loading " user-file) - #f)) - (if (access? auto-file F_OK) - (if (false-if-exception (primitive-load auto-file)) - (set! gnc:*user-config-loaded?* #t) - (begin - (gnc:warn "failure loading " auto-file) - #f)))))) - -(define gnc:*system-config-loaded?* #f) - -(define (gnc:load-system-config) - (gnc:debug "loading system configuration") - - (let ((system-config (string-append - (gnc:config-var-value-get gnc:*config-dir*) - "/config"))) - - (if (false-if-exception (primitive-load system-config)) - (set! gnc:*system-config-loaded?* #t) - (begin - (gnc:warn "failure loading " system-config) - #f)))) - -(define gnc:_load-path-directories_ #f) -(define gnc:_doc-path-directories_ #f) - -(define (directory? path) - ;; This follows symlinks normally. - (let* ((status (false-if-exception (stat path))) - (type (if status (stat:type status) #f))) - (eq? type 'directory))) - - -(define (gnc:directory-subdirectories dir-name) - ;; Return a recursive list of the subdirs of dir-name, including - ;; dir-name. Follow symlinks. - - (let ((dir-port (opendir dir-name))) - (if (not dir-port) - #f - (do ((item (readdir dir-port) (readdir dir-port)) - (dirs '())) - ((eof-object? item) (reverse dirs)) - - (if (not (or (string=? item ".") - (string=? item ".."))) - (let* ((full-path (string-append dir-name "/" item))) - ;; ignore symlinks, etc. - (if (access? full-path F_OK) - (let* ((status (lstat full-path)) - (type (if status (stat:type status) #f))) - (if (and (eq? type 'directory)) - (set! dirs - (cons full-path - (append - (gnc:directory-subdirectories full-path) - dirs)))))))))))) - -(define (gnc:_path-expand_ items default-items) - (if - (null? items) - '() - (let ((item (car items)) - (other-items (cdr items))) - (cond - ((eq? item 'default) - (append - (gnc:_path-expand_ default-items)) - (gnc:_path-expand_ other-items default-items)) - ((string? item) - (if (and (char=? #\( (string-ref item 0)) - (char=? #\) (string-ref item (- (string-length item) 1)))) - - (let ((current-dir - (make-shared-substring item 1 (- (string-length item) 1)))) - - (if (directory? current-dir) - (let ((subdirs (gnc:directory-subdirectories current-dir)) - (rest (gnc:_path-expand_ other-items default-items))) - (cons current-dir (append subdirs rest))) - (begin - (gnc:warn "Ignoring non-directory " current-dir - " in gnc:_path-expand_ item.") - (gnc:_path-expand_ other-items default-items)))) - (if (directory? item) - (begin - (gnc:warn "Ignoring non-directory " item - " in gnc:_path-expand_ item.") - (gnc:_path-expand_ other-items default-items)) - (cons item (gnc:_path-expand_ other-items default-items))))) - (else (gnc:warn "Ignoring invalid item " item " in gnc:_path-expand_.") - (gnc:_path-expand_ other-items default-items)))))) - -(define (gnc:_load-path-update_ var items) - (gnc:msg "Updating load path from " items) - (let ((result (gnc:_path-expand_ - items - (gnc:config-var-default-value-get var)))) - (if result - (begin - (set! gnc:_load-path-directories_ result) - (gnc:msg " Setting path to " result) - result) - (begin - (gnc:msg " No path... " result) - #f)))) - -(define (gnc:_doc-path-update_ var items) - (let ((result (gnc:_path-expand_ - items - (gnc:config-var-default-value-get var)))) - (if result - (begin - (set! gnc:_doc-path-directories_ result) - result) - #f))) - -(define (gnc:find-in-directories file directories) - "Find file named 'file' anywhere in 'directories'. 'file' must be a -string and 'directories' must be a list of strings." - - (gnc:debug "gnc:find-in-directories looking for " file " in " directories) - - (do ((rest directories (cdr rest)) - (finished? #f) - (result #f)) - ((or (null? rest) finished?) result) - - (let ((file-name (string-append (car rest) "/" file))) - (gnc:debug " checking for " file-name) - (if (access? file-name F_OK) - (begin - (gnc:debug "found file " file-name) - (set! finished? #t) - (set! result file-name)))))) - -;; It may make sense to dump this in favor of guile's load-path later, -;; but for now this works, and having gnc things separate may be less -;; confusing and avoids shadowing problems. - -(define (gnc:load name) - "Name must be a string. The system attempts to locate the file of -the given name and load it. The system will attempt to locate the -file in all of the directories specified by gnc:*load-path*." - - (let ((file-name (gnc:find-in-directories name gnc:_load-path-directories_))) - (if (not file-name) - #f - (if (false-if-exception (primitive-load file-name)) - (begin - (gnc:debug "loaded file " file-name) - #t) - (begin - (gnc:warn "failure loading " file-name) - #f))))) - -;;; config-var: You can create them, set values, find out of the value -;;; is different from the default, and you can get a description. You -;;; can also specify an action function which will be called whenever -;;; the value is changed. The action function receives the special -;;; var and the new value as arguments and should return either #f if -;;; the modification should be rejected, or a list containing the -;;; result otherwise. - -;;; Finally, a config var has two states, "officially" modified, and -;;; unofficially modified. You control what kind of modification -;;; you're making with the second argument to -;;; gnc:config-var-value-set! The idea is that options specified on -;;; the command line will set the value of these config vars, but that -;;; setting is considered transient. Other settings (like from the UI -;;; preferences panel, or normal user code) should be considered -;;; permanent, and if they leave the variable value different from the -;;; default, should be saved to ~/.gnucash/config.auto. - -(define (gnc:make-config-var description - set-action-func - equality-func - default) - (let ((var - (vector description set-action-func equality-func #f default default))) - (gnc:config-var-value-set! var #f default) - var)) - -(define (gnc:config-var-description-get var) (vector-ref var 0)) - -(define (gnc:config-var-action-func-get var) (vector-ref var 1)) - -(define (gnc:config-var-equality-func-get var) (vector-ref var 2)) - -(define (gnc:config-var-modified? var) (vector-ref var 3)) -(define (gnc:config-var-modified?-set! var value) (vector-set! var 3 value)) - -(define (gnc:config-var-default-value-get var) (vector-ref var 4)) -(define (gnc:config-var-default-value-set! var value) (vector-set! var 4 value)) - -(define (gnc:config-var-value-get var) (vector-ref var 5)) -(define (gnc:config-var-value-set! var is-config-mod? value) - (let ((set-action (gnc:config-var-action-func-get var)) - (result (list value))) - (if set-action (set! result (set-action var value))) - (if result - (begin - (if is-config-mod? (gnc:config-var-modified?-set var #t)) - (vector-set! var 5 (car result)))))) - -(define (gnc:config-var-value-is-default? var) - (if (not (gnc:config-var-modified? var)) - #t - (let (equal-values? gnc:config-var-equality-func-get var) - (equal-values? - (gnc:config-var-default-value-get var) - (gnc:config-var-value-get var))))) - - -;;;; Preferences - -(define gnc:*arg-show-usage* - (gnc:make-config-var - "Generate an argument summary." - (lambda (var value) (if (boolean? value) (list value) #f)) - eq? - #f)) - -(define gnc:*arg-show-help* - (gnc:make-config-var - "Generate an argument summary." - (lambda (var value) (if (boolean? value) (list value) #f)) - eq? - #f)) - -(define gnc:*debugging?* - (gnc:make-config-var - "Enable debugging code." - (lambda (var value) (if (boolean? value) (list value) #f)) - eq? - #f)) - -(define gnc:*startup-file* - (gnc:make-config-var - "Initial lowest level scheme startup file." - (lambda (var value) - ;; You can't change the startup file from here since this is the - ;; startup file... - #f) - string=? - gnc:_startup-file-default_)) - -(define gnc:*config-dir* - (gnc:make-config-var - "Configuration directory." - (lambda (var value) (if (string? value) (list value) #f)) - string=? - gnc:_config-dir-default_)) - -(define gnc:*share-dir* - (gnc:make-config-var - "Shared files directory." - (lambda (var value) (if (string? value) (list value) #f)) - string=? - gnc:_share-dir-default_)) - -(define gnc:*load-path* - (gnc:make-config-var - "A list of strings indicating the load path for (gnc:load name). -Any path element enclosed in parentheses will automatically be -expanded to that directory and all its subdirectories whenever this -variable is modified. The symbol element default will expand to the default directory. i.e. (gnc:config-var-value-set! gnc:*load-path* '(\"/my/dir/\" default))" - (lambda (var value) - (if (not (list? value)) - #f - (let ((result (gnc:_load-path-update_ var value))) - (if (list? result) - (list result) - #f)))) - equal? - (list - (string-append "(" (getenv "HOME") "/.gnucash/scm)") - (string-append "(" gnc:_share-dir-default_ "/scm)")))) - -(define gnc:*doc-path* - (gnc:make-config-var - "A list of strings indicating where to look for html and parsed-html files -Any path element enclosed in parentheses will automatically be -expanded to that directory and all its subdirectories whenever this -variable is modified. The symbol element default will expand to the -default directory. i.e. (gnc:config-var-value-set! gnc:*doc-path* -'(\"/my/dir/\" default))" - (lambda (var value) - (if (not (list? value)) - #f - (let ((result (gnc:_doc-path-update_ var value))) - (if (list? result) - (list result) - #f)))) - equal? - (list - (string-append "(" (getenv "HOME") "/.gnucash/doc)") - (string-append "(" gnc:_share-dir-default_ "/Docs)") - (string-append "(" gnc:_share-dir-default_ "/Reports)")))) - -(define gnc:*prefs* - (list - - (cons - "usage" - (cons 'boolean - (lambda (val) - (gnc:config-var-value-set! gnc:*arg-show-usage* #f val)))) - (cons - "help" - (cons 'boolean - (lambda (val) - (gnc:config-var-value-set! gnc:*arg-show-help* #f val)))) - (cons - "debug" - (cons 'boolean - (lambda (val) - (gnc:config-var-value-set! gnc:*debugging?* #f val)))) - - (cons - "startup-file" - (cons 'string - (lambda (val) - (gnc:config-var-value-set! gnc:*startup-file* #f val)))) - - (cons - "config-dir" - (cons 'string - (lambda (val) - (gnc:config-var-value-set! gnc:*config-dir* #f val)))) - - (cons - "share-dir" - (cons 'string - (lambda (val) - (gnc:config-var-value-set! gnc:*share-dir* #f val)))) - - - (cons - "load-path" - (cons 'string - (lambda (val) - (let ((path-list - (call-with-input-string val (lambda (port) (read port))))) - (if (list? path-list) - (gnc:config-var-value-set! gnc:*load-path* #f path-list) - (begin - (gnc:error "non-list given for --load-path: " val) - (gnc:shutdown 1))))))) - - (cons - "doc-path" - (cons 'string - (lambda (val) - (let ((path-list - (call-with-input-string val (lambda (port) (read port))))) - (if (list? path-list) - (gnc:config-var-value-set! gnc:*doc-path* #f path-list) - (begin - (gnc:error "non-list given for --doc-path: " val) - (gnc:shutdown 1))))))) - - (cons "load-user-config" (cons 'boolean gnc:load-user-config)) - (cons "load-system-config" (cons 'boolean gnc:load-system-config)))) - - -;; also "-c" - - -(define (gnc:cmd-line-get-boolean-arg args) - ;; --arg means #t - ;; --arg true means #t - ;; --arg false means #f - - (if (not (pair? args)) - ;; Special case of end of list - (list #t args) - (let ((arg (car args))) - (if (string=? arg "false") - (list #f (cdr args)) - (list #t - (if (string=? arg "true") - (cdr args) - args)))))) - -(define (gnc:cmd-line-get-integer-arg args) - (let ((arg (car args))) - (let ((value (string->number arg))) - (if (not value) - #f - (if (not (exact? value)) - #f - (list value (cdr args))))))) - -(define (gnc:cmd-line-get-string-arg args) - (list (car args) (cdr args))) - -(define (gnc:prefs-show-usage) - (display "usage: gnucash [ option ... ] [ datafile ]") (newline)) - - -(define (gnc:handle-command-line-args) - (gnc:debug "handling command line arguments") - - (let ((files-to-open '()) - (result #t)) - - (do ((rest (cdr (program-arguments))) ; initial cdr skips argv[0] - (quit? #f) - (item #f)) - ((or quit? (null? rest))) - - (set! item (car rest)) - - (gnc:debug "handling arg " item) - - (if (not (string=? "--" (make-shared-substring item 0 2))) - (begin - (gnc:debug "non-option " item ", assuming file") - (set! rest (cdr rest)) - (set! files-to-open (cons item files-to-open))) - - ;; Got something that looks like an option... - (let* ((arg-string (make-shared-substring item 2)) - (arg-def (assoc-ref gnc:*prefs* arg-string))) - - (if (not arg-def) - (begin - (gnc:prefs-show-usage) - (set! result #f) - (set! quit? #t)) - - (let* ((arg-type (car arg-def)) - (arg-parse-result - (case arg-type - ((boolean) (gnc:cmd-line-get-boolean-arg (cdr rest))) - ((string) (gnc:cmd-line-get-string-arg (cdr rest))) - ((integer) - (gnc:cmd-line-get-integer-arg (cdr rest))) - (else - (gnc:error "bad argument type " arg-type ".") - (gnc:shutdown 1))))) - - (if (not arg-parse-result) - (begin - (set result #f) - (set! quit? #t)) - (let ((parsed-value (car arg-parse-result)) - (remaining-args (cadr arg-parse-result))) - ((cdr arg-def) parsed-value) - (set! rest remaining-args)))))))) - (if result - (gnc:debug "files to open: " files-to-open)) - - (set! gnc:*command-line-files* files-to-open) - - result)) - -;;;; Now the fun begins. - -(gnc:startup) - -(if (not (gnc:handle-command-line-args)) - (gnc:shutdown 1)) - -;;; Now we can load a bunch of files. - -(gnc:load "hooks.scm") -(gnc:load "doc.scm") - -;;; Load the system and user configs - -(if (not gnc:*user-config-loaded?*) - (if (not (gnc:load-system-config)) - (gnc:shutdown 1))) - -(if (not gnc:*system-config-loaded?*) - (if (not (gnc:load-user-config)) - (gnc:shutdown 1))) - -(gnc:hook-run-danglers gnc:*startup-hook*) - -(if (or (gnc:config-var-value-get gnc:*arg-show-usage*) - (gnc:config-var-value-get gnc:*arg-show-help*)) - (begin - (gnc:prefs-show-usage) - (gnc:shutdown 0))) - -(if (not (= (gnucash_lowlev_app_init) 0)) - (gnc:shutdown 0)) - -(if (pair? gnc:*command-line-files*) - ;; You can only open single files right now... - (gnucash_ui_open_file (car gnc:*command-line-files*)) - (gnucash_ui_select_file)) - -(gnucash_lowlev_app_main) - -(gnc:shutdown 0) diff --git a/src/scm/startup/command-line.scm b/src/scm/startup/command-line.scm new file mode 100644 index 0000000000..91804ea59c --- /dev/null +++ b/src/scm/startup/command-line.scm @@ -0,0 +1,93 @@ + +;; also "-c" + +(define gnc:*command-line-files* #f) + +(define (gnc:cmd-line-get-boolean-arg args) + ;; --arg means #t + ;; --arg true means #t + ;; --arg false means #f + + (if (not (pair? args)) + ;; Special case of end of list + (list #t args) + (let ((arg (car args))) + (if (string=? arg "false") + (list #f (cdr args)) + (list #t + (if (string=? arg "true") + (cdr args) + args)))))) + +(define (gnc:cmd-line-get-integer-arg args) + (let ((arg (car args))) + (let ((value (string->number arg))) + (if (not value) + #f + (if (not (exact? value)) + #f + (list value (cdr args))))))) + +(define (gnc:cmd-line-get-string-arg args) + (list (car args) (cdr args))) + +(define (gnc:prefs-show-usage) + (display "usage: gnucash [ option ... ] [ datafile ]") (newline)) + + +(define (gnc:handle-command-line-args) + (gnc:debug "handling command line arguments") + + (let ((files-to-open '()) + (result #t)) + + (do ((rest (cdr (program-arguments))) ; initial cdr skips argv[0] + (quit? #f) + (item #f)) + ((or quit? (null? rest))) + + (set! item (car rest)) + + (gnc:debug "handling arg " item) + + (if (not (string=? "--" (make-shared-substring item 0 2))) + (begin + (gnc:debug "non-option " item ", assuming file") + (set! rest (cdr rest)) + (set! files-to-open (cons item files-to-open))) + + ;; Got something that looks like an option... + (let* ((arg-string (make-shared-substring item 2)) + (arg-def (assoc-ref gnc:*prefs* arg-string))) + + (if (not arg-def) + (begin + (gnc:prefs-show-usage) + (set! result #f) + (set! quit? #t)) + + (let* ((arg-type (car arg-def)) + (arg-parse-result + (case arg-type + ((boolean) (gnc:cmd-line-get-boolean-arg (cdr rest))) + ((string) (gnc:cmd-line-get-string-arg (cdr rest))) + ((integer) + (gnc:cmd-line-get-integer-arg (cdr rest))) + (else + (gnc:error "bad argument type " arg-type ".") + (gnc:shutdown 1))))) + + (if (not arg-parse-result) + (begin + (set result #f) + (set! quit? #t)) + (let ((parsed-value (car arg-parse-result)) + (remaining-args (cadr arg-parse-result))) + ((cdr arg-def) parsed-value) + (set! rest remaining-args)))))))) + (if result + (gnc:debug "files to open: " files-to-open)) + + (set! gnc:*command-line-files* files-to-open) + + result)) diff --git a/src/scm/startup/config-var.scm b/src/scm/startup/config-var.scm new file mode 100644 index 0000000000..cc012e5ad4 --- /dev/null +++ b/src/scm/startup/config-var.scm @@ -0,0 +1,57 @@ + +;;; config-var: You can create them, set values, find out of the value +;;; is different from the default, and you can get a description. You +;;; can also specify an action function which will be called whenever +;;; the value is changed. The action function receives the special +;;; var and the new value as arguments and should return either #f if +;;; the modification should be rejected, or a list containing the +;;; result otherwise. + +;;; Finally, a config var has two states, "officially" modified, and +;;; unofficially modified. You control what kind of modification +;;; you're making with the second argument to +;;; gnc:config-var-value-set! The idea is that options specified on +;;; the command line will set the value of these config vars, but that +;;; setting is considered transient. Other settings (like from the UI +;;; preferences panel, or normal user code) should be considered +;;; permanent, and if they leave the variable value different from the +;;; default, should be saved to ~/.gnucash/config.auto. + +(define (gnc:make-config-var description + set-action-func + equality-func + default) + (let ((var + (vector description set-action-func equality-func #f default default))) + (gnc:config-var-value-set! var #f default) + var)) + +(define (gnc:config-var-description-get var) (vector-ref var 0)) + +(define (gnc:config-var-action-func-get var) (vector-ref var 1)) + +(define (gnc:config-var-equality-func-get var) (vector-ref var 2)) + +(define (gnc:config-var-modified? var) (vector-ref var 3)) +(define (gnc:config-var-modified?-set! var value) (vector-set! var 3 value)) + +(define (gnc:config-var-default-value-get var) (vector-ref var 4)) +(define (gnc:config-var-default-value-set! var value) (vector-set! var 4 value)) + +(define (gnc:config-var-value-get var) (vector-ref var 5)) +(define (gnc:config-var-value-set! var is-config-mod? value) + (let ((set-action (gnc:config-var-action-func-get var)) + (result (list value))) + (if set-action (set! result (set-action var value))) + (if result + (begin + (if is-config-mod? (gnc:config-var-modified?-set var #t)) + (vector-set! var 5 (car result)))))) + +(define (gnc:config-var-value-is-default? var) + (if (not (gnc:config-var-modified? var)) + #t + (let (equal-values? gnc:config-var-equality-func-get var) + (equal-values? + (gnc:config-var-default-value-get var) + (gnc:config-var-value-get var))))) diff --git a/src/scm/startup/init.scm.in b/src/scm/startup/init.scm.in new file mode 100644 index 0000000000..b24092488e --- /dev/null +++ b/src/scm/startup/init.scm.in @@ -0,0 +1,37 @@ +;;;; startup.scm -*-scheme-*- +;; +;; Minimal startup code. This file should just contain enough code to +;; get the arguments parsed and things like gnc:*load-path* set up. +;; After that *everything* should be loaded via gnc:load. + +;; This load should go away when guile gets fixed. as of guile1.3, +;; it's not. You have to do this manually, unless you call scm_shell, +;; which we can't. +(let ((boot-file (if (assoc 'prefix %guile-build-info) + (string-append (cdr (assoc 'prefix %guile-build-info)) + "/share/guile/" + (version) + "/ice-9/boot-9.scm") + "/usr/share/guile/1.3a/ice-9/boot-9.scm"))) + (primitive-load boot-file)) + +;; Automatically generated defaults... +(define gnc:_config-dir-default_ "@GNC_RUNTIME_CONFIGDIR@") +(define gnc:_share-dir-default_ "@GNC_RUNTIME_SHAREDIR@") + +(let ((lowlev-files + '("utilities.scm" + "config-var.scm" + "path.scm" + "prefs.scm" + "command-line.scm" + "main.scm"))) + + (for-each (lambda (filename) + (display "loading startup file ") + (display (string-append gnc:_startup-dir-default_ "/" filename)) + (newline) + + (primitive-load + (string-append gnc:_startup-dir-default_ "/" filename))) + lowlev-files)) diff --git a/src/scm/startup/main.scm b/src/scm/startup/main.scm new file mode 100644 index 0000000000..710deec090 --- /dev/null +++ b/src/scm/startup/main.scm @@ -0,0 +1,51 @@ + +(define (gnc:startup) + (gnc:debug "starting up.") + #t) + +(define (gnc:shutdown exit-status) + (gnc:debug "Shutdown -- exit-status: " exit-status) + + (gnc:hook-run-danglers gnc:*shutdown-hook*) + (_gnc_shutdown_ exit-status) + (exit exit-status)) + +;;;; Now the fun begins. + +(gnc:startup) + +(if (not (gnc:handle-command-line-args)) + (gnc:shutdown 1)) + +;;; Now we can load a bunch of files. + +(gnc:load "hooks.scm") +(gnc:load "doc.scm") + +;;; Load the system and user configs + +(if (not (gnc:load-system-config-if-needed)) + (gnc:shutdown 1)) + +(if (not (gnc:load-user-config-if-needed)) + (gnc:shutdown 1)) + +(gnc:hook-run-danglers gnc:*startup-hook*) + +(if (or (gnc:config-var-value-get gnc:*arg-show-usage*) + (gnc:config-var-value-get gnc:*arg-show-help*)) + (begin + (gnc:prefs-show-usage) + (gnc:shutdown 0))) + +(if (not (= (gnucash_lowlev_app_init) 0)) + (gnc:shutdown 0)) + +(if (pair? gnc:*command-line-files*) + ;; You can only open single files right now... + (gnucash_ui_open_file (car gnc:*command-line-files*)) + (gnucash_ui_select_file)) + +(gnucash_lowlev_app_main) + +(gnc:shutdown 0) diff --git a/src/scm/startup/path.scm b/src/scm/startup/path.scm new file mode 100644 index 0000000000..45f5c11bfe --- /dev/null +++ b/src/scm/startup/path.scm @@ -0,0 +1,124 @@ + +(define gnc:_load-path-directories_ #f) +(define gnc:_doc-path-directories_ #f) + +(define (gnc:_path-expand_ items default-items) + (if + (null? items) + '() + (let ((item (car items)) + (other-items (cdr items))) + (cond + ((eq? item 'default) + (append + (gnc:_path-expand_ default-items)) + (gnc:_path-expand_ other-items default-items)) + ((string? item) + (if (and (char=? #\( (string-ref item 0)) + (char=? #\) (string-ref item (- (string-length item) 1)))) + + (let ((current-dir + (make-shared-substring item 1 (- (string-length item) 1)))) + + (if (directory? current-dir) + (let ((subdirs (gnc:directory-subdirectories current-dir)) + (rest (gnc:_path-expand_ other-items default-items))) + (cons current-dir (append subdirs rest))) + (begin + (gnc:warn "Ignoring non-directory " current-dir + " in gnc:_path-expand_ item.") + (gnc:_path-expand_ other-items default-items)))) + (if (directory? item) + (begin + (gnc:warn "Ignoring non-directory " item + " in gnc:_path-expand_ item.") + (gnc:_path-expand_ other-items default-items)) + (cons item (gnc:_path-expand_ other-items default-items))))) + (else (gnc:warn "Ignoring invalid item " item " in gnc:_path-expand_.") + (gnc:_path-expand_ other-items default-items)))))) + +(define (gnc:_load-path-update_ var items) + (gnc:msg "Updating load path from " items) + (let ((result (gnc:_path-expand_ + items + (gnc:config-var-default-value-get var)))) + (if result + (begin + (set! gnc:_load-path-directories_ result) + (gnc:msg " Setting path to " result) + result) + (begin + (gnc:msg " No path... " result) + #f)))) + +(define (gnc:_doc-path-update_ var items) + (let ((result (gnc:_path-expand_ + items + (gnc:config-var-default-value-get var)))) + (if result + (begin + (set! gnc:_doc-path-directories_ result) + result) + #f))) + +;; It may make sense to dump this in favor of guile's load-path later, +;; but for now this works, and having gnc things separate may be less +;; confusing and avoids shadowing problems. + +(define (gnc:load name) + "Name must be a string. The system attempts to locate the file of +the given name and load it. The system will attempt to locate the +file in all of the directories specified by gnc:*load-path*." + + (let ((file-name (gnc:find-in-directories name gnc:_load-path-directories_))) + (if (not file-name) + #f + (if (false-if-exception (primitive-load file-name)) + (begin + (gnc:debug "loaded file " file-name) + #t) + (begin + (gnc:warn "failure loading " file-name) + #f))))) + +(define (gnc:load-user-config-if-needed) + (let ((user-config-loaded? #f)) + (lambda () + (if (not user-config-loaded) + (begin + (gnc:debug "loading user configuration") + + (let ((user-file + (string-append (getenv "HOME") "/.gnucash/config.user")) + (auto-file + (string-append (getenv "HOME") "/.gnucash/config.auto"))) + + (if (access? user-file F_OK) + (if (false-if-exception (primitive-load user-file)) + (set! gnc:user-config-loaded #t) + (begin + (gnc:warn "failure loading " user-file) + #f)) + (if (access? auto-file F_OK) + (if (false-if-exception (primitive-load auto-file)) + (set! user-config-loaded? #t) + (begin + (gnc:warn "failure loading " auto-file) + #f)))))))))) + +(define gnc:load-system-config-if-needed + (let ((system-config-loaded? #f)) + (lambda () + (if (not system-config-loaded?) + (begin + (gnc:debug "loading system configuration") + + (let ((system-config (string-append + (gnc:config-var-value-get gnc:*config-dir*) + "/config"))) + + (if (false-if-exception (primitive-load system-config)) + (set! system-config-loaded? #t) + (begin + (gnc:warn "failure loading " system-config) + #f)))))))) diff --git a/src/scm/startup/prefs.scm b/src/scm/startup/prefs.scm new file mode 100644 index 0000000000..6362a0edd3 --- /dev/null +++ b/src/scm/startup/prefs.scm @@ -0,0 +1,152 @@ + + +;;;; Preferences + +(define gnc:*arg-show-usage* + (gnc:make-config-var + "Generate an argument summary." + (lambda (var value) (if (boolean? value) (list value) #f)) + eq? + #f)) + +(define gnc:*arg-show-help* + (gnc:make-config-var + "Generate an argument summary." + (lambda (var value) (if (boolean? value) (list value) #f)) + eq? + #f)) + +(define gnc:*debugging?* + (gnc:make-config-var + "Enable debugging code." + (lambda (var value) (if (boolean? value) (list value) #f)) + eq? + #f)) + +(define gnc:*startup-dir* + (gnc:make-config-var + "Location of initial lowest level scheme startup files." + (lambda (var value) + ;; You can't change the startup dir from here. It's considered + ;; hard-coded once known -- see startup/init.scm. + #f) + string=? + gnc:_startup-dir-default_)) + +(define gnc:*config-dir* + (gnc:make-config-var + "Configuration directory." + (lambda (var value) (if (string? value) (list value) #f)) + string=? + gnc:_config-dir-default_)) + +(define gnc:*share-dir* + (gnc:make-config-var + "Shared files directory." + (lambda (var value) (if (string? value) (list value) #f)) + string=? + gnc:_share-dir-default_)) + +(define gnc:*load-path* + (gnc:make-config-var + "A list of strings indicating the load path for (gnc:load name). +Any path element enclosed in parentheses will automatically be +expanded to that directory and all its subdirectories whenever this +variable is modified. The symbol element default will expand to the default directory. i.e. (gnc:config-var-value-set! gnc:*load-path* '(\"/my/dir/\" default))" + (lambda (var value) + (if (not (list? value)) + #f + (let ((result (gnc:_load-path-update_ var value))) + (if (list? result) + (list result) + #f)))) + equal? + (list + (string-append "(" (getenv "HOME") "/.gnucash/scm)") + (string-append "(" gnc:_share-dir-default_ "/scm)")))) + +(define gnc:*doc-path* + (gnc:make-config-var + "A list of strings indicating where to look for html and parsed-html files +Any path element enclosed in parentheses will automatically be +expanded to that directory and all its subdirectories whenever this +variable is modified. The symbol element default will expand to the +default directory. i.e. (gnc:config-var-value-set! gnc:*doc-path* +'(\"/my/dir/\" default))" + (lambda (var value) + (if (not (list? value)) + #f + (let ((result (gnc:_doc-path-update_ var value))) + (if (list? result) + (list result) + #f)))) + equal? + (list + (string-append "(" (getenv "HOME") "/.gnucash/doc)") + (string-append "(" gnc:_share-dir-default_ "/Docs)") + (string-append "(" gnc:_share-dir-default_ "/Reports)")))) + +(define gnc:*prefs* + (list + + (cons + "usage" + (cons 'boolean + (lambda (val) + (gnc:config-var-value-set! gnc:*arg-show-usage* #f val)))) + (cons + "help" + (cons 'boolean + (lambda (val) + (gnc:config-var-value-set! gnc:*arg-show-help* #f val)))) + (cons + "debug" + (cons 'boolean + (lambda (val) + (gnc:config-var-value-set! gnc:*debugging?* #f val)))) + + (cons + "startup-dir" + (cons 'string + (lambda (val) + (gnc:config-var-value-set! gnc:*startup-dir* #f val)))) + + (cons + "config-dir" + (cons 'string + (lambda (val) + (gnc:config-var-value-set! gnc:*config-dir* #f val)))) + + (cons + "share-dir" + (cons 'string + (lambda (val) + (gnc:config-var-value-set! gnc:*share-dir* #f val)))) + + + (cons + "load-path" + (cons 'string + (lambda (val) + (let ((path-list + (call-with-input-string val (lambda (port) (read port))))) + (if (list? path-list) + (gnc:config-var-value-set! gnc:*load-path* #f path-list) + (begin + (gnc:error "non-list given for --load-path: " val) + (gnc:shutdown 1))))))) + + (cons + "doc-path" + (cons 'string + (lambda (val) + (let ((path-list + (call-with-input-string val (lambda (port) (read port))))) + (if (list? path-list) + (gnc:config-var-value-set! gnc:*doc-path* #f path-list) + (begin + (gnc:error "non-list given for --doc-path: " val) + (gnc:shutdown 1))))))) + + (cons "load-user-config" (cons 'boolean gnc:load-user-config-if-needed)) + (cons "load-system-config" (cons 'boolean gnc:load-system-config-if-needed)))) diff --git a/src/scm/startup/utilities.scm b/src/scm/startup/utilities.scm new file mode 100644 index 0000000000..0a6494a3f3 --- /dev/null +++ b/src/scm/startup/utilities.scm @@ -0,0 +1,76 @@ + + +;;;; Warning functions... + +(define (gnc:warn . items) + (display "gnucash: [W] ") + (for-each (lambda (i) (display i)) items) + (newline)) + +(define (gnc:error . items) + (display "gnucash: [E] ") + (for-each (lambda (i) (display i)) items) + (newline)) + +(define (gnc:msg . items) + (display "gnucash: [M] ") + (for-each (lambda (i) (display i)) items) + (newline)) + +(define (gnc:debug . items) + (if (gnc:config-var-value-get gnc:*debugging?*) + (begin + (display "gnucash: [D] ") + (for-each (lambda (i) (display i)) items) + (newline)))) + + +(define (directory? path) + ;; This follows symlinks normally. + (let* ((status (false-if-exception (stat path))) + (type (if status (stat:type status) #f))) + (eq? type 'directory))) + +(define (gnc:directory-subdirectories dir-name) + ;; Return a recursive list of the subdirs of dir-name, including + ;; dir-name. Follow symlinks. + + (let ((dir-port (opendir dir-name))) + (if (not dir-port) + #f + (do ((item (readdir dir-port) (readdir dir-port)) + (dirs '())) + ((eof-object? item) (reverse dirs)) + + (if (not (or (string=? item ".") + (string=? item ".."))) + (let* ((full-path (string-append dir-name "/" item))) + ;; ignore symlinks, etc. + (if (access? full-path F_OK) + (let* ((status (lstat full-path)) + (type (if status (stat:type status) #f))) + (if (and (eq? type 'directory)) + (set! dirs + (cons full-path + (append + (gnc:directory-subdirectories full-path) + dirs)))))))))))) + +(define (gnc:find-in-directories file directories) + "Find file named 'file' anywhere in 'directories'. 'file' must be a +string and 'directories' must be a list of strings." + + (gnc:debug "gnc:find-in-directories looking for " file " in " directories) + + (do ((rest directories (cdr rest)) + (finished? #f) + (result #f)) + ((or (null? rest) finished?) result) + + (let ((file-name (string-append (car rest) "/" file))) + (gnc:debug " checking for " file-name) + (if (access? file-name F_OK) + (begin + (gnc:debug "found file " file-name) + (set! finished? #t) + (set! result file-name))))))