patches from rob browning

git-svn-id: svn+ssh://svn.gnucash.org/repo/gnucash/trunk@1397 57a11ea4-9604-0410-9ed3-97b8803252fd

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:

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

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

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} "$@"

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

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))

src/scm/startup/Makefile.in

@@ -0,0 +1,38 @@
+# Makefile -- makefile for gnucash/scm
+# Copyright (C) 1998 Rob Browning <rlb@cs.utexas.edu>              
+#                                                                  
+# 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:

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))
     

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@")

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.
-
-(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)
+(define (gnc:main)
+  
+  ;; Now the fun begins.
 
-(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))

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))))