AUDIT: r17191 - gnucash/trunk/src - QIF Import: Fix support for multi-byte account separators.
Charles Day
cedayiv at cvs.gnucash.org
Fri Jun 6 12:46:04 EDT 2008
Author: cedayiv
Date: 2008-06-06 12:46:03 -0400 (Fri, 06 Jun 2008)
New Revision: 17191
Trac: http://svn.gnucash.org/trac/changeset/17191
Added:
gnucash/trunk/src/scm/string.scm
Modified:
gnucash/trunk/src/import-export/qif-import/qif-dialog-utils.scm
gnucash/trunk/src/import-export/qif-import/qif-guess-map.scm
gnucash/trunk/src/import-export/qif-import/qif-parse.scm
gnucash/trunk/src/import-export/qif-import/qif-to-gnc.scm
gnucash/trunk/src/import-export/qif-import/qif-utils.scm
gnucash/trunk/src/scm/Makefile.am
gnucash/trunk/src/scm/main.scm
Log:
QIF Import: Fix support for multi-byte account separators.
In doing so, a number of reusable Scheme string manipulation procedures were written and placed in string.scm. These are now available to all Scheme code by automatic inclusion in main.scm.
The new Scheme procedures are:
gnc:string-rcontains (a variation on string-contains)
gnc:substring-count (a variation on string-count)
gnc:substring-split (a variation on string-split)
gnc:substring-replace (search/replace a substring)
gnc:string-replace-char (search/replace a character)
gnc:string-delete-chars (delete a variety of characters)
Finally, the custom version of string-split was removed because Guile 1.4 is no longer supported and later versions come with this procedure.
BP
Modified: gnucash/trunk/src/import-export/qif-import/qif-dialog-utils.scm
===================================================================
--- gnucash/trunk/src/import-export/qif-import/qif-dialog-utils.scm 2008-06-04 22:25:40 UTC (rev 17190)
+++ gnucash/trunk/src/import-export/qif-import/qif-dialog-utils.scm 2008-06-06 16:46:03 UTC (rev 17191)
@@ -637,11 +637,10 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (qif-import:get-account-name fullname)
- (let ((lastsep (string-rindex fullname
- (string-ref (gnc-get-account-separator-string)
- 0))))
- (if lastsep
- (substring fullname (+ lastsep 1))
+ (let* ((sep (gnc-get-account-separator-string))
+ (last-sep (gnc:string-rcontains fullname sep)))
+ (if last-sep
+ (substring fullname (+ last-sep (string-length sep)))
fullname)))
@@ -839,7 +838,8 @@
(let ((accts '())
(acct-tree '())
- (separator (string-ref (gnc-get-account-separator-string) 0)))
+ (sep (gnc-get-account-separator-string)))
+
;; get the new accounts from the account map
(for-each
(lambda (acctmap)
@@ -849,8 +849,8 @@
(if (qif-map-entry:display? v)
(set! accts
(cons
- (cons (string-split (qif-map-entry:gnc-name v)
- separator)
+ (cons (gnc:substring-split (qif-map-entry:gnc-name v)
+ sep)
(qif-map-entry:new-acct? v))
accts)))
#f)
@@ -862,9 +862,7 @@
(lambda (acct)
(set! accts
(cons
- (cons (string-split
- (gnc-account-get-full-name acct)
- separator)
+ (cons (gnc:substring-split (gnc-account-get-full-name acct) sep)
#f)
accts)))
(gnc-account-get-descendants-sorted (gnc-get-current-root-account)))
Modified: gnucash/trunk/src/import-export/qif-import/qif-guess-map.scm
===================================================================
--- gnucash/trunk/src/import-export/qif-import/qif-guess-map.scm 2008-06-04 22:25:40 UTC (rev 17190)
+++ gnucash/trunk/src/import-export/qif-import/qif-guess-map.scm 2008-06-06 16:46:03 UTC (rev 17191)
@@ -97,6 +97,11 @@
(set! qif-security-list (safe-read))
(set! saved-sep (safe-read))
+ ;; Convert the separator to a string if necessary.
+ ;; It was a character prior to 2.2.6.
+ (if (char? saved-sep)
+ (set! saved-sep (string saved-sep)))
+
;; Process the QIF account mapping.
(if (not (list? qif-account-list))
(set! qif-account-hash (make-hash-table 20))
@@ -162,8 +167,8 @@
(define (qif-import:read-map tablist tab-sep)
(let* ((table (make-hash-table 20))
- (sep (string-ref (gnc-get-account-separator-string) 0))
- (changed-sep? (and (char? tab-sep) (not (char=? tab-sep sep)))))
+ (sep (gnc-get-account-separator-string))
+ (changed-sep? (and (string? tab-sep) (not (string=? tab-sep sep)))))
(for-each
(lambda (entry)
@@ -175,8 +180,9 @@
(let ((acct-name (qif-map-entry:gnc-name value)))
(if (string? acct-name)
(qif-map-entry:set-gnc-name! value
- (string-map (lambda (c) (if (char=? c tab-sep) sep c))
- acct-name)))))
+ (gnc:substring-replace acct-name
+ tab-sep
+ sep)))))
(qif-map-entry:set-display?! value #f)
(hash-set! table key value)))
@@ -295,7 +301,7 @@
(display ";;; GnuCash separator used in these mappings")
(newline)
- (write (string-ref (gnc-get-account-separator-string) 0))
+ (write (gnc-get-account-separator-string))
(newline)))))
Modified: gnucash/trunk/src/import-export/qif-import/qif-parse.scm
===================================================================
--- gnucash/trunk/src/import-export/qif-import/qif-parse.scm 2008-06-04 22:25:40 UTC (rev 17190)
+++ gnucash/trunk/src/import-export/qif-import/qif-parse.scm 2008-06-06 16:46:03 UTC (rev 17191)
@@ -553,7 +553,7 @@
(define (qif-parse:parse-number/format value-string format)
(case format
((decimal)
- (let* ((filtered-string (string-remove-chars value-string ",$'"))
+ (let* ((filtered-string (gnc:string-delete-chars value-string ",$'"))
(read-val (with-input-from-string filtered-string
(lambda () (read)))))
(if (number? read-val)
@@ -564,8 +564,8 @@
GNC-RND-ROUND))
(gnc-numeric-zero))))
((comma)
- (let* ((filtered-string (string-replace-char
- (string-remove-chars value-string ".$'")
+ (let* ((filtered-string (gnc:string-replace-char
+ (gnc:string-delete-chars value-string ".$'")
#\, #\.))
(read-val (with-input-from-string filtered-string
(lambda () (read)))))
Modified: gnucash/trunk/src/import-export/qif-import/qif-to-gnc.scm
===================================================================
--- gnucash/trunk/src/import-export/qif-import/qif-to-gnc.scm 2008-06-04 22:25:40 UTC (rev 17190)
+++ gnucash/trunk/src/import-export/qif-import/qif-to-gnc.scm 2008-06-06 16:46:03 UTC (rev 17191)
@@ -1,9 +1,9 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; qif-to-gnc.scm
-;;; this is where QIF transactions are transformed into a
+;;; this is where QIF transactions are transformed into a
;;; Gnucash account tree.
;;;
-;;; Copyright 2000-2001 Bill Gribble <grib at billgribble.com>
+;;; Copyright 2000-2001 Bill Gribble <grib at billgribble.com>
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(use-modules (srfi srfi-13))
@@ -19,69 +19,69 @@
(define (qif-import:find-or-make-acct acct-info check-types? commodity
check-commodity? default-currency
gnc-acct-hash old-root new-root)
- (let* ((separator (string-ref (gnc-get-account-separator-string) 0))
+ (let* ((sep (gnc-get-account-separator-string))
(gnc-name (qif-map-entry:gnc-name acct-info))
(existing-account (hash-ref gnc-acct-hash gnc-name))
- (same-gnc-account
+ (same-gnc-account
(gnc-account-lookup-by-full-name old-root gnc-name))
- (allowed-types
+ (allowed-types
(qif-map-entry:allowed-types acct-info))
(make-new-acct #f)
(incompatible-acct #f))
-
+
(define (compatible? account)
(let ((acc-type (xaccAccountGetType account))
(acc-commodity (xaccAccountGetCommodity account)))
(and
- (if check-types?
+ (if check-types?
(and (list? allowed-types)
(memv acc-type allowed-types))
#t)
(if check-commodity?
(gnc-commodity-equiv acc-commodity commodity)
#t))))
-
+
(define (make-unique-name-variant long-name short-name)
(if (not (null? (gnc-account-lookup-by-full-name old-root long-name)))
(let loop ((count 2))
- (let* ((test-name
+ (let* ((test-name
(string-append long-name (sprintf #f " %a" count)))
- (test-acct
+ (test-acct
(gnc-account-lookup-by-full-name old-root test-name)))
(if (and (not (null? test-acct)) (not (compatible? test-acct)))
(loop (+ 1 count))
(string-append short-name (sprintf #f " %a" count)))))
short-name))
-
+
;; If a GnuCash account already exists in the old root with the same
;; name, that doesn't necessarily mean we can use it. The type and
;; commodity must be compatible.
- (if (and same-gnc-account (not (null? same-gnc-account)))
+ (if (and same-gnc-account (not (null? same-gnc-account)))
(if (compatible? same-gnc-account)
- (begin
+ (begin
;; The existing GnuCash account is compatible, so we
- ;; can use it. Make sure we use the same type.
+ ;; can use it. Make sure we use the same type.
(set! make-new-acct #f)
(set! incompatible-acct #f)
- (set! allowed-types
+ (set! allowed-types
(list (xaccAccountGetType same-gnc-account))))
- (begin
+ (begin
;; There's an existing, incompatible account with that name,
;; so we have to make a new account with different properties
;; and a slightly different name.
(set! make-new-acct #t)
(set! incompatible-acct #t)))
- (begin
+ (begin
;; Otherwise, there's no existing account with the same name.
(set! make-new-acct #t)
(set! incompatible-acct #f)))
-
+
;; here, existing-account means a previously *created* account
;; (possibly a new account, possibly a copy of an existing gnucash
;; acct)
- (if (and (and existing-account (not (null? existing-account)))
+ (if (and (and existing-account (not (null? existing-account)))
(compatible? existing-account))
- existing-account
+ existing-account
(let ((new-acct (xaccMallocAccount (gnc-get-current-book)))
(parent-acct #f)
(parent-name #f)
@@ -114,15 +114,15 @@
(default-account-type (cdr allowed-types)
currency?)))))
- (set! last-sep (string-rindex gnc-name separator))
-
+ (set! last-sep (gnc:string-rcontains gnc-name sep))
+
(xaccAccountBeginEdit new-acct)
-
+
;; if this is a copy of an existing gnc account, copy the
;; account properties. For incompatible existing accts,
;; we'll do something different later.
(if (and same-gnc-account (not (null? same-gnc-account)))
- (begin
+ (begin
(xaccAccountSetName
new-acct (xaccAccountGetName same-gnc-account))
(xaccAccountSetDescription
@@ -135,38 +135,38 @@
new-acct (xaccAccountGetNotes same-gnc-account))
(xaccAccountSetCode
new-acct (xaccAccountGetCode same-gnc-account))))
-
+
;; If this is a nested account foo:bar:baz, make sure
;; that foo:bar and foo exist also.
(if last-sep
- (begin
+ (begin
(set! parent-name (substring gnc-name 0 last-sep))
- (set! acct-name (substring gnc-name (+ 1 last-sep)
- (string-length gnc-name))))
+ (set! acct-name (substring gnc-name (+ (string-length sep)
+ last-sep))))
(set! acct-name gnc-name))
-
+
;; If this is a completely new account (as opposed to a copy
;; of an existing account), use the parameters passed in.
(if make-new-acct
- (begin
+ (begin
;; Set the name, description, and commodity.
(xaccAccountSetName new-acct acct-name)
(if (qif-map-entry:description acct-info)
(xaccAccountSetDescription
new-acct (qif-map-entry:description acct-info)))
(xaccAccountSetCommodity new-acct commodity)
-
+
;; If there was an existing, incompatible account with
;; the same name, set the new account name to be unique,
;; and set a description that hints at what's happened.
(if incompatible-acct
- (let ((new-name (make-unique-name-variant
+ (let ((new-name (make-unique-name-variant
gnc-name acct-name)))
(xaccAccountSetName new-acct new-name)
(xaccAccountSetDescription
- new-acct
+ new-acct
(_ "QIF import: Name conflict with another account."))))
-
+
;; Set the account type.
(xaccAccountSetType new-acct
(default-account-type
@@ -179,61 +179,61 @@
(let ((pinfo (make-qif-map-entry)))
(qif-map-entry:set-qif-name! pinfo parent-name)
(qif-map-entry:set-gnc-name! pinfo parent-name)
- (qif-map-entry:set-allowed-types!
+ (qif-map-entry:set-allowed-types!
acct-info (list (xaccAccountGetType new-acct)))
- (qif-map-entry:set-allowed-types!
+ (qif-map-entry:set-allowed-types!
pinfo (qif-map-entry:allowed-parent-types acct-info))
-
- (set! parent-acct (qif-import:find-or-make-acct
+
+ (set! parent-acct (qif-import:find-or-make-acct
pinfo #t default-currency #f default-currency
gnc-acct-hash old-root new-root))))
(if (and parent-acct (not (null? parent-acct)))
(gnc-account-append-child parent-acct new-acct)
(gnc-account-append-child new-root new-acct))
-
+
(hash-set! gnc-acct-hash gnc-name new-acct)
new-acct))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; qif-import:qif-to-gnc
+;; qif-import:qif-to-gnc
;;
;; This is the top-level of the back end conversion from QIF
-;; to GnuCash. All the account mappings and so on should be
-;; done before this is called.
+;; to GnuCash. All the account mappings and so on should be
+;; done before this is called.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(define (qif-import:qif-to-gnc qif-files-list
- qif-acct-map qif-cat-map
- qif-memo-map stock-map
+(define (qif-import:qif-to-gnc qif-files-list
+ qif-acct-map qif-cat-map
+ qif-memo-map stock-map
default-currency-name window)
(let ((progress-dialog '())
(retval #f))
(set! retval
- (gnc:backtrace-if-exception
+ (gnc:backtrace-if-exception
(lambda ()
(let* ((old-root (gnc-get-current-root-account))
(new-root (xaccMallocAccount (gnc-get-current-book)))
(gnc-acct-hash (make-hash-table 20))
- (separator (string-ref (gnc-get-account-separator-string) 0))
- (default-currency
+ (sep (gnc-get-account-separator-string))
+ (default-currency
(gnc-commodity-table-find-full
(gnc-commodity-table-get-table (gnc-get-current-book))
GNC_COMMODITY_NS_CURRENCY default-currency-name))
(sorted-accounts-list '())
(markable-xtns '())
- (sorted-qif-files-list
- (sort qif-files-list
+ (sorted-qif-files-list
+ (sort qif-files-list
(lambda (a b)
- (> (length (qif-file:xtns a))
+ (> (length (qif-file:xtns a))
(length (qif-file:xtns b))))))
(work-to-do 0)
(work-done 0))
-
+
;; first, build a local account tree that mirrors the gnucash
;; accounts in the mapping data. we need to iterate over the
;; cat-map and the acct-map to build the list
- (hash-fold
+ (hash-fold
(lambda (k v p)
(if (qif-map-entry:display? v)
(set! sorted-accounts-list
@@ -241,7 +241,7 @@
#t)
#t qif-acct-map)
- (hash-fold
+ (hash-fold
(lambda (k v p)
(if (qif-map-entry:display? v)
(set! sorted-accounts-list
@@ -249,79 +249,74 @@
#t)
#t qif-cat-map)
- (hash-fold
+ (hash-fold
(lambda (k v p)
(if (qif-map-entry:display? v)
(set! sorted-accounts-list
(cons v sorted-accounts-list)))
#t)
#t qif-memo-map)
-
+
;; sort the account info on the depth of the account path. if a
;; short part is explicitly mentioned, make sure it gets created
;; before the deeper path, which will create the parent accounts
;; without the information about their type.
- (set! sorted-accounts-list
- (sort sorted-accounts-list
+ (set! sorted-accounts-list
+ (sort sorted-accounts-list
(lambda (a b)
- (let ((a-depth
- (length
- (string-split (qif-map-entry:gnc-name a)
- separator)))
- (b-depth
- (length
- (string-split (qif-map-entry:gnc-name b)
- separator))))
- (< a-depth b-depth)))))
-
- ;; make all the accounts
- (for-each
+ (< (gnc:substring-count (qif-map-entry:gnc-name a)
+ sep)
+ (gnc:substring-count (qif-map-entry:gnc-name b)
+ sep)))))
+
+ ;; make all the accounts
+ (for-each
(lambda (acctinfo)
- (let* ((security
- (and stock-map
- (hash-ref stock-map
- (qif-import:get-account-name
+ (let* ((security
+ (and stock-map
+ (hash-ref stock-map
+ (qif-import:get-account-name
(qif-map-entry:qif-name acctinfo)))))
(ok-types (qif-map-entry:allowed-types acctinfo))
(equity? (memv GNC-EQUITY-TYPE ok-types))
(stock? (or (memv GNC-STOCK-TYPE ok-types)
(memv GNC-MUTUAL-TYPE ok-types))))
-
+
;; Debug
;; (for-each
;; (lambda (expr)
;; (display expr))
- ;; (list "Account: " acctinfo "\nsecurity = " security
- ;; "\nequity? = " equity?
+ ;; (list "Account: " acctinfo "\nsecurity = " security
+ ;; "\nequity? = " equity?
;; "\n"))
(cond ((and equity? security) ;; a "retained holdings" acct
(qif-import:find-or-make-acct acctinfo #f
security #t
default-currency
- gnc-acct-hash
+ gnc-acct-hash
old-root new-root))
((and security (or stock?
(gnc-commodity-is-currency security)))
- (qif-import:find-or-make-acct
+ (qif-import:find-or-make-acct
acctinfo #f security #t default-currency
gnc-acct-hash old-root new-root))
- (#t
- (qif-import:find-or-make-acct
+ (#t
+ (qif-import:find-or-make-acct
acctinfo #f default-currency #t default-currency
gnc-acct-hash old-root new-root)))))
sorted-accounts-list)
-
- ;; before trying to mark transactions, prune down the list of
- ;; ones to match.
- (for-each
+
+ ;; before trying to mark transactions, prune down the list of
+ ;; ones to match.
+ (for-each
(lambda (qif-file)
- (for-each
+ (for-each
(lambda (xtn)
(set! work-to-do (+ 1 work-to-do))
- (let splitloop ((splits (qif-xtn:splits xtn)))
+ (let splitloop ((splits (qif-xtn:splits xtn)))
(if (qif-split:category-is-account? (car splits))
- (begin
+ (begin
(set! markable-xtns (cons xtn markable-xtns))
(set! work-to-do (+ 1 work-to-do)))
(if (not (null? (cdr splits)))
@@ -330,21 +325,21 @@
qif-files-list)
(if (> work-to-do 100)
- (begin
+ (begin
(set! progress-dialog (gnc-progress-dialog-new window #f))
(gnc-progress-dialog-set-title progress-dialog (_ "Progress"))
(gnc-progress-dialog-set-heading progress-dialog
(_ "Importing transactions..."))))
-
+
;; now run through the markable transactions marking any
;; duplicates. marked transactions/splits won't get imported.
(if (> (length markable-xtns) 1)
(let xloop ((xtn (car markable-xtns))
(rest (cdr markable-xtns)))
(set! work-done (+ 1 work-done))
- (if (not (null? progress-dialog))
- (begin
+ (if (not (null? progress-dialog))
+ (begin
(gnc-progress-dialog-set-value
progress-dialog (/ work-done work-to-do))
(gnc-progress-dialog-update progress-dialog)))
@@ -353,20 +348,20 @@
(if (not (null? (cdr rest)))
(xloop (car rest) (cdr rest)))))
- ;; iterate over files. Going in the sort order by number of
+ ;; iterate over files. Going in the sort order by number of
;; transactions should give us a small speed advantage.
- (for-each
+ (for-each
(lambda (qif-file)
- (for-each
+ (for-each
(lambda (xtn)
(set! work-done (+ 1 work-done))
- (if (not (null? progress-dialog))
- (begin
+ (if (not (null? progress-dialog))
+ (begin
(gnc-progress-dialog-set-value
progress-dialog (/ work-done work-to-do))
(gnc-progress-dialog-update progress-dialog)))
(if (not (qif-xtn:mark xtn))
- (begin
+ (begin
;; create and fill in the GNC transaction
(let ((gnc-xtn (xaccMallocTransaction
(gnc-get-current-book))))
@@ -376,8 +371,8 @@
(xaccTransSetCurrency gnc-xtn (gnc-default-currency))
;; build the transaction
- (qif-import:qif-xtn-to-gnc-xtn
- xtn qif-file gnc-xtn gnc-acct-hash
+ (qif-import:qif-xtn-to-gnc-xtn
+ xtn qif-file gnc-xtn gnc-acct-hash
qif-acct-map qif-cat-map qif-memo-map)
;; rebalance and commit everything
@@ -396,12 +391,12 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; qif-import:qif-xtn-to-gnc-xtn
-;; translate a single transaction to a set of gnucash splits and
-;; a gnucash transaction structure.
+;; translate a single transaction to a set of gnucash splits and
+;; a gnucash transaction structure.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(define (qif-import:qif-xtn-to-gnc-xtn qif-xtn qif-file gnc-xtn
- gnc-acct-hash
+(define (qif-import:qif-xtn-to-gnc-xtn qif-xtn qif-file gnc-xtn
+ gnc-acct-hash
qif-acct-map qif-cat-map qif-memo-map)
(let ((splits (qif-xtn:splits qif-xtn))
(gnc-near-split (xaccMallocSplit (gnc-get-current-book)))
@@ -423,7 +418,7 @@
(n+ (lambda (a b) (gnc-numeric-add a b 0 GNC-DENOM-LCD)))
(n* (lambda (a b) (gnc-numeric-mul a b 0 GNC-DENOM-REDUCE)))
(n/ (lambda (a b) (gnc-numeric-div a b 0 GNC-DENOM-REDUCE))))
-
+
;; Set properties of the whole transaction.
;; Set the transaction date.
@@ -442,8 +437,8 @@
#f))
(else
(apply xaccTransSetDate gnc-xtn (qif-xtn:date qif-xtn))))
-
- ;; fixme: bug #105
+
+ ;; fixme: bug #105
(if qif-payee
(xaccTransSetDescription gnc-xtn qif-payee))
(if qif-number
@@ -462,14 +457,14 @@
;; Use the memo for the transaction notes. Previously this went to
;; the debit/credit lines. See bug 495219 for more information.
(xaccTransSetNotes gnc-xtn qif-memo)))
-
- (if (eq? qif-cleared 'cleared)
+
+ (if (eq? qif-cleared 'cleared)
(xaccSplitSetReconcile gnc-near-split #\c))
(if (eq? qif-cleared 'reconciled)
(xaccSplitSetReconcile gnc-near-split #\y))
-
+
(if (not qif-security)
- (begin
+ (begin
;; NON-STOCK TRANSACTIONS: the near account is the current
;; bank-account or the default associated with the file.
;; the far account is the one associated with the split
@@ -477,10 +472,10 @@
(set! near-acct-info (hash-ref qif-acct-map qif-from-acct))
(set! near-acct-name (qif-map-entry:gnc-name near-acct-info))
(set! near-acct (hash-ref gnc-acct-hash near-acct-name))
-
+
;; iterate over QIF splits. Each split defines one "far
;; end" for the transaction.
- (for-each
+ (for-each
(lambda (qif-split)
(if (not (qif-split:mark qif-split))
(let ((gnc-far-split (xaccMallocSplit
@@ -495,7 +490,7 @@
(if qif-default-split
(qif-split:memo qif-split) #f))
(cat (qif-split:category qif-split)))
-
+
(if (not split-amt) (set! split-amt (gnc-numeric-zero)))
;; fill the splits in (near first). This handles
;; files in multiple currencies by pulling the
@@ -505,14 +500,14 @@
(xaccSplitSetAmount gnc-far-split (n- split-amt))
(if memo (xaccSplitSetMemo gnc-far-split memo))
-
+
;; figure out what the far acct is
- (cond
+ (cond
;; If the category is an account, use the account mapping.
((and (not (string=? cat ""))
(qif-split:category-is-account? qif-split))
(set! far-acct-info (hash-ref qif-acct-map cat)))
-
+
;; Otherwise, if it isn't empty, use the category mapping.
((not (string=? cat ""))
(set! far-acct-info (hash-ref qif-cat-map cat)))
@@ -524,7 +519,7 @@
;; the default category mapping (the Unspecified account,
;; unless the user has changed it).
(#t
- (set! far-acct-info
+ (set! far-acct-info
(if (= (length splits) 1)
(or (and (string? qif-payee)
(not (string=? qif-payee ""))
@@ -540,25 +535,25 @@
(set! far-acct-name (qif-map-entry:gnc-name far-acct-info))
(set! far-acct (hash-ref gnc-acct-hash far-acct-name))
-
- ;; set the reconcile status.
+
+ ;; set the reconcile status.
(let ((cleared (qif-split:matching-cleared qif-split)))
(if (eq? 'cleared cleared)
(xaccSplitSetReconcile gnc-far-split #\c))
(if (eq? 'reconciled cleared)
(xaccSplitSetReconcile gnc-far-split #\y)))
-
- ;; finally, plug the split into the account
+
+ ;; finally, plug the split into the account
(xaccSplitSetAccount gnc-far-split far-acct)
(xaccSplitSetParent gnc-far-split gnc-xtn))))
splits)
-
+
;; the value of the near split is the total of the far splits.
(xaccSplitSetValue gnc-near-split near-split-total)
(xaccSplitSetAmount gnc-near-split near-split-total)
(xaccSplitSetParent gnc-near-split gnc-xtn)
(xaccSplitSetAccount gnc-near-split near-acct))
-
+
;; STOCK TRANSACTIONS: the near/far accounts depend on the
;; "action" encoded in the Number field. It's generally the
;; security account (for buys, sells, and reinvests) but can
@@ -579,7 +574,7 @@
(commission-split #f)
(defer-share-price #f)
(gnc-far-split (xaccMallocSplit (gnc-get-current-book))))
-
+
(if (not num-shares) (set! num-shares (gnc-numeric-zero)))
;; Determine the extended price of all shares without commission.
@@ -607,31 +602,31 @@
;; share price ourselves. For more information, see
;; bug 373584.
(set! share-price (n/ split-amt num-shares))))
-
- ;; I don't think this should ever happen, but I want
- ;; to keep this check just in case.
+
+ ;; I don't think this should ever happen, but I want
+ ;; to keep this check just in case.
(if (> (length splits) 1)
(gnc:warn "qif-import:qif-xtn-to-gnc-xtn: "
"splits in stock transaction!"))
- (set! qif-accts
+ (set! qif-accts
(qif-split:accounts-affected (car (qif-xtn:splits qif-xtn))
qif-xtn))
-
+
(set! qif-near-acct (car qif-accts))
(set! qif-far-acct (cadr qif-accts))
(set! qif-commission-acct (caddr qif-accts))
;; Translate the QIF account names into GnuCash accounts.
(if (and qif-near-acct qif-far-acct)
- (begin
+ (begin
;; Determine the near account.
- (set! near-acct-info
+ (set! near-acct-info
(or (hash-ref qif-acct-map qif-near-acct)
(hash-ref qif-cat-map qif-near-acct)))
(set! near-acct-name (qif-map-entry:gnc-name near-acct-info))
(set! near-acct (hash-ref gnc-acct-hash near-acct-name))
-
+
;; Determine the far account.
(if (or (not (string? qif-far-acct))
(string=? qif-far-acct ""))
@@ -648,9 +643,9 @@
(hash-ref qif-cat-map qif-far-acct))))
(set! far-acct-name (qif-map-entry:gnc-name far-acct-info))
(set! far-acct (hash-ref gnc-acct-hash far-acct-name))))
-
- ;; the amounts and signs: are shares going in or out?
- ;; are amounts currency or shares?
+
+ ;; the amounts and signs: are shares going in or out?
+ ;; are amounts currency or shares?
(case qif-action
((buy buyx reinvint reinvdiv reinvsg reinvsh reinvmd reinvlg)
(if (not share-price) (set! share-price (gnc-numeric-zero)))
@@ -658,27 +653,27 @@
(xaccSplitSetValue gnc-near-split split-amt)
(xaccSplitSetValue gnc-far-split (n- xtn-amt))
(xaccSplitSetAmount gnc-far-split (n- xtn-amt)))
-
- ((sell sellx)
+
+ ((sell sellx)
(if (not share-price) (set! share-price (gnc-numeric-zero)))
(xaccSplitSetAmount gnc-near-split (n- num-shares))
(xaccSplitSetValue gnc-near-split (n- split-amt))
(xaccSplitSetValue gnc-far-split xtn-amt)
(xaccSplitSetAmount gnc-far-split xtn-amt))
-
- ((cgshort cgshortx cgmid cgmidx cglong cglongx intinc intincx
+
+ ((cgshort cgshortx cgmid cgmidx cglong cglongx intinc intincx
div divx miscinc miscincx xin rtrncap rtrncapx)
(xaccSplitSetValue gnc-near-split xtn-amt)
(xaccSplitSetAmount gnc-near-split xtn-amt)
(xaccSplitSetValue gnc-far-split (n- xtn-amt))
(xaccSplitSetAmount gnc-far-split (n- xtn-amt)))
-
+
((xout miscexp miscexpx margint margintx)
(xaccSplitSetValue gnc-near-split (n- xtn-amt))
(xaccSplitSetAmount gnc-near-split (n- xtn-amt))
(xaccSplitSetValue gnc-far-split xtn-amt)
(xaccSplitSetAmount gnc-far-split xtn-amt))
-
+
((shrsin)
;; getting rid of the old equity-acct-per-stock trick.
;; you must now have a cash/basis value for the stock.
@@ -686,37 +681,37 @@
(xaccSplitSetValue gnc-near-split split-amt)
(xaccSplitSetValue gnc-far-split (n- xtn-amt))
(xaccSplitSetAmount gnc-far-split (n- xtn-amt)))
-
+
((shrsout)
- ;; shrsout is like shrsin
+ ;; shrsout is like shrsin
(xaccSplitSetAmount gnc-near-split (n- num-shares))
(xaccSplitSetValue gnc-near-split (n- split-amt))
(xaccSplitSetValue gnc-far-split xtn-amt)
(xaccSplitSetAmount gnc-far-split xtn-amt))
-
+
;; stock splits: QIF just specifies the split ratio, not
;; the number of shares in and out, so we have to fetch
- ;; the number of shares from the security account
-
+ ;; the number of shares from the security account
+
;; FIXME : this could be wrong. Make sure the
;; share-amount is at the correct time.
((stksplit)
(let* ((splitratio (n/ num-shares (gnc-numeric-create 10 1)))
- (in-shares
+ (in-shares
(xaccAccountGetBalance near-acct))
(out-shares (n* in-shares splitratio)))
(xaccSplitSetAmount gnc-near-split out-shares)
(xaccSplitSetAmount gnc-far-split (n- in-shares))
(xaccSplitSetValue gnc-near-split (n- split-amt))
(xaccSplitSetValue gnc-far-split split-amt))))
-
- (let ((cleared (qif-split:matching-cleared
+
+ (let ((cleared (qif-split:matching-cleared
(car (qif-xtn:splits qif-xtn)))))
(if (eq? 'cleared cleared)
(xaccSplitSetReconcile gnc-far-split #\c))
(if (eq? 'reconciled cleared)
(xaccSplitSetReconcile gnc-far-split #\y)))
-
+
(if qif-commission-acct
(let* ((commission-acct-info
(or (hash-ref qif-acct-map qif-commission-acct)
@@ -727,24 +722,24 @@
(if commission-acct-name
(set! commission-acct
(hash-ref gnc-acct-hash commission-acct-name)))))
-
+
(if (and commission-amt commission-acct)
- (begin
+ (begin
(set! commission-split (xaccMallocSplit
(gnc-get-current-book)))
(xaccSplitSetValue commission-split commission-amt)
(xaccSplitSetAmount commission-split commission-amt)))
(if (and qif-near-acct qif-far-acct)
- (begin
+ (begin
(xaccSplitSetParent gnc-near-split gnc-xtn)
(xaccSplitSetAccount gnc-near-split near-acct)
-
+
(xaccSplitSetParent gnc-far-split gnc-xtn)
(xaccSplitSetAccount gnc-far-split far-acct)
-
+
(if commission-split
- (begin
+ (begin
(xaccSplitSetParent commission-split gnc-xtn)
(xaccSplitSetAccount commission-split
commission-acct)))))))
@@ -759,26 +754,26 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; qif-import:mark-matching-xtns
-;; find transactions that are the "opposite half" of xtn and
-;; mark them so they won't be imported.
+;; qif-import:mark-matching-xtns
+;; find transactions that are the "opposite half" of xtn and
+;; mark them so they won't be imported.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (qif-import:mark-matching-xtns xtn candidate-xtns)
(let splitloop ((splits-left (qif-xtn:splits xtn)))
-
+
;; splits-left starts out as all the splits of this transaction.
- ;; if multiple splits match up with a single split on the other
+ ;; if multiple splits match up with a single split on the other
;; end, we may remove more than one split from splits-left with
- ;; each call to mark-some-splits.
+ ;; each call to mark-some-splits.
(if (not (null? splits-left))
(if (and (not (qif-split:mark (car splits-left)))
(qif-split:category-is-account? (car splits-left)))
- (set! splits-left
- (qif-import:mark-some-splits
+ (set! splits-left
+ (qif-import:mark-some-splits
splits-left xtn candidate-xtns))
(set! splits-left (cdr splits-left))))
-
+
(if (not (null? splits-left))
(splitloop splits-left))))
@@ -801,7 +796,7 @@
(date (qif-xtn:date xtn))
(amount (n- (qif-split:amount split)))
(group-amount #f)
- (memo (qif-split:memo split))
+ (memo (qif-split:memo split))
(security-name (qif-xtn:security-name xtn))
(action (qif-xtn:action xtn))
(bank-xtn? (not security-name))
@@ -810,35 +805,35 @@
(same-acct-splits '())
(how #f)
(done #f))
-
+
(if bank-xtn?
- (begin
+ (begin
(set! near-acct-name (qif-xtn:from-acct xtn))
(set! far-acct-name (qif-split:category split))
(set! group-amount (gnc-numeric-zero))
-
+
;; group-amount is the sum of all the splits in this xtn
;; going to the same account as 'split'. We might be able
;; to match this whole group to a single matching opposite
;; split.
- (for-each
+ (for-each
(lambda (s)
(if (and (qif-split:category-is-account? s)
(string=? far-acct-name (qif-split:category s)))
(begin
- (set! same-acct-splits
+ (set! same-acct-splits
(cons s same-acct-splits))
(set! group-amount (nsub group-amount (qif-split:amount s))))
- (set! different-acct-splits
+ (set! different-acct-splits
(cons s different-acct-splits))))
splits)
-
+
(set! same-acct-splits (reverse same-acct-splits))
(set! different-acct-splits (reverse different-acct-splits)))
-
+
;; stock transactions. they can't have splits as far as I can
;; tell, so the 'different-acct-splits' is always '()
- (let ((qif-accts
+ (let ((qif-accts
(qif-split:accounts-affected split xtn)))
(set! near-acct-name (car qif-accts))
(set! far-acct-name (cadr qif-accts))
@@ -848,7 +843,7 @@
;; transactions to match up. Quicken thinks the near
;; and far accounts are different than we do.
(case action
- ((intincx divx cglongx cgmidx cgshortx rtrncapx margintx
+ ((intincx divx cglongx cgmidx cgshortx rtrncapx margintx
sellx)
(set! amount (n- amount))
(set! near-acct-name (qif-xtn:from-acct xtn))
@@ -862,26 +857,26 @@
(set! far-acct-name (qif-split:category split)))
((xout)
(set! amount (n- amount)))))))
-
+
;; this is the grind loop. Go over every unmarked transaction in
;; the candidate-xtns list.
(let xtn-loop ((xtns candidate-xtns))
(if (and (not (qif-xtn:mark (car xtns)))
(string=? (qif-xtn:from-acct (car xtns)) far-acct-name))
- (begin
+ (begin
(set! how
(qif-import:xtn-has-matches? (car xtns) near-acct-name
date amount group-amount))
(if how
(begin
- (qif-import:merge-and-mark-xtns xtn same-acct-splits
+ (qif-import:merge-and-mark-xtns xtn same-acct-splits
(car xtns) how)
(set! done #t)))))
;; iterate with the next transaction
(if (and (not done)
(not (null? (cdr xtns))))
(xtn-loop (cdr xtns))))
-
+
;; return the rest of the splits to iterate on
(if (not how)
(cdr splits)
@@ -904,7 +899,7 @@
(same-acct-splits '())
(this-group-amt (gnc-numeric-zero))
(how #f)
- (date-matches
+ (date-matches
(let ((self-date (qif-xtn:date xtn)))
(and (pair? self-date)
(pair? date)
@@ -918,17 +913,17 @@
(n+ (lambda (a b) (gnc-numeric-add a b 0 GNC-DENOM-LCD)))
(n* (lambda (a b) (gnc-numeric-mul a b 0 GNC-DENOM-REDUCE)))
(n/ (lambda (a b) (gnc-numeric-div a b 0 GNC-DENOM-REDUCE))))
-
- (if date-matches
- (begin
- ;; calculate a group total for splits going to acct-name
+
+ (if date-matches
+ (begin
+ ;; calculate a group total for splits going to acct-name
(let split-loop ((splits-left (qif-xtn:splits xtn)))
(let ((split (car splits-left)))
;; does the account match up?
(if (and (qif-split:category-is-account? split)
(string? acct-name)
(string=? (qif-split:category split) acct-name))
- ;; if so, get the amount
+ ;; if so, get the amount
(let ((this-amt (qif-split:amount split))
(stock-xtn (qif-xtn:security-name xtn))
(action (qif-xtn:action xtn)))
@@ -936,92 +931,92 @@
;; stock transactions (buy/sell both positive in
;; QIF)
(if (and stock-xtn action)
- (case action
- ((xout sellx intincx divx cglongx cgshortx
+ (case action
+ ((xout sellx intincx divx cglongx cgshortx
miscincx miscexpx)
(set! this-amt (n- this-amt)))))
-
- ;; we might be done if this-amt is either equal
+
+ ;; we might be done if this-amt is either equal
;; to the split amount or the group amount.
- (cond
+ (cond
((gnc-numeric-equal this-amt amount)
- (set! how
+ (set! how
(cons 'one-to-one (list split))))
((and group-amt (gnc-numeric-equal this-amt group-amt))
(set! how
(cons 'one-to-many (list split))))
(#t
(set! same-acct-splits (cons split same-acct-splits))
- (set! this-group-amt
+ (set! this-group-amt
(n+ this-group-amt this-amt))))))
-
+
;; if 'how' is non-#f, we are ready to return.
- (if (and (not how)
+ (if (and (not how)
(not (null? (cdr splits-left))))
(split-loop (cdr splits-left)))))
-
- ;; now we're out of the loop. if 'how' isn't set,
+
+ ;; now we're out of the loop. if 'how' isn't set,
;; we can still have a many-to-one match.
(if (and (not how)
(gnc-numeric-equal this-group-amt amount))
- (begin
- (set! how
+ (begin
+ (set! how
(cons 'many-to-one same-acct-splits))))))
-
- ;; we're all done. 'how' either is #f or a
- ;; cons of the way-it-matched and a list of the matching
- ;; splits.
+
+ ;; we're all done. 'how' either is #f or a
+ ;; cons of the way-it-matched and a list of the matching
+ ;; splits.
how))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; (qif-split:accounts-affected split xtn)
-;; Get the near and far ends of a split, returned as a list
+;; Get the near and far ends of a split, returned as a list
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(define (qif-split:accounts-affected split xtn)
+(define (qif-split:accounts-affected split xtn)
(let ((near-acct-name #f)
(far-acct-name #f)
(commission-acct-name #f)
(security (qif-xtn:security-name xtn))
(action (qif-xtn:action xtn))
(from-acct (qif-xtn:from-acct xtn)))
-
- ;; for non-security transactions, the near account is the
- ;; acct in which the xtn is, and the far is the account
- ;; linked by the category line.
-
+
+ ;; for non-security transactions, the near account is the
+ ;; acct in which the xtn is, and the far is the account
+ ;; linked by the category line.
+
(if (not security)
- ;; non-security transactions
- (begin
+ ;; non-security transactions
+ (begin
(set! near-acct-name from-acct)
(set! far-acct-name (qif-split:category split)))
-
- ;; security transactions : the near end is either the
- ;; brokerage, the stock, or the category
+
+ ;; security transactions : the near end is either the
+ ;; brokerage, the stock, or the category
(begin
(case action
- ((buy buyx sell sellx reinvint reinvdiv reinvsg reinvsh
+ ((buy buyx sell sellx reinvint reinvdiv reinvsg reinvsh
reinvlg reinvmd shrsin shrsout stksplit)
(set! near-acct-name (default-stock-acct from-acct security)))
- ((div cgshort cglong cgmid intinc miscinc miscexp
+ ((div cgshort cglong cgmid intinc miscinc miscexp
rtrncap margint xin xout)
(set! near-acct-name from-acct))
((divx cgshortx cglongx cgmidx intincx rtrncapx margintx)
- (set! near-acct-name
+ (set! near-acct-name
(qif-split:category (car (qif-xtn:splits xtn)))))
((miscincx miscexpx)
- (set! near-acct-name
+ (set! near-acct-name
(qif-split:miscx-category (car (qif-xtn:splits xtn))))))
- ;; the far split: where is the money coming from?
+ ;; the far split: where is the money coming from?
;; Either the brokerage account, the category,
- ;; or an external account
+ ;; or an external account
(case action
((buy sell)
(set! far-acct-name from-acct))
((buyx sellx miscinc miscincx miscexp miscexpx xin xout)
- (set! far-acct-name
+ (set! far-acct-name
(qif-split:category (car (qif-xtn:splits xtn)))))
((stksplit)
(set! far-acct-name (default-stock-acct from-acct security)))
@@ -1045,27 +1040,27 @@
(default-capital-return-acct from-acct security)))
((div divx reinvdiv)
(set! far-acct-name
- (default-dividend-acct from-acct security)))
+ (default-dividend-acct from-acct security)))
((shrsin shrsout)
(set! far-acct-name
(default-equity-holding security))))
-
- ;; the commission account, if it exists
+
+ ;; the commission account, if it exists
(if (qif-xtn:commission xtn)
- (set! commission-acct-name
+ (set! commission-acct-name
(default-commission-acct from-acct)))))
-
+
(list near-acct-name far-acct-name commission-acct-name)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; qif-import:merge-and-mark-xtns
-;; we know that the splits match. Pick one to mark and
-;; merge the information into the other one.
+;; qif-import:merge-and-mark-xtns
+;; we know that the splits match. Pick one to mark and
+;; merge the information into the other one.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (qif-import:merge-and-mark-xtns xtn splits other-xtn how)
- ;; merge transaction fields
+ ;; merge transaction fields
(let ((action (qif-xtn:action xtn))
(o-action (qif-xtn:action other-xtn))
(security (qif-xtn:security-name xtn))
@@ -1073,32 +1068,32 @@
(split (car splits))
(match-type (car how))
(match-splits (cdr how)))
- (case match-type
+ (case match-type
;; many-to-one: the other-xtn has several splits that total
;; in amount to 'split'. We want to preserve the multi-split
- ;; transaction.
+ ;; transaction.
((many-to-one)
(qif-xtn:mark-split xtn split)
(qif-import:merge-xtn-info xtn other-xtn)
- (for-each
+ (for-each
(lambda (s)
(qif-split:set-matching-cleared! s (qif-xtn:cleared xtn)))
match-splits))
-
+
;; one-to-many: 'split' is just one of a set of splits in xtn
;; that total up to the split in match-splits.
((one-to-many)
(qif-xtn:mark-split other-xtn (car match-splits))
(qif-import:merge-xtn-info other-xtn xtn)
- (for-each
+ (for-each
(lambda (s)
- (qif-split:set-matching-cleared!
+ (qif-split:set-matching-cleared!
s (qif-xtn:cleared other-xtn)))
splits))
;; otherwise: one-to-one, a normal single split match.
- (else
- (cond
+ (else
+ (cond
;; If one transaction has more splits than the other, mark the
;; one with less splits, regardless of all other conditions.
;; Otherwise, QIF split transactions will become mangled. For
@@ -1109,7 +1104,7 @@
(qif-import:merge-xtn-info xtn other-xtn)
(qif-split:set-matching-cleared!
(car match-splits) (qif-xtn:cleared xtn)))
-
+
((> (length (qif-xtn:splits xtn))
(length (qif-xtn:splits other-xtn)))
(qif-xtn:mark-split other-xtn (car match-splits))
@@ -1117,40 +1112,40 @@
(qif-split:set-matching-cleared!
split (qif-xtn:cleared other-xtn)))
- ;; this is a transfer involving a security xtn. Let the
- ;; security xtn dominate the way it's handled.
+ ;; this is a transfer involving a security xtn. Let the
+ ;; security xtn dominate the way it's handled.
((and (not action) o-action o-security)
(qif-xtn:mark-split xtn split)
(qif-import:merge-xtn-info xtn other-xtn)
- (qif-split:set-matching-cleared!
+ (qif-split:set-matching-cleared!
(car match-splits) (qif-xtn:cleared xtn)))
-
+
((and action (not o-action) security)
(qif-xtn:mark-split other-xtn (car match-splits))
(qif-import:merge-xtn-info other-xtn xtn)
- (qif-split:set-matching-cleared!
+ (qif-split:set-matching-cleared!
split (qif-xtn:cleared other-xtn)))
-
+
;; this is a security transaction from one brokerage to another
;; or within a brokerage. The "foox" xtn has the most
;; information about what went on, so use it.
((and action o-action o-security)
(case o-action
- ((buyx sellx cgshortx cgmidx cglongx intincx divx
+ ((buyx sellx cgshortx cgmidx cglongx intincx divx
margintx rtrncapx miscincx miscexpx)
(qif-xtn:mark-split xtn split)
(qif-import:merge-xtn-info xtn other-xtn)
(qif-split:set-matching-cleared!
(car match-splits) (qif-xtn:cleared xtn)))
-
- (else
+
+ (else
(qif-xtn:mark-split other-xtn (car match-splits))
(qif-import:merge-xtn-info other-xtn xtn)
- (qif-split:set-matching-cleared!
+ (qif-split:set-matching-cleared!
split (qif-xtn:cleared other-xtn)))))
-
+
;; Otherwise, this is a normal no-frills split match.
- (#t
+ (#t
(qif-xtn:mark-split other-xtn (car match-splits))
(qif-import:merge-xtn-info other-xtn xtn)
(qif-split:set-matching-cleared!
Modified: gnucash/trunk/src/import-export/qif-import/qif-utils.scm
===================================================================
--- gnucash/trunk/src/import-export/qif-import/qif-utils.scm 2008-06-04 22:25:40 UTC (rev 17190)
+++ gnucash/trunk/src/import-export/qif-import/qif-utils.scm 2008-06-06 16:46:03 UTC (rev 17191)
@@ -5,7 +5,7 @@
;;; Bill Gribble <grib at billgribble.com> 20 Feb 2000
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(use-modules (srfi srfi-13))
+(use-modules (ice-9 regex))
(define (simple-filter pred list)
@@ -49,33 +49,11 @@
(regexp-substitute/global #f rexpstr str 'pre 'post)))
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; string-remove-chars
-;;
-;; Removes all characters in string "chars" from string "str".
-;; Example: (string-remove-chars "abcd" "cb") returns "ad".
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (string-remove-chars str chars)
- (string-delete str (lambda (c) (string-index chars c))))
-
-
(define (string-char-count str char)
(length (simple-filter (lambda (elt) (eq? elt char))
(string->list str))))
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; string-replace-char
-;;
-;; Replaces all occurrences of char "old" with char "new".
-;; Example: (string-replace-char "foo" #\o #\c) returns "fcc".
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (string-replace-char str old new)
- (string-map (lambda (c) (if (char=? c old) new c)) str))
-
-
(define (string-replace-char! str old new)
(let ((rexpstr
(if (not (eq? old #\.))
@@ -89,4 +67,3 @@
(string-downcase
(string-remove-leading-space
(string-remove-trailing-space str)))))
-
Modified: gnucash/trunk/src/scm/Makefile.am
===================================================================
--- gnucash/trunk/src/scm/Makefile.am 2008-06-04 22:25:40 UTC (rev 17190)
+++ gnucash/trunk/src/scm/Makefile.am 2008-06-06 16:46:03 UTC (rev 17191)
@@ -7,6 +7,7 @@
gncscmmod_DATA = main.scm price-quotes.scm
gnc_regular_scm_files = \
+ string.scm \
command-line.scm \
doc.scm \
fin.scm \
Modified: gnucash/trunk/src/scm/main.scm
===================================================================
--- gnucash/trunk/src/scm/main.scm 2008-06-04 22:25:40 UTC (rev 17190)
+++ gnucash/trunk/src/scm/main.scm 2008-06-06 16:46:03 UTC (rev 17191)
@@ -37,6 +37,7 @@
;; files we can load from the top-level because they're "well behaved"
;; (these should probably be in modules eventually)
+(load-from-path "string.scm")
(load-from-path "doc.scm")
(load-from-path "main-window.scm") ;; depends on app-utils (N_, etc.)...
(load-from-path "fin.scm")
@@ -56,7 +57,6 @@
(export gnc:safe-strcmp) ;; only used by aging.scm atm...
(re-export hash-fold)
-(re-export string-split)
;; from command-line.scm
(export gnc:*doc-path*)
@@ -127,20 +127,6 @@
(cons joinstr (cons (car remaining-elements)
(loop (cdr remaining-elements)))))))))
-(define (string-split str char)
- (let ((parts '())
- (first-char #f))
- (let loop ((last-char (string-length str)))
- (set! first-char (string-rindex str char 0 last-char))
- (if first-char
- (begin
- (set! parts (cons (substring str (+ 1 first-char) last-char)
- parts))
- (loop first-char))
- (set! parts (cons (substring str 0 last-char) parts))))
- parts))
-
-
(define (gnc:backtrace-if-exception proc . args)
(define (dumper key . args)
(let ((stack (make-stack #t dumper)))
Added: gnucash/trunk/src/scm/string.scm
===================================================================
--- gnucash/trunk/src/scm/string.scm (rev 0)
+++ gnucash/trunk/src/scm/string.scm 2008-06-06 16:46:03 UTC (rev 17191)
@@ -0,0 +1,121 @@
+;; 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 at gnu.org
+
+(use-modules (srfi srfi-13))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; gnc:string-rcontains
+;;
+;; Similar to string-contains, but searches from the right.
+;;
+;; Example: (gnc:string-rcontains "foobarfoobarf" "bar")
+;; returns 9.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-public (gnc:string-rcontains s1 s2)
+ (let ((s2len (string-length s2)))
+ (let loop ((i (string-contains s1 s2))
+ (retval #f))
+ (if i
+ (loop (string-contains s1 s2 (+ i s2len)) i)
+ retval))))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; gnc:substring-count
+;;
+;; Similar to string-count, but searches for a substring rather
+;; than a single character.
+;;
+;; Example: (gnc:substring-count "foobarfoobarfoo" "bar")
+;; returns 2.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-public (gnc:substring-count s1 s2)
+ (let ((s2len (string-length s2)))
+ (let loop ((i (string-contains s1 s2))
+ (retval 0))
+ (if i
+ (loop (string-contains s1 s2 (+ i s2len)) (+ 1 retval))
+ retval))))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; gnc:substring-split
+;;
+;; Similar to string-split, but the delimiter is a string
+;; rather than a single character.
+;;
+;; Example: (gnc:substring-split "foobarfoobarf" "bar") returns
+;; ("foo" "foo" "f").
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-public (gnc:substring-split s1 s2)
+ (let ((i (string-contains s1 s2)))
+ (if i
+ (cons (substring s1 0 i)
+ (gnc:substring-split (substring s1 (+ i (string-length s2))) s2))
+ (list s1))))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; gnc:substring-replace
+;;
+;; Search for all occurrences in string "s1" of string "s2" and
+;; replace them with string "s3".
+;;
+;; Example: (gnc:substring-replace "foobarfoobar" "bar" "xyz")
+;; returns "fooxyzfooxyz".
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-public (gnc:substring-replace s1 s2 s3)
+ (let ((s2len (string-length s2)))
+ (let loop ((start1 0)
+ (i (string-contains s1 s2)))
+ (if i
+ (string-append (substring s1 start1 i)
+ s3
+ (loop (+ i s2len) (string-contains s1 s2 (+ i s2len))))
+ (substring s1 start1)))))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; gnc:string-replace-char
+;;
+;; Replaces all occurrences in string "s" of character "old"
+;; with character "new".
+;;
+;; Example: (gnc:string-replace-char "foo" #\o #\c) returns
+;; "fcc".
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-public (gnc:string-replace-char s old new)
+ (string-map (lambda (c) (if (char=? c old) new c)) s))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; gnc:string-delete-chars
+;;
+;; Filter string "s", retaining only those characters that do not
+;; appear in string "chars".
+;;
+;; Example: (gnc:string-delete-chars "abcd" "cb") returns "ad".
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-public (gnc:string-delete-chars s chars)
+ (string-delete s (lambda (c) (string-index chars c))))
Property changes on: gnucash/trunk/src/scm/string.scm
___________________________________________________________________
Name: svn:keywords
+ Author Date Id Revision
More information about the gnucash-changes
mailing list