mirror of
https://github.com/Gnucash/gnucash.git
synced 2025-02-25 18:55:30 -06:00
* src/scm/bootstrap.scm.in: deleted (yesterday actually).
git-svn-id: svn+ssh://svn.gnucash.org/repo/gnucash/trunk@6259 57a11ea4-9604-0410-9ed3-97b8803252fd
This commit is contained in:
Rob Browning
parent
dbdb77a957
commit
f1a1379750
@ -1,250 +0,0 @@
|
||||
;; bootstrap.scm -*-scheme-*-
|
||||
;;
|
||||
;; This program is free software; you can redistribute it and/or
|
||||
;; modify it under the terms of the GNU General Public License as
|
||||
;; published by the Free Software Foundation; either version 2 of
|
||||
;; the License, or (at your option) any later version.
|
||||
;;
|
||||
;; This program is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
;;
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program; if not, contact:
|
||||
;;
|
||||
;; Free Software Foundation Voice: +1-617-542-5942
|
||||
;; 59 Temple Place - Suite 330 Fax: +1-617-542-2652
|
||||
;; Boston, MA 02111-1307, USA gnu@gnu.org
|
||||
|
||||
(define-module (gnucash bootstrap))
|
||||
|
||||
(use-modules (ice-9 slib))
|
||||
(use-modules (g-wrapped gw-gnc))
|
||||
(use-modules (g-wrapped gw-runtime))
|
||||
|
||||
;; from bootstrap.scm
|
||||
(export gnc:version)
|
||||
(export gnc:debugging?)
|
||||
(export gnc:warn)
|
||||
(export gnc:error)
|
||||
(export gnc:msg)
|
||||
(export gnc:debug)
|
||||
(export build-path)
|
||||
(export gnc:load)
|
||||
(export gnc:use-module-here!)
|
||||
|
||||
;; from main.scm
|
||||
(export gnc:main)
|
||||
|
||||
;; from path.scm
|
||||
(export gnc:make-home-dir)
|
||||
(export gnc:current-config-auto)
|
||||
|
||||
;; from command-line.scm
|
||||
(export gnc:*command-line-remaining*)
|
||||
(export gnc:*config-dir*)
|
||||
(export gnc:*share-dir*)
|
||||
|
||||
;; from doc.scm
|
||||
(export gnc:find-doc-file)
|
||||
(export gnc:load-help-topics)
|
||||
|
||||
;; from main-window.scm
|
||||
(export gnc:find-acct-tree-window-options)
|
||||
(export gnc:make-new-acct-tree-window)
|
||||
(export gnc:free-acct-tree-window)
|
||||
(export gnc:main-window-save-state)
|
||||
|
||||
;; from printing/print-check.scm
|
||||
(export make-print-check-format)
|
||||
(export gnc:print-check)
|
||||
|
||||
;; from tip-of-the-day.scm
|
||||
(export gnc:get-current-tip)
|
||||
(export gnc:increment-tip-number)
|
||||
(export gnc:decrement-tip-number)
|
||||
|
||||
(define gnc:use-guile-module-here!
|
||||
;; FIXME: this should be a temporary fix. We need to check to see
|
||||
;; if there's a more approved way to do this. As I recall, there's
|
||||
;; not, but I belive a better way will be added to Guile soon.
|
||||
|
||||
;; module == '(ice-9 slib)
|
||||
(cond
|
||||
((or (string=? "1.3" (version))
|
||||
(string=? "1.3.4" (version))
|
||||
(string=? "1.4" (version)))
|
||||
(lambda (module)
|
||||
(process-use-modules (list module))))
|
||||
(else
|
||||
(lambda (module)
|
||||
(process-use-modules (list (list module)))))))
|
||||
|
||||
;; Test for simple-format
|
||||
(if (not (defined? 'simple-format))
|
||||
(begin
|
||||
(require 'format)
|
||||
(export simple-format)
|
||||
(define simple-format format)))
|
||||
|
||||
;; Automatically generated defaults
|
||||
(define gnc:_config-dir-default_ "@-GNC_CONFIGDIR-@")
|
||||
(define gnc:_share-dir-default_ "@-GNC_SHAREDIR-@")
|
||||
(define gnc:_help-dir-default_ "@-GNC_HELPDIR-@")
|
||||
(define gnc:_lib-dir-default_ "@-GNC_LIB_INSTALLDIR-@")
|
||||
(define gnc:_pkglib-dir-default_ "@-GNC_PKGLIB_INSTALLDIR-@")
|
||||
|
||||
(define gnc:version "@-VERSION-@")
|
||||
|
||||
(set! %load-path
|
||||
(cons (string-append gnc:_share-dir-default_ "/scm")
|
||||
%load-path))
|
||||
(set! %load-path
|
||||
(cons (string-append gnc:_share-dir-default_ "/guile-modules")
|
||||
%load-path))
|
||||
|
||||
;(simple-format #t "load-path == ~S\n" %load-path)
|
||||
|
||||
;; These will be converted to config vars later (see command-line.scm)
|
||||
(define gnc:*load-path* #f)
|
||||
(define gnc:*debugging?* (if (getenv "GNC_DEBUG") #t #f))
|
||||
(define gnc:*develmode* (if (getenv "GNC_DEVEL_MODE") #t #f))
|
||||
|
||||
;; Function to get debugging
|
||||
(define (gnc:debugging?)
|
||||
(if (boolean? gnc:*debugging?*)
|
||||
gnc:*debugging?*
|
||||
(gnc:config-var-value-get gnc:*debugging?*)))
|
||||
|
||||
(define (gnc:setup-debugging)
|
||||
(if (gnc:debugging?)
|
||||
(debug-enable 'backtrace)))
|
||||
|
||||
;; These are needed for a guile 1.3.4 bug
|
||||
(debug-enable 'debug)
|
||||
(read-enable 'positions)
|
||||
|
||||
(debug-set! maxdepth 100000)
|
||||
(debug-set! stack 2000000)
|
||||
|
||||
(gnc:setup-debugging)
|
||||
|
||||
|
||||
;;;; Status output functions.
|
||||
|
||||
(define (gnc:warn . items)
|
||||
(display "gnucash: [W] ")
|
||||
(for-each (lambda (i) (write i)) items)
|
||||
(newline))
|
||||
|
||||
(define (gnc:error . items)
|
||||
(display "gnucash: [E] ")
|
||||
(for-each (lambda (i) (write i)) items)
|
||||
(newline))
|
||||
|
||||
(define (gnc:msg . items)
|
||||
(display "gnucash: [M] ")
|
||||
(for-each (lambda (i) (write i)) items)
|
||||
(newline))
|
||||
|
||||
(define (gnc:debug . items)
|
||||
(if (gnc:debugging?)
|
||||
(begin
|
||||
(display "gnucash: [D] ")
|
||||
(for-each (lambda (i) (write i)) items)
|
||||
(newline))))
|
||||
|
||||
|
||||
;; Set up timing functions
|
||||
|
||||
(define gnc:*last-time* (gettimeofday))
|
||||
|
||||
(define (gnc:timestamp . stuff)
|
||||
(let* ((now (gettimeofday))
|
||||
(delta (+ (- (car now) (car gnc:*last-time*))
|
||||
(/ (- (cdr now) (cdr gnc:*last-time*)) 1000000))))
|
||||
(gnc:msg stuff "-- Elapsed time: " delta "seconds.")
|
||||
(set! gnc:*last-time* now)))
|
||||
|
||||
|
||||
;;; Set up gnc:load.
|
||||
|
||||
(define (build-path firstelement . restofpath)
|
||||
(define separator "/")
|
||||
(define (bp first rest)
|
||||
(if (null? rest)
|
||||
first
|
||||
(bp
|
||||
(string-append first separator (car rest))
|
||||
(cdr rest))))
|
||||
(if (null? restofpath)
|
||||
firstelement
|
||||
(bp
|
||||
(string-append firstelement separator
|
||||
(car restofpath))
|
||||
(cdr restofpath))))
|
||||
|
||||
(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 (build-path (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))))))
|
||||
|
||||
(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* ((path (if (list? gnc:*load-path*)
|
||||
gnc:*load-path*
|
||||
(gnc:config-var-value-get gnc:*load-path*)))
|
||||
(file-name (gnc:find-in-directories name path)))
|
||||
(if (not file-name)
|
||||
#f
|
||||
(primitive-load file-name))))
|
||||
|
||||
(define (gnc:expand-load-path new-path)
|
||||
(let ((load-path-interpret
|
||||
(lambda (item)
|
||||
(cond ((string? item) (list item))
|
||||
((symbol? item)
|
||||
(case item
|
||||
((default)
|
||||
(list
|
||||
(string-append (getenv "HOME") "/.gnucash")
|
||||
(string-append (getenv "HOME") "/.gnucash/scm")
|
||||
(string-append gnc:_share-dir-default_ "/scm")))
|
||||
((current)
|
||||
(if (list? gnc:*load-path*)
|
||||
gnc:*load-path*
|
||||
(gnc:config-var-value-get gnc:*load-path*)))
|
||||
(else
|
||||
(gnc:warn "bad item " item " in load-path. Ignoring.")
|
||||
'())))
|
||||
(else
|
||||
(gnc:warn "bad item " item " in load-path. Ignoring.")
|
||||
'())))))
|
||||
(apply append (map load-path-interpret new-path))))
|
||||
|
||||
(let* ((load-path-override (getenv "GNC_SCM_LOAD_PATH"))
|
||||
(new-path (if load-path-override
|
||||
(call-with-input-string
|
||||
load-path-override (lambda (p) (read p)))
|
||||
'(default))))
|
||||
(set! gnc:*load-path* (gnc:expand-load-path new-path)))
|
||||
|
||||
(load-from-path "main.scm")
|
||||
Loading…
Reference in New Issue
Block a user