diff --git a/libgnucash/scm/CMakeLists.txt b/libgnucash/scm/CMakeLists.txt index 076bddd398..727a506901 100644 --- a/libgnucash/scm/CMakeLists.txt +++ b/libgnucash/scm/CMakeLists.txt @@ -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) diff --git a/libgnucash/scm/build-config.scm.in b/libgnucash/scm/build-config.scm.in deleted file mode 100644 index f906a33bfe..0000000000 --- a/libgnucash/scm/build-config.scm.in +++ /dev/null @@ -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@")) diff --git a/libgnucash/scm/config b/libgnucash/scm/config deleted file mode 100644 index a5494f052c..0000000000 --- a/libgnucash/scm/config +++ /dev/null @@ -1,4 +0,0 @@ -;;; -*-scheme-*- - -;; Sample system-wide config file. At the moment, it's empty. - diff --git a/libgnucash/scm/fin.scm b/libgnucash/scm/fin.scm deleted file mode 100644 index d30cc85803..0000000000 --- a/libgnucash/scm/fin.scm +++ /dev/null @@ -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 -;; Update 2012 Frank H. Elenberger -;; - -;; 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) - ) - ) - ) -) diff --git a/libgnucash/scm/gnumeric/CMakeLists.txt b/libgnucash/scm/gnumeric/CMakeLists.txt deleted file mode 100644 index 3ea75dd522..0000000000 --- a/libgnucash/scm/gnumeric/CMakeLists.txt +++ /dev/null @@ -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}) diff --git a/libgnucash/scm/gnumeric/gnumeric-utilities.scm b/libgnucash/scm/gnumeric/gnumeric-utilities.scm deleted file mode 100644 index 8872b5d9d2..0000000000 --- a/libgnucash/scm/gnumeric/gnumeric-utilities.scm +++ /dev/null @@ -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);_($*"-"??_);(@_)") - (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" p) - (output-xml-element ss p) - (close-output-port p))) diff --git a/libgnucash/scm/gnumeric/table-utils.scm b/libgnucash/scm/gnumeric/table-utils.scm deleted file mode 100644 index 10fa1420fa..0000000000 --- a/libgnucash/scm/gnumeric/table-utils.scm +++ /dev/null @@ -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 ()) -; > - diff --git a/libgnucash/scm/main.scm b/libgnucash/scm/main.scm index 69f74db68d..8597273a70 100644 --- a/libgnucash/scm/main.scm +++ b/libgnucash/scm/main.scm @@ -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 diff --git a/libgnucash/scm/substring-search.scm b/libgnucash/scm/substring-search.scm deleted file mode 100644 index bb249802aa..0000000000 --- a/libgnucash/scm/substring-search.scm +++ /dev/null @@ -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))))))))) diff --git a/libgnucash/scm/xml-generator.scm b/libgnucash/scm/xml-generator.scm deleted file mode 100644 index 2aa826eeaf..0000000000 --- a/libgnucash/scm/xml-generator.scm +++ /dev/null @@ -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 -;;;; , -;;;; -;;;; 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 -;;;; -;;;; b) It may be a simple attribute, like "Contents" or 1.5, as -;;;; with (SimpleEndTag #f "Contents") which transforms to: -;;;; Contents -;;;; c) Otherwise, it must consist of a list of elements, thusly: -;;;; (Parent #f ((Child #f Value1) (Child #f Value2)) which turns -;;;; to: Value1 Value2 -;;;; -;;;; 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 "" 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 - "") - 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) diff --git a/po/POTFILES.in b/po/POTFILES.in index f10717e4fe..b4090ac9a1 100644 --- a/po/POTFILES.in +++ b/po/POTFILES.in @@ -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