Formatting changes and initial inclusion of ledger-schedule
This commit is contained in:
Craig Earls
parent
a6cb179d8a
commit
cf2fa5c32b
11 changed files with 746 additions and 761 deletions
|
|
@ -34,50 +34,50 @@
|
||||||
:group 'ledger-reconcile)
|
:group 'ledger-reconcile)
|
||||||
|
|
||||||
(defcustom ledger-scale 10000
|
(defcustom ledger-scale 10000
|
||||||
"The 10 ^ maximum number of digits you would expect to appear in your reports.
|
"The 10 ^ maximum number of digits you would expect to appear in your reports.
|
||||||
This is a cheap way of getting around floating point silliness in subtraction")
|
This is a cheap way of getting around floating point silliness in subtraction")
|
||||||
|
|
||||||
(defun ledger-split-commodity-string (str)
|
(defun ledger-split-commodity-string (str)
|
||||||
"Split a commoditized string, STR, into two parts.
|
"Split a commoditized string, STR, into two parts.
|
||||||
Returns a list with (value commodity)."
|
Returns a list with (value commodity)."
|
||||||
(let ((number-regex (if (assoc "decimal-comma" ledger-environment-alist)
|
(let ((number-regex (if (assoc "decimal-comma" ledger-environment-alist)
|
||||||
ledger-amount-decimal-comma-regex
|
ledger-amount-decimal-comma-regex
|
||||||
ledger-amount-decimal-period-regex)))
|
ledger-amount-decimal-period-regex)))
|
||||||
(if (> (length str) 0)
|
(if (> (length str) 0)
|
||||||
(with-temp-buffer
|
(with-temp-buffer
|
||||||
(insert str)
|
(insert str)
|
||||||
(goto-char (point-min))
|
(goto-char (point-min))
|
||||||
(cond
|
(cond
|
||||||
((re-search-forward "\"\\(.*\\)\"" nil t) ; look for quoted commodities
|
((re-search-forward "\"\\(.*\\)\"" nil t) ; look for quoted commodities
|
||||||
(let ((com (delete-and-extract-region
|
(let ((com (delete-and-extract-region
|
||||||
(match-beginning 1)
|
(match-beginning 1)
|
||||||
(match-end 1))))
|
(match-end 1))))
|
||||||
(if (re-search-forward
|
(if (re-search-forward
|
||||||
number-regex nil t)
|
number-regex nil t)
|
||||||
(list
|
(list
|
||||||
(ledger-string-to-number
|
(ledger-string-to-number
|
||||||
(delete-and-extract-region (match-beginning 0) (match-end 0)))
|
(delete-and-extract-region (match-beginning 0) (match-end 0)))
|
||||||
com))))
|
com))))
|
||||||
((re-search-forward number-regex nil t)
|
((re-search-forward number-regex nil t)
|
||||||
;; found a number in the current locale, return it in the
|
;; found a number in the current locale, return it in the
|
||||||
;; car. Anything left over is annotation, the first
|
;; car. Anything left over is annotation, the first
|
||||||
;; thing should be the commodity, separated by
|
;; thing should be the commodity, separated by
|
||||||
;; whitespace, return it in the cdr. I can't think of
|
;; whitespace, return it in the cdr. I can't think of
|
||||||
;; any counterexamples
|
;; any counterexamples
|
||||||
(list
|
(list
|
||||||
(ledger-string-to-number
|
(ledger-string-to-number
|
||||||
(delete-and-extract-region (match-beginning 0) (match-end 0)))
|
(delete-and-extract-region (match-beginning 0) (match-end 0)))
|
||||||
(nth 0 (split-string (buffer-substring-no-properties (point-min) (point-max))))))
|
(nth 0 (split-string (buffer-substring-no-properties (point-min) (point-max))))))
|
||||||
((re-search-forward "0" nil t)
|
((re-search-forward "0" nil t)
|
||||||
;; couldn't find a decimal number, look for a single 0,
|
;; couldn't find a decimal number, look for a single 0,
|
||||||
;; indicating account with zero balance
|
;; indicating account with zero balance
|
||||||
(list 0 ledger-reconcile-default-commodity))))
|
(list 0 ledger-reconcile-default-commodity))))
|
||||||
;; nothing found, return 0
|
;; nothing found, return 0
|
||||||
(list 0 ledger-reconcile-default-commodity))))
|
(list 0 ledger-reconcile-default-commodity))))
|
||||||
|
|
||||||
(defun ledger-string-balance-to-commoditized-amount (str)
|
(defun ledger-string-balance-to-commoditized-amount (str)
|
||||||
"Return a commoditized amount (val, 'comm') from STR."
|
"Return a commoditized amount (val, 'comm') from STR."
|
||||||
; break any balances with multi commodities into a list
|
; break any balances with multi commodities into a list
|
||||||
(mapcar #'(lambda (st)
|
(mapcar #'(lambda (st)
|
||||||
(ledger-split-commodity-string st))
|
(ledger-split-commodity-string st))
|
||||||
(split-string str "[\n\r]")))
|
(split-string str "[\n\r]")))
|
||||||
|
|
@ -85,8 +85,10 @@ Returns a list with (value commodity)."
|
||||||
(defun -commodity (c1 c2)
|
(defun -commodity (c1 c2)
|
||||||
"Subtract C2 from C1, ensuring their commodities match."
|
"Subtract C2 from C1, ensuring their commodities match."
|
||||||
(if (string= (cadr c1) (cadr c2))
|
(if (string= (cadr c1) (cadr c2))
|
||||||
; the scaling below is to get around inexact subtraction results where, for example
|
; the scaling below is to get around inexact
|
||||||
; 1.23 - 4.56 = -3.3299999999999996 instead of -3.33
|
; subtraction results where, for example 1.23
|
||||||
|
; - 4.56 = -3.3299999999999996 instead of
|
||||||
|
; -3.33
|
||||||
(list (/ (- (* ledger-scale (car c1)) (* ledger-scale (car c2))) ledger-scale) (cadr c1))
|
(list (/ (- (* ledger-scale (car c1)) (* ledger-scale (car c2))) ledger-scale) (cadr c1))
|
||||||
(error "Can't subtract different commodities %S from %S" c2 c1)))
|
(error "Can't subtract different commodities %S from %S" c2 c1)))
|
||||||
|
|
||||||
|
|
@ -97,50 +99,50 @@ Returns a list with (value commodity)."
|
||||||
(error "Can't add different commodities, %S to %S" c1 c2)))
|
(error "Can't add different commodities, %S to %S" c1 c2)))
|
||||||
|
|
||||||
(defun ledger-strip (str char)
|
(defun ledger-strip (str char)
|
||||||
(let (new-str)
|
(let (new-str)
|
||||||
(concat (dolist (ch (append str nil) new-str)
|
(concat (dolist (ch (append str nil) new-str)
|
||||||
(unless (= ch char)
|
(unless (= ch char)
|
||||||
(setq new-str (append new-str (list ch))))))))
|
(setq new-str (append new-str (list ch))))))))
|
||||||
|
|
||||||
(defun ledger-string-to-number (str &optional decimal-comma)
|
(defun ledger-string-to-number (str &optional decimal-comma)
|
||||||
"improve builtin string-to-number by handling internationalization, and return nil if number can't be parsed"
|
"improve builtin string-to-number by handling internationalization, and return nil if number can't be parsed"
|
||||||
(let ((nstr (if (or decimal-comma
|
(let ((nstr (if (or decimal-comma
|
||||||
(assoc "decimal-comma" ledger-environment-alist))
|
(assoc "decimal-comma" ledger-environment-alist))
|
||||||
(ledger-strip str ?.)
|
(ledger-strip str ?.)
|
||||||
(ledger-strip str ?,))))
|
(ledger-strip str ?,))))
|
||||||
(while (string-match "," nstr) ;if there is a comma now, it is a thousands separator
|
(while (string-match "," nstr) ;if there is a comma now, it is a thousands separator
|
||||||
(setq nstr (replace-match "." nil nil nstr)))
|
(setq nstr (replace-match "." nil nil nstr)))
|
||||||
(string-to-number nstr)))
|
(string-to-number nstr)))
|
||||||
|
|
||||||
(defun ledger-number-to-string (n &optional decimal-comma)
|
(defun ledger-number-to-string (n &optional decimal-comma)
|
||||||
(let ((str (number-to-string n)))
|
(let ((str (number-to-string n)))
|
||||||
(if (or decimal-comma
|
(if (or decimal-comma
|
||||||
(assoc "decimal-comma" ledger-environment-alist))
|
(assoc "decimal-comma" ledger-environment-alist))
|
||||||
(while (string-match "\\." str)
|
(while (string-match "\\." str)
|
||||||
(setq str (replace-match "," nil nil str)))
|
(setq str (replace-match "," nil nil str)))
|
||||||
str)))
|
str)))
|
||||||
|
|
||||||
(defun ledger-commodity-to-string (c1)
|
(defun ledger-commodity-to-string (c1)
|
||||||
"Return string representing C1.
|
"Return string representing C1.
|
||||||
Single character commodities are placed ahead of the value,
|
Single character commodities are placed ahead of the value,
|
||||||
longer ones are after the value."
|
longer ones are after the value."
|
||||||
(let ((str (ledger-number-to-string (car c1)))
|
(let ((str (ledger-number-to-string (car c1)))
|
||||||
(commodity (cadr c1)))
|
(commodity (cadr c1)))
|
||||||
(if (> (length commodity) 1)
|
(if (> (length commodity) 1)
|
||||||
(concat str " " commodity)
|
(concat str " " commodity)
|
||||||
(concat commodity " " str))))
|
(concat commodity " " str))))
|
||||||
|
|
||||||
(defun ledger-read-commodity-string (prompt)
|
(defun ledger-read-commodity-string (prompt)
|
||||||
(let ((str (read-from-minibuffer
|
(let ((str (read-from-minibuffer
|
||||||
(concat prompt " (" ledger-reconcile-default-commodity "): ")))
|
(concat prompt " (" ledger-reconcile-default-commodity "): ")))
|
||||||
comm)
|
comm)
|
||||||
(if (and (> (length str) 0)
|
(if (and (> (length str) 0)
|
||||||
(ledger-split-commodity-string str))
|
(ledger-split-commodity-string str))
|
||||||
(progn
|
(progn
|
||||||
(setq comm (ledger-split-commodity-string str))
|
(setq comm (ledger-split-commodity-string str))
|
||||||
(if (cadr comm)
|
(if (cadr comm)
|
||||||
comm
|
comm
|
||||||
(list (car comm) ledger-reconcile-default-commodity))))))
|
(list (car comm) ledger-reconcile-default-commodity))))))
|
||||||
|
|
||||||
(provide 'ldg-commodities)
|
(provide 'ldg-commodities)
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -34,8 +34,8 @@
|
||||||
;; with pcomplete. See pcomplete-parse-arguments-function for
|
;; with pcomplete. See pcomplete-parse-arguments-function for
|
||||||
;; details
|
;; details
|
||||||
(let* ((begin (save-excursion
|
(let* ((begin (save-excursion
|
||||||
(ledger-thing-at-point) ;; leave point at beginning of thing under point
|
(ledger-thing-at-point) ;; leave point at beginning of thing under point
|
||||||
(point)))
|
(point)))
|
||||||
(end (point))
|
(end (point))
|
||||||
begins args)
|
begins args)
|
||||||
;; to support end of line metadata
|
;; to support end of line metadata
|
||||||
|
|
@ -65,42 +65,42 @@
|
||||||
(unless (and (>= origin (match-beginning 0))
|
(unless (and (>= origin (match-beginning 0))
|
||||||
(< origin (match-end 0)))
|
(< origin (match-end 0)))
|
||||||
(setq payees-list (cons (match-string-no-properties 3)
|
(setq payees-list (cons (match-string-no-properties 3)
|
||||||
payees-list))))) ;; add the payee
|
payees-list))))) ;; add the payee
|
||||||
;; to the list
|
;; to the list
|
||||||
(pcomplete-uniqify-list (nreverse payees-list))))
|
(pcomplete-uniqify-list (nreverse payees-list))))
|
||||||
|
|
||||||
|
|
||||||
(defun ledger-find-accounts-in-buffer ()
|
(defun ledger-find-accounts-in-buffer ()
|
||||||
(interactive)
|
(interactive)
|
||||||
(let ((origin (point))
|
(let ((origin (point))
|
||||||
accounts
|
accounts
|
||||||
(account-tree (list t))
|
(account-tree (list t))
|
||||||
(account-elements nil)
|
(account-elements nil)
|
||||||
(seed-regex (ledger-account-any-status-with-seed-regex
|
(seed-regex (ledger-account-any-status-with-seed-regex
|
||||||
(regexp-quote (car pcomplete-args)))))
|
(regexp-quote (car pcomplete-args)))))
|
||||||
(save-excursion
|
(save-excursion
|
||||||
(goto-char (point-min))
|
(goto-char (point-min))
|
||||||
|
|
||||||
(dolist (account
|
(dolist (account
|
||||||
(delete-dups
|
(delete-dups
|
||||||
(progn
|
(progn
|
||||||
(while (re-search-forward seed-regex nil t)
|
(while (re-search-forward seed-regex nil t)
|
||||||
(unless (between origin (match-beginning 0) (match-end 0))
|
(unless (between origin (match-beginning 0) (match-end 0))
|
||||||
(setq accounts (cons (match-string-no-properties 2) accounts))))
|
(setq accounts (cons (match-string-no-properties 2) accounts))))
|
||||||
accounts)))
|
accounts)))
|
||||||
(let ((root account-tree))
|
(let ((root account-tree))
|
||||||
(setq account-elements
|
(setq account-elements
|
||||||
(split-string
|
(split-string
|
||||||
account ":"))
|
account ":"))
|
||||||
(while account-elements
|
(while account-elements
|
||||||
(let ((xact (assoc (car account-elements) root)))
|
(let ((xact (assoc (car account-elements) root)))
|
||||||
(if xact
|
(if xact
|
||||||
(setq root (cdr xact))
|
(setq root (cdr xact))
|
||||||
(setq xact (cons (car account-elements) (list t)))
|
(setq xact (cons (car account-elements) (list t)))
|
||||||
(nconc root (list xact))
|
(nconc root (list xact))
|
||||||
(setq root (cdr xact))))
|
(setq root (cdr xact))))
|
||||||
(setq account-elements (cdr account-elements))))))
|
(setq account-elements (cdr account-elements))))))
|
||||||
account-tree))
|
account-tree))
|
||||||
|
|
||||||
(defun ledger-find-metadata-in-buffer ()
|
(defun ledger-find-metadata-in-buffer ()
|
||||||
"Search through buffer and build list of metadata.
|
"Search through buffer and build list of metadata.
|
||||||
|
|
@ -129,19 +129,19 @@ Return list."
|
||||||
(setq prefix (concat prefix (and prefix ":")
|
(setq prefix (concat prefix (and prefix ":")
|
||||||
(car elements))
|
(car elements))
|
||||||
root (cdr xact))
|
root (cdr xact))
|
||||||
(setq root nil elements nil)))
|
(setq root nil elements nil)))
|
||||||
(setq elements (cdr elements)))
|
(setq elements (cdr elements)))
|
||||||
(setq root (delete (list (car elements) t) root))
|
(setq root (delete (list (car elements) t) root))
|
||||||
(and root
|
(and root
|
||||||
(sort
|
(sort
|
||||||
(mapcar (function
|
(mapcar (function
|
||||||
(lambda (x)
|
(lambda (x)
|
||||||
(let ((term (if prefix
|
(let ((term (if prefix
|
||||||
(concat prefix ":" (car x))
|
(concat prefix ":" (car x))
|
||||||
(car x))))
|
(car x))))
|
||||||
(if (> (length (cdr x)) 1)
|
(if (> (length (cdr x)) 1)
|
||||||
(concat term ":")
|
(concat term ":")
|
||||||
term))))
|
term))))
|
||||||
(cdr root))
|
(cdr root))
|
||||||
'string-lessp))))
|
'string-lessp))))
|
||||||
|
|
||||||
|
|
@ -155,39 +155,39 @@ Return list."
|
||||||
(delete
|
(delete
|
||||||
(caar (ledger-parse-arguments))
|
(caar (ledger-parse-arguments))
|
||||||
(ledger-payees-in-buffer)) ;; this completes against payee names
|
(ledger-payees-in-buffer)) ;; this completes against payee names
|
||||||
(progn
|
(progn
|
||||||
(let ((text (buffer-substring-no-properties
|
(let ((text (buffer-substring-no-properties
|
||||||
(line-beginning-position)
|
(line-beginning-position)
|
||||||
(line-end-position))))
|
(line-end-position))))
|
||||||
(delete-region (line-beginning-position)
|
(delete-region (line-beginning-position)
|
||||||
(line-end-position))
|
(line-end-position))
|
||||||
(condition-case nil
|
(condition-case nil
|
||||||
(ledger-add-transaction text t)
|
(ledger-add-transaction text t)
|
||||||
(error nil)))
|
(error nil)))
|
||||||
(forward-line)
|
(forward-line)
|
||||||
(goto-char (line-end-position))
|
(goto-char (line-end-position))
|
||||||
(search-backward ";" (line-beginning-position) t)
|
(search-backward ";" (line-beginning-position) t)
|
||||||
(skip-chars-backward " \t0123456789.,")
|
(skip-chars-backward " \t0123456789.,")
|
||||||
(throw 'pcompleted t)))
|
(throw 'pcompleted t)))
|
||||||
(ledger-accounts)))))
|
(ledger-accounts)))))
|
||||||
|
|
||||||
(defun ledger-fully-complete-xact ()
|
(defun ledger-fully-complete-xact ()
|
||||||
"Completes a transaction if there is another matching payee in the buffer.
|
"Completes a transaction if there is another matching payee in the buffer.
|
||||||
Does not use ledger xact"
|
Does not use ledger xact"
|
||||||
(interactive)
|
(interactive)
|
||||||
(let* ((name (caar (ledger-parse-arguments)))
|
(let* ((name (caar (ledger-parse-arguments)))
|
||||||
(rest-of-name name)
|
(rest-of-name name)
|
||||||
xacts)
|
xacts)
|
||||||
(save-excursion
|
(save-excursion
|
||||||
(when (eq 'transaction (ledger-thing-at-point))
|
(when (eq 'transaction (ledger-thing-at-point))
|
||||||
(delete-region (point) (+ (length name) (point)))
|
(delete-region (point) (+ (length name) (point)))
|
||||||
;; Search backward for a matching payee
|
;; Search backward for a matching payee
|
||||||
(when (re-search-backward
|
(when (re-search-backward
|
||||||
(concat "^[0-9/.=-]+\\(\\s-+\\*\\)?\\(\\s-+(.*?)\\)?\\s-+\\(.*"
|
(concat "^[0-9/.=-]+\\(\\s-+\\*\\)?\\(\\s-+(.*?)\\)?\\s-+\\(.*"
|
||||||
(regexp-quote name) ".*\\)" ) nil t)
|
(regexp-quote name) ".*\\)" ) nil t)
|
||||||
(setq rest-of-name (match-string 3))
|
(setq rest-of-name (match-string 3))
|
||||||
;; Start copying the postings
|
;; Start copying the postings
|
||||||
(forward-line)
|
(forward-line)
|
||||||
(while (looking-at ledger-account-any-status-regex)
|
(while (looking-at ledger-account-any-status-regex)
|
||||||
(setq xacts (cons (buffer-substring-no-properties
|
(setq xacts (cons (buffer-substring-no-properties
|
||||||
(line-beginning-position)
|
(line-beginning-position)
|
||||||
|
|
@ -198,7 +198,7 @@ Does not use ledger xact"
|
||||||
;; Insert rest-of-name and the postings
|
;; Insert rest-of-name and the postings
|
||||||
(when xacts
|
(when xacts
|
||||||
(save-excursion
|
(save-excursion
|
||||||
(insert rest-of-name ?\n)
|
(insert rest-of-name ?\n)
|
||||||
(while xacts
|
(while xacts
|
||||||
(insert (car xacts) ?\n)
|
(insert (car xacts) ?\n)
|
||||||
(setq xacts (cdr xacts))))
|
(setq xacts (cdr xacts))))
|
||||||
|
|
@ -227,30 +227,30 @@ ledger-magic-tab would cycle properly"
|
||||||
(push (car (last pcomplete-current-completions))
|
(push (car (last pcomplete-current-completions))
|
||||||
pcomplete-current-completions)
|
pcomplete-current-completions)
|
||||||
(setcdr (last pcomplete-current-completions 2) nil))
|
(setcdr (last pcomplete-current-completions 2) nil))
|
||||||
(nconc pcomplete-current-completions
|
(nconc pcomplete-current-completions
|
||||||
(list (car pcomplete-current-completions)))
|
(list (car pcomplete-current-completions)))
|
||||||
(setq pcomplete-current-completions
|
(setq pcomplete-current-completions
|
||||||
(cdr pcomplete-current-completions)))
|
(cdr pcomplete-current-completions)))
|
||||||
(pcomplete-insert-entry pcomplete-last-completion-stub
|
(pcomplete-insert-entry pcomplete-last-completion-stub
|
||||||
(car pcomplete-current-completions)
|
(car pcomplete-current-completions)
|
||||||
nil pcomplete-last-completion-raw))
|
nil pcomplete-last-completion-raw))
|
||||||
(setq pcomplete-current-completions nil
|
(setq pcomplete-current-completions nil
|
||||||
pcomplete-last-completion-raw nil)
|
pcomplete-last-completion-raw nil)
|
||||||
(catch 'pcompleted
|
(catch 'pcompleted
|
||||||
(let* ((pcomplete-stub)
|
(let* ((pcomplete-stub)
|
||||||
pcomplete-seen pcomplete-norm-func
|
pcomplete-seen pcomplete-norm-func
|
||||||
pcomplete-args pcomplete-last pcomplete-index
|
pcomplete-args pcomplete-last pcomplete-index
|
||||||
(pcomplete-autolist pcomplete-autolist)
|
(pcomplete-autolist pcomplete-autolist)
|
||||||
(pcomplete-suffix-list pcomplete-suffix-list)
|
(pcomplete-suffix-list pcomplete-suffix-list)
|
||||||
(completions (pcomplete-completions))
|
(completions (pcomplete-completions))
|
||||||
(result (pcomplete-do-complete pcomplete-stub completions)))
|
(result (pcomplete-do-complete pcomplete-stub completions)))
|
||||||
(and result
|
(and result
|
||||||
(not (eq (car result) 'listed))
|
(not (eq (car result) 'listed))
|
||||||
(cdr result)
|
(cdr result)
|
||||||
(pcomplete-insert-entry pcomplete-stub (cdr result)
|
(pcomplete-insert-entry pcomplete-stub (cdr result)
|
||||||
(memq (car result)
|
(memq (car result)
|
||||||
'(sole shortest))
|
'(sole shortest))
|
||||||
pcomplete-last-completion-raw))))))
|
pcomplete-last-completion-raw))))))
|
||||||
|
|
||||||
(provide 'ldg-complete)
|
(provide 'ldg-complete)
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -51,14 +51,14 @@
|
||||||
(concat (symbol-name e) "-string")))))) "[ \t]*$")))
|
(concat (symbol-name e) "-string")))))) "[ \t]*$")))
|
||||||
|
|
||||||
(defmacro single-line-config2 (&rest elements)
|
(defmacro single-line-config2 (&rest elements)
|
||||||
"Take list of ELEMENTS and return regex and element list for use in context-at-point"
|
"Take list of ELEMENTS and return regex and element list for use in context-at-point"
|
||||||
(let (regex-string)
|
(let (regex-string)
|
||||||
`'(,(concat (dolist (e elements regex-string)
|
`'(,(concat (dolist (e elements regex-string)
|
||||||
(setq regex-string
|
(setq regex-string
|
||||||
(concat regex-string
|
(concat regex-string
|
||||||
(eval
|
(eval
|
||||||
(intern
|
(intern
|
||||||
(concat (symbol-name e) "-string")))))) "[ \t]*$")
|
(concat (symbol-name e) "-string")))))) "[ \t]*$")
|
||||||
,elements)))
|
,elements)))
|
||||||
|
|
||||||
(defmacro single-line-config (&rest elements)
|
(defmacro single-line-config (&rest elements)
|
||||||
|
|
@ -68,8 +68,8 @@
|
||||||
|
|
||||||
(defconst ledger-line-config
|
(defconst ledger-line-config
|
||||||
(list (list 'xact (list (single-line-config date nil status nil code nil payee nil comment)
|
(list (list 'xact (list (single-line-config date nil status nil code nil payee nil comment)
|
||||||
(single-line-config date nil status nil code nil payee)
|
(single-line-config date nil status nil code nil payee)
|
||||||
(single-line-config date nil status nil payee)))
|
(single-line-config date nil status nil payee)))
|
||||||
(list 'acct-transaction (list (single-line-config indent comment)
|
(list 'acct-transaction (list (single-line-config indent comment)
|
||||||
(single-line-config2 indent status account nil commodity amount nil comment)
|
(single-line-config2 indent status account nil commodity amount nil comment)
|
||||||
(single-line-config2 indent status account nil commodity amount)
|
(single-line-config2 indent status account nil commodity amount)
|
||||||
|
|
|
||||||
|
|
@ -38,7 +38,7 @@
|
||||||
(let ((matchb (match-beginning 0)) ;; save the match data, string-match stamp on it
|
(let ((matchb (match-beginning 0)) ;; save the match data, string-match stamp on it
|
||||||
(matche (match-end 0)))
|
(matche (match-end 0)))
|
||||||
(end-of-line)
|
(end-of-line)
|
||||||
(setq environment-alist
|
(setq environment-alist
|
||||||
(append environment-alist
|
(append environment-alist
|
||||||
(list (cons (let ((flag (buffer-substring-no-properties (+ 2 matchb) matche)))
|
(list (cons (let ((flag (buffer-substring-no-properties (+ 2 matchb) matche)))
|
||||||
(if (string-match "[ \t\n\r]+\\'" flag)
|
(if (string-match "[ \t\n\r]+\\'" flag)
|
||||||
|
|
@ -55,13 +55,13 @@
|
||||||
(let ((init-base-name (file-name-nondirectory ledger-init-file-name)))
|
(let ((init-base-name (file-name-nondirectory ledger-init-file-name)))
|
||||||
(if (get-buffer init-base-name) ;; init file already loaded, parse it and leave it
|
(if (get-buffer init-base-name) ;; init file already loaded, parse it and leave it
|
||||||
(ledger-init-parse-initialization init-base-name)
|
(ledger-init-parse-initialization init-base-name)
|
||||||
(when (and ledger-init-file-name
|
(when (and ledger-init-file-name
|
||||||
(file-exists-p ledger-init-file-name)
|
(file-exists-p ledger-init-file-name)
|
||||||
(file-readable-p ledger-init-file-name))
|
(file-readable-p ledger-init-file-name))
|
||||||
(find-file-noselect ledger-init-file-name)
|
(find-file-noselect ledger-init-file-name)
|
||||||
(setq ledger-environment-alist
|
(setq ledger-environment-alist
|
||||||
(ledger-init-parse-initialization init-base-name))
|
(ledger-init-parse-initialization init-base-name))
|
||||||
(kill-buffer init-base-name)))))
|
(kill-buffer init-base-name)))))
|
||||||
|
|
||||||
(provide 'ldg-init)
|
(provide 'ldg-init)
|
||||||
|
|
||||||
|
|
|
||||||
260
lisp/ldg-mode.el
260
lisp/ldg-mode.el
|
|
@ -41,31 +41,31 @@
|
||||||
|
|
||||||
(defun ledger-read-account-with-prompt (prompt)
|
(defun ledger-read-account-with-prompt (prompt)
|
||||||
(let* ((context (ledger-context-at-point))
|
(let* ((context (ledger-context-at-point))
|
||||||
(default (if (and (eq (ledger-context-line-type context) 'acct-transaction)
|
(default (if (and (eq (ledger-context-line-type context) 'acct-transaction)
|
||||||
(eq (ledger-context-current-field context) 'account))
|
(eq (ledger-context-current-field context) 'account))
|
||||||
(regexp-quote (ledger-context-field-value context 'account))
|
(regexp-quote (ledger-context-field-value context 'account))
|
||||||
nil)))
|
nil)))
|
||||||
(ledger-read-string-with-default prompt default)))
|
(ledger-read-string-with-default prompt default)))
|
||||||
|
|
||||||
(defun ledger-read-string-with-default (prompt default)
|
(defun ledger-read-string-with-default (prompt default)
|
||||||
"Return user supplied string after PROMPT, or DEFAULT."
|
"Return user supplied string after PROMPT, or DEFAULT."
|
||||||
(read-string (concat prompt
|
(read-string (concat prompt
|
||||||
(if default
|
(if default
|
||||||
(concat " (" default "): ")
|
(concat " (" default "): ")
|
||||||
": "))
|
": "))
|
||||||
nil 'ledger-minibuffer-history default))
|
nil 'ledger-minibuffer-history default))
|
||||||
|
|
||||||
(defun ledger-display-balance-at-point ()
|
(defun ledger-display-balance-at-point ()
|
||||||
"Display the cleared-or-pending balance.
|
"Display the cleared-or-pending balance.
|
||||||
And calculate the target-delta of the account being reconciled."
|
And calculate the target-delta of the account being reconciled."
|
||||||
(interactive)
|
(interactive)
|
||||||
(let* ((account (ledger-read-account-with-prompt "Account balance to show"))
|
(let* ((account (ledger-read-account-with-prompt "Account balance to show"))
|
||||||
(buffer (current-buffer))
|
(buffer (current-buffer))
|
||||||
(balance (with-temp-buffer
|
(balance (with-temp-buffer
|
||||||
(ledger-exec-ledger buffer (current-buffer) "cleared" account)
|
(ledger-exec-ledger buffer (current-buffer) "cleared" account)
|
||||||
(if (> (buffer-size) 0)
|
(if (> (buffer-size) 0)
|
||||||
(buffer-substring-no-properties (point-min) (1- (point-max)))
|
(buffer-substring-no-properties (point-min) (1- (point-max)))
|
||||||
(concat account " is empty.")))))
|
(concat account " is empty.")))))
|
||||||
(when balance
|
(when balance
|
||||||
(message balance))))
|
(message balance))))
|
||||||
|
|
||||||
|
|
@ -74,9 +74,9 @@ And calculate the target-delta of the account being reconciled."
|
||||||
And calculate the target-delta of the account being reconciled."
|
And calculate the target-delta of the account being reconciled."
|
||||||
(interactive)
|
(interactive)
|
||||||
(let* ((buffer (current-buffer))
|
(let* ((buffer (current-buffer))
|
||||||
(balance (with-temp-buffer
|
(balance (with-temp-buffer
|
||||||
(ledger-exec-ledger buffer (current-buffer) "stats")
|
(ledger-exec-ledger buffer (current-buffer) "stats")
|
||||||
(buffer-substring-no-properties (point-min) (1- (point-max))))))
|
(buffer-substring-no-properties (point-min) (1- (point-max))))))
|
||||||
(when balance
|
(when balance
|
||||||
(message balance))))
|
(message balance))))
|
||||||
|
|
||||||
|
|
@ -84,144 +84,146 @@ And calculate the target-delta of the account being reconciled."
|
||||||
"Decide what to with with <TAB>.
|
"Decide what to with with <TAB>.
|
||||||
Can indent, complete or align depending on context."
|
Can indent, complete or align depending on context."
|
||||||
(interactive "p")
|
(interactive "p")
|
||||||
(if (= (point) (line-beginning-position))
|
(if (= (point) (line-beginning-position))
|
||||||
(indent-to ledger-post-account-alignment-column)
|
(indent-to ledger-post-account-alignment-column)
|
||||||
(if (and (> (point) 1)
|
(if (and (> (point) 1)
|
||||||
(looking-back "\\([^ \t]\\)" 1))
|
(looking-back "\\([^ \t]\\)" 1))
|
||||||
(ledger-pcomplete interactively)
|
(ledger-pcomplete interactively)
|
||||||
(ledger-post-align-postings))))
|
(ledger-post-align-postings))))
|
||||||
|
|
||||||
(defvar ledger-mode-abbrev-table)
|
(defvar ledger-mode-abbrev-table)
|
||||||
|
|
||||||
(defun ledger-insert-effective-date ()
|
(defun ledger-insert-effective-date ()
|
||||||
(interactive)
|
(interactive)
|
||||||
(let ((context (car (ledger-context-at-point)))
|
(let ((context (car (ledger-context-at-point)))
|
||||||
(date-string (format-time-string (cdr (assoc "date-format" ledger-environment-alist)))))
|
(date-string (format-time-string (cdr (assoc "date-format" ledger-environment-alist)))))
|
||||||
(cond ((eq 'xact context)
|
(cond ((eq 'xact context)
|
||||||
(beginning-of-line)
|
(beginning-of-line)
|
||||||
(insert date-string "="))
|
(insert date-string "="))
|
||||||
((eq 'acct-transaction context)
|
((eq 'acct-transaction context)
|
||||||
(end-of-line)
|
(end-of-line)
|
||||||
(insert " ; [=" date-string "]")))))
|
(insert " ; [=" date-string "]")))))
|
||||||
|
|
||||||
(defun ledger-mode-remove-extra-lines ()
|
(defun ledger-mode-remove-extra-lines ()
|
||||||
(goto-char (point-min))
|
(goto-char (point-min))
|
||||||
(while (re-search-forward "\n\n\\(\n\\)+" nil t)
|
(while (re-search-forward "\n\n\\(\n\\)+" nil t)
|
||||||
(replace-match "\n\n")))
|
(replace-match "\n\n")))
|
||||||
|
|
||||||
(defun ledger-mode-clean-buffer ()
|
(defun ledger-mode-clean-buffer ()
|
||||||
"indent, remove multiple linfe feeds and sort the buffer"
|
"indent, remove multiple linfe feeds and sort the buffer"
|
||||||
(interactive)
|
(interactive)
|
||||||
(ledger-sort-buffer)
|
(ledger-sort-buffer)
|
||||||
(ledger-post-align-postings (point-min) (point-max))
|
(ledger-post-align-postings (point-min) (point-max))
|
||||||
(ledger-mode-remove-extra-lines))
|
(ledger-mode-remove-extra-lines))
|
||||||
|
|
||||||
|
|
||||||
;;;###autoload
|
;;;###autoload
|
||||||
(define-derived-mode ledger-mode text-mode "Ledger"
|
(define-derived-mode ledger-mode text-mode "Ledger"
|
||||||
"A mode for editing ledger data files."
|
"A mode for editing ledger data files."
|
||||||
(ledger-check-version)
|
(ledger-check-version)
|
||||||
(ledger-post-setup)
|
(ledger-check-schedule-available)
|
||||||
|
(ledger-post-setup)
|
||||||
|
|
||||||
(set (make-local-variable 'comment-start) " ; ")
|
(set (make-local-variable 'comment-start) " ; ")
|
||||||
(set (make-local-variable 'comment-end) "")
|
(set (make-local-variable 'comment-end) "")
|
||||||
(set (make-local-variable 'indent-tabs-mode) nil)
|
(set (make-local-variable 'indent-tabs-mode) nil)
|
||||||
|
|
||||||
(if (boundp 'font-lock-defaults)
|
(if (boundp 'font-lock-defaults)
|
||||||
(set (make-local-variable 'font-lock-defaults)
|
(set (make-local-variable 'font-lock-defaults)
|
||||||
'(ledger-font-lock-keywords nil t)))
|
'(ledger-font-lock-keywords nil t)))
|
||||||
(setq font-lock-extend-region-functions
|
(setq font-lock-extend-region-functions
|
||||||
(list #'font-lock-extend-region-wholelines))
|
(list #'font-lock-extend-region-wholelines))
|
||||||
(setq font-lock-multiline nil)
|
(setq font-lock-multiline nil)
|
||||||
|
|
||||||
(set (make-local-variable 'pcomplete-parse-arguments-function)
|
(set (make-local-variable 'pcomplete-parse-arguments-function)
|
||||||
'ledger-parse-arguments)
|
'ledger-parse-arguments)
|
||||||
(set (make-local-variable 'pcomplete-command-completion-function)
|
(set (make-local-variable 'pcomplete-command-completion-function)
|
||||||
'ledger-complete-at-point)
|
'ledger-complete-at-point)
|
||||||
(set (make-local-variable 'pcomplete-termination-string) "")
|
(set (make-local-variable 'pcomplete-termination-string) "")
|
||||||
|
|
||||||
(add-hook 'post-command-hook 'ledger-highlight-xact-under-point nil t)
|
(add-hook 'post-command-hook 'ledger-highlight-xact-under-point nil t)
|
||||||
(add-hook 'before-revert-hook 'ledger-occur-remove-all-overlays nil t)
|
(add-hook 'before-revert-hook 'ledger-occur-remove-all-overlays nil t)
|
||||||
(make-variable-buffer-local 'highlight-overlay)
|
(make-variable-buffer-local 'highlight-overlay)
|
||||||
|
|
||||||
(ledger-init-load-init-file)
|
(ledger-init-load-init-file)
|
||||||
|
|
||||||
(set (make-local-variable 'indent-region-function) 'ledger-post-align-postings)
|
(set (make-local-variable 'indent-region-function) 'ledger-post-align-postings)
|
||||||
|
|
||||||
(let ((map (current-local-map)))
|
(let ((map (current-local-map)))
|
||||||
(define-key map [(control ?c) (control ?a)] 'ledger-add-transaction)
|
(define-key map [(control ?c) (control ?a)] 'ledger-add-transaction)
|
||||||
(define-key map [(control ?c) (control ?b)] 'ledger-post-edit-amount)
|
(define-key map [(control ?c) (control ?b)] 'ledger-post-edit-amount)
|
||||||
(define-key map [(control ?c) (control ?c)] 'ledger-toggle-current)
|
(define-key map [(control ?c) (control ?c)] 'ledger-toggle-current)
|
||||||
(define-key map [(control ?c) (control ?d)] 'ledger-delete-current-transaction)
|
(define-key map [(control ?c) (control ?d)] 'ledger-delete-current-transaction)
|
||||||
(define-key map [(control ?c) (control ?e)] 'ledger-toggle-current-transaction)
|
(define-key map [(control ?c) (control ?e)] 'ledger-toggle-current-transaction)
|
||||||
(define-key map [(control ?c) (control ?f)] 'ledger-occur)
|
(define-key map [(control ?c) (control ?f)] 'ledger-occur)
|
||||||
(define-key map [(control ?c) (control ?k)] 'ledger-copy-transaction-at-point)
|
(define-key map [(control ?c) (control ?k)] 'ledger-copy-transaction-at-point)
|
||||||
(define-key map [(control ?c) (control ?m)] 'ledger-set-month)
|
(define-key map [(control ?c) (control ?m)] 'ledger-set-month)
|
||||||
(define-key map [(control ?c) (control ?r)] 'ledger-reconcile)
|
(define-key map [(control ?c) (control ?r)] 'ledger-reconcile)
|
||||||
(define-key map [(control ?c) (control ?s)] 'ledger-sort-region)
|
(define-key map [(control ?c) (control ?s)] 'ledger-sort-region)
|
||||||
(define-key map [(control ?c) (control ?t)] 'ledger-insert-effective-date)
|
(define-key map [(control ?c) (control ?t)] 'ledger-insert-effective-date)
|
||||||
(define-key map [(control ?c) (control ?u)] 'ledger-schedule-upcoming)
|
(define-key map [(control ?c) (control ?u)] 'ledger-schedule-upcoming)
|
||||||
(define-key map [(control ?c) (control ?y)] 'ledger-set-year)
|
(define-key map [(control ?c) (control ?y)] 'ledger-set-year)
|
||||||
(define-key map [(control ?c) (control ?p)] 'ledger-display-balance-at-point)
|
(define-key map [(control ?c) (control ?p)] 'ledger-display-balance-at-point)
|
||||||
(define-key map [(control ?c) (control ?l)] 'ledger-display-ledger-stats)
|
(define-key map [(control ?c) (control ?l)] 'ledger-display-ledger-stats)
|
||||||
(define-key map [(control ?c) (control ?q)] 'ledger-post-align-xact)
|
(define-key map [(control ?c) (control ?q)] 'ledger-post-align-xact)
|
||||||
|
|
||||||
(define-key map [tab] 'ledger-magic-tab)
|
(define-key map [tab] 'ledger-magic-tab)
|
||||||
(define-key map [(control tab)] 'ledger-post-align-xact)
|
(define-key map [(control tab)] 'ledger-post-align-xact)
|
||||||
(define-key map [(control ?i)] 'ledger-magic-tab)
|
(define-key map [(control ?i)] 'ledger-magic-tab)
|
||||||
(define-key map [(control ?c) tab] 'ledger-fully-complete-xact)
|
(define-key map [(control ?c) tab] 'ledger-fully-complete-xact)
|
||||||
(define-key map [(control ?c) (control ?i)] 'ledger-fully-complete-xact)
|
(define-key map [(control ?c) (control ?i)] 'ledger-fully-complete-xact)
|
||||||
|
|
||||||
(define-key map [(control ?c) (control ?o) (control ?a)] 'ledger-report-redo)
|
(define-key map [(control ?c) (control ?o) (control ?a)] 'ledger-report-redo)
|
||||||
(define-key map [(control ?c) (control ?o) (control ?e)] 'ledger-report-edit)
|
(define-key map [(control ?c) (control ?o) (control ?e)] 'ledger-report-edit)
|
||||||
(define-key map [(control ?c) (control ?o) (control ?g)] 'ledger-report-goto)
|
(define-key map [(control ?c) (control ?o) (control ?g)] 'ledger-report-goto)
|
||||||
(define-key map [(control ?c) (control ?o) (control ?k)] 'ledger-report-kill)
|
(define-key map [(control ?c) (control ?o) (control ?k)] 'ledger-report-kill)
|
||||||
(define-key map [(control ?c) (control ?o) (control ?r)] 'ledger-report)
|
(define-key map [(control ?c) (control ?o) (control ?r)] 'ledger-report)
|
||||||
(define-key map [(control ?c) (control ?o) (control ?s)] 'ledger-report-save)
|
(define-key map [(control ?c) (control ?o) (control ?s)] 'ledger-report-save)
|
||||||
|
|
||||||
(define-key map [(meta ?p)] 'ledger-post-prev-xact)
|
(define-key map [(meta ?p)] 'ledger-post-prev-xact)
|
||||||
(define-key map [(meta ?n)] 'ledger-post-next-xact)
|
(define-key map [(meta ?n)] 'ledger-post-next-xact)
|
||||||
|
|
||||||
(define-key map [menu-bar] (make-sparse-keymap "ldg-menu"))
|
(define-key map [menu-bar] (make-sparse-keymap "ldg-menu"))
|
||||||
(define-key map [menu-bar ldg-menu] (cons "Ledger" map))
|
(define-key map [menu-bar ldg-menu] (cons "Ledger" map))
|
||||||
|
|
||||||
(define-key map [report-kill] '(menu-item "Kill Report" ledger-report-kill :enable ledger-works))
|
(define-key map [report-kill] '(menu-item "Kill Report" ledger-report-kill :enable ledger-works))
|
||||||
(define-key map [report-edit] '(menu-item "Edit Report" ledger-report-edit :enable ledger-works))
|
(define-key map [report-edit] '(menu-item "Edit Report" ledger-report-edit :enable ledger-works))
|
||||||
(define-key map [report-save] '(menu-item "Save Report" ledger-report-save :enable ledger-works))
|
(define-key map [report-save] '(menu-item "Save Report" ledger-report-save :enable ledger-works))
|
||||||
(define-key map [report-rrun] '(menu-item "Re-run Report" ledger-report-redo :enable ledger-works))
|
(define-key map [report-rrun] '(menu-item "Re-run Report" ledger-report-redo :enable ledger-works))
|
||||||
(define-key map [report-goto] '(menu-item "Goto Report" ledger-report-goto :enable ledger-works))
|
(define-key map [report-goto] '(menu-item "Goto Report" ledger-report-goto :enable ledger-works))
|
||||||
(define-key map [report-run] '(menu-item "Run Report" ledger-report :enable ledger-works))
|
(define-key map [report-run] '(menu-item "Run Report" ledger-report :enable ledger-works))
|
||||||
(define-key map [sep5] '(menu-item "--"))
|
(define-key map [sep5] '(menu-item "--"))
|
||||||
(define-key map [set-month] '(menu-item "Set Month" ledger-set-month :enable ledger-works))
|
(define-key map [set-month] '(menu-item "Set Month" ledger-set-month :enable ledger-works))
|
||||||
(define-key map [set-year] '(menu-item "Set Year" ledger-set-year :enable ledger-works))
|
(define-key map [set-year] '(menu-item "Set Year" ledger-set-year :enable ledger-works))
|
||||||
(define-key map [cust] '(menu-item "Customize Ledger Mode" (lambda ()
|
(define-key map [cust] '(menu-item "Customize Ledger Mode" (lambda ()
|
||||||
(interactive)
|
(interactive)
|
||||||
(customize-group 'ledger))))
|
(customize-group 'ledger))))
|
||||||
(define-key map [sep1] '("--"))
|
(define-key map [sep1] '("--"))
|
||||||
(define-key map [effective-date] '(menu-item "Set effective date" ledger-insert-effective-date))
|
(define-key map [effective-date] '(menu-item "Set effective date" ledger-insert-effective-date))
|
||||||
(define-key map [sort-end] '(menu-item "Mark Sort End" ledger-sort-insert-end-mark))
|
(define-key map [sort-end] '(menu-item "Mark Sort End" ledger-sort-insert-end-mark))
|
||||||
(define-key map [sort-start] '(menu-item "Mark Sort Beginning" ledger-sort-insert-start-mark))
|
(define-key map [sort-start] '(menu-item "Mark Sort Beginning" ledger-sort-insert-start-mark))
|
||||||
(define-key map [sort-buff] '(menu-item "Sort Buffer" ledger-sort-buffer))
|
(define-key map [sort-buff] '(menu-item "Sort Buffer" ledger-sort-buffer))
|
||||||
(define-key map [sort-reg] '(menu-item "Sort Region" ledger-sort-region :enable mark-active))
|
(define-key map [sort-reg] '(menu-item "Sort Region" ledger-sort-region :enable mark-active))
|
||||||
(define-key map [align-xact] '(menu-item "Align Xact" ledger-post-align-xact))
|
(define-key map [align-xact] '(menu-item "Align Xact" ledger-post-align-xact))
|
||||||
(define-key map [align-reg] '(menu-item "Align Region" ledger-post-align-postings :enable mark-active))
|
(define-key map [align-reg] '(menu-item "Align Region" ledger-post-align-postings :enable mark-active))
|
||||||
(define-key map [clean-buf] '(menu-item "Clean-up Buffer" ledger-mode-clean-buffer))
|
(define-key map [clean-buf] '(menu-item "Clean-up Buffer" ledger-mode-clean-buffer))
|
||||||
(define-key map [sep2] '(menu-item "--"))
|
(define-key map [sep2] '(menu-item "--"))
|
||||||
(define-key map [copy-xact] '(menu-item "Copy Trans at Point" ledger-copy-transaction-at-point))
|
(define-key map [copy-xact] '(menu-item "Copy Trans at Point" ledger-copy-transaction-at-point))
|
||||||
(define-key map [toggle-post] '(menu-item "Toggle Current Posting" ledger-toggle-current))
|
(define-key map [toggle-post] '(menu-item "Toggle Current Posting" ledger-toggle-current))
|
||||||
(define-key map [toggle-xact] '(menu-item "Toggle Current Transaction" ledger-toggle-current-transaction))
|
(define-key map [toggle-xact] '(menu-item "Toggle Current Transaction" ledger-toggle-current-transaction))
|
||||||
(define-key map [sep4] '(menu-item "--"))
|
(define-key map [sep4] '(menu-item "--"))
|
||||||
(define-key map [recon-account] '(menu-item "Reconcile Account" ledger-reconcile :enable ledger-works))
|
(define-key map [recon-account] '(menu-item "Reconcile Account" ledger-reconcile :enable ledger-works))
|
||||||
(define-key map [check-balance] '(menu-item "Check Balance" ledger-display-balance-at-point :enable ledger-works))
|
(define-key map [check-balance] '(menu-item "Check Balance" ledger-display-balance-at-point :enable ledger-works))
|
||||||
(define-key map [sep6] '(menu-item "--"))
|
(define-key map [sep6] '(menu-item "--"))
|
||||||
(define-key map [edit-amount] '(menu-item "Calc on Amount" ledger-post-edit-amount))
|
(define-key map [edit-amount] '(menu-item "Calc on Amount" ledger-post-edit-amount))
|
||||||
(define-key map [sep] '(menu-item "--"))
|
(define-key map [sep] '(menu-item "--"))
|
||||||
(define-key map [delete-xact] '(menu-item "Delete Transaction" ledger-delete-current-transaction))
|
(define-key map [delete-xact] '(menu-item "Delete Transaction" ledger-delete-current-transaction))
|
||||||
(define-key map [cmp-xact] '(menu-item "Complete Transaction" ledger-fully-complete-xact))
|
(define-key map [cmp-xact] '(menu-item "Complete Transaction" ledger-fully-complete-xact))
|
||||||
(define-key map [add-xact] '(menu-item "Add Transaction (ledger xact)" ledger-add-transaction :enable ledger-works))
|
(define-key map [add-xact] '(menu-item "Add Transaction (ledger xact)" ledger-add-transaction :enable ledger-works))
|
||||||
(define-key map [sep3] '(menu-item "--"))
|
(define-key map [generate-scheduled] '(menu-item "Show Upcoming Transactions" ledger-schedule-upcoming :enable ledger-schedule-available))
|
||||||
(define-key map [stats] '(menu-item "Ledger Statistics" ledger-display-ledger-stats :enable ledger-works))
|
(define-key map [sep3] '(menu-item "--"))
|
||||||
(define-key map [fold-buffer] '(menu-item "Narrow to REGEX" ledger-occur))))
|
(define-key map [stats] '(menu-item "Ledger Statistics" ledger-display-ledger-stats :enable ledger-works))
|
||||||
|
(define-key map [fold-buffer] '(menu-item "Narrow to REGEX" ledger-occur))))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -39,7 +39,7 @@
|
||||||
|
|
||||||
|
|
||||||
(defvar ledger-occur-mode nil
|
(defvar ledger-occur-mode nil
|
||||||
"name of the minor mode, shown in the mode-line")
|
"name of the minor mode, shown in the mode-line")
|
||||||
|
|
||||||
(make-variable-buffer-local 'ledger-occur-mode)
|
(make-variable-buffer-local 'ledger-occur-mode)
|
||||||
|
|
||||||
|
|
@ -65,19 +65,19 @@
|
||||||
When REGEX is nil, unhide everything, and remove higlight"
|
When REGEX is nil, unhide everything, and remove higlight"
|
||||||
(set-buffer buffer)
|
(set-buffer buffer)
|
||||||
(setq ledger-occur-mode
|
(setq ledger-occur-mode
|
||||||
(if (or (null regex)
|
(if (or (null regex)
|
||||||
(zerop (length regex)))
|
(zerop (length regex)))
|
||||||
nil
|
nil
|
||||||
(concat " Ledger-Narrowed: " regex)))
|
(concat " Ledger-Narrowed: " regex)))
|
||||||
(force-mode-line-update)
|
(force-mode-line-update)
|
||||||
(ledger-occur-remove-overlays)
|
(ledger-occur-remove-overlays)
|
||||||
(when ledger-occur-mode
|
(when ledger-occur-mode
|
||||||
(ledger-occur-create-overlays
|
(ledger-occur-create-overlays
|
||||||
(ledger-occur-compress-matches
|
(ledger-occur-compress-matches
|
||||||
(ledger-occur-find-matches regex)))
|
(ledger-occur-find-matches regex)))
|
||||||
(setq ledger-occur-last-match regex)
|
(setq ledger-occur-last-match regex)
|
||||||
(if (get-buffer-window buffer)
|
(if (get-buffer-window buffer)
|
||||||
(select-window (get-buffer-window buffer))))
|
(select-window (get-buffer-window buffer))))
|
||||||
(recenter))
|
(recenter))
|
||||||
|
|
||||||
(defun ledger-occur (regex)
|
(defun ledger-occur (regex)
|
||||||
|
|
@ -90,7 +90,7 @@ When REGEX is nil, unhide everything, and remove higlight"
|
||||||
(if ledger-occur-mode
|
(if ledger-occur-mode
|
||||||
(list nil)
|
(list nil)
|
||||||
(list (read-string (concat "Regexp<" (ledger-occur-prompt) ">: ")
|
(list (read-string (concat "Regexp<" (ledger-occur-prompt) ">: ")
|
||||||
nil 'ledger-occur-history (ledger-occur-prompt)))))
|
nil 'ledger-occur-history (ledger-occur-prompt)))))
|
||||||
(ledger-occur-mode regex (current-buffer)))
|
(ledger-occur-mode regex (current-buffer)))
|
||||||
|
|
||||||
(defun ledger-occur-prompt ()
|
(defun ledger-occur-prompt ()
|
||||||
|
|
@ -108,32 +108,32 @@ When REGEX is nil, unhide everything, and remove higlight"
|
||||||
(if (= (line-number-at-pos pos1)
|
(if (= (line-number-at-pos pos1)
|
||||||
(line-number-at-pos pos2))
|
(line-number-at-pos pos2))
|
||||||
(buffer-substring-no-properties pos1 pos2)))
|
(buffer-substring-no-properties pos1 pos2)))
|
||||||
(current-word))))
|
(current-word))))
|
||||||
prompt))
|
prompt))
|
||||||
|
|
||||||
|
|
||||||
(defun ledger-occur-make-visible-overlay (beg end)
|
(defun ledger-occur-make-visible-overlay (beg end)
|
||||||
(let ((ovl (make-overlay beg end (current-buffer))))
|
(let ((ovl (make-overlay beg end (current-buffer))))
|
||||||
(overlay-put ovl ledger-occur-overlay-property-name t)
|
(overlay-put ovl ledger-occur-overlay-property-name t)
|
||||||
(overlay-put ovl 'face 'ledger-occur-xact-face)))
|
(overlay-put ovl 'face 'ledger-occur-xact-face)))
|
||||||
|
|
||||||
(defun ledger-occur-make-invisible-overlay (beg end)
|
(defun ledger-occur-make-invisible-overlay (beg end)
|
||||||
(let ((ovl (make-overlay beg end (current-buffer))))
|
(let ((ovl (make-overlay beg end (current-buffer))))
|
||||||
(overlay-put ovl ledger-occur-overlay-property-name t)
|
(overlay-put ovl ledger-occur-overlay-property-name t)
|
||||||
(overlay-put ovl 'invisible t)))
|
(overlay-put ovl 'invisible t)))
|
||||||
|
|
||||||
(defun ledger-occur-create-overlays (ovl-bounds)
|
(defun ledger-occur-create-overlays (ovl-bounds)
|
||||||
"Create the overlays for the visible transactions.
|
"Create the overlays for the visible transactions.
|
||||||
Argument OVL-BOUNDS contains bounds for the transactions to be left visible."
|
Argument OVL-BOUNDS contains bounds for the transactions to be left visible."
|
||||||
(let* ((beg (caar ovl-bounds))
|
(let* ((beg (caar ovl-bounds))
|
||||||
(end (cadar ovl-bounds)))
|
(end (cadar ovl-bounds)))
|
||||||
(ledger-occur-make-invisible-overlay (point-min) (1- beg))
|
(ledger-occur-make-invisible-overlay (point-min) (1- beg))
|
||||||
(dolist (visible (cdr ovl-bounds))
|
(dolist (visible (cdr ovl-bounds))
|
||||||
(ledger-occur-make-visible-overlay beg end)
|
(ledger-occur-make-visible-overlay beg end)
|
||||||
(ledger-occur-make-invisible-overlay (1+ end) (1- (car visible)))
|
(ledger-occur-make-invisible-overlay (1+ end) (1- (car visible)))
|
||||||
(setq beg (car visible))
|
(setq beg (car visible))
|
||||||
(setq end (cadr visible)))
|
(setq end (cadr visible)))
|
||||||
(ledger-occur-make-invisible-overlay (1+ end) (point-max))))
|
(ledger-occur-make-invisible-overlay (1+ end) (point-max))))
|
||||||
|
|
||||||
(defun ledger-occur-quit-buffer (buffer)
|
(defun ledger-occur-quit-buffer (buffer)
|
||||||
"Quits hidings transaction in the given BUFFER.
|
"Quits hidings transaction in the given BUFFER.
|
||||||
|
|
@ -148,7 +148,7 @@ Used for coordinating `ledger-occur' with other buffers, like reconcile."
|
||||||
"Remove the transaction hiding overlays."
|
"Remove the transaction hiding overlays."
|
||||||
(interactive)
|
(interactive)
|
||||||
(remove-overlays (point-min)
|
(remove-overlays (point-min)
|
||||||
(point-max) ledger-occur-overlay-property-name t)
|
(point-max) ledger-occur-overlay-property-name t)
|
||||||
(setq ledger-occur-overlay-list nil))
|
(setq ledger-occur-overlay-list nil))
|
||||||
|
|
||||||
(defun ledger-occur-find-matches (regex)
|
(defun ledger-occur-find-matches (regex)
|
||||||
|
|
@ -157,35 +157,35 @@ Used for coordinating `ledger-occur' with other buffers, like reconcile."
|
||||||
(goto-char (point-min))
|
(goto-char (point-min))
|
||||||
;; Set initial values for variables
|
;; Set initial values for variables
|
||||||
(let (curpoint
|
(let (curpoint
|
||||||
endpoint
|
endpoint
|
||||||
(lines (list)))
|
(lines (list)))
|
||||||
;; Search loop
|
;; Search loop
|
||||||
(while (not (eobp))
|
(while (not (eobp))
|
||||||
(setq curpoint (point))
|
(setq curpoint (point))
|
||||||
;; if something found
|
;; if something found
|
||||||
(when (setq endpoint (re-search-forward regex nil 'end))
|
(when (setq endpoint (re-search-forward regex nil 'end))
|
||||||
(save-excursion
|
(save-excursion
|
||||||
(let ((bounds (ledger-find-xact-extents (match-beginning 0))))
|
(let ((bounds (ledger-find-xact-extents (match-beginning 0))))
|
||||||
(push bounds lines)
|
(push bounds lines)
|
||||||
(setq curpoint (cadr bounds)))) ;; move to the end of
|
(setq curpoint (cadr bounds)))) ;; move to the end of
|
||||||
;; the xact, no need to
|
;; the xact, no need to
|
||||||
;; search inside it more
|
;; search inside it more
|
||||||
(goto-char curpoint))
|
(goto-char curpoint))
|
||||||
(forward-line 1))
|
(forward-line 1))
|
||||||
(setq lines (nreverse lines)))))
|
(setq lines (nreverse lines)))))
|
||||||
|
|
||||||
(defun ledger-occur-compress-matches (buffer-matches)
|
(defun ledger-occur-compress-matches (buffer-matches)
|
||||||
"identify sequential xacts to reduce number of overlays required"
|
"identify sequential xacts to reduce number of overlays required"
|
||||||
(let ((points (list))
|
(let ((points (list))
|
||||||
(current-beginning (caar buffer-matches))
|
(current-beginning (caar buffer-matches))
|
||||||
(current-end (cadar buffer-matches)))
|
(current-end (cadar buffer-matches)))
|
||||||
(dolist (match (cdr buffer-matches))
|
(dolist (match (cdr buffer-matches))
|
||||||
(if (< (- (car match) current-end) 2)
|
(if (< (- (car match) current-end) 2)
|
||||||
(setq current-end (cadr match))
|
(setq current-end (cadr match))
|
||||||
(push (list current-beginning current-end) points)
|
(push (list current-beginning current-end) points)
|
||||||
(setq current-beginning (car match))
|
(setq current-beginning (car match))
|
||||||
(setq current-end (cadr match))))
|
(setq current-end (cadr match))))
|
||||||
(nreverse (push (list current-beginning current-end) points))))
|
(nreverse (push (list current-beginning current-end) points))))
|
||||||
|
|
||||||
(provide 'ldg-occur)
|
(provide 'ldg-occur)
|
||||||
|
|
||||||
|
|
|
||||||
148
lisp/ldg-post.el
148
lisp/ldg-post.el
|
|
@ -44,10 +44,10 @@
|
||||||
(defcustom ledger-post-use-completion-engine :built-in
|
(defcustom ledger-post-use-completion-engine :built-in
|
||||||
"Which completion engine to use, :iswitchb or :ido chose those engines,
|
"Which completion engine to use, :iswitchb or :ido chose those engines,
|
||||||
:built-in uses built-in Ledger-mode completion"
|
:built-in uses built-in Ledger-mode completion"
|
||||||
:type '(radio (const :tag "built in completion" :built-in)
|
:type '(radio (const :tag "built in completion" :built-in)
|
||||||
(const :tag "ido completion" :ido)
|
(const :tag "ido completion" :ido)
|
||||||
(const :tag "iswitchb completion" :iswitchb) )
|
(const :tag "iswitchb completion" :iswitchb) )
|
||||||
:group 'ledger-post)
|
:group 'ledger-post)
|
||||||
|
|
||||||
(defun ledger-post-all-accounts ()
|
(defun ledger-post-all-accounts ()
|
||||||
"Return a list of all accounts in the buffer."
|
"Return a list of all accounts in the buffer."
|
||||||
|
|
@ -72,15 +72,15 @@
|
||||||
PROMPT is a string to prompt with. CHOICES is a list of strings
|
PROMPT is a string to prompt with. CHOICES is a list of strings
|
||||||
to choose from."
|
to choose from."
|
||||||
(cond ((eq ledger-post-use-completion-engine :iswitchb)
|
(cond ((eq ledger-post-use-completion-engine :iswitchb)
|
||||||
(let* ((iswitchb-use-virtual-buffers nil)
|
(let* ((iswitchb-use-virtual-buffers nil)
|
||||||
(iswitchb-make-buflist-hook
|
(iswitchb-make-buflist-hook
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(setq iswitchb-temp-buflist choices))))
|
(setq iswitchb-temp-buflist choices))))
|
||||||
(iswitchb-read-buffer prompt)))
|
(iswitchb-read-buffer prompt)))
|
||||||
((eq ledger-post-use-completion-engine :ido)
|
((eq ledger-post-use-completion-engine :ido)
|
||||||
(ido-completing-read prompt choices))
|
(ido-completing-read prompt choices))
|
||||||
(t
|
(t
|
||||||
(completing-read prompt choices))))
|
(completing-read prompt choices))))
|
||||||
|
|
||||||
(defvar ledger-post-current-list nil)
|
(defvar ledger-post-current-list nil)
|
||||||
|
|
||||||
|
|
@ -102,12 +102,12 @@ to choose from."
|
||||||
(match-end ledger-regex-post-line-group-account))
|
(match-end ledger-regex-post-line-group-account))
|
||||||
(insert account)
|
(insert account)
|
||||||
(cond
|
(cond
|
||||||
((> existing-len account-len)
|
((> existing-len account-len)
|
||||||
(insert (make-string (- existing-len account-len) ? )))
|
(insert (make-string (- existing-len account-len) ? )))
|
||||||
((< existing-len account-len)
|
((< existing-len account-len)
|
||||||
(dotimes (n (- account-len existing-len))
|
(dotimes (n (- account-len existing-len))
|
||||||
(if (looking-at "[ \t]\\( [ \t]\\|\t\\)")
|
(if (looking-at "[ \t]\\( [ \t]\\|\t\\)")
|
||||||
(delete-char 1)))))))
|
(delete-char 1)))))))
|
||||||
(goto-char pos)))
|
(goto-char pos)))
|
||||||
|
|
||||||
|
|
||||||
|
|
@ -128,18 +128,18 @@ point at beginning of the commodity."
|
||||||
"Move point to the beginning of the next account, or status marker (!*), as long as it is not past END.
|
"Move point to the beginning of the next account, or status marker (!*), as long as it is not past END.
|
||||||
Return the column of the beginning of the account and leave point
|
Return the column of the beginning of the account and leave point
|
||||||
at beginning of account"
|
at beginning of account"
|
||||||
(if (> end (point))
|
(if (> end (point))
|
||||||
(when (re-search-forward ledger-account-any-status-regex (1+ end) t)
|
(when (re-search-forward ledger-account-any-status-regex (1+ end) t)
|
||||||
;; the 1+ is to make sure we can catch the newline
|
;; the 1+ is to make sure we can catch the newline
|
||||||
(if (match-beginning 1)
|
(if (match-beginning 1)
|
||||||
(goto-char (match-beginning 1))
|
(goto-char (match-beginning 1))
|
||||||
(goto-char (match-beginning 2)))
|
(goto-char (match-beginning 2)))
|
||||||
(current-column))))
|
(current-column))))
|
||||||
|
|
||||||
(defun ledger-post-align-xact (pos)
|
(defun ledger-post-align-xact (pos)
|
||||||
(interactive "d")
|
(interactive "d")
|
||||||
(let ((bounds (ledger-find-xact-extents pos)))
|
(let ((bounds (ledger-find-xact-extents pos)))
|
||||||
(ledger-post-align-postings (car bounds) (cadr bounds))))
|
(ledger-post-align-postings (car bounds) (cadr bounds))))
|
||||||
|
|
||||||
(defun ledger-post-align-postings (&optional beg end)
|
(defun ledger-post-align-postings (&optional beg end)
|
||||||
"Align all accounts and amounts within region, if there is no
|
"Align all accounts and amounts within region, if there is no
|
||||||
|
|
@ -149,52 +149,52 @@ region align the posting on the current line."
|
||||||
|
|
||||||
(save-excursion
|
(save-excursion
|
||||||
(if (or (not (mark))
|
(if (or (not (mark))
|
||||||
(not (use-region-p)))
|
(not (use-region-p)))
|
||||||
(set-mark (point)))
|
(set-mark (point)))
|
||||||
|
|
||||||
(let* ((inhibit-modification-hooks t)
|
(let* ((inhibit-modification-hooks t)
|
||||||
(mark-first (< (mark) (point)))
|
(mark-first (< (mark) (point)))
|
||||||
(begin-region (if beg
|
(begin-region (if beg
|
||||||
beg
|
beg
|
||||||
(if mark-first (mark) (point))))
|
(if mark-first (mark) (point))))
|
||||||
(end-region (if end
|
(end-region (if end
|
||||||
end
|
end
|
||||||
(if mark-first (point) (mark))))
|
(if mark-first (point) (mark))))
|
||||||
acct-start-column acct-end-column acct-adjust amt-width
|
acct-start-column acct-end-column acct-adjust amt-width
|
||||||
(lines-left 1))
|
(lines-left 1))
|
||||||
;; Condition point and mark to the beginning and end of lines
|
;; Condition point and mark to the beginning and end of lines
|
||||||
(goto-char end-region)
|
(goto-char end-region)
|
||||||
(setq end-region (line-end-position))
|
(setq end-region (line-end-position))
|
||||||
(goto-char begin-region)
|
(goto-char begin-region)
|
||||||
(goto-char
|
(goto-char
|
||||||
(setq begin-region
|
(setq begin-region
|
||||||
(line-beginning-position)))
|
(line-beginning-position)))
|
||||||
|
|
||||||
;; This is the guts of the alignment loop
|
;; This is the guts of the alignment loop
|
||||||
(while (and (or (setq acct-start-column (ledger-next-account (line-end-position)))
|
(while (and (or (setq acct-start-column (ledger-next-account (line-end-position)))
|
||||||
lines-left)
|
lines-left)
|
||||||
(< (point) end-region))
|
(< (point) end-region))
|
||||||
(when acct-start-column
|
(when acct-start-column
|
||||||
(setq acct-end-column (save-excursion
|
(setq acct-end-column (save-excursion
|
||||||
(goto-char (match-end 2))
|
(goto-char (match-end 2))
|
||||||
(current-column)))
|
(current-column)))
|
||||||
(when (/= (setq acct-adjust (- ledger-post-account-alignment-column acct-start-column)) 0)
|
(when (/= (setq acct-adjust (- ledger-post-account-alignment-column acct-start-column)) 0)
|
||||||
(setq acct-end-column (+ acct-end-column acct-adjust)) ;;adjust the account ending column
|
(setq acct-end-column (+ acct-end-column acct-adjust)) ;;adjust the account ending column
|
||||||
(if (> acct-adjust 0)
|
(if (> acct-adjust 0)
|
||||||
(insert (make-string acct-adjust ? ))
|
(insert (make-string acct-adjust ? ))
|
||||||
(delete-char acct-adjust)))
|
(delete-char acct-adjust)))
|
||||||
(when (setq amt-width (ledger-next-amount (line-end-position)))
|
(when (setq amt-width (ledger-next-amount (line-end-position)))
|
||||||
(if (/= 0 (setq amt-adjust (- (if (> (- ledger-post-amount-alignment-column amt-width)
|
(if (/= 0 (setq amt-adjust (- (if (> (- ledger-post-amount-alignment-column amt-width)
|
||||||
(+ 2 acct-end-column))
|
(+ 2 acct-end-column))
|
||||||
ledger-post-amount-alignment-column ;;we have room
|
ledger-post-amount-alignment-column ;;we have room
|
||||||
(+ acct-end-column 2 amt-width))
|
(+ acct-end-column 2 amt-width))
|
||||||
amt-width
|
amt-width
|
||||||
(current-column))))
|
(current-column))))
|
||||||
(if (> amt-adjust 0)
|
(if (> amt-adjust 0)
|
||||||
(insert (make-string amt-adjust ? ))
|
(insert (make-string amt-adjust ? ))
|
||||||
(delete-char amt-adjust)))))
|
(delete-char amt-adjust)))))
|
||||||
(forward-line)
|
(forward-line)
|
||||||
(setq lines-left (not (eobp))))
|
(setq lines-left (not (eobp))))
|
||||||
(setq inhibit-modification-hooks nil))))
|
(setq inhibit-modification-hooks nil))))
|
||||||
|
|
||||||
|
|
||||||
|
|
@ -208,16 +208,16 @@ region align the posting on the current line."
|
||||||
(let ((end-of-amount (re-search-forward "[-.,0-9]+" (line-end-position) t)))
|
(let ((end-of-amount (re-search-forward "[-.,0-9]+" (line-end-position) t)))
|
||||||
;; determine if there is an amount to edit
|
;; determine if there is an amount to edit
|
||||||
(if end-of-amount
|
(if end-of-amount
|
||||||
(let ((val (ledger-string-to-number (match-string 0))))
|
(let ((val (ledger-string-to-number (match-string 0))))
|
||||||
(goto-char (match-beginning 0))
|
(goto-char (match-beginning 0))
|
||||||
(delete-region (match-beginning 0) (match-end 0))
|
(delete-region (match-beginning 0) (match-end 0))
|
||||||
(calc)
|
(calc)
|
||||||
(calc-eval val 'push)) ;; edit the amount
|
(calc-eval val 'push)) ;; edit the amount
|
||||||
(progn ;;make sure there are two spaces after the account name and go to calc
|
(progn ;;make sure there are two spaces after the account name and go to calc
|
||||||
(if (search-backward " " (- (point) 3) t)
|
(if (search-backward " " (- (point) 3) t)
|
||||||
(goto-char (line-end-position))
|
(goto-char (line-end-position))
|
||||||
(insert " "))
|
(insert " "))
|
||||||
(calc))))))
|
(calc))))))
|
||||||
|
|
||||||
(defun ledger-post-prev-xact ()
|
(defun ledger-post-prev-xact ()
|
||||||
"Move point to the previous transaction."
|
"Move point to the previous transaction."
|
||||||
|
|
|
||||||
|
|
@ -33,7 +33,7 @@
|
||||||
(defvar ledger-target nil)
|
(defvar ledger-target nil)
|
||||||
|
|
||||||
(defgroup ledger-reconcile nil
|
(defgroup ledger-reconcile nil
|
||||||
"Options for Ledger-mode reconciliation"
|
"Options for Ledger-mode reconciliation"
|
||||||
:group 'ledger)
|
:group 'ledger)
|
||||||
|
|
||||||
(defcustom ledger-recon-buffer-name "*Reconcile*"
|
(defcustom ledger-recon-buffer-name "*Reconcile*"
|
||||||
|
|
@ -59,8 +59,8 @@ Then that transaction will be shown in its source buffer."
|
||||||
(defcustom ledger-reconcile-toggle-to-pending t
|
(defcustom ledger-reconcile-toggle-to-pending t
|
||||||
"If true then toggle between uncleared and pending.
|
"If true then toggle between uncleared and pending.
|
||||||
reconcile-finish will mark all pending posting cleared."
|
reconcile-finish will mark all pending posting cleared."
|
||||||
:type 'boolean
|
:type 'boolean
|
||||||
:group 'ledger-reconcile)
|
:group 'ledger-reconcile)
|
||||||
|
|
||||||
(defcustom ledger-reconcile-default-date-format "%Y/%m/%d"
|
(defcustom ledger-reconcile-default-date-format "%Y/%m/%d"
|
||||||
"Default date format for the reconcile buffer"
|
"Default date format for the reconcile buffer"
|
||||||
|
|
@ -73,7 +73,7 @@ reconcile-finish will mark all pending posting cleared."
|
||||||
:group 'ledger-reconcile)
|
:group 'ledger-reconcile)
|
||||||
|
|
||||||
(defvar ledger-reconcile-sort-key "(date)"
|
(defvar ledger-reconcile-sort-key "(date)"
|
||||||
"Default key for sorting reconcile buffer")
|
"Default key for sorting reconcile buffer")
|
||||||
|
|
||||||
(defun ledger-reconcile-get-cleared-or-pending-balance (buffer account)
|
(defun ledger-reconcile-get-cleared-or-pending-balance (buffer account)
|
||||||
"Calculate the cleared or pending balance of the account."
|
"Calculate the cleared or pending balance of the account."
|
||||||
|
|
@ -87,10 +87,10 @@ reconcile-finish will mark all pending posting cleared."
|
||||||
;; split arguments like the shell does, so you need to
|
;; split arguments like the shell does, so you need to
|
||||||
;; specify the individual fields in the command line.
|
;; specify the individual fields in the command line.
|
||||||
(if (ledger-exec-ledger buffer (current-buffer)
|
(if (ledger-exec-ledger buffer (current-buffer)
|
||||||
"balance" "--limit" "cleared or pending" "--empty" "--collapse"
|
"balance" "--limit" "cleared or pending" "--empty" "--collapse"
|
||||||
"--format" "%(display_total)" account)
|
"--format" "%(display_total)" account)
|
||||||
(ledger-split-commodity-string
|
(ledger-split-commodity-string
|
||||||
(buffer-substring-no-properties (point-min) (point-max))))))
|
(buffer-substring-no-properties (point-min) (point-max))))))
|
||||||
|
|
||||||
(defun ledger-display-balance ()
|
(defun ledger-display-balance ()
|
||||||
"Display the cleared-or-pending balance.
|
"Display the cleared-or-pending balance.
|
||||||
|
|
@ -98,12 +98,12 @@ And calculate the target-delta of the account being reconciled."
|
||||||
(interactive)
|
(interactive)
|
||||||
(let* ((pending (ledger-reconcile-get-cleared-or-pending-balance ledger-buf ledger-acct)))
|
(let* ((pending (ledger-reconcile-get-cleared-or-pending-balance ledger-buf ledger-acct)))
|
||||||
(when pending
|
(when pending
|
||||||
(if ledger-target
|
(if ledger-target
|
||||||
(message "Pending balance: %s, Difference from target: %s"
|
(message "Pending balance: %s, Difference from target: %s"
|
||||||
(ledger-commodity-to-string pending)
|
(ledger-commodity-to-string pending)
|
||||||
(ledger-commodity-to-string (-commodity ledger-target pending)))
|
(ledger-commodity-to-string (-commodity ledger-target pending)))
|
||||||
(message "Pending balance: %s"
|
(message "Pending balance: %s"
|
||||||
(ledger-commodity-to-string pending))))))
|
(ledger-commodity-to-string pending))))))
|
||||||
|
|
||||||
(defun is-stdin (file)
|
(defun is-stdin (file)
|
||||||
"True if ledger FILE is standard input."
|
"True if ledger FILE is standard input."
|
||||||
|
|
@ -127,27 +127,27 @@ And calculate the target-delta of the account being reconciled."
|
||||||
status)
|
status)
|
||||||
(when (ledger-reconcile-get-buffer where)
|
(when (ledger-reconcile-get-buffer where)
|
||||||
(with-current-buffer (ledger-reconcile-get-buffer where)
|
(with-current-buffer (ledger-reconcile-get-buffer where)
|
||||||
(ledger-goto-line (cdr where))
|
(ledger-goto-line (cdr where))
|
||||||
(forward-char)
|
(forward-char)
|
||||||
(setq status (ledger-toggle-current (if ledger-reconcile-toggle-to-pending
|
(setq status (ledger-toggle-current (if ledger-reconcile-toggle-to-pending
|
||||||
'pending
|
'pending
|
||||||
'cleared))))
|
'cleared))))
|
||||||
;; remove the existing face and add the new face
|
;; remove the existing face and add the new face
|
||||||
(remove-text-properties (line-beginning-position)
|
(remove-text-properties (line-beginning-position)
|
||||||
(line-end-position)
|
(line-end-position)
|
||||||
(list 'face))
|
(list 'face))
|
||||||
(cond ((eq status 'pending)
|
(cond ((eq status 'pending)
|
||||||
(add-text-properties (line-beginning-position)
|
(add-text-properties (line-beginning-position)
|
||||||
(line-end-position)
|
(line-end-position)
|
||||||
(list 'face 'ledger-font-reconciler-pending-face )))
|
(list 'face 'ledger-font-reconciler-pending-face )))
|
||||||
((eq status 'cleared)
|
((eq status 'cleared)
|
||||||
(add-text-properties (line-beginning-position)
|
(add-text-properties (line-beginning-position)
|
||||||
(line-end-position)
|
(line-end-position)
|
||||||
(list 'face 'ledger-font-reconciler-cleared-face )))
|
(list 'face 'ledger-font-reconciler-cleared-face )))
|
||||||
(t
|
(t
|
||||||
(add-text-properties (line-beginning-position)
|
(add-text-properties (line-beginning-position)
|
||||||
(line-end-position)
|
(line-end-position)
|
||||||
(list 'face 'ledger-font-reconciler-uncleared-face )))))
|
(list 'face 'ledger-font-reconciler-uncleared-face )))))
|
||||||
(forward-line)
|
(forward-line)
|
||||||
(beginning-of-line)
|
(beginning-of-line)
|
||||||
(ledger-display-balance)))
|
(ledger-display-balance)))
|
||||||
|
|
@ -159,18 +159,18 @@ Return the number of uncleared xacts found."
|
||||||
(let ((inhibit-read-only t))
|
(let ((inhibit-read-only t))
|
||||||
(erase-buffer)
|
(erase-buffer)
|
||||||
(prog1
|
(prog1
|
||||||
(ledger-do-reconcile ledger-reconcile-sort-key)
|
(ledger-do-reconcile ledger-reconcile-sort-key)
|
||||||
(set-buffer-modified-p t))))
|
(set-buffer-modified-p t))))
|
||||||
|
|
||||||
(defun ledger-reconcile-refresh-after-save ()
|
(defun ledger-reconcile-refresh-after-save ()
|
||||||
"Refresh the recon-window after the ledger buffer is saved."
|
"Refresh the recon-window after the ledger buffer is saved."
|
||||||
(let ((curbuf (current-buffer))
|
(let ((curbuf (current-buffer))
|
||||||
(curpoint (point))
|
(curpoint (point))
|
||||||
(recon-buf (get-buffer ledger-recon-buffer-name)))
|
(recon-buf (get-buffer ledger-recon-buffer-name)))
|
||||||
(when (buffer-live-p recon-buf)
|
(when (buffer-live-p recon-buf)
|
||||||
(with-current-buffer recon-buf
|
(with-current-buffer recon-buf
|
||||||
(ledger-reconcile-refresh)
|
(ledger-reconcile-refresh)
|
||||||
(set-buffer-modified-p nil))
|
(set-buffer-modified-p nil))
|
||||||
(select-window (get-buffer-window curbuf))
|
(select-window (get-buffer-window curbuf))
|
||||||
(goto-char curpoint))))
|
(goto-char curpoint))))
|
||||||
|
|
||||||
|
|
@ -200,19 +200,19 @@ Return the number of uncleared xacts found."
|
||||||
(progn
|
(progn
|
||||||
(beginning-of-line)
|
(beginning-of-line)
|
||||||
(let* ((where (get-text-property (1+ (point)) 'where))
|
(let* ((where (get-text-property (1+ (point)) 'where))
|
||||||
(target-buffer (if where
|
(target-buffer (if where
|
||||||
(ledger-reconcile-get-buffer where)
|
(ledger-reconcile-get-buffer where)
|
||||||
nil))
|
nil))
|
||||||
(cur-win (get-buffer-window (get-buffer ledger-recon-buffer-name))))
|
(cur-win (get-buffer-window (get-buffer ledger-recon-buffer-name))))
|
||||||
(when target-buffer
|
(when target-buffer
|
||||||
(switch-to-buffer-other-window target-buffer)
|
(switch-to-buffer-other-window target-buffer)
|
||||||
(ledger-goto-line (cdr where))
|
(ledger-goto-line (cdr where))
|
||||||
(forward-char)
|
(forward-char)
|
||||||
(recenter)
|
(recenter)
|
||||||
(ledger-highlight-xact-under-point)
|
(ledger-highlight-xact-under-point)
|
||||||
(forward-char -1)
|
(forward-char -1)
|
||||||
(if (and come-back cur-win)
|
(if (and come-back cur-win)
|
||||||
(select-window cur-win))))))
|
(select-window cur-win))))))
|
||||||
|
|
||||||
(defun ledger-reconcile-save ()
|
(defun ledger-reconcile-save ()
|
||||||
"Save the ledger buffer."
|
"Save the ledger buffer."
|
||||||
|
|
@ -220,7 +220,7 @@ Return the number of uncleared xacts found."
|
||||||
(let ((curpoint (point)))
|
(let ((curpoint (point)))
|
||||||
(dolist (buf (cons ledger-buf ledger-bufs))
|
(dolist (buf (cons ledger-buf ledger-bufs))
|
||||||
(with-current-buffer buf
|
(with-current-buffer buf
|
||||||
(save-buffer)))
|
(save-buffer)))
|
||||||
(with-current-buffer (get-buffer ledger-recon-buffer-name)
|
(with-current-buffer (get-buffer ledger-recon-buffer-name)
|
||||||
(set-buffer-modified-p nil)
|
(set-buffer-modified-p nil)
|
||||||
(ledger-display-balance)
|
(ledger-display-balance)
|
||||||
|
|
@ -243,94 +243,94 @@ and exit reconcile mode"
|
||||||
(ledger-toggle-current 'cleared))))
|
(ledger-toggle-current 'cleared))))
|
||||||
(forward-line 1)))
|
(forward-line 1)))
|
||||||
(ledger-reconcile-save)
|
(ledger-reconcile-save)
|
||||||
(ledger-reconcile-quit))
|
(ledger-reconcile-quit))
|
||||||
|
|
||||||
|
|
||||||
(defun ledger-reconcile-quit ()
|
(defun ledger-reconcile-quit ()
|
||||||
"Quit the reconcile window without saving ledger buffer."
|
"Quit the reconcile window without saving ledger buffer."
|
||||||
(interactive)
|
(interactive)
|
||||||
(let ((recon-buf (get-buffer ledger-recon-buffer-name))
|
(let ((recon-buf (get-buffer ledger-recon-buffer-name))
|
||||||
buf)
|
buf)
|
||||||
(if recon-buf
|
(if recon-buf
|
||||||
(with-current-buffer recon-buf
|
(with-current-buffer recon-buf
|
||||||
(ledger-reconcile-quit-cleanup)
|
(ledger-reconcile-quit-cleanup)
|
||||||
(setq buf ledger-buf)
|
(setq buf ledger-buf)
|
||||||
;; Make sure you delete the window before you delete the buffer,
|
;; Make sure you delete the window before you delete the buffer,
|
||||||
;; otherwise, madness ensues
|
;; otherwise, madness ensues
|
||||||
(delete-window (get-buffer-window recon-buf))
|
(delete-window (get-buffer-window recon-buf))
|
||||||
(kill-buffer recon-buf)
|
(kill-buffer recon-buf)
|
||||||
(set-window-buffer (selected-window) buf)))))
|
(set-window-buffer (selected-window) buf)))))
|
||||||
|
|
||||||
(defun ledger-reconcile-quit-cleanup ()
|
(defun ledger-reconcile-quit-cleanup ()
|
||||||
"Cleanup all hooks established by reconcile mode."
|
"Cleanup all hooks established by reconcile mode."
|
||||||
(interactive)
|
(interactive)
|
||||||
(let ((buf ledger-buf))
|
(let ((buf ledger-buf))
|
||||||
(if (buffer-live-p buf)
|
(if (buffer-live-p buf)
|
||||||
(with-current-buffer buf
|
(with-current-buffer buf
|
||||||
(remove-hook 'after-save-hook 'ledger-reconcile-refresh-after-save t)
|
(remove-hook 'after-save-hook 'ledger-reconcile-refresh-after-save t)
|
||||||
(when ledger-narrow-on-reconcile
|
(when ledger-narrow-on-reconcile
|
||||||
(ledger-occur-quit-buffer buf)
|
(ledger-occur-quit-buffer buf)
|
||||||
(ledger-highlight-xact-under-point))))))
|
(ledger-highlight-xact-under-point))))))
|
||||||
|
|
||||||
(defun ledger-marker-where-xact-is (emacs-xact posting)
|
(defun ledger-marker-where-xact-is (emacs-xact posting)
|
||||||
"Find the position of the EMACS-XACT in the `ledger-buf'.
|
"Find the position of the EMACS-XACT in the `ledger-buf'.
|
||||||
POSTING is used in `ledger-clear-whole-transactions' is nil."
|
POSTING is used in `ledger-clear-whole-transactions' is nil."
|
||||||
(let ((buf (if (is-stdin (nth 0 emacs-xact))
|
(let ((buf (if (is-stdin (nth 0 emacs-xact))
|
||||||
ledger-buf
|
ledger-buf
|
||||||
(find-file-noselect (nth 0 emacs-xact)))))
|
(find-file-noselect (nth 0 emacs-xact)))))
|
||||||
(cons
|
(cons
|
||||||
buf
|
buf
|
||||||
(if ledger-clear-whole-transactions
|
(if ledger-clear-whole-transactions
|
||||||
(nth 1 emacs-xact) ;; return line-no of xact
|
(nth 1 emacs-xact) ;; return line-no of xact
|
||||||
(nth 0 posting))))) ;; return line-no of posting
|
(nth 0 posting))))) ;; return line-no of posting
|
||||||
|
|
||||||
(defun ledger-do-reconcile (&optional sort)
|
(defun ledger-do-reconcile (&optional sort)
|
||||||
"Return the number of uncleared transactions in the account and display them in the *Reconcile* buffer."
|
"Return the number of uncleared transactions in the account and display them in the *Reconcile* buffer."
|
||||||
(let* ((buf ledger-buf)
|
(let* ((buf ledger-buf)
|
||||||
(account ledger-acct)
|
(account ledger-acct)
|
||||||
(ledger-success nil)
|
(ledger-success nil)
|
||||||
(sort-by (if sort
|
(sort-by (if sort
|
||||||
sort
|
sort
|
||||||
"(date)"))
|
"(date)"))
|
||||||
(xacts
|
(xacts
|
||||||
(with-temp-buffer
|
(with-temp-buffer
|
||||||
(when (ledger-exec-ledger buf (current-buffer)
|
(when (ledger-exec-ledger buf (current-buffer)
|
||||||
"--uncleared" "--real" "emacs" "--sort" sort-by account)
|
"--uncleared" "--real" "emacs" "--sort" sort-by account)
|
||||||
(setq ledger-success t)
|
(setq ledger-success t)
|
||||||
(goto-char (point-min))
|
(goto-char (point-min))
|
||||||
(unless (eobp)
|
(unless (eobp)
|
||||||
(if (looking-at "(")
|
(if (looking-at "(")
|
||||||
(read (current-buffer)))))))) ;current-buffer is the *temp* created above
|
(read (current-buffer)))))))) ;current-buffer is the *temp* created above
|
||||||
(if (and ledger-success (> (length xacts) 0))
|
(if (and ledger-success (> (length xacts) 0))
|
||||||
(let ((date-format (cdr (assoc "date-format" ledger-environment-alist))))
|
(let ((date-format (cdr (assoc "date-format" ledger-environment-alist))))
|
||||||
(dolist (xact xacts)
|
(dolist (xact xacts)
|
||||||
(dolist (posting (nthcdr 5 xact))
|
(dolist (posting (nthcdr 5 xact))
|
||||||
(let ((beg (point))
|
(let ((beg (point))
|
||||||
(where (ledger-marker-where-xact-is xact posting)))
|
(where (ledger-marker-where-xact-is xact posting)))
|
||||||
(insert (format "%s %-4s %-30s %-30s %15s\n"
|
(insert (format "%s %-4s %-30s %-30s %15s\n"
|
||||||
(format-time-string (if date-format
|
(format-time-string (if date-format
|
||||||
date-format
|
date-format
|
||||||
ledger-reconcile-default-date-format) (nth 2 xact))
|
ledger-reconcile-default-date-format) (nth 2 xact))
|
||||||
(if (nth 3 xact)
|
(if (nth 3 xact)
|
||||||
(nth 3 xact)
|
(nth 3 xact)
|
||||||
"")
|
"")
|
||||||
(nth 4 xact) (nth 1 posting) (nth 2 posting)))
|
(nth 4 xact) (nth 1 posting) (nth 2 posting)))
|
||||||
(if (nth 3 posting)
|
(if (nth 3 posting)
|
||||||
(if (eq (nth 3 posting) 'pending)
|
(if (eq (nth 3 posting) 'pending)
|
||||||
(set-text-properties beg (1- (point))
|
(set-text-properties beg (1- (point))
|
||||||
(list 'face 'ledger-font-reconciler-pending-face
|
(list 'face 'ledger-font-reconciler-pending-face
|
||||||
'where where))
|
'where where))
|
||||||
(set-text-properties beg (1- (point))
|
(set-text-properties beg (1- (point))
|
||||||
(list 'face 'ledger-font-reconciler-cleared-face
|
(list 'face 'ledger-font-reconciler-cleared-face
|
||||||
'where where)))
|
'where where)))
|
||||||
(set-text-properties beg (1- (point))
|
(set-text-properties beg (1- (point))
|
||||||
(list 'face 'ledger-font-reconciler-uncleared-face
|
(list 'face 'ledger-font-reconciler-uncleared-face
|
||||||
'where where)))) ))
|
'where where)))) ))
|
||||||
(goto-char (point-max))
|
(goto-char (point-max))
|
||||||
(delete-char -1)) ;gets rid of the extra line feed at the bottom of the list
|
(delete-char -1)) ;gets rid of the extra line feed at the bottom of the list
|
||||||
(if ledger-success
|
(if ledger-success
|
||||||
(insert (concat "There are no uncleared entries for " account))
|
(insert (concat "There are no uncleared entries for " account))
|
||||||
(insert "Ledger has reported a problem. Check *Ledger Error* buffer.")))
|
(insert "Ledger has reported a problem. Check *Ledger Error* buffer.")))
|
||||||
(goto-char (point-min))
|
(goto-char (point-min))
|
||||||
(set-buffer-modified-p nil)
|
(set-buffer-modified-p nil)
|
||||||
(toggle-read-only t)
|
(toggle-read-only t)
|
||||||
|
|
@ -344,30 +344,30 @@ ledger buffer is at the bottom of the main window. The key to
|
||||||
this is to ensure the window is selected when the buffer point is
|
this is to ensure the window is selected when the buffer point is
|
||||||
moved and recentered. If they aren't strange things happen."
|
moved and recentered. If they aren't strange things happen."
|
||||||
|
|
||||||
(let ((recon-window (get-buffer-window (get-buffer ledger-recon-buffer-name))))
|
(let ((recon-window (get-buffer-window (get-buffer ledger-recon-buffer-name))))
|
||||||
(when recon-window
|
(when recon-window
|
||||||
(fit-window-to-buffer recon-window)
|
(fit-window-to-buffer recon-window)
|
||||||
(with-current-buffer buf
|
(with-current-buffer buf
|
||||||
(add-hook 'kill-buffer-hook 'ledger-reconcile-quit nil t)
|
(add-hook 'kill-buffer-hook 'ledger-reconcile-quit nil t)
|
||||||
(if (get-buffer-window buf)
|
(if (get-buffer-window buf)
|
||||||
(select-window (get-buffer-window buf)))
|
(select-window (get-buffer-window buf)))
|
||||||
(goto-char (point-max))
|
(goto-char (point-max))
|
||||||
(recenter -1))
|
(recenter -1))
|
||||||
(select-window recon-window)
|
(select-window recon-window)
|
||||||
(ledger-reconcile-visit t))
|
(ledger-reconcile-visit t))
|
||||||
(add-hook 'post-command-hook 'ledger-reconcile-track-xact nil t)))
|
(add-hook 'post-command-hook 'ledger-reconcile-track-xact nil t)))
|
||||||
|
|
||||||
(defun ledger-reconcile-track-xact ()
|
(defun ledger-reconcile-track-xact ()
|
||||||
"Force the ledger buffer to recenter on the transaction at point in the reconcile buffer."
|
"Force the ledger buffer to recenter on the transaction at point in the reconcile buffer."
|
||||||
(if (and ledger-buffer-tracks-reconcile-buffer
|
(if (and ledger-buffer-tracks-reconcile-buffer
|
||||||
(member this-command (list 'next-line
|
(member this-command (list 'next-line
|
||||||
'previous-line
|
'previous-line
|
||||||
'mouse-set-point
|
'mouse-set-point
|
||||||
'ledger-reconcile-toggle
|
'ledger-reconcile-toggle
|
||||||
'end-of-buffer
|
'end-of-buffer
|
||||||
'beginning-of-buffer)))
|
'beginning-of-buffer)))
|
||||||
(save-excursion
|
(save-excursion
|
||||||
(ledger-reconcile-visit t))))
|
(ledger-reconcile-visit t))))
|
||||||
|
|
||||||
(defun ledger-reconcile-open-windows (buf rbuf)
|
(defun ledger-reconcile-open-windows (buf rbuf)
|
||||||
"Ensure that the ledger buffer BUF is split by RBUF."
|
"Ensure that the ledger buffer BUF is split by RBUF."
|
||||||
|
|
@ -380,39 +380,39 @@ moved and recentered. If they aren't strange things happen."
|
||||||
"Start reconciling, prompt for account."
|
"Start reconciling, prompt for account."
|
||||||
(interactive)
|
(interactive)
|
||||||
(let ((account (ledger-read-account-with-prompt "Account to reconcile"))
|
(let ((account (ledger-read-account-with-prompt "Account to reconcile"))
|
||||||
(buf (current-buffer))
|
(buf (current-buffer))
|
||||||
(rbuf (get-buffer ledger-recon-buffer-name)))
|
(rbuf (get-buffer ledger-recon-buffer-name)))
|
||||||
|
|
||||||
(add-hook 'after-save-hook 'ledger-reconcile-refresh-after-save nil t)
|
(add-hook 'after-save-hook 'ledger-reconcile-refresh-after-save nil t)
|
||||||
|
|
||||||
(if rbuf ;; *Reconcile* already exists
|
(if rbuf ;; *Reconcile* already exists
|
||||||
(with-current-buffer rbuf
|
(with-current-buffer rbuf
|
||||||
(set 'ledger-acct account) ;; already buffer local
|
(set 'ledger-acct account) ;; already buffer local
|
||||||
(when (not (eq buf rbuf))
|
(when (not (eq buf rbuf))
|
||||||
;; called from some other ledger-mode buffer
|
;; called from some other ledger-mode buffer
|
||||||
(ledger-reconcile-quit-cleanup)
|
(ledger-reconcile-quit-cleanup)
|
||||||
(set 'ledger-buf buf)) ;; should already be buffer-local
|
(set 'ledger-buf buf)) ;; should already be buffer-local
|
||||||
|
|
||||||
(unless (get-buffer-window rbuf)
|
(unless (get-buffer-window rbuf)
|
||||||
(ledger-reconcile-open-windows buf rbuf)))
|
(ledger-reconcile-open-windows buf rbuf)))
|
||||||
|
|
||||||
;; no recon-buffer, starting from scratch.
|
;; no recon-buffer, starting from scratch.
|
||||||
|
|
||||||
(with-current-buffer (setq rbuf
|
(with-current-buffer (setq rbuf
|
||||||
(get-buffer-create ledger-recon-buffer-name))
|
(get-buffer-create ledger-recon-buffer-name))
|
||||||
(ledger-reconcile-open-windows buf rbuf)
|
(ledger-reconcile-open-windows buf rbuf)
|
||||||
(ledger-reconcile-mode)
|
(ledger-reconcile-mode)
|
||||||
(make-local-variable 'ledger-target)
|
(make-local-variable 'ledger-target)
|
||||||
(set (make-local-variable 'ledger-buf) buf)
|
(set (make-local-variable 'ledger-buf) buf)
|
||||||
(set (make-local-variable 'ledger-acct) account)))
|
(set (make-local-variable 'ledger-acct) account)))
|
||||||
|
|
||||||
;; Narrow the ledger buffer
|
;; Narrow the ledger buffer
|
||||||
(with-current-buffer rbuf
|
(with-current-buffer rbuf
|
||||||
(save-excursion
|
(save-excursion
|
||||||
(if ledger-narrow-on-reconcile
|
(if ledger-narrow-on-reconcile
|
||||||
(ledger-occur-mode account ledger-buf)))
|
(ledger-occur-mode account ledger-buf)))
|
||||||
(if (> (ledger-reconcile-refresh) 0)
|
(if (> (ledger-reconcile-refresh) 0)
|
||||||
(ledger-reconcile-change-target))
|
(ledger-reconcile-change-target))
|
||||||
(ledger-display-balance))))
|
(ledger-display-balance))))
|
||||||
|
|
||||||
(defvar ledger-reconcile-mode-abbrev-table)
|
(defvar ledger-reconcile-mode-abbrev-table)
|
||||||
|
|
@ -423,62 +423,62 @@ moved and recentered. If they aren't strange things happen."
|
||||||
(setq ledger-target (ledger-read-commodity-string ledger-reconcile-target-prompt-string)))
|
(setq ledger-target (ledger-read-commodity-string ledger-reconcile-target-prompt-string)))
|
||||||
|
|
||||||
(defmacro ledger-reconcile-change-sort-key-and-refresh (sort-by)
|
(defmacro ledger-reconcile-change-sort-key-and-refresh (sort-by)
|
||||||
`(lambda ()
|
`(lambda ()
|
||||||
(interactive)
|
(interactive)
|
||||||
|
|
||||||
(setq ledger-reconcile-sort-key ,sort-by)
|
(setq ledger-reconcile-sort-key ,sort-by)
|
||||||
(ledger-reconcile-refresh)))
|
(ledger-reconcile-refresh)))
|
||||||
|
|
||||||
(define-derived-mode ledger-reconcile-mode text-mode "Reconcile"
|
(define-derived-mode ledger-reconcile-mode text-mode "Reconcile"
|
||||||
"A mode for reconciling ledger entries."
|
"A mode for reconciling ledger entries."
|
||||||
(let ((map (make-sparse-keymap)))
|
(let ((map (make-sparse-keymap)))
|
||||||
(define-key map [(control ?m)] 'ledger-reconcile-visit)
|
(define-key map [(control ?m)] 'ledger-reconcile-visit)
|
||||||
(define-key map [return] 'ledger-reconcile-visit)
|
(define-key map [return] 'ledger-reconcile-visit)
|
||||||
(define-key map [(control ?l)] 'ledger-reconcile-refresh)
|
(define-key map [(control ?l)] 'ledger-reconcile-refresh)
|
||||||
(define-key map [(control ?c) (control ?c)] 'ledger-reconcile-finish)
|
(define-key map [(control ?c) (control ?c)] 'ledger-reconcile-finish)
|
||||||
(define-key map [? ] 'ledger-reconcile-toggle)
|
(define-key map [? ] 'ledger-reconcile-toggle)
|
||||||
(define-key map [?a] 'ledger-reconcile-add)
|
(define-key map [?a] 'ledger-reconcile-add)
|
||||||
(define-key map [?d] 'ledger-reconcile-delete)
|
(define-key map [?d] 'ledger-reconcile-delete)
|
||||||
(define-key map [?g] 'ledger-reconcile);
|
(define-key map [?g] 'ledger-reconcile);
|
||||||
(define-key map [?n] 'next-line)
|
(define-key map [?n] 'next-line)
|
||||||
(define-key map [?p] 'previous-line)
|
(define-key map [?p] 'previous-line)
|
||||||
(define-key map [?t] 'ledger-reconcile-change-target)
|
(define-key map [?t] 'ledger-reconcile-change-target)
|
||||||
(define-key map [?s] 'ledger-reconcile-save)
|
(define-key map [?s] 'ledger-reconcile-save)
|
||||||
(define-key map [?q] 'ledger-reconcile-quit)
|
(define-key map [?q] 'ledger-reconcile-quit)
|
||||||
(define-key map [?b] 'ledger-display-balance)
|
(define-key map [?b] 'ledger-display-balance)
|
||||||
|
|
||||||
(define-key map [(control ?c) (control ?a)] (ledger-reconcile-change-sort-key-and-refresh "(amount)"))
|
(define-key map [(control ?c) (control ?a)] (ledger-reconcile-change-sort-key-and-refresh "(amount)"))
|
||||||
|
|
||||||
(define-key map [(control ?c) (control ?d)] (ledger-reconcile-change-sort-key-and-refresh "(date)"))
|
(define-key map [(control ?c) (control ?d)] (ledger-reconcile-change-sort-key-and-refresh "(date)"))
|
||||||
|
|
||||||
(define-key map [(control ?c) (control ?p)] (ledger-reconcile-change-sort-key-and-refresh "(payee)"))
|
(define-key map [(control ?c) (control ?p)] (ledger-reconcile-change-sort-key-and-refresh "(payee)"))
|
||||||
|
|
||||||
(define-key map [menu-bar] (make-sparse-keymap "ldg-recon-menu"))
|
(define-key map [menu-bar] (make-sparse-keymap "ldg-recon-menu"))
|
||||||
(define-key map [menu-bar ldg-recon-menu] (cons "Reconcile" map))
|
(define-key map [menu-bar ldg-recon-menu] (cons "Reconcile" map))
|
||||||
(define-key map [menu-bar ldg-recon-menu qui] '("Quit" . ledger-reconcile-quit))
|
(define-key map [menu-bar ldg-recon-menu qui] '("Quit" . ledger-reconcile-quit))
|
||||||
(define-key map [menu-bar ldg-recon-menu sep1] '("--"))
|
(define-key map [menu-bar ldg-recon-menu sep1] '("--"))
|
||||||
(define-key map [menu-bar ldg-recon-menu pre] '("Previous Entry" . previous-line))
|
(define-key map [menu-bar ldg-recon-menu pre] '("Previous Entry" . previous-line))
|
||||||
(define-key map [menu-bar ldg-recon-menu vis] '("Visit Source" . ledger-reconcile-visit))
|
(define-key map [menu-bar ldg-recon-menu vis] '("Visit Source" . ledger-reconcile-visit))
|
||||||
(define-key map [menu-bar ldg-recon-menu nex] '("Next Entry" . next-line))
|
(define-key map [menu-bar ldg-recon-menu nex] '("Next Entry" . next-line))
|
||||||
(define-key map [menu-bar ldg-recon-menu sep2] '("--"))
|
(define-key map [menu-bar ldg-recon-menu sep2] '("--"))
|
||||||
(define-key map [menu-bar ldg-recon-menu del] '("Delete Entry" . ledger-reconcile-delete))
|
(define-key map [menu-bar ldg-recon-menu del] '("Delete Entry" . ledger-reconcile-delete))
|
||||||
(define-key map [menu-bar ldg-recon-menu add] '("Add Entry" . ledger-reconcile-add))
|
(define-key map [menu-bar ldg-recon-menu add] '("Add Entry" . ledger-reconcile-add))
|
||||||
(define-key map [menu-bar ldg-recon-menu tog] '("Toggle Entry" . ledger-reconcile-toggle))
|
(define-key map [menu-bar ldg-recon-menu tog] '("Toggle Entry" . ledger-reconcile-toggle))
|
||||||
(define-key map [menu-bar ldg-recon-menu sep3] '("--"))
|
(define-key map [menu-bar ldg-recon-menu sep3] '("--"))
|
||||||
(define-key map [menu-bar ldg-recon-menu sort-amt] `("Sort by amount" . ,(ledger-reconcile-change-sort-key-and-refresh "(amount)")))
|
(define-key map [menu-bar ldg-recon-menu sort-amt] `("Sort by amount" . ,(ledger-reconcile-change-sort-key-and-refresh "(amount)")))
|
||||||
(define-key map [menu-bar ldg-recon-menu sort-pay] `("Sort by date" . ,(ledger-reconcile-change-sort-key-and-refresh "(date)")))
|
(define-key map [menu-bar ldg-recon-menu sort-pay] `("Sort by date" . ,(ledger-reconcile-change-sort-key-and-refresh "(date)")))
|
||||||
(define-key map [menu-bar ldg-recon-menu sort-dat] `("Sort by payee" . ,(ledger-reconcile-change-sort-key-and-refresh "(payee)")))
|
(define-key map [menu-bar ldg-recon-menu sort-dat] `("Sort by payee" . ,(ledger-reconcile-change-sort-key-and-refresh "(payee)")))
|
||||||
(define-key map [menu-bar ldg-recon-menu sep4] '("--"))
|
(define-key map [menu-bar ldg-recon-menu sep4] '("--"))
|
||||||
(define-key map [menu-bar ldg-recon-menu bal] '("Show Cleared Balance" . ledger-display-balance))
|
(define-key map [menu-bar ldg-recon-menu bal] '("Show Cleared Balance" . ledger-display-balance))
|
||||||
(define-key map [menu-bar ldg-recon-menu tgt] '("Change Target Balance" . ledger-reconcile-change-target))
|
(define-key map [menu-bar ldg-recon-menu tgt] '("Change Target Balance" . ledger-reconcile-change-target))
|
||||||
(define-key map [menu-bar ldg-recon-menu sep5] '("--"))
|
(define-key map [menu-bar ldg-recon-menu sep5] '("--"))
|
||||||
(define-key map [menu-bar ldg-recon-menu rna] '("Reconcile New Account" . ledger-reconcile))
|
(define-key map [menu-bar ldg-recon-menu rna] '("Reconcile New Account" . ledger-reconcile))
|
||||||
(define-key map [menu-bar ldg-recon-menu sep6] '("--"))
|
(define-key map [menu-bar ldg-recon-menu sep6] '("--"))
|
||||||
(define-key map [menu-bar ldg-recon-menu fin] '("Finish" . ledger-reconcile-finish))
|
(define-key map [menu-bar ldg-recon-menu fin] '("Finish" . ledger-reconcile-finish))
|
||||||
(define-key map [menu-bar ldg-recon-menu ref] '("Refresh" . ledger-reconcile-refresh))
|
(define-key map [menu-bar ldg-recon-menu ref] '("Refresh" . ledger-reconcile-refresh))
|
||||||
(define-key map [menu-bar ldg-recon-menu sav] '("Save" . ledger-reconcile-save))
|
(define-key map [menu-bar ldg-recon-menu sav] '("Save" . ledger-reconcile-save))
|
||||||
|
|
||||||
(use-local-map map)))
|
(use-local-map map)))
|
||||||
|
|
||||||
(provide 'ldg-reconcile)
|
(provide 'ldg-reconcile)
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -20,7 +20,7 @@
|
||||||
;; Boston, MA 02111-1307, USA.
|
;; Boston, MA 02111-1307, USA.
|
||||||
|
|
||||||
;;; Commentary:
|
;;; Commentary:
|
||||||
;;
|
;;
|
||||||
;; This module provides for automatically adding transactions to a
|
;; This module provides for automatically adding transactions to a
|
||||||
;; ledger buffer on a periodic basis. Recurrence expressions are
|
;; ledger buffer on a periodic basis. Recurrence expressions are
|
||||||
;; inspired by Martin Fowler's "Recurring Events for Calendars",
|
;; inspired by Martin Fowler's "Recurring Events for Calendars",
|
||||||
|
|
@ -49,14 +49,20 @@
|
||||||
:type 'integer
|
:type 'integer
|
||||||
:group 'ledger-schedule)
|
:group 'ledger-schedule)
|
||||||
|
|
||||||
(defcustom ledger-schedule-file "~/FinanceData/ledger-schedule.ledger"
|
(defcustom ledger-schedule-file "~/ledger-schedule.ledger"
|
||||||
"File to find scheduled transactions."
|
"File to find scheduled transactions."
|
||||||
:type 'file
|
:type 'file
|
||||||
:group 'ledger-schedule)
|
:group 'ledger-schedule)
|
||||||
|
|
||||||
|
(defvar ledger-schedule-available nil)
|
||||||
|
|
||||||
(defsubst between (val low high)
|
(defsubst between (val low high)
|
||||||
(and (>= val low) (<= val high)))
|
(and (>= val low) (<= val high)))
|
||||||
|
|
||||||
|
(defun ledger-check-schedule-available ()
|
||||||
|
(setq ledger-schedule-available (and ledger-schedule-file
|
||||||
|
(file-exists-p ledger-schedule-file))))
|
||||||
|
|
||||||
(defun ledger-schedule-days-in-month (month year)
|
(defun ledger-schedule-days-in-month (month year)
|
||||||
"Return number of days in the MONTH, MONTH is from 1 to 12.
|
"Return number of days in the MONTH, MONTH is from 1 to 12.
|
||||||
If year is nil, assume it is not a leap year"
|
If year is nil, assume it is not a leap year"
|
||||||
|
|
@ -67,7 +73,7 @@ If year is nil, assume it is not a leap year"
|
||||||
(error "Month out of range, MONTH=%S" month)))
|
(error "Month out of range, MONTH=%S" month)))
|
||||||
|
|
||||||
;; Macros to handle date expressions
|
;; Macros to handle date expressions
|
||||||
|
|
||||||
(defun ledger-schedule-constrain-day-in-month (count day-of-week)
|
(defun ledger-schedule-constrain-day-in-month (count day-of-week)
|
||||||
"Return a form that evaluates DATE that returns true for the COUNT DAY-OF-WEEK.
|
"Return a form that evaluates DATE that returns true for the COUNT DAY-OF-WEEK.
|
||||||
For example, return true if date is the 3rd Thursday of the
|
For example, return true if date is the 3rd Thursday of the
|
||||||
|
|
@ -80,24 +86,24 @@ COUNT 0) means EVERY day-of-week (eg. every Saturday)"
|
||||||
(let ((decoded (gensym)))
|
(let ((decoded (gensym)))
|
||||||
`(let ((,decoded (decode-time date)))
|
`(let ((,decoded (decode-time date)))
|
||||||
(and (eq (nth 6 ,decoded) ,day-of-week)
|
(and (eq (nth 6 ,decoded) ,day-of-week)
|
||||||
(between (nth 3 ,decoded)
|
(between (nth 3 ,decoded)
|
||||||
,(* (1- count) 7)
|
,(* (1- count) 7)
|
||||||
,(* count 7))))))
|
,(* count 7))))))
|
||||||
((< count 0)
|
((< count 0)
|
||||||
(let ((days-in-month (gensym))
|
(let ((days-in-month (gensym))
|
||||||
(decoded (gensym)))
|
(decoded (gensym)))
|
||||||
`(let* ((,decoded (decode-time date))
|
`(let* ((,decoded (decode-time date))
|
||||||
(,days-in-month (ledger-schedule-days-in-month
|
(,days-in-month (ledger-schedule-days-in-month
|
||||||
(nth 4 ,decoded)
|
(nth 4 ,decoded)
|
||||||
(nth 5 ,decoded))))
|
(nth 5 ,decoded))))
|
||||||
(and (eq (nth 6 ,decoded) ,day-of-week)
|
(and (eq (nth 6 ,decoded) ,day-of-week)
|
||||||
(between (nth 3 ,decoded)
|
(between (nth 3 ,decoded)
|
||||||
(+ ,days-in-month ,(* count 7))
|
(+ ,days-in-month ,(* count 7))
|
||||||
(+ ,days-in-month ,(* (1+ count) 7)))))))
|
(+ ,days-in-month ,(* (1+ count) 7)))))))
|
||||||
(t
|
(t
|
||||||
(error "COUNT out of range, COUNT=%S" count)))
|
(error "COUNT out of range, COUNT=%S" count)))
|
||||||
(error "Invalid argument to ledger-schedule-day-in-month-macro %S %S"
|
(error "Invalid argument to ledger-schedule-day-in-month-macro %S %S"
|
||||||
count
|
count
|
||||||
day-of-week)))
|
day-of-week)))
|
||||||
|
|
||||||
(defun ledger-schedule-constrain-every-count-day (day-of-week skip start-date)
|
(defun ledger-schedule-constrain-every-count-day (day-of-week skip start-date)
|
||||||
|
|
@ -138,10 +144,10 @@ the transaction should be logged for that day."
|
||||||
(let ((date-descriptor "")
|
(let ((date-descriptor "")
|
||||||
(transaction nil)
|
(transaction nil)
|
||||||
(xact-start (match-end 0)))
|
(xact-start (match-end 0)))
|
||||||
(setq date-descriptors
|
(setq date-descriptors
|
||||||
(ledger-schedule-read-descriptor-tree
|
(ledger-schedule-read-descriptor-tree
|
||||||
(buffer-substring-no-properties
|
(buffer-substring-no-properties
|
||||||
(match-beginning 0)
|
(match-beginning 0)
|
||||||
(match-end 0))))
|
(match-end 0))))
|
||||||
(forward-paragraph)
|
(forward-paragraph)
|
||||||
(setq transaction (list date-descriptors
|
(setq transaction (list date-descriptors
|
||||||
|
|
@ -150,7 +156,7 @@ the transaction should be logged for that day."
|
||||||
(point))))
|
(point))))
|
||||||
(setq xact-list (cons transaction xact-list))))
|
(setq xact-list (cons transaction xact-list))))
|
||||||
xact-list)))
|
xact-list)))
|
||||||
|
|
||||||
(defun ledger-schedule-replace-brackets ()
|
(defun ledger-schedule-replace-brackets ()
|
||||||
"Replace all brackets with parens"
|
"Replace all brackets with parens"
|
||||||
(goto-char (point-min))
|
(goto-char (point-min))
|
||||||
|
|
@ -166,7 +172,7 @@ the transaction should be logged for that day."
|
||||||
"\\([\*]\\|\\([0-3][0-9]\\)\\|"
|
"\\([\*]\\|\\([0-3][0-9]\\)\\|"
|
||||||
"\\([0-5]"
|
"\\([0-5]"
|
||||||
"\\(\\(Su\\)\\|"
|
"\\(\\(Su\\)\\|"
|
||||||
"\\(Mo\\)\\|"
|
"\\(Mo\\)\\|"
|
||||||
"\\(Tu\\)\\|"
|
"\\(Tu\\)\\|"
|
||||||
"\\(We\\)\\|"
|
"\\(We\\)\\|"
|
||||||
"\\(Th\\)\\|"
|
"\\(Th\\)\\|"
|
||||||
|
|
@ -182,19 +188,19 @@ returns true if the date meets the requirements"
|
||||||
;; Replace brackets with parens
|
;; Replace brackets with parens
|
||||||
(insert descriptor-string)
|
(insert descriptor-string)
|
||||||
(ledger-schedule-replace-brackets)
|
(ledger-schedule-replace-brackets)
|
||||||
|
|
||||||
(goto-char (point-max))
|
(goto-char (point-max))
|
||||||
;; double quote all the descriptors for string processing later
|
;; double quote all the descriptors for string processing later
|
||||||
(while (re-search-backward ledger-schedule-descriptor-regex nil t) ;; Day slot
|
(while (re-search-backward ledger-schedule-descriptor-regex nil t) ;; Day slot
|
||||||
(goto-char
|
(goto-char
|
||||||
(match-end 0))
|
(match-end 0))
|
||||||
(insert ?\")
|
(insert ?\")
|
||||||
(goto-char (match-beginning 0))
|
(goto-char (match-beginning 0))
|
||||||
(insert "\"" )))
|
(insert "\"" )))
|
||||||
|
|
||||||
;; read the descriptor string into a lisp object the transform the
|
;; read the descriptor string into a lisp object the transform the
|
||||||
;; string descriptor into useable things
|
;; string descriptor into useable things
|
||||||
(ledger-schedule-transform-auto-tree
|
(ledger-schedule-transform-auto-tree
|
||||||
(read (buffer-substring-no-properties (point-min) (point-max))))))
|
(read (buffer-substring-no-properties (point-min) (point-max))))))
|
||||||
|
|
||||||
(defun ledger-schedule-transform-auto-tree (descriptor-string-list)
|
(defun ledger-schedule-transform-auto-tree (descriptor-string-list)
|
||||||
|
|
@ -207,7 +213,7 @@ returns true if the date meets the requirements"
|
||||||
(if (consp newcar)
|
(if (consp newcar)
|
||||||
(setq newcar (ledger-schedule-transform-auto-tree (car descriptor-string-list))))
|
(setq newcar (ledger-schedule-transform-auto-tree (car descriptor-string-list))))
|
||||||
;; newcar may be a cons now, after ledger-schedule-transfrom-auto-tree
|
;; newcar may be a cons now, after ledger-schedule-transfrom-auto-tree
|
||||||
(if (consp newcar)
|
(if (consp newcar)
|
||||||
(push newcar result)
|
(push newcar result)
|
||||||
;; this is where we actually turn the string descriptor into useful lisp
|
;; this is where we actually turn the string descriptor into useful lisp
|
||||||
(push (ledger-schedule-compile-constraints newcar) result)) )
|
(push (ledger-schedule-compile-constraints newcar) result)) )
|
||||||
|
|
@ -215,7 +221,7 @@ returns true if the date meets the requirements"
|
||||||
|
|
||||||
;; tie up all the clauses in a big or and lambda, and return
|
;; tie up all the clauses in a big or and lambda, and return
|
||||||
;; the lambda function as list to be executed by funcall
|
;; the lambda function as list to be executed by funcall
|
||||||
`(lambda (date)
|
`(lambda (date)
|
||||||
,(nconc (list 'or) (nreverse result) descriptor-string-list)))))
|
,(nconc (list 'or) (nreverse result) descriptor-string-list)))))
|
||||||
|
|
||||||
(defun ledger-schedule-compile-constraints (descriptor-string)
|
(defun ledger-schedule-compile-constraints (descriptor-string)
|
||||||
|
|
@ -238,8 +244,8 @@ returns true if the date meets the requirements"
|
||||||
(error "Improperly specified year constraint: " str)))))
|
(error "Improperly specified year constraint: " str)))))
|
||||||
|
|
||||||
(defun ledger-schedule-constrain-month (str)
|
(defun ledger-schedule-constrain-month (str)
|
||||||
|
|
||||||
(let ((month-match t))
|
(let ((month-match t))
|
||||||
(cond ((string= str "*")
|
(cond ((string= str "*")
|
||||||
month-match) ;; always match
|
month-match) ;; always match
|
||||||
((/= 0 (setq month-match (string-to-number str)))
|
((/= 0 (setq month-match (string-to-number str)))
|
||||||
|
|
@ -291,35 +297,10 @@ returns true if the date meets the requirements"
|
||||||
(ledger-mode))
|
(ledger-mode))
|
||||||
(length candidates)))
|
(length candidates)))
|
||||||
|
|
||||||
|
|
||||||
;;
|
|
||||||
;; Test harnesses for use in ielm
|
|
||||||
;;
|
|
||||||
(defvar auto-items)
|
|
||||||
|
|
||||||
(defun ledger-schedule-test ( early horizon)
|
|
||||||
(ledger-schedule-create-auto-buffer
|
|
||||||
(ledger-schedule-scan-transactions ledger-schedule-file)
|
|
||||||
early
|
|
||||||
horizon
|
|
||||||
(get-buffer "2013.ledger")))
|
|
||||||
|
|
||||||
|
|
||||||
(defun ledger-schedule-test-predict ()
|
|
||||||
(let ((today (current-time))
|
|
||||||
test-date items)
|
|
||||||
|
|
||||||
(loop for day from 0 to ledger-schedule-look-forward by 1 do
|
|
||||||
(setq test-date (time-add today (days-to-time day)))
|
|
||||||
(dolist (item auto-items items)
|
|
||||||
(if (funcall (car item) test-date)
|
|
||||||
(setq items (append items (list (decode-time test-date) (cdr item)))))))
|
|
||||||
items))
|
|
||||||
|
|
||||||
(defun ledger-schedule-upcoming ()
|
(defun ledger-schedule-upcoming ()
|
||||||
(interactive)
|
(interactive)
|
||||||
(ledger-schedule-create-auto-buffer
|
(ledger-schedule-create-auto-buffer
|
||||||
(ledger-schedule-scan-transactions ledger-schedule-file)
|
(ledger-schedule-scan-transactions ledger-schedule-file)
|
||||||
ledger-schedule-look-backward
|
ledger-schedule-look-backward
|
||||||
ledger-schedule-look-forward
|
ledger-schedule-look-forward
|
||||||
(current-buffer)))
|
(current-buffer)))
|
||||||
|
|
|
||||||
|
|
@ -49,7 +49,7 @@
|
||||||
(save-excursion
|
(save-excursion
|
||||||
(goto-char (point-min))
|
(goto-char (point-min))
|
||||||
(if (ledger-sort-find-start)
|
(if (ledger-sort-find-start)
|
||||||
(delete-region (match-beginning 0) (match-end 0))))
|
(delete-region (match-beginning 0) (match-end 0))))
|
||||||
(beginning-of-line)
|
(beginning-of-line)
|
||||||
(insert "\n; Ledger-mode: Start sort\n\n"))
|
(insert "\n; Ledger-mode: Start sort\n\n"))
|
||||||
|
|
||||||
|
|
@ -58,7 +58,7 @@
|
||||||
(save-excursion
|
(save-excursion
|
||||||
(goto-char (point-min))
|
(goto-char (point-min))
|
||||||
(if (ledger-sort-find-end)
|
(if (ledger-sort-find-end)
|
||||||
(delete-region (match-beginning 0) (match-end 0))))
|
(delete-region (match-beginning 0) (match-end 0))))
|
||||||
(beginning-of-line)
|
(beginning-of-line)
|
||||||
(insert "\n; Ledger-mode: End sort\n\n"))
|
(insert "\n; Ledger-mode: End sort\n\n"))
|
||||||
|
|
||||||
|
|
@ -69,57 +69,57 @@
|
||||||
(defun ledger-sort-region (beg end)
|
(defun ledger-sort-region (beg end)
|
||||||
"Sort the region from BEG to END in chronological order."
|
"Sort the region from BEG to END in chronological order."
|
||||||
(interactive "r") ;; load beg and end from point and mark
|
(interactive "r") ;; load beg and end from point and mark
|
||||||
;; automagically
|
;; automagically
|
||||||
(let ((new-beg beg)
|
(let ((new-beg beg)
|
||||||
(new-end end)
|
(new-end end)
|
||||||
point-delta
|
point-delta
|
||||||
(bounds (ledger-find-xact-extents (point)))
|
(bounds (ledger-find-xact-extents (point)))
|
||||||
target-xact)
|
target-xact)
|
||||||
|
|
||||||
(setq point-delta (- (point) (car bounds)))
|
(setq point-delta (- (point) (car bounds)))
|
||||||
(setq target-xact (buffer-substring (car bounds) (cadr bounds)))
|
(setq target-xact (buffer-substring (car bounds) (cadr bounds)))
|
||||||
(setq inhibit-modification-hooks t)
|
(setq inhibit-modification-hooks t)
|
||||||
(save-excursion
|
(save-excursion
|
||||||
(save-restriction
|
(save-restriction
|
||||||
(goto-char beg)
|
(goto-char beg)
|
||||||
(ledger-next-record-function) ;; make sure point is at the
|
(ledger-next-record-function) ;; make sure point is at the
|
||||||
;; beginning of a xact
|
;; beginning of a xact
|
||||||
(setq new-beg (point))
|
(setq new-beg (point))
|
||||||
(goto-char end)
|
(goto-char end)
|
||||||
(ledger-next-record-function) ;; make sure end of region is at
|
(ledger-next-record-function) ;; make sure end of region is at
|
||||||
;; the beginning of next record
|
;; the beginning of next record
|
||||||
;; after the region
|
;; after the region
|
||||||
(setq new-end (point))
|
(setq new-end (point))
|
||||||
(narrow-to-region new-beg new-end)
|
(narrow-to-region new-beg new-end)
|
||||||
(goto-char new-beg)
|
(goto-char new-beg)
|
||||||
|
|
||||||
(let ((inhibit-field-text-motion t))
|
(let ((inhibit-field-text-motion t))
|
||||||
(sort-subr
|
(sort-subr
|
||||||
nil
|
nil
|
||||||
'ledger-next-record-function
|
'ledger-next-record-function
|
||||||
'ledger-end-record-function
|
'ledger-end-record-function
|
||||||
'ledger-sort-startkey))))
|
'ledger-sort-startkey))))
|
||||||
|
|
||||||
(goto-char (point-min))
|
(goto-char (point-min))
|
||||||
(re-search-forward (regexp-quote target-xact))
|
(re-search-forward (regexp-quote target-xact))
|
||||||
(goto-char (+ (match-beginning 0) point-delta))
|
(goto-char (+ (match-beginning 0) point-delta))
|
||||||
(setq inhibit-modification-hooks nil)))
|
(setq inhibit-modification-hooks nil)))
|
||||||
|
|
||||||
(defun ledger-sort-buffer ()
|
(defun ledger-sort-buffer ()
|
||||||
"Sort the entire buffer."
|
"Sort the entire buffer."
|
||||||
(interactive)
|
(interactive)
|
||||||
(let (sort-start
|
(let (sort-start
|
||||||
sort-end)
|
sort-end)
|
||||||
(save-excursion
|
(save-excursion
|
||||||
(goto-char (point-min))
|
(goto-char (point-min))
|
||||||
(setq sort-start (ledger-sort-find-start)
|
(setq sort-start (ledger-sort-find-start)
|
||||||
sort-end (ledger-sort-find-end)))
|
sort-end (ledger-sort-find-end)))
|
||||||
(ledger-sort-region (if sort-start
|
(ledger-sort-region (if sort-start
|
||||||
sort-start
|
sort-start
|
||||||
(point-min))
|
(point-min))
|
||||||
(if sort-end
|
(if sort-end
|
||||||
sort-end
|
sort-end
|
||||||
(point-max)))))
|
(point-max)))))
|
||||||
|
|
||||||
(provide 'ldg-sort)
|
(provide 'ldg-sort)
|
||||||
|
|
||||||
|
|
|
||||||
110
lisp/ldg-xact.el
110
lisp/ldg-xact.el
|
|
@ -46,28 +46,28 @@ within the transaction."
|
||||||
(save-excursion
|
(save-excursion
|
||||||
(goto-char pos)
|
(goto-char pos)
|
||||||
(list (progn
|
(list (progn
|
||||||
(backward-paragraph)
|
(backward-paragraph)
|
||||||
(if (/= (point) (point-min))
|
(if (/= (point) (point-min))
|
||||||
(forward-line))
|
(forward-line))
|
||||||
(line-beginning-position))
|
(line-beginning-position))
|
||||||
(progn
|
(progn
|
||||||
(forward-paragraph)
|
(forward-paragraph)
|
||||||
(line-beginning-position)))))
|
(line-beginning-position)))))
|
||||||
|
|
||||||
(defun ledger-highlight-xact-under-point ()
|
(defun ledger-highlight-xact-under-point ()
|
||||||
"Move the highlight overlay to the current transaction."
|
"Move the highlight overlay to the current transaction."
|
||||||
(if ledger-highlight-xact-under-point
|
(if ledger-highlight-xact-under-point
|
||||||
(let ((exts (ledger-find-xact-extents (point)))
|
(let ((exts (ledger-find-xact-extents (point)))
|
||||||
(ovl highlight-overlay))
|
(ovl highlight-overlay))
|
||||||
(if (not highlight-overlay)
|
(if (not highlight-overlay)
|
||||||
(setq ovl
|
(setq ovl
|
||||||
(setq highlight-overlay
|
(setq highlight-overlay
|
||||||
(make-overlay (car exts)
|
(make-overlay (car exts)
|
||||||
(cadr exts)
|
(cadr exts)
|
||||||
(current-buffer) t nil)))
|
(current-buffer) t nil)))
|
||||||
(move-overlay ovl (car exts) (cadr exts)))
|
(move-overlay ovl (car exts) (cadr exts)))
|
||||||
(overlay-put ovl 'face 'ledger-font-xact-highlight-face)
|
(overlay-put ovl 'face 'ledger-font-xact-highlight-face)
|
||||||
(overlay-put ovl 'priority 100))))
|
(overlay-put ovl 'priority 100))))
|
||||||
|
|
||||||
(defun ledger-xact-payee ()
|
(defun ledger-xact-payee ()
|
||||||
"Return the payee of the transaction containing point or nil."
|
"Return the payee of the transaction containing point or nil."
|
||||||
|
|
@ -77,7 +77,7 @@ within the transaction."
|
||||||
(let ((context-info (ledger-context-other-line i)))
|
(let ((context-info (ledger-context-other-line i)))
|
||||||
(if (eq (ledger-context-line-type context-info) 'xact)
|
(if (eq (ledger-context-line-type context-info) 'xact)
|
||||||
(ledger-context-field-value context-info 'payee)
|
(ledger-context-field-value context-info 'payee)
|
||||||
nil))))
|
nil))))
|
||||||
|
|
||||||
(defun ledger-time-less-p (t1 t2)
|
(defun ledger-time-less-p (t1 t2)
|
||||||
"Say whether time value T1 is less than time value T2."
|
"Say whether time value T1 is less than time value T2."
|
||||||
|
|
@ -93,7 +93,7 @@ MOMENT is an encoded date"
|
||||||
(function
|
(function
|
||||||
(lambda (start date mark desc)
|
(lambda (start date mark desc)
|
||||||
(if (ledger-time-less-p moment date)
|
(if (ledger-time-less-p moment date)
|
||||||
(throw 'found t)))))))
|
(throw 'found t)))))))
|
||||||
|
|
||||||
(defun ledger-xact-iterate-transactions (callback)
|
(defun ledger-xact-iterate-transactions (callback)
|
||||||
"Iterate through each transaction call CALLBACK for each."
|
"Iterate through each transaction call CALLBACK for each."
|
||||||
|
|
@ -105,19 +105,19 @@ MOMENT is an encoded date"
|
||||||
(let ((found-y-p (match-string 2)))
|
(let ((found-y-p (match-string 2)))
|
||||||
(if found-y-p
|
(if found-y-p
|
||||||
(setq current-year (string-to-number found-y-p)) ;; a Y directive was found
|
(setq current-year (string-to-number found-y-p)) ;; a Y directive was found
|
||||||
(let ((start (match-beginning 0))
|
(let ((start (match-beginning 0))
|
||||||
(year (match-string 4))
|
(year (match-string 4))
|
||||||
(month (string-to-number (match-string 5)))
|
(month (string-to-number (match-string 5)))
|
||||||
(day (string-to-number (match-string 6)))
|
(day (string-to-number (match-string 6)))
|
||||||
(mark (match-string 7))
|
(mark (match-string 7))
|
||||||
(code (match-string 8))
|
(code (match-string 8))
|
||||||
(desc (match-string 9)))
|
(desc (match-string 9)))
|
||||||
(if (and year (> (length year) 0))
|
(if (and year (> (length year) 0))
|
||||||
(setq year (string-to-number year)))
|
(setq year (string-to-number year)))
|
||||||
(funcall callback start
|
(funcall callback start
|
||||||
(encode-time 0 0 0 day month
|
(encode-time 0 0 0 day month
|
||||||
(or year current-year))
|
(or year current-year))
|
||||||
mark desc)))))
|
mark desc)))))
|
||||||
(forward-line))))
|
(forward-line))))
|
||||||
|
|
||||||
(defsubst ledger-goto-line (line-number)
|
(defsubst ledger-goto-line (line-number)
|
||||||
|
|
@ -128,8 +128,8 @@ MOMENT is an encoded date"
|
||||||
(defun ledger-year-and-month ()
|
(defun ledger-year-and-month ()
|
||||||
(let ((sep (if ledger-use-iso-dates
|
(let ((sep (if ledger-use-iso-dates
|
||||||
"-"
|
"-"
|
||||||
"/")))
|
"/")))
|
||||||
(concat ledger-year sep ledger-month sep)))
|
(concat ledger-year sep ledger-month sep)))
|
||||||
|
|
||||||
(defun ledger-copy-transaction-at-point (date)
|
(defun ledger-copy-transaction-at-point (date)
|
||||||
"Ask for a new DATE and copy the transaction under point to that date. Leave point on the first amount."
|
"Ask for a new DATE and copy the transaction under point to that date. Leave point on the first amount."
|
||||||
|
|
@ -137,14 +137,14 @@ MOMENT is an encoded date"
|
||||||
(read-string "Copy to date: " (ledger-year-and-month)
|
(read-string "Copy to date: " (ledger-year-and-month)
|
||||||
'ledger-minibuffer-history)))
|
'ledger-minibuffer-history)))
|
||||||
(let* ((here (point))
|
(let* ((here (point))
|
||||||
(extents (ledger-find-xact-extents (point)))
|
(extents (ledger-find-xact-extents (point)))
|
||||||
(transaction (buffer-substring-no-properties (car extents) (cadr extents)))
|
(transaction (buffer-substring-no-properties (car extents) (cadr extents)))
|
||||||
encoded-date)
|
encoded-date)
|
||||||
(if (string-match ledger-iso-date-regexp date)
|
(if (string-match ledger-iso-date-regexp date)
|
||||||
(setq encoded-date
|
(setq encoded-date
|
||||||
(encode-time 0 0 0 (string-to-number (match-string 4 date))
|
(encode-time 0 0 0 (string-to-number (match-string 4 date))
|
||||||
(string-to-number (match-string 3 date))
|
(string-to-number (match-string 3 date))
|
||||||
(string-to-number (match-string 2 date)))))
|
(string-to-number (match-string 2 date)))))
|
||||||
(ledger-xact-find-slot encoded-date)
|
(ledger-xact-find-slot encoded-date)
|
||||||
(insert transaction "\n")
|
(insert transaction "\n")
|
||||||
(backward-paragraph 2)
|
(backward-paragraph 2)
|
||||||
|
|
@ -179,20 +179,20 @@ correct chronological place in the buffer."
|
||||||
(string-to-number (match-string 2 date)))))
|
(string-to-number (match-string 2 date)))))
|
||||||
(ledger-xact-find-slot date)))
|
(ledger-xact-find-slot date)))
|
||||||
(if (> (length args) 1)
|
(if (> (length args) 1)
|
||||||
(save-excursion
|
(save-excursion
|
||||||
(insert
|
(insert
|
||||||
(with-temp-buffer
|
(with-temp-buffer
|
||||||
(setq exit-code
|
(setq exit-code
|
||||||
(apply #'ledger-exec-ledger ledger-buf (current-buffer) "xact"
|
(apply #'ledger-exec-ledger ledger-buf (current-buffer) "xact"
|
||||||
(mapcar 'eval args)))
|
(mapcar 'eval args)))
|
||||||
(goto-char (point-min))
|
(goto-char (point-min))
|
||||||
(if (looking-at "Error: ")
|
(if (looking-at "Error: ")
|
||||||
(error (concat "Error in ledger-add-transaction: " (buffer-string)))
|
(error (concat "Error in ledger-add-transaction: " (buffer-string)))
|
||||||
(buffer-string)))
|
(buffer-string)))
|
||||||
"\n"))
|
"\n"))
|
||||||
(progn
|
(progn
|
||||||
(insert (car args) " \n\n")
|
(insert (car args) " \n\n")
|
||||||
(end-of-line -1)))))
|
(end-of-line -1)))))
|
||||||
|
|
||||||
|
|
||||||
(provide 'ldg-xact)
|
(provide 'ldg-xact)
|
||||||
|
|
|
||||||
Loading…
Add table
Reference in a new issue