mirror of
https://github.com/Gnucash/gnucash.git
synced 2025-02-25 18:55:30 -06:00
*** empty log message ***
git-svn-id: svn+ssh://svn.gnucash.org/repo/gnucash/trunk@2066 57a11ea4-9604-0410-9ed3-97b8803252fd
This commit is contained in:
Dave Peticolas
parent
14b0d47c54
commit
74465a8726
@ -12,7 +12,7 @@
|
||||
* edited row(s)).
|
||||
* -- an array of cell-block handlers. The handlers provide
|
||||
* the actual GUI editing infrastructure: the handlers
|
||||
* ake sure that only allowed edits are made to a block
|
||||
* make sure that only allowed edits are made to a block
|
||||
* of cells.
|
||||
* -- The "cursor", which defines the region of cells that
|
||||
* are currently being edited.
|
||||
@ -20,7 +20,7 @@
|
||||
* to the cellblock handlers that know how to handle edits
|
||||
* to the physical, display cells.
|
||||
* -- A table of user-defined data hooks that can be associated
|
||||
* with each cell block. By "user" we ean the prograer who
|
||||
* with each cell block. By "user" we mean the programmer who
|
||||
* makes use of this object.
|
||||
* -- Tab-traversing mechanism so that operator can tab in a
|
||||
* predefined order between cells.
|
||||
|
||||
@ -1,7 +1,9 @@
|
||||
;; -*-scheme-*-
|
||||
;; $ID$
|
||||
;; dateutils.scm
|
||||
;; date utility functions. mainly used by budget
|
||||
;; Bryan Larsen (blarsen@ada-works.com)
|
||||
;; Revised by Christopher Browne
|
||||
|
||||
(gnc:support "dateutils.scm")
|
||||
|
||||
@ -80,3 +82,121 @@
|
||||
((gnc:budget-month) "months")
|
||||
((gnc:budget-year) "years")))
|
||||
|
||||
;; Modify a date
|
||||
(define (moddate op adate delta)
|
||||
(let ((newtm (localtime (car adate))))
|
||||
(begin
|
||||
(set-tm:sec newtm (op (tm:sec newtm) (tm:sec delta)))
|
||||
(set-tm:min newtm (op (tm:min newtm) (tm:min delta)))
|
||||
(set-tm:hour newtm (op (tm:hour newtm) (tm:hour delta)))
|
||||
(set-tm:mday newtm (op (tm:mday newtm) (tm:mday delta)))
|
||||
(set-tm:mon newtm (op (tm:mon newtm) (tm:mon delta)))
|
||||
(set-tm:year newtm (op (tm:year newtm) (tm:year delta)))
|
||||
|
||||
(let ((time (car (mktime newtm))))
|
||||
(cons time 0)))))
|
||||
|
||||
;; Add or subtract time from a date
|
||||
(define (decdate adate delta)(moddate - adate delta ))
|
||||
(define (incdate adate delta)(moddate + adate delta ))
|
||||
|
||||
;; Time comparison, true if t2 is later than t1
|
||||
(define (gnc:timepair-later t1 t2)
|
||||
(< (car t1) (car t2)))
|
||||
|
||||
;; Build a list of time intervals
|
||||
(define (dateloop curd endd incr)
|
||||
(cond ((gnc:timepair-later curd endd)
|
||||
(let ((nextd (incdate curd incr)))
|
||||
(cons (list curd (decdate nextd SecDelta) '())
|
||||
(dateloop nextd endd incr))))
|
||||
(else '())))
|
||||
|
||||
; A reference zero date - the Beginning Of The Epoch
|
||||
; Note: use of eval is evil... by making this a generator function,
|
||||
; each delta function gets its own instance of Zero Date
|
||||
(define (make-zdate)
|
||||
(let ((zd (localtime 0)))
|
||||
(set-tm:hour zd 0)
|
||||
(set-tm:min zd 0)
|
||||
(set-tm:sec zd 0)
|
||||
(set-tm:mday zd 0)
|
||||
(set-tm:mon zd 0)
|
||||
(set-tm:year zd 0)
|
||||
(set-tm:yday zd 0)
|
||||
(set-tm:wday zd 0)
|
||||
zd))
|
||||
|
||||
(define SecDelta
|
||||
(let ((ddt (make-zdate)))
|
||||
(set-tm:sec ddt 1)
|
||||
ddt))
|
||||
|
||||
(define YearDelta
|
||||
(let ((ddt (make-zdate)))
|
||||
(set-tm:year ddt 1)
|
||||
ddt))
|
||||
|
||||
(define DayDelta
|
||||
(let ((ddt (make-zdate)))
|
||||
(set-tm:mday ddt 1)
|
||||
ddt))
|
||||
|
||||
(define WeekDelta
|
||||
(let ((ddt (make-zdate)))
|
||||
(set-tm:mday ddt 7)
|
||||
ddt))
|
||||
|
||||
(define TwoWeekDelta
|
||||
(let ((ddt (make-zdate)))
|
||||
(set-tm:mday ddt 14)
|
||||
ddt))
|
||||
|
||||
(define MonthDelta
|
||||
(let ((ddt (make-zdate)))
|
||||
(set-tm:mon ddt 1)
|
||||
ddt))
|
||||
|
||||
(define (gnc:timepair-to-ldatestring tp)
|
||||
(let ((bdtime (localtime (car tp))))
|
||||
(strftime "%m/%d/%Y" bdtime)))
|
||||
|
||||
;; Find difference in seconds (?) between time 1 and time2
|
||||
(define (gnc:timepair-delta t1 t2)
|
||||
(- (car t2) (car t1)))
|
||||
|
||||
;; timepair manipulation functions
|
||||
;; hack alert - these should probably be put somewhere else
|
||||
;; and be implemented PROPERLY rather than hackily
|
||||
;;; Added from transaction-report.scm
|
||||
|
||||
(define (gnc:timepair-to-datestring tp)
|
||||
(let ((bdtime (localtime (car tp))))
|
||||
(strftime "%x" bdtime)))
|
||||
|
||||
;; given a timepair contains any time on a certain day (local time)
|
||||
;; converts it to be midday that day.
|
||||
|
||||
(define (gnc:timepair-canonical-day-time tp)
|
||||
(let ((bdt (localtime (car tp))))
|
||||
(set-tm:sec bdt 0)
|
||||
(set-tm:min bdt 0)
|
||||
(set-tm:hour bdt 12)
|
||||
(let ((newtime (car (mktime bdt))))
|
||||
; alert - blarsen@ada-works.com fixed this. you may want to
|
||||
; revert if I'm wrong.
|
||||
(cons newtime 0))))
|
||||
|
||||
(define (gnc:timepair-earlier-or-eq-date t1 t2)
|
||||
(let ((time1 (car (gnc:timepair-canonical-day-time t1)))
|
||||
(time2 (car (gnc:timepair-canonical-day-time t2))))
|
||||
(<= time1 time2)))
|
||||
|
||||
(define (gnc:timepair-later-date t1 t2)
|
||||
(let ((time1 (car (gnc:timepair-canonical-day-time t1)))
|
||||
(time2 (car (gnc:timepair-canonical-day-time t2))))
|
||||
(< time1 time2)))
|
||||
|
||||
(define (gnc:timepair-later-or-eq-date t1 t2)
|
||||
(gnc:timepair-earlier-or-eq-date t2 t1))
|
||||
|
||||
|
||||
@ -98,3 +98,50 @@
|
||||
(define (html-end-table)
|
||||
(list "</table>"))
|
||||
|
||||
;;;; Here's functions defined in average-balance.scm
|
||||
;;;; The point to this is twofold:
|
||||
;;;; 1. It doesn't break anything because if the functions get
|
||||
;;;; redefined somewhere here, things were *already broken.*
|
||||
;;;; 2. It pushes all HTML stuff into *this* file, and encourages
|
||||
;;;; fixing any resulting mess.
|
||||
;;;;;;;;;;;;;;;;;;;;
|
||||
;; HTML Table
|
||||
;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
; Convert to string
|
||||
(define (tostring val)
|
||||
(if (number? val)
|
||||
(sprintf #f "%.2f" val)
|
||||
(call-with-output-string
|
||||
(lambda (p)
|
||||
(display val p)))))
|
||||
|
||||
; Create a column entry
|
||||
(define (html-table-col val)
|
||||
(sprintf #f "<TD align=right> %s </TD>" (tostring val)))
|
||||
|
||||
; Create an html table row from a list of entries
|
||||
(define (html-table-row lst)
|
||||
(cond ((string? lst) lst)
|
||||
(else
|
||||
(string-append
|
||||
(sprintf #f "<TR>")
|
||||
(apply string-append (map html-table-col lst))
|
||||
(sprintf #f "</TR>\n")))))
|
||||
|
||||
; Create an html table from a list of rows, each containing
|
||||
; a list of column entries
|
||||
(define (html-table hdrlst llst)
|
||||
(string-append
|
||||
(html-table-header hdrlst)
|
||||
(apply string-append (map html-table-row llst))
|
||||
(html-table-footer)))
|
||||
|
||||
(define (html-table-headcol val)
|
||||
(sprintf #f "<TH justify=center> %s </TH>" (tostring val)))
|
||||
|
||||
(define (html-table-header vec)
|
||||
(apply string-append "<TABLE cellspacing=10 rules=\"rows\">\n" (map html-table-headcol vec)))
|
||||
|
||||
(define (html-table-footer)
|
||||
(sprintf #f "</TABLE>"))
|
||||
|
||||
@ -1,4 +1,7 @@
|
||||
;; $Id$
|
||||
(gnc:support "qifs/dates-qif.scm")
|
||||
(gnc:depend "substring-search.scm")
|
||||
|
||||
;;;;;;; Date-related code
|
||||
(define findspace (substring-search-maker " "))
|
||||
|
||||
@ -1,4 +1,8 @@
|
||||
;;; $Id$
|
||||
(gnc:support "qifs/gc-import-qifs.scm")
|
||||
(gnc:depend "qifs/qifcats.scm")
|
||||
(gnc:depend "qifs/qif2gc.scm")
|
||||
|
||||
(display "Started gc-impor.scm")
|
||||
(newline)
|
||||
(define (gnc:get-account-list account-group)
|
||||
@ -13,7 +17,6 @@
|
||||
(newline)
|
||||
(filteroutnulls fullacclist))))
|
||||
|
||||
|
||||
(define (gnc:import-file-into-account-group account-group)
|
||||
;(sample-dialog)
|
||||
(let ((file-name
|
||||
@ -1,4 +1,7 @@
|
||||
;;; $Id$
|
||||
(gnc:support "qifs/guess-category-qif.scm")
|
||||
(gnc:depend "substring-search.scm")
|
||||
|
||||
;;; Need a bunch of metrics, and probably to vectorize this...
|
||||
;;; 1. Braces --> pick gnucash entries from account list
|
||||
;;; No braces --> pick gnucash entries from category list
|
||||
@ -1,7 +1,7 @@
|
||||
;;; $Id$
|
||||
;;; Import QIF File
|
||||
|
||||
(gnc:support "importqif.scm")
|
||||
(gnc:depend "qifs/gc-import-qifs.scm")
|
||||
|
||||
(define testing? #f) ;;; Should we do testing?
|
||||
|
||||
@ -15,7 +15,7 @@
|
||||
(begin
|
||||
(display "account-group:")
|
||||
(display account-group) (newline)
|
||||
(let ((loadfun (lambda (x) (gnc:load x)))
|
||||
(let ((loadfun (lambda (x) (gnc:load (string-append "qifs/" x))))
|
||||
(loadlist '("testbed.scm" "analytical-qifs.scm"
|
||||
"gc-import-qifs.scm"
|
||||
"qifutils.scm" "acc-create.scm")))
|
||||
@ -35,7 +35,7 @@
|
||||
(begin
|
||||
(display "account-group:")
|
||||
(display account-group) (newline)
|
||||
(let ((loadfun (lambda (x) (gnc:load x)))
|
||||
(let ((loadfun (lambda (x) (gnc:load (string-append "qifs/" x))))
|
||||
(loadlist '("testbed.scm" "analytical-qifs.scm"
|
||||
"gc-import-qifs.scm" "qifutils.scm"
|
||||
"acc-create.scm" "txn-create.scm")))
|
||||
@ -55,8 +55,8 @@
|
||||
(begin
|
||||
(display "account-group:")
|
||||
(display account-group) (newline)
|
||||
(let ((loadfun (lambda (x) (gnc:load x)))
|
||||
(loadlist '("testbed.scm" "sstring-qif.scm"
|
||||
(let ((loadfun (lambda (x) (gnc:load (string-append "qifs/" x))))
|
||||
(loadlist '("testbed.scm"
|
||||
"qifutils.scm" "dates-qif.scm"
|
||||
"acc-create.scm"
|
||||
"txn-create.scm"
|
||||
@ -1,7 +1,12 @@
|
||||
;;; $Id$
|
||||
;;;;;;;;;;; QIF Parsing ;;;;;;;;;;;;;;
|
||||
|
||||
(require 'hash-table)
|
||||
(gnc:support "qifs/parseqif.scm")
|
||||
(gnc:depend "qifs/qifcats.scm")
|
||||
(gnc:depend "qifs/dates-qif.scm")
|
||||
(gnc:depend "qifs/gc-import-qifs.scm")
|
||||
(gnc:depend "qifs/qifstate.scm")
|
||||
(gnc:depend "qifs/split-qif.scm")
|
||||
(gnc:depend "qifs/guess-category-qif.scm")
|
||||
|
||||
(define qif-txn-list '())
|
||||
|
||||
@ -1,4 +1,6 @@
|
||||
;;; $Id$
|
||||
(gnc:support "qifs/qif2gc.scm")
|
||||
(gnc:depend "qifs/guess-category-qif.scm")
|
||||
;;;; Take the set of stuff from a QIF file, and turn it into the
|
||||
;;;; structures expected by GnuCash.
|
||||
|
||||
@ -1,5 +1,6 @@
|
||||
;;; $Id$
|
||||
;;;;; Category management
|
||||
(gnc:support "qifs/qifcats.scm")
|
||||
|
||||
(define qif-cat-list (initialize-hashtable))
|
||||
|
||||
@ -1,4 +1,5 @@
|
||||
;;; $Id$
|
||||
(gnc:support "qifs/qifstate.scm")
|
||||
;;;;; - Transactions should not be marked off as being finally reconciled on
|
||||
;;;;; the GnuCash side, as the reconciliation hasn't been done there.
|
||||
;;;;;
|
||||
@ -1,75 +1,6 @@
|
||||
;;; $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))))
|
||||
(gnc:support "qifs/qifutils.scm")
|
||||
(gnc:depend "utilities.scm")
|
||||
|
||||
(define (strip-qif-header line)
|
||||
(substring line 1 (string-length line)))
|
||||
@ -130,16 +61,6 @@
|
||||
#\.
|
||||
(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*
|
||||
(
|
||||
@ -215,11 +136,3 @@
|
||||
'(d a e)
|
||||
(shorten-to-best! 3 alist))))
|
||||
|
||||
;;;; Simple lookup scheme; can be turned into a hash table If Need Be.
|
||||
;;; Initialize lookup table
|
||||
(define (initialize-hashtable . size)
|
||||
(make-vector
|
||||
(if (null? size)
|
||||
313
|
||||
(car size))
|
||||
'()))
|
||||
@ -3,6 +3,9 @@
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;;; Variables used to handle splits ;;;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(gnc:support "qifs/split-qif.scm")
|
||||
(gnc:depend "structure.scm")
|
||||
|
||||
(define splits? #f)
|
||||
(define splitlist '())
|
||||
(define qif-split-structure
|
||||
@ -1,6 +1,5 @@
|
||||
;;; $Id$
|
||||
;;; Reporting utilities
|
||||
|
||||
(gnc:support "report-utilities.scm")
|
||||
|
||||
(define (gnc:account-separator-char)
|
||||
@ -197,4 +196,127 @@
|
||||
(vector-N-ref vector ref-list))
|
||||
(loop (+ 1 i))))))))))
|
||||
|
||||
;;; applies thunk to each split in account account
|
||||
(define (gnc:for-each-split-in-account account thunk)
|
||||
(gnc:for-loop (lambda (x)
|
||||
(thunk (gnc:account-get-split account x)))
|
||||
0 (gnc:account-get-split-count account) 1))
|
||||
|
||||
;; register a configuration option for the transaction report
|
||||
(define (trep-options-generator)
|
||||
(define gnc:*transaction-report-options* (gnc:new-options))
|
||||
(define (gnc:register-trep-option new-option)
|
||||
(gnc:register-option gnc:*transaction-report-options* new-option))
|
||||
;; from date
|
||||
;; hack alert - could somebody set this to an appropriate date?
|
||||
(gnc:register-trep-option
|
||||
(gnc:make-date-option
|
||||
"Report Options" "From"
|
||||
"a" "Report Items from this date"
|
||||
(lambda ()
|
||||
(let ((bdtime (localtime (current-time))))
|
||||
(set-tm:sec bdtime 0)
|
||||
(set-tm:min bdtime 0)
|
||||
(set-tm:hour bdtime 0)
|
||||
(set-tm:mday bdtime 1)
|
||||
(set-tm:mon bdtime 0)
|
||||
(let ((time (car (mktime bdtime))))
|
||||
(cons time 0))))
|
||||
#f))
|
||||
|
||||
;; to-date
|
||||
(gnc:register-trep-option
|
||||
(gnc:make-date-option
|
||||
"Report Options" "To"
|
||||
"b" "Report items up to and including this date"
|
||||
(lambda () (cons (current-time) 0))
|
||||
#f))
|
||||
|
||||
;; account to do report on
|
||||
(gnc:register-trep-option
|
||||
(gnc:make-account-list-option
|
||||
"Report Options" "Account"
|
||||
"c" "Do transaction report on this account"
|
||||
(lambda ()
|
||||
(let ((current-accounts (gnc:get-current-accounts))
|
||||
(num-accounts (gnc:group-get-num-accounts (gnc:get-current-group)))
|
||||
(first-account (gnc:group-get-account (gnc:get-current-group) 0)))
|
||||
(cond ((not (null? current-accounts)) (list (car current-accounts)))
|
||||
((> num-accounts 0) (list first-account))
|
||||
(else ()))))
|
||||
#f #f))
|
||||
|
||||
;; primary sorting criterion
|
||||
(gnc:register-trep-option
|
||||
(gnc:make-multichoice-option
|
||||
"Sorting" "Primary Key"
|
||||
"a" "Sort by this criterion first"
|
||||
'date
|
||||
(list #(date
|
||||
"Date"
|
||||
"Sort by date")
|
||||
#(time
|
||||
"Time"
|
||||
"Sort by EXACT entry time")
|
||||
#(corresponding-acc
|
||||
"Transfer from/to"
|
||||
"Sort by account transferred from/to's name")
|
||||
#(amount
|
||||
"Amount"
|
||||
"Sort by amount")
|
||||
#(description
|
||||
"Description"
|
||||
"Sort by description")
|
||||
#(number
|
||||
"Number"
|
||||
"Sort by check/transaction number")
|
||||
#(memo
|
||||
"Memo"
|
||||
"Sort by memo"))))
|
||||
|
||||
(gnc:register-trep-option
|
||||
(gnc:make-multichoice-option
|
||||
"Sorting" "Primary Sort Order"
|
||||
"b" "Order of primary sorting"
|
||||
'ascend
|
||||
(list #(ascend "Ascending" "smallest to largest, earliest to latest")
|
||||
#(descend "Descending" "largest to smallest, latest to earliest"))))
|
||||
|
||||
(gnc:register-trep-option
|
||||
(gnc:make-multichoice-option
|
||||
"Sorting" "Secondary Key"
|
||||
"c"
|
||||
"Sort by this criterion second"
|
||||
'corresponding-acc
|
||||
(list #(date
|
||||
"Date"
|
||||
"Sort by date")
|
||||
#(time
|
||||
"Time"
|
||||
"Sort by EXACT entry time")
|
||||
#(corresponding-acc
|
||||
"Transfer from/to"
|
||||
"Sort by account transferred from/to's name")
|
||||
#(amount
|
||||
"Amount"
|
||||
"Sort by amount")
|
||||
#(description
|
||||
"Description"
|
||||
"Sort by description")
|
||||
#(number
|
||||
"Number"
|
||||
"Sort by check/transaction number")
|
||||
#(memo
|
||||
"Memo"
|
||||
"Sort by memo"))))
|
||||
|
||||
(gnc:register-trep-option
|
||||
(gnc:make-multichoice-option
|
||||
"Sorting" "Secondary Sort Order"
|
||||
"d" "Order of Secondary sorting"
|
||||
'ascend
|
||||
(list #(ascend "Ascending" "smallest to largest, earliest to latest")
|
||||
#(descend "Descending" "largest to smallest, latest to earliest"))))
|
||||
|
||||
gnc:*transaction-report-options*)
|
||||
|
||||
|
||||
@ -10,47 +10,12 @@
|
||||
;; Matt Martin <matt.martin@ieee.org>
|
||||
|
||||
(gnc:support "report/average-balance.scm")
|
||||
|
||||
(use-modules (ice-9 regex))
|
||||
(require 'hash-table)
|
||||
|
||||
(gnc:depend "structure.scm")
|
||||
(gnc:depend "report/transaction-report.scm")
|
||||
|
||||
;; Modify a date
|
||||
(define (moddate op adate delta)
|
||||
(let ((newtm (localtime (car adate))))
|
||||
(begin
|
||||
(set-tm:sec newtm (op (tm:sec newtm) (tm:sec delta)))
|
||||
(set-tm:min newtm (op (tm:min newtm) (tm:min delta)))
|
||||
(set-tm:hour newtm (op (tm:hour newtm) (tm:hour delta)))
|
||||
(set-tm:mday newtm (op (tm:mday newtm) (tm:mday delta)))
|
||||
(set-tm:mon newtm (op (tm:mon newtm) (tm:mon delta)))
|
||||
(set-tm:year newtm (op (tm:year newtm) (tm:year delta)))
|
||||
|
||||
(let ((time (car (mktime newtm))))
|
||||
(cons time 0))
|
||||
))
|
||||
)
|
||||
|
||||
;; Add or subtract time from a date
|
||||
(define (decdate adate delta)(moddate - adate delta ))
|
||||
(define (incdate adate delta)(moddate + adate delta ))
|
||||
|
||||
;; Time comparison, true if t2 is later than t1
|
||||
(define (gnc:timepair-later t1 t2)
|
||||
(< (car t1) (car t2)))
|
||||
|
||||
;; Build a list of time intervals
|
||||
(define (dateloop curd endd incr)
|
||||
(cond ((gnc:timepair-later curd endd)
|
||||
(let ((nextd (incdate curd incr)))
|
||||
(cons (list curd (decdate nextd SecDelta) '())
|
||||
(dateloop nextd endd incr))))
|
||||
(else '())
|
||||
)
|
||||
)
|
||||
|
||||
(gnc:depend "html-generator.scm")
|
||||
(gnc:depend "date-utilities.scm")
|
||||
|
||||
;; Options
|
||||
(define (runavg-options-generator)
|
||||
@ -73,8 +38,7 @@
|
||||
(set-tm:hour bdtime 0)
|
||||
(set-tm:mday bdtime 1)
|
||||
(set-tm:mon bdtime 0)
|
||||
(let ((time (car (mktime bdtime))))
|
||||
(cons time 0))))
|
||||
(cons (car (mktime bdtime)) 0))))
|
||||
#f))
|
||||
|
||||
;; to-date
|
||||
@ -135,45 +99,10 @@
|
||||
(list #(NoPlot "Nothing" "Make No Plot")
|
||||
#(AvgBalPlot "Average" "Average Balance")
|
||||
#(GainPlot "Net Gain" "Net Gain")
|
||||
#(GLPlot "Gain/Loss" "Gain And Loss")
|
||||
)))
|
||||
#(GLPlot "Gain/Loss" "Gain And Loss"))))
|
||||
|
||||
gnc:*runavg-track-options*)
|
||||
|
||||
; A reference zero date
|
||||
(define zdate (let ((zd (localtime 0)))
|
||||
(set-tm:hour zd 0)
|
||||
(set-tm:min zd 0)
|
||||
(set-tm:sec zd 0)
|
||||
(set-tm:mday zd 0)
|
||||
(set-tm:mon zd 0)
|
||||
(set-tm:year zd 0)
|
||||
(set-tm:yday zd 0)
|
||||
(set-tm:wday zd 0)
|
||||
zd
|
||||
))
|
||||
|
||||
(define SecDelta (let ((ddt (eval zdate)))
|
||||
(set-tm:sec ddt 1)
|
||||
ddt))
|
||||
(define YearDelta (let ((ddt (eval zdate)))
|
||||
(set-tm:year ddt 1)
|
||||
ddt))
|
||||
|
||||
(define DayDelta (let ((ddt (eval zdate)))
|
||||
(set-tm:mday ddt 1)
|
||||
ddt))
|
||||
(define WeekDelta (let ((ddt (eval zdate)))
|
||||
(set-tm:mday ddt 7)
|
||||
ddt))
|
||||
(define TwoWeekDelta (let ((ddt (eval zdate)))
|
||||
(set-tm:mday ddt 14)
|
||||
ddt))
|
||||
|
||||
(define MonthDelta (let ((ddt (eval zdate)))
|
||||
(set-tm:mon ddt 1)
|
||||
ddt))
|
||||
|
||||
;; Plot strings
|
||||
(define AvgBalPlot "using 2:3:4:5 t 'Average Balance' with errorbars, '' using 2:3 smooth sbezier t '' with lines")
|
||||
(define GainPlot "using 2:6 t 'Net Gain' with linespoints, '' using 2:6 smooth sbezier t '' with lines" )
|
||||
@ -199,64 +128,6 @@
|
||||
(define (gnc:split-get-account-name split)
|
||||
(gnc:account-get-name (gnc:split-get-account split)))
|
||||
|
||||
(define (gnc:timepair-to-ldatestring tp)
|
||||
(let ((bdtime (localtime (car tp))))
|
||||
(strftime "%m/%d/%Y" bdtime)))
|
||||
|
||||
|
||||
;; Find difference in seconds (?) between time 1 and time2
|
||||
(define (gnc:timepair-delta t1 t2)
|
||||
(- (car t2) (car t1)))
|
||||
|
||||
; Convert to string
|
||||
(define (tostring val)
|
||||
(cond ((number? val) (sprintf #f "%.2f" val))
|
||||
(else (call-with-output-string (lambda (p)(display val p))))
|
||||
))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;
|
||||
;; HTML Table
|
||||
;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
; Create a column entry
|
||||
(define (html-table-col val)
|
||||
(sprintf #f "<TD align=right> %s </TD>" (tostring val))
|
||||
)
|
||||
|
||||
; Create an html table row from a list of entries
|
||||
(define (html-table-row lst)
|
||||
(cond ((string? lst) lst)
|
||||
(else
|
||||
(string-append
|
||||
(sprintf #f "<TR>")
|
||||
(apply string-append (map html-table-col lst))
|
||||
(sprintf #f "</TR>\n")
|
||||
)))
|
||||
)
|
||||
|
||||
; Create an html table from a list of rows, each containing
|
||||
; a list of column entries
|
||||
(define (html-table hdrlst llst)
|
||||
(string-append
|
||||
(html-table-header hdrlst)
|
||||
(apply string-append (map html-table-row llst))
|
||||
(html-table-footer)
|
||||
)
|
||||
)
|
||||
|
||||
(define (html-table-headcol val)
|
||||
(sprintf #f "<TH justify=center> %s </TH>" (tostring val))
|
||||
)
|
||||
|
||||
(define (html-table-header vec)
|
||||
(apply string-append "<TABLE cellspacing=10 rules=\"rows\">\n" (map html-table-headcol vec))
|
||||
)
|
||||
|
||||
(define (html-table-footer)
|
||||
(sprintf #f "</TABLE>")
|
||||
)
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Text table
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
@ -489,17 +360,8 @@
|
||||
(gnc:account-get-children (car accounts)))
|
||||
(allsubaccounts (cdr accounts))))))
|
||||
|
||||
(gnc:define-report
|
||||
;; version
|
||||
1
|
||||
;; Name
|
||||
"Account Balance Tracker"
|
||||
;; Options
|
||||
runavg-options-generator
|
||||
;; renderer
|
||||
(lambda (options)
|
||||
(let* (
|
||||
(begindate (gnc:option-value
|
||||
(define (average-balance-renderer options)
|
||||
(let* ((begindate (gnc:option-value
|
||||
(gnc:lookup-option options "Report Options" "From")))
|
||||
(enddate (gnc:option-value
|
||||
(gnc:lookup-option options "Report Options" "To")))
|
||||
@ -529,9 +391,7 @@
|
||||
(rept-text "")
|
||||
(gncq (gnc:malloc-query))
|
||||
|
||||
(slist '())
|
||||
|
||||
)
|
||||
(slist '()))
|
||||
|
||||
(gnc:init-query gncq)
|
||||
|
||||
@ -540,22 +400,15 @@
|
||||
(list "<TR><TD>You have not selected an account.</TD></TR>"))
|
||||
(begin
|
||||
; Grab account names
|
||||
(set! acctname (gnc:account-get-name (car accounts)))
|
||||
(map (lambda(an)
|
||||
(set! acctname
|
||||
(string-append
|
||||
acctname
|
||||
" , "
|
||||
(gnc:account-get-name an))))
|
||||
(cdr accounts) )
|
||||
|
||||
(set! acctname (string-join
|
||||
(map gnc-account-getname accounts)
|
||||
" , "))
|
||||
(cond ((equal? dosubs #t)
|
||||
(map (lambda (a)
|
||||
(set! accounts (addunique accounts a)))
|
||||
(allsubaccounts accounts))
|
||||
|
||||
(set! acctname (string-append acctname " and sub-accounts"))
|
||||
))
|
||||
(set! acctname (string-append acctname " and sub-accounts"))))
|
||||
|
||||
(map (lambda(acct) (gnc:query-add-account gncq acct)) accounts)
|
||||
|
||||
@ -613,12 +466,20 @@
|
||||
(system
|
||||
(string-append "echo \"" preplot "plot '"
|
||||
fn "'" (eval plotstr)
|
||||
"\"|gnuplot -persist " ))))
|
||||
))
|
||||
"\"|gnuplot -persist " ))))))
|
||||
|
||||
(append prefix
|
||||
(if (null? accounts)
|
||||
()
|
||||
(list "Report for " acctname "<p>\n"))
|
||||
(list rept-text) suffix)))
|
||||
)
|
||||
(list rept-text) suffix))))
|
||||
|
||||
(gnc:define-report
|
||||
;; version
|
||||
1
|
||||
;; Name
|
||||
"Account Balance Tracker"
|
||||
;; Options
|
||||
runavg-options-generator
|
||||
;; renderer
|
||||
average-balance-renderer)
|
||||
|
||||
@ -1,7 +1,6 @@
|
||||
;; -*-scheme-*-
|
||||
|
||||
(gnc:support "report/balance-and-pnl.scm")
|
||||
|
||||
(gnc:depend "text-export.scm")
|
||||
|
||||
(let ()
|
||||
@ -94,7 +93,6 @@
|
||||
|
||||
;; Ignore
|
||||
'()
|
||||
|
||||
(let ((childrens-output (gnc:group-map-accounts
|
||||
handle-level-2-account
|
||||
(gnc:account-get-children account)))
|
||||
@ -107,13 +105,13 @@
|
||||
(set! level-1-balance (+ level-1-balance account-balance))
|
||||
(set! level-0-balance (+ level-0-balance level-1-balance))
|
||||
|
||||
(let ((level-1-output (render-level-1-account account
|
||||
(let ((level-1-output
|
||||
(render-level-1-account account
|
||||
level-1-balance
|
||||
level-2-balance)))
|
||||
(set! level-1-balance 0)
|
||||
(set! level-2-balance 0)
|
||||
(list childrens-output level-1-output))))))
|
||||
|
||||
(if (not (pointer-token-null? current-group))
|
||||
(set! output
|
||||
(list
|
||||
|
||||
@ -15,7 +15,6 @@
|
||||
(gnc:depend "html-generator.scm")
|
||||
(gnc:depend "date-utilities.scm")
|
||||
|
||||
|
||||
;; time values
|
||||
;(define gnc:budget-day 1)
|
||||
;(define gnc:budget-week 2)
|
||||
@ -38,10 +37,21 @@
|
||||
;; 3 - period: the time span of the budget line in #4
|
||||
;; 4 - period-type:
|
||||
;; 5 - triggers: as yet undefined
|
||||
|
||||
(define (make-budget-entry desc amt acct per ptype trigger)
|
||||
(list->vector desc amt acct per ptype trigger))
|
||||
|
||||
(define gnc:budget
|
||||
#(#("lunch" 8 ("Food:Lunch") 1 gnc:budget-day gnc:budget-recurring)
|
||||
#("junk food" 0.50 ("Food:Junk") 1 gnc:budget-day gnc:budget-recurring)
|
||||
#("car repairs" 2500 ("Car:Repairs") 5 gnc:budget-year gnc:budget-contingency)))
|
||||
(list->vector
|
||||
(make-budget-entry "lunch" 8 ("Food:Lunch") 1
|
||||
gnc:budget-day gnc:budget-recurring)
|
||||
(make-budget-entry "junk food" 0.50 ("Food:Junk") 1
|
||||
gnc:budget-day gnc:budget-recurring)
|
||||
(make-budget-entry "car repairs" 2500 ("Car:Repairs") 5
|
||||
gnc:budget-year gnc:budget-contingency)))
|
||||
|
||||
;;; For future: make-budget-entry should create a structure.
|
||||
;;; And gnc:budget should be a list, not a vector.
|
||||
|
||||
(define gnc:budget-headers
|
||||
#(("" "Description")
|
||||
@ -239,12 +249,8 @@
|
||||
#(status
|
||||
"Status"
|
||||
"How are you doing on your budget?"))))
|
||||
|
||||
|
||||
gnc:*budget-report-options*)
|
||||
|
||||
|
||||
|
||||
(gnc:define-report
|
||||
;; version
|
||||
1
|
||||
@ -254,7 +260,11 @@
|
||||
budget-report-options-generator
|
||||
;; renderer
|
||||
(lambda (options)
|
||||
(let* ((begindate (gnc:lookup-option options "Report Options" "From"))
|
||||
(let* ((maxrow (vector-length gnc:budget))
|
||||
;;; Note that by using maxrow, *all* references to
|
||||
;;; (vector-length gnc:budget) disappear, and this notably
|
||||
;;; takes some code out of at least 3 loops...
|
||||
(begindate (gnc:lookup-option options "Report Options" "From"))
|
||||
(enddate (gnc:lookup-option options "Report Options" "To"))
|
||||
(date-filter-pred (gnc:tr-report-make-filter-predicate
|
||||
(gnc:option-value begindate)
|
||||
@ -263,13 +273,13 @@
|
||||
(gnc:option-value begindate))))
|
||||
(end-date-secs (car (gnc:timepair-canonical-day-time
|
||||
(gnc:option-value enddate))))
|
||||
(budget-report (make-vector (vector-length gnc:budget)))
|
||||
(budget-report (make-vector maxrow))
|
||||
(budget-order #())
|
||||
(budget-report-order #()))
|
||||
(gnc:debug gnc:budget)
|
||||
|
||||
(do ((i 0 (+ i 1)))
|
||||
((= i (vector-length gnc:budget)))
|
||||
((= i maxrow))
|
||||
(vector-set! budget-report i (vector 0 0 0 0 0 0)))
|
||||
|
||||
(let loop ((group (gnc:get-current-group)))
|
||||
@ -291,8 +301,10 @@
|
||||
(loop children)))
|
||||
group)))
|
||||
|
||||
;;; Note: This shouldn't need to use a set of vectors...
|
||||
|
||||
(do ((i 0 (+ i 1)))
|
||||
((= i (vector-length gnc:budget)))
|
||||
((= i maxrow))
|
||||
(let ((budget-line (vector-ref gnc:budget i))
|
||||
(budget-report-line (vector-ref budget-report i)))
|
||||
(gnc:budget-calculate-periods!
|
||||
@ -316,7 +328,6 @@
|
||||
(set! budget-report-order #(10 #f #f 4 5 2)))
|
||||
(else
|
||||
(gnc:debug "Invalid view option")))
|
||||
|
||||
(let ((order (find-vector-mappings
|
||||
(vector budget-order budget-report-order))))
|
||||
(list
|
||||
@ -333,9 +344,10 @@
|
||||
(lambda (item) (html-cell-header (cadr item)))
|
||||
(vector gnc:budget-headers gnc:budget-report-headers)
|
||||
order))
|
||||
;;; This loop ought not to need to use a vector
|
||||
(let loop ((row 0))
|
||||
(cond ((= row (vector-length gnc:budget)) '())
|
||||
(else
|
||||
(if (= row maxrow)
|
||||
'()
|
||||
(cons
|
||||
(html-table-row-manual
|
||||
(vector-map-in-specified-order-uniquely
|
||||
@ -344,6 +356,6 @@
|
||||
(vector (vector-ref gnc:budget row)
|
||||
(vector-ref budget-report row))
|
||||
order))
|
||||
(loop (+ row 1))))))
|
||||
(loop (+ row 1)))))
|
||||
(html-end-table)
|
||||
(html-end-document))))))
|
||||
@ -1,7 +1,6 @@
|
||||
;; Index file to load all of the releavant reports.
|
||||
|
||||
(gnc:support "report/report-list.scm")
|
||||
|
||||
(gnc:depend "report/average-balance.scm")
|
||||
(gnc:depend "report/balance-and-pnl.scm")
|
||||
(gnc:depend "report/folio.scm")
|
||||
|
||||
@ -3,23 +3,20 @@
|
||||
;; Report on all transactions in an account
|
||||
;; Robert Merkel (rgmerk@mira.net)
|
||||
|
||||
(gnc:support "report/transaction-report.scm")
|
||||
|
||||
(require 'sort)
|
||||
|
||||
(gnc:support "report/transaction-report.scm")
|
||||
;hack alert - is this line necessary?
|
||||
(gnc:depend "text-export.scm")
|
||||
(gnc:depend "report-utilities.scm")
|
||||
(gnc:depend "date-utilities.scm")
|
||||
(gnc:depend "html-generator.scm")
|
||||
|
||||
;; hack alert - possibly unecessary globals
|
||||
|
||||
|
||||
;; functions for manipulating total inflow and outflow counts.
|
||||
|
||||
(define gnc:total-inflow 0)
|
||||
(define gnc:total-outflow 0)
|
||||
|
||||
|
||||
(define (gnc:set-total-inflow! x)
|
||||
(set! gnc:total-inflow x))
|
||||
|
||||
@ -53,128 +50,6 @@
|
||||
(else (cons (fn (car the-list))
|
||||
(gnc:inorder-map (cdr the-list) fn)))))
|
||||
|
||||
;; register a configuration option for the transaction report
|
||||
(define (trep-options-generator)
|
||||
|
||||
(define gnc:*transaction-report-options* (gnc:new-options))
|
||||
|
||||
(define (gnc:register-trep-option new-option)
|
||||
(gnc:register-option gnc:*transaction-report-options* new-option))
|
||||
|
||||
;; from date
|
||||
;; hack alert - could somebody set this to an appropriate date?
|
||||
(gnc:register-trep-option
|
||||
(gnc:make-date-option
|
||||
"Report Options" "From"
|
||||
"a" "Report Items from this date"
|
||||
(lambda ()
|
||||
(let ((bdtime (localtime (current-time))))
|
||||
(set-tm:sec bdtime 0)
|
||||
(set-tm:min bdtime 0)
|
||||
(set-tm:hour bdtime 0)
|
||||
(set-tm:mday bdtime 1)
|
||||
(set-tm:mon bdtime 0)
|
||||
(let ((time (car (mktime bdtime))))
|
||||
(cons time 0))))
|
||||
#f))
|
||||
|
||||
;; to-date
|
||||
(gnc:register-trep-option
|
||||
(gnc:make-date-option
|
||||
"Report Options" "To"
|
||||
"b" "Report items up to and including this date"
|
||||
(lambda () (cons (current-time) 0))
|
||||
#f))
|
||||
|
||||
;; account to do report on
|
||||
(gnc:register-trep-option
|
||||
(gnc:make-account-list-option
|
||||
"Report Options" "Account"
|
||||
"c" "Do transaction report on this account"
|
||||
(lambda ()
|
||||
(let ((current-accounts (gnc:get-current-accounts))
|
||||
(num-accounts (gnc:group-get-num-accounts (gnc:get-current-group)))
|
||||
(first-account (gnc:group-get-account (gnc:get-current-group) 0)))
|
||||
(cond ((not (null? current-accounts)) (list (car current-accounts)))
|
||||
((> num-accounts 0) (list first-account))
|
||||
(else ()))))
|
||||
#f #f))
|
||||
|
||||
;; primary sorting criterion
|
||||
(gnc:register-trep-option
|
||||
(gnc:make-multichoice-option
|
||||
"Sorting" "Primary Key"
|
||||
"a" "Sort by this criterion first"
|
||||
'date
|
||||
(list #(date
|
||||
"Date"
|
||||
"Sort by date")
|
||||
#(time
|
||||
"Time"
|
||||
"Sort by EXACT entry time")
|
||||
#(corresponding-acc
|
||||
"Transfer from/to"
|
||||
"Sort by account transferred from/to's name")
|
||||
#(amount
|
||||
"Amount"
|
||||
"Sort by amount")
|
||||
#(description
|
||||
"Description"
|
||||
"Sort by description")
|
||||
#(number
|
||||
"Number"
|
||||
"Sort by check/transaction number")
|
||||
#(memo
|
||||
"Memo"
|
||||
"Sort by memo"))))
|
||||
|
||||
(gnc:register-trep-option
|
||||
(gnc:make-multichoice-option
|
||||
"Sorting" "Primary Sort Order"
|
||||
"b" "Order of primary sorting"
|
||||
'ascend
|
||||
(list #(ascend "Ascending" "smallest to largest, earliest to latest")
|
||||
#(descend "Descending" "largest to smallest, latest to earliest"))))
|
||||
|
||||
(gnc:register-trep-option
|
||||
(gnc:make-multichoice-option
|
||||
"Sorting" "Secondary Key"
|
||||
"c"
|
||||
"Sort by this criterion second"
|
||||
'corresponding-acc
|
||||
(list #(date
|
||||
"Date"
|
||||
"Sort by date")
|
||||
#(time
|
||||
"Time"
|
||||
"Sort by EXACT entry time")
|
||||
#(corresponding-acc
|
||||
"Transfer from/to"
|
||||
"Sort by account transferred from/to's name")
|
||||
#(amount
|
||||
"Amount"
|
||||
"Sort by amount")
|
||||
#(description
|
||||
"Description"
|
||||
"Sort by description")
|
||||
#(number
|
||||
"Number"
|
||||
"Sort by check/transaction number")
|
||||
#(memo
|
||||
"Memo"
|
||||
"Sort by memo"))))
|
||||
|
||||
(gnc:register-trep-option
|
||||
(gnc:make-multichoice-option
|
||||
"Sorting" "Secondary Sort Order"
|
||||
"d" "Order of Secondary sorting"
|
||||
'ascend
|
||||
(list #(ascend "Ascending" "smallest to largest, earliest to latest")
|
||||
#(descend "Descending" "largest to smallest, latest to earliest"))))
|
||||
|
||||
gnc:*transaction-report-options*)
|
||||
|
||||
|
||||
;; extract fields out of the scheme split representation
|
||||
|
||||
(define (gnc:tr-report-get-memo split-scm)
|
||||
@ -210,26 +85,11 @@
|
||||
(define (gnc:tr-report-get-other-splits split-scm)
|
||||
(vector-ref split-scm 10))
|
||||
|
||||
|
||||
|
||||
(define (gnc:tr-report-get-first-acc-name split-scm)
|
||||
(let ((other-splits (gnc:tr-report-get-other-splits split-scm)))
|
||||
(cond ((= (length other-splits) 0) "-")
|
||||
(else (caar other-splits)))))
|
||||
|
||||
;;; something like
|
||||
;;; for(i = first; i < last; i+= step) { thunk(i);}
|
||||
|
||||
(define (gnc:for-loop thunk first last step)
|
||||
(cond ((< first last) (thunk first)
|
||||
(gnc:for-loop thunk (+ first step) last step))
|
||||
(else #f)))
|
||||
|
||||
;;; applies thunk to each split in account account
|
||||
(define (gnc:for-each-split-in-account account thunk)
|
||||
(gnc:for-loop (lambda (x) (thunk (gnc:account-get-split account x)))
|
||||
0 (gnc:account-get-split-count account) 1))
|
||||
|
||||
;; get transactions date from split - needs to be done indirectly
|
||||
;; as it's stored in the parent transaction
|
||||
|
||||
@ -284,39 +144,8 @@
|
||||
(gnc:split-get-corresponding-account-name-and-values split
|
||||
split-filter)))
|
||||
|
||||
;; timepair manipulation functions
|
||||
;; hack alert - these should probably be put somewhere else
|
||||
;; and be implemented PROPERLY rather than hackily
|
||||
|
||||
(define (gnc:timepair-to-datestring tp)
|
||||
(let ((bdtime (localtime (car tp))))
|
||||
(strftime "%x" bdtime)))
|
||||
|
||||
;; given a timepair contains any time on a certain day (local time)
|
||||
;; converts it to be midday that day.
|
||||
|
||||
(define (gnc:timepair-canonical-day-time tp)
|
||||
(let ((bdt (localtime (car tp))))
|
||||
(set-tm:sec bdt 0)
|
||||
(set-tm:min bdt 0)
|
||||
(set-tm:hour bdt 12)
|
||||
(let ((newtime (car (mktime bdt))))
|
||||
; alert - blarsen@ada-works.com fixed this. you may want to
|
||||
; revert if I'm wrong.
|
||||
(cons newtime 0))))
|
||||
|
||||
(define (gnc:timepair-earlier-or-eq-date t1 t2)
|
||||
(let ((time1 (car (gnc:timepair-canonical-day-time t1)))
|
||||
(time2 (car (gnc:timepair-canonical-day-time t2))))
|
||||
(<= time1 time2)))
|
||||
|
||||
(define (gnc:timepair-later-date t1 t2)
|
||||
(let ((time1 (car (gnc:timepair-canonical-day-time t1)))
|
||||
(time2 (car (gnc:timepair-canonical-day-time t2))))
|
||||
(< time1 time2)))
|
||||
|
||||
(define (gnc:timepair-later-or-eq-date t1 t2)
|
||||
(gnc:timepair-earlier-or-eq-date t2 t1))
|
||||
;;;; Note: This can be turned into a lookup table which will
|
||||
;;;; *massively* simplify it...
|
||||
|
||||
(define (gnc:sort-predicate-component component order)
|
||||
(let ((ascending-order-comparator
|
||||
@ -439,7 +268,8 @@
|
||||
(gnc:tr-report-get-value split-scm))))
|
||||
(else
|
||||
(gnc:set-total-outflow! (+ gnc:total-outflow
|
||||
(- (gnc:tr-report-get-value split-scm))))))
|
||||
(- (gnc:tr-report-get-value
|
||||
split-scm))))))
|
||||
(for-each
|
||||
(lambda (split-sub first last)
|
||||
(set! report-string
|
||||
|
||||
@ -1,4 +1,5 @@
|
||||
;;; $Id$
|
||||
(gnc:support "substring-search.scm")
|
||||
; IMPLEMENTS Substring search
|
||||
; AUTHOR Ken Dickey
|
||||
; DATE 1991 August 6
|
||||
@ -27,16 +27,12 @@
|
||||
; (gnc:transaction-set-write-flag transaction 2)))
|
||||
; (loop num-splits (+ i 1))))))
|
||||
|
||||
|
||||
|
||||
|
||||
(define (gnc:main-win-export-data-as-text win)
|
||||
(let ((account-group (gnc:get-current-group)))
|
||||
(if (not account-group)
|
||||
(gnc:error-dialog "No account group available for text export.")
|
||||
(gnc:account-group-export-as-text account-group))))
|
||||
|
||||
|
||||
(define (gnc:account->output-form a)
|
||||
(list
|
||||
'account
|
||||
|
||||
@ -1,4 +1,5 @@
|
||||
|
||||
;;;; $Id$
|
||||
;;;; These utilities are loaded straight off
|
||||
(define (directory? path)
|
||||
;; This follows symlinks normally.
|
||||
(let* ((status (false-if-exception (stat path)))
|
||||
@ -8,7 +9,6 @@
|
||||
(define (gnc:directory-subdirectories dir-name)
|
||||
;; Return a recursive list of the subdirs of dir-name, including
|
||||
;; dir-name. Follow symlinks.
|
||||
|
||||
(let ((dir-port (opendir dir-name)))
|
||||
(if (not dir-port)
|
||||
#f
|
||||
@ -48,3 +48,56 @@ string and 'directories' must be a list of strings."
|
||||
(gnc:debug "found file " file-name)
|
||||
(set! finished? #t)
|
||||
(set! result file-name))))))
|
||||
|
||||
(define (filteroutnulls lst)
|
||||
(cond
|
||||
((null? lst) '())
|
||||
((eq? (car lst) #f) (filteroutnulls (cdr lst)))
|
||||
(else
|
||||
(cons (car lst) (filteroutnulls (cdr lst))))))
|
||||
|
||||
(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)))
|
||||
|
||||
(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)))))
|
||||
|
||||
(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
|
||||
""))))
|
||||
|
||||
;;;; Simple lookup scheme; can be turned into a hash table If Need Be.
|
||||
;;; Initialize lookup table
|
||||
(define (initialize-hashtable . size)
|
||||
(make-vector
|
||||
(if (null? size)
|
||||
313
|
||||
(car size))
|
||||
'()))
|
||||
Loading…
Reference in New Issue
Block a user