diff --git a/Makefile.in b/Makefile.in index 6fc0f3a825..79ed1529dd 100644 --- a/Makefile.in +++ b/Makefile.in @@ -55,7 +55,6 @@ build-flavor: @cd lib; $(MAKE) ${FLAVOR} @cd src; $(MAKE) ${FLAVOR} ln -sf gnucash.${FLAVOR} gnucash.bin - ln -sf gnucash.${FLAVOR} gnucash-shell (cd share && rm -f scm && ln -sf ../src/scm scm) motif: diff --git a/configure b/configure index 2dcc4a49fb..a300eec10e 100755 --- a/configure +++ b/configure @@ -2700,6 +2700,7 @@ trap 'rm -fr `echo "Makefile src/guile/Makefile src/guile/gnucash.h src/scm/Makefile + src/scm/startup/Makefile src/scm/startup/init.scm src/gnome/Makefile src/motif/Makefile @@ -2813,6 +2814,7 @@ CONFIG_FILES=\${CONFIG_FILES-"Makefile src/guile/Makefile src/guile/gnucash.h src/scm/Makefile + src/scm/startup/Makefile src/scm/startup/init.scm src/gnome/Makefile src/motif/Makefile diff --git a/configure.in b/configure.in index b1e2f6ff32..b8025ecc80 100644 --- a/configure.in +++ b/configure.in @@ -239,6 +239,7 @@ AC_OUTPUT(Makefile src/guile/Makefile src/guile/gnucash.h src/scm/Makefile + src/scm/startup/Makefile src/scm/startup/init.scm src/gnome/Makefile src/motif/Makefile diff --git a/gnucash b/gnucash index 40cff10ae1..a7ce696c02 100755 --- a/gnucash +++ b/gnucash @@ -8,4 +8,4 @@ GNC_ARGS="${GNC_ARGS} --load-path (\"(./share/scm)\")" GNC_ARGS="${GNC_ARGS} --doc-path (\"(./Docs)\"\"(./Reports)\")" # Run whichever one was built last. -exec ./gnucash.bin ${GNC_ARGS} $@ +exec ./gnucash.bin ${GNC_ARGS} "$@" diff --git a/src/scm/Makefile.in b/src/scm/Makefile.in index 9319ae2c05..9518fc33d2 100644 --- a/src/scm/Makefile.in +++ b/src/scm/Makefile.in @@ -20,6 +20,7 @@ include @top_srcdir@/Makefile.init ###################################################################### # See Makefile.common for information about these variables. # +CLEAN_SUBDIRS := startup ###################################################################### all: default diff --git a/src/scm/graph.scm b/src/scm/graph.scm index 560101cd6f..8fb17cd2ae 100644 --- a/src/scm/graph.scm +++ b/src/scm/graph.scm @@ -1,27 +1,29 @@ -(define (gnc:debug . items) - (if #t - (begin - (display "gnucash: [D] ") - (for-each (lambda (i) (display i)) items) - (newline)))) - (define gnc:*pi* 3.14159265359) +(define gnc:pie-chart-colors '("DarkGreen" + "FireBrick" + "DarkBlue" + "DarkOliveGreen" + "DarkOrange" + "MediumSeaGreen" + "peru" + "DarkOrchid" + "LimeGreen")) +(set-cdr! (last-pair gnc:pie-chart-colors) gnc:pie-chart-colors) + + (define (gnc:_pie-chart-slice_ color width height center-x center-y total start-angle label value) - + (let* ((pie-radius (/ width 3)) - (full-circle (* 2 gnc:*pi*)) - (arc-sweep (* (/ value total) full-circle))) - - (gnc:debug - color width height center-x center-y total start-angle label value) - + (full-circle (* 2 gnc:*pi*)) + (arc-sweep (* (/ value total) full-circle))) + (savestate) (filltype 1) (colorname color) @@ -37,33 +39,30 @@ (endpath) (restorestate) - - (fmove (/ (* 0.90 width) (* 2 (cos (+ start-angle (/ arc-sweep 2))))) - (/ (* 0.90 width) (* 2 (sin (+ start-angle (/ arc-sweep 2)))))) - + + (let ((label-offset (* 0.90 (/ width 3)))) + (fmove (/ label-offset (* 2 (cos (+ start-angle (/ arc-sweep 2))))) + (/ label-offset (* 2 (sin (+ start-angle (/ arc-sweep 2))))))) + + (colorname "black") (alabel (char->integer #\c) (char->integer #\c) label) (restorestate) - (gnc:debug "start: " start-angle " sweep: " arc-sweep "\n") - arc-sweep)) -(define gnc:_next-wedge-color_ - (let ((colors '("DarkGreen" - "FireBrick" - "DarkBlue" - "DarkOliveGreen" - "DarkOrange" - "MediumSeaGreen" - "peru" - "DarkOrchid" - "LimeGreen"))) - (set-cdr! (last-pair colors) colors) - - (lambda () - (set! colors (cdr colors)) - (car colors)))) +(define gnc:_next-wedge-color_ #f) +(define gnc:_reset-wedge-colors_ #f) + +(let ((current-color gnc:pie-chart-colors)) + (set! gnc:_next-wedge-color_ + (lambda () + (set! current-color (cdr current-color)) + (car current-color))) + + (set! gnc:_reset-wedge-colors_ + (lambda () + (set! current-color gnc:pie-chart-colors)))) (define (pie-plotutils chart-items) ;; ((label value) (label value) (label value)) @@ -74,7 +73,6 @@ ;; get total (for-each (lambda (item) - (gnc:debug (cadr item)) (set! total (+ total (cadr item)))) chart-items) @@ -152,6 +150,65 @@ ("intangibles" 45.44) ("giant fungi" 241.87))) + (if (< (closepl) 0) ; close Plotter + (display "Couldn't close Plotter\n") + (set! result 1)) + (selectpl 0) ; select default Plotter + (if (< (deletepl handle) 0) ; delete Plotter we used + (display "Couldn't delete Plotter\n") + (set! result 1)))) + +(define (text-test) + (let ((handle #f) + (result 0)) + ;; create a Postscript Plotter that writes to standard output + (set! handle (newpl "X" + (get_fileptr_stdin) + (get_fileptr_stdout) + (get_fileptr_stderr))) + (if (< handle 0) + (begin + (display "Couldn't create Plotter\n") + (set! result 1))) + + (if (= result 0) + (begin + (selectpl handle) ; select the Plotter for use + + (if (< (openpl) 0) ; open Plotter + (begin + (display "Couldn't open Plotter\n") + (set! result 1))))) + + (space -200 -200 200 200) + (colorname "grey83") + (box -180 -180 180 180) + + (savestate) + + (filltype 1) + (colorname "DarkGreen") + (move 0 0) + + ;;(savestate) + ;;(frotate (/ (* start-angle 180) gnc:*pi*)) + ;;(cont (inexact->exact pie-radius) 0) + ;;(farc 0 0 pie-radius 0 + ;; (* pie-radius (cos arc-sweep)) + ;; (* pie-radius (sin arc-sweep))) + ;;(cont 0 0) + ;;(endpath) + + ;;(restorestate) + + ;;(fmove (/ (* 0.90 width) (* 2 (cos (+ start-angle (/ arc-sweep 2))))) + ;; (/ (* 0.90 width) (* 2 (sin (+ start-angle (/ arc-sweep 2)))))) + + (alabel (char->integer #\c) (char->integer #\c) "Rampage!") + + (restorestate) + + (if (< (closepl) 0) ; close Plotter (display "Couldn't close Plotter\n") (set! result 1)) diff --git a/src/scm/startup/Makefile.in b/src/scm/startup/Makefile.in new file mode 100644 index 0000000000..9319ae2c05 --- /dev/null +++ b/src/scm/startup/Makefile.in @@ -0,0 +1,38 @@ +# Makefile -- makefile for gnucash/scm +# Copyright (C) 1998 Rob Browning +# +# 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, write to the Free Software +# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +include @top_srcdir@/Makefile.init + +###################################################################### +# See Makefile.common for information about these variables. +# +###################################################################### + +all: default + +# This inclusion must come after the first target, and after the +# definitions of *_SRCS, etc., but before the usage of *_OBJS. +include @top_srcdir@/Makefile.common + +default: + @echo Nothing to do. + +.PHONY: default + +# Local Variables: +# tab-width: 2 +# End: diff --git a/src/scm/startup/command-line.scm b/src/scm/startup/command-line.scm index 91804ea59c..5a4bb18063 100644 --- a/src/scm/startup/command-line.scm +++ b/src/scm/startup/command-line.scm @@ -3,6 +3,75 @@ (define gnc:*command-line-files* #f) +(define gnc:*arg-defs* + (list + + (cons + "shell" + (cons 'boolean (lambda (val) #t))) + + (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)))) + (define (gnc:cmd-line-get-boolean-arg args) ;; --arg means #t ;; --arg true means #t @@ -56,35 +125,38 @@ (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 (string=? "--" item) + ;; ignore -- + (set! rest (cdr rest)) + ;; Got something that looks like an option... + (let* ((arg-string (make-shared-substring item 2)) + (arg-def (assoc-ref gnc:*arg-defs* 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 (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)) diff --git a/src/scm/startup/init.scm.in b/src/scm/startup/init.scm.in index b24092488e..fb144205e3 100644 --- a/src/scm/startup/init.scm.in +++ b/src/scm/startup/init.scm.in @@ -1,19 +1,22 @@ ;;;; 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. +;; Minimal startup code. This file should just contain (or load) +;; 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)) + +;; In pre 1.3 guile's you have to do this manually, unless you call +;; scm_shell, which we can't. +(if (or (string=? (version) "1.2") + (string=? (version) "1.3a")) + (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@") diff --git a/src/scm/startup/main.scm b/src/scm/startup/main.scm index 710deec090..246363b43b 100644 --- a/src/scm/startup/main.scm +++ b/src/scm/startup/main.scm @@ -1,7 +1,30 @@ (define (gnc:startup) (gnc:debug "starting up.") - #t) + (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))) + ) (define (gnc:shutdown exit-status) (gnc:debug "Shutdown -- exit-status: " exit-status) @@ -10,42 +33,20 @@ (_gnc_shutdown_ exit-status) (exit exit-status)) -;;;; Now the fun begins. +(define (gnc:main) + + ;; 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) + (gnc:startup) + + (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/prefs.scm b/src/scm/startup/prefs.scm index 6362a0edd3..35cb1bde40 100644 --- a/src/scm/startup/prefs.scm +++ b/src/scm/startup/prefs.scm @@ -85,68 +85,3 @@ default directory. i.e. (gnc:config-var-value-set! gnc:*doc-path* (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))))