IntenseFinance/gnucash
3
0
Fork 0
mirror of https://github.com/Gnucash/gnucash.git synced 2025-02-25 18:55:30 -06:00
Code Issues Packages Projects Releases Wiki Activity

patches from rob browning

Browse Source 
git-svn-id: svn+ssh://svn.gnucash.org/repo/gnucash/trunk@1397 57a11ea4-9604-0410-9ed3-97b8803252fd
This commit is contained in:
Linas Vepstas 1998-11-20 03:42:06 +00:00
parent a923e45fc3
commit dd05ce1fad
11 changed files with 292 additions and 183 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
Makefile.in
View File

@ -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:

2
configure vendored
View File

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

1
configure.in
View File

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

2
gnucash
View File

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

1
src/scm/Makefile.in
View File

@ -20,6 +20,7 @@ include @top_srcdir@/Makefile.init
######################################################################
# See Makefile.common for information about these variables.
#
CLEAN_SUBDIRS := startup
######################################################################
all: default

129
src/scm/graph.scm
View File

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

38
src/scm/startup/Makefile.in Normal file
View File

@ -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:

128
src/scm/startup/command-line.scm
View File

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

29
src/scm/startup/init.scm.in
View File

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

79
src/scm/startup/main.scm
View File

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

65
src/scm/startup/prefs.scm
View File

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