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

Remove some obsolete and unused Scheme files.

Browse Source
This commit is contained in:
John Ralls 2018-02-16 15:37:46 -08:00
parent 26e51339a6
commit 8b0d9425e9
11 changed files with 9 additions and 851 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

39
libgnucash/scm/CMakeLists.txt
View File

@ -1,49 +1,26 @@
ADD_SUBDIRECTORY(gnumeric)
SET (BUILD_CONFIG_SCM ${CMAKE_CURRENT_BINARY_DIR}/build-config.scm)
SET (scm_SCHEME_4
substring-search.scm
xml-generator.scm
)
configure_file(build-config.scm.in ${BUILD_CONFIG_SCM})
add_custom_target(build-config-scm DEPENDS ${BUILD_CONFIG_SCM})
SET(GUILE_DEPENDS scm-core-utils scm-gnc-module)
SET(scm_scm_1_SCHEME printf.scm string.scm main.scm)
SET(scm_SCHEME_0
fin.scm
string.scm
${BUILD_CONFIG_SCM}
substring-search.scm
xml-generator.scm
)
GNC_ADD_SCHEME_TARGETS(scm-scm-0 "${scm_SCHEME_0}" "" "" FALSE)
GNC_ADD_SCHEME_TARGETS(scm-scm-1 "printf.scm" gnucash "" FALSE)
GNC_ADD_SCHEME_TARGETS(scm-scm-2
main.scm
GNC_ADD_SCHEME_TARGETS(scm-scm-1
"${scm_scm_1_SCHEME}"
gnucash
"scm-scm-1;${GUILE_DEPENDS};build-config-scm" # requires printf.scm from scm-scm-1 and modules from GUILE_DEPENDS
"${GUILE_DEPENDS}"
FALSE
)
# depends on main.scm
GNC_ADD_SCHEME_TARGETS(scm-scm-3
GNC_ADD_SCHEME_TARGETS(scm-scm-2
price-quotes.scm
gnucash
"scm-scm-2;scm-scm-0" # depends on build_config.scm
scm-scm-1
FALSE)
ADD_CUSTOM_TARGET(scm-scm ALL DEPENDS scm-scm-3 scm-scm-2 scm-scm-1 scm-scm-0 scm-gnumeric)
ADD_CUSTOM_TARGET(scm-scm ALL DEPENDS scm-scm-1 scm-scm-2)
INSTALL(FILES config DESTINATION ${CMAKE_INSTALL_FULL_SYSCONFDIR}/gnucash)
SET_LOCAL_DIST(scm_DIST_local config CMakeLists.txt fin.scm string.scm build-config.scm.in substring-search.scm
xml-generator.scm main.scm price-quotes.scm printf.scm ${scm_SCHEME_4})
SET_LOCAL_DIST(scm_DIST_local CMakeLists.txt ${scm_scm_1_SCHEME} price-quotes.scm)
SET(scm_DIST ${scm_DIST_local} ${scm_gnumeric_DIST} PARENT_SCOPE)

6
libgnucash/scm/build-config.scm.in
View File

@ -1,6 +0,0 @@
(define gnc:version "@VERSION@")
;; Automatically generated defaults (don't use these directly --
;; they're used during actual initialization elsewhere)
(define gnc:_install-doc-path_ '("@GNC_HELPDIR@"))

4
libgnucash/scm/config
View File

@ -1,4 +0,0 @@
;;; -*-scheme-*-
;; Sample system-wide config file. At the moment, it's empty.

181
libgnucash/scm/fin.scm
View File

@ -1,181 +0,0 @@
;; 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
;; 51 Franklin Street, Fifth Floor Fax: +1-617-542-2652
;; Boston, MA 02110-1301, USA gnu@gnu.org
;; Financial functions originally used by the mortgage/loan druid,
;; but useful in scheduled transactions
;;
;; Copyright 2002 Joshua Sled <jsled@asynchronous.org>
;; Update 2012 Frank H. Elenberger <frank.h.ellenberger@gmail.com>
;;
;; Simple function for testing:
(define (gnc:foobar val) val)
;; pretty literal copies of similar code from gnumeric-1.0.8, except we want
;; positive values to be returned (as gnucash will handle the credit/debit
;; appropriately)
;; interest payment amount:
(define (gnc:ipmt rate per nper pv fv type)
(* -1 (* rate
(- 0 (calc-principal pv
(calc-pmt rate nper pv fv type)
rate (- (if (> per nper) nper per) 1)))))
)
;; principal payment amount:
(define (gnc:ppmt rate per nper pv fv type)
(let* ((pmt (calc-pmt rate nper pv fv type))
(ipmt (gnc:ipmt rate per nper pv fv type)))
(* -1 (- pmt (* -1 ipmt))))
)
;; payment amount:
(define (gnc:pmt rate nper pv fv type)
(* -1 (calc-pmt rate nper pv fv type))
)
;; 2 functions from http://lists.gnucash.org/pipermail/gnucash-user/2005-February/012964.html
;; future value of deposits with compound interests:
(define (gnc:futureValue a r n t)
;; Parameters:
;; a: amount
;; r: interest rate
;; n: frequency per year
;; t: time
;;
;; formula from http://www.riskglossary.com/articles/compounding.htm
(* a (expt (+ 1 (/ r n)) (* n t))))
(define (gnc:computeInterestIncrement amount interest periods i)
(let ((thisVal (gnc:futureValue amount interest periods i))
(prevVal (gnc:futureValue amount interest periods (- i 1))))
(- thisVal prevVal)
)
)
;;;;;
;; below: not-exposed/"private" functions, used by the "public" functions
;; above.
;;;;;
(define (calc-pmt rate nper pv fv type)
(let ((pvif (calc-pvif rate nper))
(fvifa (calc-fvifa rate nper)))
(/ (- (* (- 0 pv) pvif) fv)
(* fvifa
(+ 1.0
(* rate type)))))
)
(define (calc-pvif rate nper)
(expt (+ 1 rate) nper)
)
(define (calc-fvifa rate nper)
(/ (- (expt (+ 1 rate) nper) 1) rate)
)
(define (calc-principal pv pmt rate per)
(+ (* pv (expt (+ 1.0 rate) per))
(* pmt (/ (- (expt (+ 1 rate) per)
1)
rate)))
)
;; This section added in 2005. Ludovic Nicolle
;; Formula to get the rate for a given period if there are yper in the year
;; And the official rate is compounded ycomp in the year.
;; For example, a mortgage being monthly has yper = 12
;; and if the posted rate is a plain annual rate, then ycomp = 1.
;; but if the posted rate is compounded semi-annually, as is the case in Canada,
;; then ycomp = 2.
;; this function can be used to enter the nominal rate in the formulas, without
;; pre-calculating the power function below.
(define (gnc:periodic_rate rate yper ycomp)
(- (expt (+ 1.0 (/ rate ycomp)) (/ ycomp yper) ) 1.0)
)
;; the three following functions with prefix gnc:cpd_ are more generic equivalents of
;; gnc:pmt, gnc:ipmt and gnc:ppmt above, with some differences.
;; First difference is that they take the annual nominal rate and two yearly frequencies:
;; rate is annual, not per period (the functions calculate it themselves)
;; yfreq determines the compounding frequency of the payed/charged interest
;; ycomp determines the compounding frequency of the annual nominal rate
;; Second difference is for rounding. My experience shows that all banks do not use
;; the exact same rounding parameters. Moreover, on top of that situation, numerical calculations
;; in gnucash using the original gnc:pmt, gnc:ipmt and gnc:ppmt functions above can also
;; create another set of rounding issues. Both problems create the "odd-penny imbalance" problem.
;; So the gnc:cpd_Zpmt functions do automatic rounding, the goal being to have PPMT = PMT - I
;; holding true for all calculated numbers. However, this won't fix the first problem if your bank
;; can't do proper maths and manual fixing of transactions will still be required.
;; FIXME: One problem with the rounding procedure in these three functions is that it is always
;; rounding at the second decimal. This works great with dollars and euros and a lot of major
;; currencies but might well cause issues with other currencies not typically divided in 100.
;; I have not tested anything else than dollars.
;; If the automatic rounding causes issues for a particular case, one can always use the
;; equivalence of the cpd_ and non-cpd_ functions, by using periodic_rate() like this:
;; gnc:cpd_pmt( rate:yfreq:ycomp :nper:pv:fv:type)
;; is equivalent to gnc:pmt(periodic_rate(rate:yfreq:ycomp):nper:pv:fv:type)
;; On the opposite side, if you want the automatic rounding but don't understand how to use
;; the cpd_ functions, here is a quick example on how to convert original gnc:Zpmt
;; function calls. The typical setup is to use 'rate/yfreq' as the first parameter, so the
;; solution is to simply use yfreq for both yfreq and ycomp in the gnc:cpd_Zpmt calls, like this:
;; gnc:pmt( rate / yfreq :nper:pv:fv:type)
;; is equivalent to gnc:cpd_pmt( rate:yfreq:yfreq :nper:pv:fv:type)
(define (gnc:cpd_ipmt rate yfreq ycomp per nper pv fv type)
(* 0.01
(round
(* -100 (* (gnc:periodic_rate rate yfreq ycomp)
(- 0 (calc-principal pv
(calc-pmt (gnc:periodic_rate rate yfreq ycomp) nper pv fv type)
(gnc:periodic_rate rate yfreq ycomp) (- per 1))))
)
)
)
)
(define (gnc:cpd_ppmt rate yfreq ycomp per nper pv fv type)
(let* (
(per_rate (gnc:periodic_rate rate yfreq ycomp))
(pmt (* -1 (gnc:cpd_pmt rate yfreq ycomp nper pv fv type)))
(ipmt (* per_rate (calc-principal pv pmt per_rate (- per 1))))
)
(
* -1 (+ pmt ipmt)
)
)
)
(define (gnc:cpd_pmt rate yfreq ycomp nper pv fv type)
(* 0.01
(round
(* -100
(calc-pmt (gnc:periodic_rate rate yfreq ycomp) nper pv fv type)
)
)
)
)

13
libgnucash/scm/gnumeric/CMakeLists.txt
View File

@ -1,13 +0,0 @@
SET(gnumeric_SCHEME gnumeric-utilities.scm table-utils.scm)
GNC_ADD_SCHEME_TARGETS(scm-gnumeric
"${gnumeric_SCHEME}"
gnumeric
""
FALSE
)
SET_DIST_LIST(scm_gnumeric_DIST CMakeLists.txt ${gnumeric_SCHEME})

248
libgnucash/scm/gnumeric/gnumeric-utilities.scm
View File

@ -1,248 +0,0 @@
;;;; gnumeric-utilities.scm - Gnumeric spreadsheet generation functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 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
;; 51 Franklin Street, Fifth Floor Fax: +1-617-542-2652
;; Boston, MA 02110-1301, USA gnu@gnu.org
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(use-modules (srfi srfi-19))
;; (gnc:depend "xml-generator.scm") -- this needs to be changed to a
;; use-modules, but since this file doesn't appear to be used right
;; now, that can wait.
;;;; Gnumeric spreadsheet consists of:
;;;; gmr:Workbook
;;;; gmr:Summary Done
;;;; gmr:Geometry Done
;;;; gmr:Sheets
;;;; gmr:Sheet
;;;; gmr:Name - Need the Sheet name
;;;; gmr:MaxCol - omission OK
;;;; gmr:MaxRow - omission OK
;;;; gmr:Zoom - omission OK
;;;; gmr:PrintInformation - omission OK
;;;; gmr:Styles - Ok to omit
;;;; gmr:StyleRegion - optional
;;;; gmr:Style - optional
;;;; gmr:Font - optional
;;;; gmr:StyleBorder - optional
;;;; gmr:Top - optional
;;;; gmr:Bottom - optional
;;;; gmr:Left - optional
;;;; gmr:Right - optional
;;;; gmr:Diagonal - optional
;;;; gmr:Rev-Diagonal - optional
;;;; gmr:Cols - Optional, but should have this one...
;;;; gmr:ColInfo (No Unit MarginA MarginB HardSize Hidden)
;;;; gmr:Rows - Quite Optional
;;;; gmr:RowInfo (No Unit MarginA MarginB HardSize Hidden)
;;;; gmr:Cells - This is the meat of the matter...
;;;; gmr:Cell (Col Row Style)
;;;; gmr:Content
;;; Here's a kludgy function that is intended to compute the number of
;;; days since December 31, 1899. It is only approximate; feel free
;;; to suggest a better function.
;;; The point of this is that Gnumeric uses this as the "native" data
;;; representation.
(define (exceldate y m d)
(let
((epoch (encode-julian-day-number 31 12 1899)))
(- (encode-julian-day-number d m y) epoch)))
;(define (ymd->number y m d)
; (+
; 1 ;;; Start at 1
; (* (- y 1900) 365) ;;; 365 days per year
; d ;;; Add the number of days
; (vector-ref #(0 31 59 90 120 151 181 212 243 273 304 334)
; (- m 1));;; Add in days associated with month
; (truncate (/ (- y 1900) 4)) ;;; Add in leap days, valid 'til
; ;;; year 2100...
; (if
; (and (= 0 (modulo y 4)) ;;; If a leap year,
; (> m 2)) ;;; and month is post-Feb
; 1 ;;; add an extra day
; 0)))
;;; gmr:Summary appears to be some metadata about who/what generated
;;; the document.
(define (make-gmr-summary)
(define (make-gmr-item name value)
(xml-element
'gmr:Item no-attributes
(list (xml-element 'gmr:name no-attributes name)
(xml-element 'gmr:val-string no-attributes value))))
(xml-element
'gmr:Summary no-attributes
(list
(make-gmr-item "application"
"gnumeric")
(make-gmr-item "Author"
"GnuCash Generator"))))
;;; This function generates a goodly chunk of the document structure;
;;; gmr:Workbook is the base element for Gnumeric
(define (gnumeric-workbook sheets)
(xml-element
'gmr:Workbook '((xmlns:gmr . "http://www.gnome.org/gnumeric/v2"))
(list
(make-gmr-summary)
(xml-element 'gmr:Geometry '((Width . 912) (Height . 720)) no-children)
(xml-element 'gmr:Sheets no-attributes sheets))))
(define (gnumeric-xml-cell row col contents)
(xml-element
'gmr:Cell
(xml-attributes (xml-attribute 'Col col)
(xml-attribute 'Row row)
(xml-attribute 'Style 0))
(list (xml-element 'gmr:Content no-attributes contents))))
;;; Generate a set of style regions for a given Sheet
;;; This ought also to support the notion of named styles, but that
;;; can wait
(define (gnumeric-styles rows colassoc)
(xml-element
'gmr:Styles no-attributes
(map
(lambda (coll)
(let ((col (car coll))
(fmt (cdr coll)))
(gnumeric-style-column rows col fmt)))
colassoc)))
;;; Generate a StyleRegion for the given column
(define (gnumeric-style-column totalrows col format)
(xml-element
'gmr:StyleRegion
(xml-attributes (xml-attribute 'startCol col)
(xml-attribute 'endCol col)
(xml-attribute 'startRow 0)
(xml-attribute 'endRow totalrows))
(list (xml-element 'gmr:Style
(xml-attributes
(xml-attribute 'Format format))
no-children))))
(define (gmr:cell col row cell-value)
(xml-element
'gmr:Cell
(xml-attributes
(xml-attribute 'Col col)
(xml-attribute 'Row row))
cell-value))
;;; Each Sheet requires Cols to define the widths of columns.
;;; Don't omit this.
(define (gnumeric-columns collist)
(xml-element 'gmr:Cols no-attributes
(map (lambda (colassoc)
(xml-element 'gmr:ColInfo colassoc no-children))
collist)))
;;; And here's a function that generates a whole Sheet.
;;; It forces in style info; that's probably not the best thing to do.
(define (gnumeric-sheet name rows cols cells)
(let ((namelst (xml-element 'gmr:Name no-attributes name))
(stylelst (gnumeric-styles
rows our-style-list))
(celllst (xml-element 'gmr:Cells no-attributes cells)))
(xml-element 'gmr:Sheet no-attributes
(list
namelst
cols
stylelst
celllst))))
;;; Define some wild accounting-oriented display formats
(define our-style-list
(let ((acctgstyle "_($*#,##0.00_);_($(#,##0.00);_($*&quot;-&quot;??_);(@_)")
(coloredstyle "$0.00_);[Red]($0.00)"))
(list (cons 0 "yyyy-mm-dd")
(cons 2 acctgstyle)
(cons 3 coloredstyle))))
(define (gen-cells-for-txn txn row)
(display txn) (newline)
(apply
(lambda (y m d descr amt)
(list
(gmr:cell 0 row (exceldate y m d))
(gmr:cell 1 row descr)
(gmr:cell 2 row amt)
(gmr:cell 3 row (string-append "=D" (number->string row)
"+C"
(number->string (+ row 1))))))
txn))
(define (sample-cells)
(let loop
((txns
(sort
(append
'((1998 12 31 "Opening Balance" 0))
(map (lambda (x) (list 1999 x 1 "Rent" -500))
'(1 2 3 4 5 6 7 8 9 10 11 12))
(map (lambda (x) (list 1999 x 1 "Salary" 1200))
'(1 2 3 4 5 6 7 8 9 10 11 12))
(map (lambda (x) (list 1999 x 15 "Salary" 1200))
'(1 2 3 4 5 6 7 8 9 10 11 12))
(map (lambda (x) (list 1999 x 12 "Phone" -35))
'(1 2 3 4 5 6 7 8 9 10 11 12)))
(lambda (lst1 lst2)
(if (= (car lst1) (car lst2))
(if (= (cadr lst1) (cadr lst2))
(if (= (caddr lst1) (caddr lst2))
(if (string=? (cadddr lst1) (cadddr lst2))
#t
(string<? (cadddr lst1) (cadddr lst2)))
(< (caddr lst1) (caddr lst2)))
(< (cadr lst1) (cadr lst2)))
(< (car lst1) (car lst2))))))
(row 1)
(cells '()))
(if (null? txns)
cells
(loop (cdr txns)
(+ row 1)
(let* ((txn (car txns)))
(append cells (gen-cells-for-txn txn row)))))))
(define (build-full-sample)
(let*
((cells (sample-cells))
(cols 4)
(collist '(((No . 0) (Unit . 85))
((No . 1) (Unit . 150))
((No . 2) (Unit . 75))
((No . 3) (Unit . 75))))
(rows (/ (length cells) cols))
(cols (gnumeric-columns collist))
(sheet (gnumeric-sheet "Sample" rows cols cells))
(sheets (list sheet)))
(gnumeric-workbook sheets)))
;;; This function generates a whole whack of cells and formulae
(define (generate-sampl filename)
(let ((p (open-output-file filename))
(ss (build-full-sample)))
(display "<?xml version=\"1.0\"?>" p)
(output-xml-element ss p)
(close-output-port p)))

61
libgnucash/scm/gnumeric/table-utils.scm
View File

@ -1,61 +0,0 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 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
;; 51 Franklin Street, Fifth Floor Fax: +1-617-542-2652
;; Boston, MA 02110-1301, USA gnu@gnu.org
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (make-table-collector)
(let ;;; variable slots
((total 0) ;;; Numeric total
(rows '()) ;;; Collection of items into total
(count 0)) ;;; Number of elements
(let
((adder (lambda (amount pos)
(set! total (+ total amount))
(set! rows (cons pos rows))
(set! count (+ count 1))))
(gettotal (lambda () total))
(getcount (lambda () count))
(getrows (lambda () rows))
(resetall (lambda ()
(set! total 0)
(set! rows '())
(set! count 0))))
(lambda (action value . rowdata)
(case action
((add) (adder value rowdata))
((total) (gettotal))
((getcount) (getcount))
((getrows) (getrows))
((reset) (resetall)))))))
;;; Here's how it looks:
; > (define a (make-table-collector))
; > (a 'add 2)
; > (a 'add 4 5 6)
; > (a 'add 6 7 8)
; > (a 'add 9 10)
; > (a 'getcount #f)
; 4
; > (a 'total #f)
; 21
; > (a 'getrows #f)
; ((10) (7 8) (5 6) ())
; > (a 'reset #f)
; > (list (a 'getcount #f) (a 'total #f) (a 'getrows #f))
; (0 0 ())
; >

6
libgnucash/scm/main.scm
View File

@ -15,8 +15,7 @@
;; 51 Franklin Street, Fifth Floor Fax: +1-617-542-2652
;; Boston, MA 02110-1301, USA gnu@gnu.org
(define-module (gnucash main)
#:use-module (gnucash printf))
(define-module (gnucash main))
;; Turn off the scheme compiler's "possibly unbound variable" warnings.
;; In guile 2.0 we get nearly 7500 of them loading the scheme files.
@ -50,9 +49,6 @@
(export gnc:debug)
(export gnc:safe-strcmp) ;; only used by aging.scm atm...
;; Get the cmake generated variables.
(load-from-path "build-config")
;; Do this stuff very early -- but other than that, don't add any
;; executable code until the end of the file if you can help it.
;; These are needed for a guile 1.3.4 bug

110
libgnucash/scm/substring-search.scm
View File

@ -1,110 +0,0 @@
; IMPLEMENTS Substring search
; AUTHOR Ken Dickey
; DATE 1991 August 6
; LAST UPDATED
; NOTES
;Based on "A Very Fast Substring Search Algorithm", Daniel M. Sunday,
;CACM v33, #8, August 1990.
;;
;; SUBSTRING-SEARCH-MAKER takes a string (the "pattern") and returns a function
;; which takes a string (the "target") and either returns #f or the index in
;; the target in which the pattern first occurs as a substring.
;;
;; E.g.: ((substring-search-maker "test") "This is a test string") -> 10
;; ((substring-search-maker "test") "This is a text string") -> #f
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 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
;; 51 Franklin Street, Fifth Floor Fax: +1-617-542-2652
;; Boston, MA 02110-1301, USA gnu@gnu.org
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (substring-search-maker pattern-string)
(define num-chars-in-charset 256) ;; update this, e.g. for iso latin 1
(define (build-shift-vector pattern-string)
(let* ((pat-len (string-length pattern-string))
(shift-vec (make-vector num-chars-in-charset
(+ pat-len 1)))
(max-pat-index (- pat-len 1)))
(let loop ((index 0))
(vector-set! shift-vec
(char->integer
(string-ref pattern-string index))
(- pat-len index))
(if (< index max-pat-index)
(loop (+ index 1))
shift-vec))))
(let ((shift-vec (build-shift-vector pattern-string))
(pat-len (string-length pattern-string)))
(lambda (target-string)
(let* ((tar-len (string-length target-string))
(max-tar-index (- tar-len 1))
(max-pat-index (- pat-len 1)))
(let outer ( (start-index 0))
(if (> (+ pat-len start-index) tar-len)
#f
(let inner ( (p-ind 0) (t-ind start-index) )
(cond
((> p-ind max-pat-index) ; nothing left to check
#f) ; fail
((char=? (string-ref pattern-string p-ind)
(string-ref target-string t-ind))
(if (= p-ind max-pat-index)
start-index ;; success -- return start index of match
(inner (+ p-ind 1) (+ t-ind 1)) ; keep checking
))
((> (+ pat-len start-index) max-tar-index) #f) ; fail
(else
(outer (+ start-index
(vector-ref
shift-vec
(char->integer
(string-ref target-string
(+ start-index pat-len)))))))))))))))
;;; Functions to split up strings
;;; Provides the generic facility to split based on *any* character
;;; We make use of splitting on spaces and on colons...
;;; Find the next occurrence of [somechar] in the string [string]
;;; starting at [startpos]
(define (split-on-somechar sourcestring somechar)
(define (next-somechar string startpos endpos somechar)
(let loop
; initialize
((pos startpos))
(cond
((>= pos endpos) endpos) ; Reached end of string
((char=? (string-ref string pos) somechar) pos) ; Reached "somechar"
(else
(loop (+ pos 1))))))
(let loop
((pos 0)
(endpos (string-length sourcestring))
(result '()))
(cond
((>= pos endpos) result)
(else
(let ((nextwhatever
(next-somechar sourcestring pos endpos somechar)))
(loop
(+ nextwhatever 1)
endpos
(append result
(list
(substring sourcestring pos nextwhatever)))))))))

187
libgnucash/scm/xml-generator.scm
View File

@ -1,187 +0,0 @@
;;;;;;;;;;;;;
;; 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
;; 51 Franklin Street, Fifth Floor Fax: +1-617-542-2652
;; Boston, MA 02110-1301, USA gnu@gnu.org
;;;;;;;;;;;;;
;;;; by Christopher Browne
;;;; <cbbrowne@hex.net>, <cbbrowne@ntlug.org>
;;;;
;;;; This was created for GnuCash to assist in creating
;;;; XML output to generate spreadsheets readable by
;;;; Gnumeric.
;;;;
;;;; The model is that an element consists of a list with
;;;; three entries. Elements are created thus:
;;;; (define (make-xml-element tag attributes children)
;;;; (list tag attributes children))
;;;; - The first entry is the tag name.
;;;; - The second entry optionally consists of an association list
;;;; containing the attributes of the element, or is #f.
;;;; - The third entry is either a list of children, or is #f.
;;;;
;;;; Notable idiosyncracies aka "features" aka "misfeatures":
;;;; - All elements may come in the form of symbols, strings, or
;;;; numbers. output-xml-element (and helpers) transform these all
;;;; into strings.
;;;; - It is possible that efficiency could be improved by memoizing
;;;; the strings that get generated. That way, we don't need to
;;;; generate a new string each time a symbol gets hit.
;;;; - The "children" can have three values:
;;;; a) #f, indicating that there are no children, as with:
;;;; (NoEndTag ((Att1 . 1) (Att2 . 2)) #f) which turns into
;;;; <NoEndTag Att1="1" Att2="2"/>
;;;; b) It may be a simple attribute, like "Contents" or 1.5, as
;;;; with (SimpleEndTag #f "Contents") which transforms to:
;;;; <SimpleEndTag>Contents</SimpleEndTag>
;;;; c) Otherwise, it must consist of a list of elements, thusly:
;;;; (Parent #f ((Child #f Value1) (Child #f Value2)) which turns
;;;; to: <Parent> <Child>Value1</Child> <Child>Value2</Child> </Parent>
;;;;
;;;; Usage
;;;; -------
;;;; The driver of it is (output-xml-element element port).
;;;; One might output an XML document with a root node, ROOT, thus:
;;;;(let ((port (open-output-file "/tmp/sampleoutput")))
;;;; (display "<?xml version=\"1.0\"?>" port)
;;;; (newline port)
;;;; (output-xml-element ROOT port)
;;;; (close-output-port port))
;;;;
;;;; If you have a Very Large Document, you might not want to
;;;; construct the whole document as One Big List;
;;;; output-xml-element will be useful for generating subtree output.
;;;; Your control structure will need to duplicate the structure of
;;;; output-xml-element. Alternatively, if "children" could is a thunk
;;;; (function with no arguments), invoking output-xml-element
;;;; internally as needed, the "children" can be an XML generator.
(define xml-indentation 0)
(define (xml-display x port)
(if port
(display x port)
(display x)))
(define (xml-newline port)
(if port
(newline port)
(newline)))
(define (make-tabs port)
(let loop
((i 0))
(if (>= i xml-indentation)
#f
(begin
(xml-display " " port)
(loop (+ i 1)))))
(set! xml-indentation (+ xml-indentation 1)))
(define (output-xml-element-name elname port)
(xml-newline port)
(make-tabs port)
(xml-display
(string-append
"<"
(element-to-string elname))
port))
(define (output-xml-element-name-end elname port)
(set! xml-indentation (- xml-indentation 1))
(xml-display
(string-append
"</"
(element-to-string elname)
">")
port))
(define (output-xml-attribute att port)
; (display "output-xml-attribute: ") (display attribute) (newline)
(xml-display (string-append
" "
(element-to-string (car att))
"=\""
(element-to-string (cdr att))
"\"")
port))
(define (element-to-string obj)
; (display "[element-to-string: ") (display obj) (display "]") (newline)
(cond
((string? obj) obj)
((symbol? obj) (symbol->string obj))
((number? obj) (number->string obj))
(else
(string-append "[ERROR in element-to-string: "
(list->string (list obj))
" not a symbol, string or number.]"))))
(define (output-xml-attributes attributes port)
;(display "output-xml-attributes: ") (display attributes) (newline)
(if attributes
(for-each
(lambda (attribute)
(output-xml-attribute attribute port))
attributes)))
(define (output-xml-children children port)
; (display "[output-xml-children: ") (display children) (display "]")(newline)
(cond
((list? children)
(for-each (lambda (child)
(output-xml-element child port))
children))
(else
(xml-display (element-to-string children) port))))
(define (output-xml-element element port)
(let ((elname (car element))
(attributes (cadr element))
(children (caddr element)))
(output-xml-element-name elname port)
(output-xml-attributes attributes port)
(cond
((not children) ;;; If children is blank
(xml-display "/>" port)) ;;; Short result
((procedure? children) ;;; If children is a function
(xml-display ">" port)
(children port) ;;; Invoke the function
(output-xml-element-name-end elname port))
(else
(xml-display ">" port)
(output-xml-children children port)
(output-xml-element-name-end elname port)))))
(define (xml-element tag attributes children)
(list tag attributes children))
(define (xml-attribute name value)
(cons name value))
(define (xml-attributes . alist)
alist)
;;; (if (> 0 (length alist)) ;;; If there's anything in the list
;;; alist ;;; Return the list
;;; #f)) ;;; Otherwise, blank to #f
(define no-attributes
(xml-attributes))
(define no-children
#f)

5
po/POTFILES.in
View File

@ -693,15 +693,10 @@ libgnucash/engine/TransLog.c
libgnucash/gnc-module/example/gncmod-example.c
libgnucash/gnc-module/gnc-module.c
libgnucash/gnc-module/gnc-module.scm
libgnucash/scm/fin.scm
libgnucash/scm/gnumeric/gnumeric-utilities.scm
libgnucash/scm/gnumeric/table-utils.scm
libgnucash/scm/main.scm
libgnucash/scm/price-quotes.scm
libgnucash/scm/printf.scm
libgnucash/scm/string.scm
libgnucash/scm/substring-search.scm
libgnucash/scm/xml-generator.scm
libgnucash/tax/us/de_DE.scm
libgnucash/tax/us/gncmod-tax-us.c
libgnucash/tax/us/txf-de_DE.scm