From afa08864161b6c41a1e9f41968e2c854e68ed9eb Mon Sep 17 00:00:00 2001
From: Linas Vepstas <linas@linas.org>
Date: Sun, 24 Oct 1999 21:33:32 +0000
Subject: [PATCH] patches from Date: Sun, 24 Oct 1999 11:57:54 -0700 From: Dave
 Peticolas <peticola@morpheus.cs.ucdavis.edu>

git-svn-id: svn+ssh://svn.gnucash.org/repo/gnucash/trunk@1950 57a11ea4-9604-0410-9ed3-97b8803252fd
---
 src/scm/extensions.scm |   8 +-
 src/scm/importqif.scm  |   9 +-
 src/scm/qif2gc.scm     |  12 +-
 src/scm/qifutils.scm   | 261 +++++++++++++++++++++++++++++++++++++++++
 src/scm/test.scm       |  28 +----
 src/scm/testbed.scm    |  65 ++++++++++
 6 files changed, 339 insertions(+), 44 deletions(-)
 create mode 100644 src/scm/qifutils.scm
 create mode 100644 src/scm/testbed.scm

diff --git a/src/scm/extensions.scm b/src/scm/extensions.scm
index 5bf5f1c87e..8afb9799ae 100644
--- a/src/scm/extensions.scm
+++ b/src/scm/extensions.scm
@@ -1,18 +1,12 @@
 
 (define (gnc:extensions-menu-test-func)
-  (gnc:debug "Extension called from scheme.\n"))
+  (display "Extension called from scheme.\n"))
 
 (define (gnc:extensions-menu-setup win)
   ;; Should take window as a parameter?
   
   (gnc:debug "Setting up extensions menu " win "\n")
   
-  (gnc:extensions-menu-add-item
-   "Test Account creation"
-   "Creates three accounts and adds them to the top group"
-   (lambda ()
-     (gnc:test-creation)))
-
   (gnc:extensions-menu-add-item "Export data as text"
                                 "Export data as text hint"
                                 (lambda ()
diff --git a/src/scm/importqif.scm b/src/scm/importqif.scm
index e5b2219b0d..b1b4319866 100644
--- a/src/scm/importqif.scm
+++ b/src/scm/importqif.scm
@@ -1,15 +1,14 @@
 ;;; $Id$
 ;;; Import QIF File
+
 (define testing? #f)  ;;; Should we do testing?
 
 (define favorite-currency "USD")  ;;;; This may need to change...
 
 (define (gnc:extensions-qif-import win)
-  (let ((account-group #f)
-	(session (gnc:main-window-get-session)))
-    (if session (set! account-group (gnc:session-get-group session)))
+  (let ((account-group (gnc:get-current-group)))
     (if (not account-group)
-	(gnc:error-message-dialog 
+	(gnc:error-dialog 
 	 "No account group available for text export.")
 	(begin
 	  (display "account-group:") (display account-group) (newline)
@@ -33,7 +32,7 @@
 	    (display "Account type list:")
 	    (display gnc:account-types)
 	    (newline))
-	  (test-load account-group) ;;;;;  This tries to create some accounts
+	  (gnc:test-load account-group) ;  This tries to create some accounts
 	  (gnc:import-file-into-account-group account-group)))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
diff --git a/src/scm/qif2gc.scm b/src/scm/qif2gc.scm
index 05e918e982..f36100f562 100644
--- a/src/scm/qif2gc.scm
+++ b/src/scm/qif2gc.scm
@@ -35,7 +35,7 @@
 (define gnc-acc-list (initialize-lookup))
 (define gnc-split-list (initialize-lookup))
 
-(define (add-qif-transaction-to-gnc-lists txn curtxn cursplitlist)
+(define (add-qif-transaction-to-gnc-lists txn curtxn cursplitlist accountname)
   (define txnref (gensym))
   (set! gnc-txn-list (lookup-set! gnc-txn-list txnref curtxn))
     ;;; Fill in gnc-txn-list, gnc-acc-list, gnc-split-list
@@ -51,9 +51,9 @@
     (mainsplit 'put 'memo (txn 'get 'memo))
     (mainsplit 'put 'share-amount (txn 'get 'amount))
     (mainsplit 'put 'reconcile-state (txn 'get 'status))
-    (mainsplit 'put 'reconcile-state 
-	       (if  (string=? (txn 'get 'status) "*")
-		    '(1999 09 03) #f))
+    (mainsplit 'put 'reconciled-date
+ 	       (if  (string=? (txn 'get 'date) "*")
+ 		    '(1999 09 03) #f))
     (mainsplit 'put 'docref (txn 'get 'id))
     (mainsplit 'put 'parenttransaction txnref)
     (mainsplit 'put 'account accountname)
@@ -70,7 +70,7 @@
   (letrec 
       ((curtxn (build-mystruct-instance gnc-txn-structure))
        (cursplitlist (initialize-lookup))
-       (process-txn (lambda (x) (add-qif-transaction-to-gnc-lists x curtxn cursplitlist))))
+       (process-txn (lambda (x) (add-qif-transaction-to-gnc-lists x curtxn cursplitlist accountname))))
     (for-each process-txn txnlist)))
 
 ; QIF essentially provides a structure that sort of looks like
@@ -181,4 +181,4 @@
 (define (improve-qif-to-gnc-translation qif gnc)
   (set! qif-to-gnc-acct-xlation-table 
 	(lookup-set! qif-to-gnc-acct-xlation-table 
-		     qif gnc)))diff -u /dev/null 'gnucash/src/scm/qifcats.scm'
+		     qif gnc)))
diff --git a/src/scm/qifutils.scm b/src/scm/qifutils.scm
new file mode 100644
index 0000000000..5917df3cd4
--- /dev/null
+++ b/src/scm/qifutils.scm
@@ -0,0 +1,261 @@
+;;; $Id$
+(define (directory? path)
+  ;; This follows symlinks normally.
+  (let* ((status (false-if-exception (stat path)))
+         (type (if status (stat:type status) #f)))
+    (eq? type 'directory)))
+
+(define (filteroutnulls lst)
+  (cond
+   ((null? lst) '())
+   ((eq? (car lst) #f) (filteroutnulls (cdr lst)))
+   (else
+    (cons (car lst) (filteroutnulls (cdr lst))))))
+
+(if testing?
+    (let ((i1 '(a b #f f g h #f #f (c d e #f #f) #f))
+	  (i2 '(#f #f #f #f)))
+      (testing  "filteroutnulls"
+		i1
+		'(a b f g h (c d e #f #f))
+		(filteroutnulls i1))
+	
+      (testing  "filteroutnulls"
+		i2
+		'()
+		(filteroutnulls i2))))
+
+(define (atom? x)
+  (and
+   (not (pair? x))
+   (not (null? x))))
+
+(define (flatten lst)
+  (cond
+   ((null? lst) '())
+   ((atom? lst) (list lst))
+   ((list? lst) 
+    (append (flatten (car lst)) 
+	    (flatten (cdr lst))))
+   (else lst)))
+
+(if testing?
+    (let ((input '(a b (c d (e (f) (g) (h i (j k))) l m no p))))
+      (testing "flatten" 
+	       input
+	       '(a b c d e f g h i j k l m no p)
+	       (flatten input))))
+
+(define (striptrailingwhitespace line)
+  (let
+      ((stringsize (string-length line)))
+    (if
+     (< stringsize 1)
+     ""
+     (let*
+	 ((lastchar (string-ref line (- stringsize 1))))
+       (if
+	(char-whitespace? lastchar)
+	(striptrailingwhitespace (substring line 0  (- stringsize 1)))
+	line)))))
+
+(if testing?
+    (begin
+      (newline)
+      (display "Test striptrailingwhitespace") (newline)
+      (let ((tstring "Here's a string        
+
+
+
+"))
+      (display tstring) (newline)
+      (display "Result:") (display (striptrailingwhitespace tstring)) (newline))))
+
+(define (strip-qif-header line)
+  (substring line 1 (string-length line)))
+
+;;; Check amount to see if it's:
+;;; a) "European" where one separates thousands using a period, and
+;;; the decimal is represented via a comma, or if this be
+;;; b) "American" where commas indicate groupings of digits, and
+;;; decimal is a "."
+
+(define (thousands-separator numstring)
+  (define findcomma (substring-search-maker ","))
+  (define findperiod (substring-search-maker "."))
+  (let
+      ((firstcomma (findcomma numstring))
+       (firstperiod (findperiod numstring)))
+    (cond
+     ((not firstcomma)   ;; No commas found
+      #\,)
+     ((not firstperiod)  ;; No periods found
+      #\.)
+     ((> firstperiod firstcomma)  ;; First comma before first period
+      #\,)
+     ((< firstperiod firstcomma)  ;; First comma after first period
+      #\.)
+     (else #f))))
+
+(if testing?
+    (begin
+      (let ((num "1,234,56.78"))
+	(testing "thousands-separator"
+		 num
+		 #\,
+		 (thousands-separator num)))
+      (let ((num "1 234 56,78"))
+	(testing "thousands-separator"
+		 num
+		 #\.
+		 (thousands-separator num)))
+      (let ((num "1 234 56.78"))
+	(testing "thousands-separator"
+		 num
+		 #\,
+		 (thousands-separator num)))
+      (let ((num ".78"))
+	(testing "thousands-separator"
+		 num
+		 #\,
+		 (thousands-separator num)))
+      (let ((num ""))
+	(testing "thousands-separator"
+		 num
+		 #\,
+		 (thousands-separator num)))
+      (let ((num "1.234.56,78"))
+	(testing "thousands-separator"
+		 num
+		 #\.
+		 (thousands-separator num)))))
+
+(define (string-join lst joinstr)
+  (let ((len (length lst)))
+    (cond 
+     ((< 1 len)
+      (string-append (car lst) joinstr (string-join (cdr lst) joinstr)))
+     ((= 1 len)
+      (car lst))
+     (else
+      ""))))
+
+(define (numerizeamount amount-as-string)
+  (let*
+      (
+       ;;; First, chop out spaces
+       (spacesplit (split-on-somechar amount-as-string #\space))
+       (despaced (apply string-append spacesplit))
+       ;;; Second, separate based on #\, or #\.
+       (curr-separator (thousands-separator despaced))
+       (decimal-separator  (if (char=? curr-separator #\,)
+			       #\.
+			       #\,))
+       (trio-split (split-on-somechar despaced curr-separator))
+       ;;; Reform into a string
+       (without-trios (apply string-append trio-split))
+       ;;; Now, split on decimal separator...
+       (decimal-split (split-on-somechar without-trios
+					 decimal-separator)) 
+       (rejoin-decimal (string-join decimal-split "."))
+       ;;; Lastly, convert to a number
+       (numeric   (string->number rejoin-decimal)))
+    (if
+     numeric				; did the conversion succeed?
+     numeric				; Yup.  Return the value
+     amount-as-string)))		; Nope.  Return the original value.
+
+(if testing?
+    (begin
+      (let ((num " 1,234,56.78"))
+	(testing "numerizeamount"
+		 num
+		 123456.78
+		 (numerizeamount num)))
+      (let ((num "1 .2 34.5 6,78"))
+	(testing "numerizeamount"
+		 num
+		 123456.78
+		 (numerizeamount num)))))
+
+(define (find-min-cdr mlist)
+  (if
+   (null? mlist)
+   #f
+   (let
+       ((first (car mlist))
+	(rest (find-min-cdr (cdr mlist))))
+     (if
+      rest   ;;; Found a value for rest
+      (if (> (cdr first) (cdr rest))
+	  rest
+	  first)
+      first))))
+
+(define (shorten-to-best keep-top-n picklist)
+  (let ((shortened '()))
+    (let loop ((count keep-top-n))
+      (if (> count 0)
+	  (let
+	      ((bestitem (find-min-cdr picklist)))
+	    (if bestitem
+		(begin
+		  (if (> 99 (cdr bestitem))
+		      (set! shortened (cons (car bestitem) shortened)))
+		  (set-cdr! bestitem 999)   ;;;; Force off list...
+		  (loop (- count 1)))))))
+    shortened))
+
+;;;; Test shorten-to-best:
+
+(if testing? 
+    (let  
+	((alist '((a . 10)  (b . 15) (c . 20) (d . 12) (e . 7))))
+      (testing "shorten-to-best 3"
+	       alist
+	       '(b c d)
+	       (shorten-to-best 3 alist))))
+
+;;;; Simple lookup scheme; can be turned into a hash table If Need Be.
+;;; Initialize lookup table
+(define (initialize-lookup)
+  '())
+
+(define (lookup key list)   ;;; Returns (key . value)
+  (assoc key list))
+
+(define (lookup-set! lookuptable key value)
+  (let 
+      ((oldval (assoc key lookuptable)))
+    (if oldval
+	(set-cdr! oldval value)
+	(set! lookuptable (cons (cons key value) lookuptable))))
+  lookuptable)
+
+(define (lookup-map lfunction ltable)
+  (map lfunction ltable))
+
+(define (lookup-keys ltable)
+  (map car ltable))
+
+(if testing?
+    (begin
+      (write "Testing lookup tables.") (newline)
+      (let 
+	  ((ltbl (initialize-lookup))
+	   (sfun (lambda (x) 
+		   (display "(car.cdr) = (") 
+		   (display (car x)) (display ".") 
+		   (display (cdr x)) (display ")") (newline))))
+	(set! ltbl (lookup-set! ltbl "1" "one"))
+	(set! ltbl (lookup-set! ltbl "2" "twoo"))
+	(set! ltbl (lookup-set! ltbl "3" "three"))
+	(set! ltbl (lookup-set! ltbl "2" "two"))
+	(display "After 4 inserts, ltbl looks like:")
+	(display ltbl) (newline)
+	(display "Now, look up 1, 3, 2") (newline)
+	(display (list (lookup "1" ltbl) (lookup "2" ltbl) (lookup "3" ltbl))) 
+	(newline)
+	(display "Try mapping using lookup-map:")(newline)
+	(lookup-map sfun ltbl)
+	(newline))))
diff --git a/src/scm/test.scm b/src/scm/test.scm
index af070a7086..9b27aba65b 100644
--- a/src/scm/test.scm
+++ b/src/scm/test.scm
@@ -1,29 +1,5 @@
-(define (gnc:create-account AccPtr name description notes type)
-  (display "start creation")(newline)
-
-  (gnc:account-begin-edit AccPtr 0)
-  (display "edit")(newline)
-
-  (display (string-append "Name:" name)) (newline)
-  (gnc:account-set-name AccPtr name)
-
-  (display (string-append "Descr:" description)) (newline)
-  (gnc:account-set-description AccPtr description)
-
-  (display (string-append "notes:" notes)) (newline)
-  (gnc:account-set-notes AccPtr notes)
-
-  (display (string-append "Type:" (number->string type))) (newline)
-
-  (gnc:account-set-type AccPtr type)
-
-  (gnc:account-commit-edit AccPtr)
-  (display "committed")(newline)
-  )
-
-(define (gnc:test-creation)
-  (let ((group (gnc:get-current-group))
-	(cash
+(define (gnc:test-load group)
+  (let ((cash
 	 (list (gnc:malloc-account)
 	       "Sample Cash"
 	       "Sample Cash Description"
diff --git a/src/scm/testbed.scm b/src/scm/testbed.scm
new file mode 100644
index 0000000000..86b0da4532
--- /dev/null
+++ b/src/scm/testbed.scm
@@ -0,0 +1,65 @@
+;;; $Id$
+(define oklist #f)
+(define errorlist #f)
+(define errcount #f)
+
+(define (initialize-testing)
+  (set! oklist '())
+  (set! errorlist '())
+  (set! errcount 0))
+
+(define (testing funname input expected actual)
+  (define (lookup-set! lookuptable key value)
+    (let 
+	((oldval (assoc key lookuptable)))
+      (if oldval
+	  (set-cdr! oldval value)
+	  (set! lookuptable (cons (cons key value) lookuptable))))
+    lookuptable)
+  
+  (if testing?
+      (begin
+	(display (string-append "Test: ("  funname " "))
+	(display input)
+	(display ")") (newline)
+	(display "Expect: ") (display expected) (newline)
+	(display "Got: ") (display actual) (newline)
+	(let ((result (list funname input expected actual)))
+	  (if (equal? expected actual)
+	      (begin
+		(display "OK")
+		(set! oklist (lookup-set! oklist (list funname input) result)))
+	      (begin
+		(display "ERROR!!!!!!!!!")
+		(set! errorlist (lookup-set! errorlist 
+					     (list funname input) 
+					     (list expected result))))))
+	(newline))))
+
+(define (reportonerrors)
+  (newline)
+  (display "Error Analysis:") (newline)
+  (display "---------------------------") (newline)
+  (display "Number Passed:") 
+  (display (number->string (length (map car oklist)))) (newline)
+  (display "Number Failed:") 
+  (display (number->string (length (map car errorlist)))) (newline)
+
+  (map 
+   (lambda (lst)
+     (display "Error:") (newline)
+     (let* ((key (car lst))
+	    (funname (car key))
+	    (input (cadr key))
+	    (value (cdr lst))
+	    (expected (car value))
+	    (actual (cadr value)))
+       (display "-------------------------------------------") (newline)
+       (display "Function:") (display funname) (newline)
+       (display "Input:") (display input) (newline)
+       (display "Expected result:") (display expected) (newline)
+       (display "Actual result:") (display actual) (newline)
+       (display "-------------------------------------------") (newline)
+       )) 
+   errorlist)
+  (newline))