sfos/ledger
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Formatting changes and initial inclusion of ledger-schedule

Browse source
This commit is contained in:
Craig Earls 2013-07-02 13:16:28 -07:00
parent a6cb179d8a
commit cf2fa5c32b
11 changed files with 746 additions and 761 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

138
lisp/ldg-commodities.el
View file

@ -34,50 +34,50 @@
:group 'ledger-reconcile)
(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")
(defun ledger-split-commodity-string (str)
"Split a commoditized string, STR, into two parts.
Returns a list with (value commodity)."
(let ((number-regex (if (assoc "decimal-comma" ledger-environment-alist)
ledger-amount-decimal-comma-regex
ledger-amount-decimal-period-regex)))
(if (> (length str) 0)
(with-temp-buffer
(insert str)
(goto-char (point-min))
(cond
((re-search-forward "\"\\(.*\\)\"" nil t) ; look for quoted commodities
(let ((com (delete-and-extract-region
(match-beginning 1)
(match-end 1))))
(if (re-search-forward
number-regex nil t)
(list
(ledger-string-to-number
(delete-and-extract-region (match-beginning 0) (match-end 0)))
com))))
((re-search-forward number-regex nil t)
;; found a number in the current locale, return it in the
;; car. Anything left over is annotation, the first
;; thing should be the commodity, separated by
;; whitespace, return it in the cdr. I can't think of
;; any counterexamples
(list
(ledger-string-to-number
(delete-and-extract-region (match-beginning 0) (match-end 0)))
(nth 0 (split-string (buffer-substring-no-properties (point-min) (point-max))))))
((re-search-forward "0" nil t)
;; couldn't find a decimal number, look for a single 0,
;; indicating account with zero balance
(list 0 ledger-reconcile-default-commodity))))
;; nothing found, return 0
(list 0 ledger-reconcile-default-commodity))))
ledger-amount-decimal-comma-regex
ledger-amount-decimal-period-regex)))
(if (> (length str) 0)
(with-temp-buffer
(insert str)
(goto-char (point-min))
(cond
((re-search-forward "\"\\(.*\\)\"" nil t) ; look for quoted commodities
(let ((com (delete-and-extract-region
(match-beginning 1)
(match-end 1))))
(if (re-search-forward
number-regex nil t)
(list
(ledger-string-to-number
(delete-and-extract-region (match-beginning 0) (match-end 0)))
com))))
((re-search-forward number-regex nil t)
;; found a number in the current locale, return it in the
;; car. Anything left over is annotation, the first
;; thing should be the commodity, separated by
;; whitespace, return it in the cdr. I can't think of
;; any counterexamples
(list
(ledger-string-to-number
(delete-and-extract-region (match-beginning 0) (match-end 0)))
(nth 0 (split-string (buffer-substring-no-properties (point-min) (point-max))))))
((re-search-forward "0" nil t)
;; couldn't find a decimal number, look for a single 0,
;; indicating account with zero balance
(list 0 ledger-reconcile-default-commodity))))
;; nothing found, return 0
(list 0 ledger-reconcile-default-commodity))))
(defun ledger-string-balance-to-commoditized-amount (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)
(ledger-split-commodity-string st))
(split-string str "[\n\r]")))
@ -85,8 +85,10 @@ Returns a list with (value commodity)."
(defun -commodity (c1 c2)
"Subtract C2 from C1, ensuring their commodities match."
(if (string= (cadr c1) (cadr c2))
; the scaling below is to get around inexact subtraction results where, for example
; 1.23 - 4.56 = -3.3299999999999996 instead of -3.33
; the scaling below is to get around inexact
; 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))
(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)))
(defun ledger-strip (str char)
(let (new-str)
(concat (dolist (ch (append str nil) new-str)
(unless (= ch char)
(setq new-str (append new-str (list ch))))))))
(let (new-str)
(concat (dolist (ch (append str nil) new-str)
(unless (= ch char)
(setq new-str (append new-str (list ch))))))))
(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"
(let ((nstr (if (or decimal-comma
(assoc "decimal-comma" ledger-environment-alist))
(ledger-strip str ?.)
(ledger-strip str ?,))))
(while (string-match "," nstr) ;if there is a comma now, it is a thousands separator
(setq nstr (replace-match "." nil nil nstr)))
(string-to-number nstr)))
"improve builtin string-to-number by handling internationalization, and return nil if number can't be parsed"
(let ((nstr (if (or decimal-comma
(assoc "decimal-comma" ledger-environment-alist))
(ledger-strip str ?.)
(ledger-strip str ?,))))
(while (string-match "," nstr) ;if there is a comma now, it is a thousands separator
(setq nstr (replace-match "." nil nil nstr)))
(string-to-number nstr)))
(defun ledger-number-to-string (n &optional decimal-comma)
(let ((str (number-to-string n)))
(if (or decimal-comma
(assoc "decimal-comma" ledger-environment-alist))
(while (string-match "\\." str)
(setq str (replace-match "," nil nil str)))
str)))
(let ((str (number-to-string n)))
(if (or decimal-comma
(assoc "decimal-comma" ledger-environment-alist))
(while (string-match "\\." str)
(setq str (replace-match "," nil nil str)))
str)))
(defun ledger-commodity-to-string (c1)
"Return string representing C1.
Single character commodities are placed ahead of the value,
longer ones are after the value."
(let ((str (ledger-number-to-string (car c1)))
(commodity (cadr c1)))
(if (> (length commodity) 1)
(concat str " " commodity)
(concat commodity " " str))))
(let ((str (ledger-number-to-string (car c1)))
(commodity (cadr c1)))
(if (> (length commodity) 1)
(concat str " " commodity)
(concat commodity " " str))))
(defun ledger-read-commodity-string (prompt)
(let ((str (read-from-minibuffer
(concat prompt " (" ledger-reconcile-default-commodity "): ")))
comm)
(concat prompt " (" ledger-reconcile-default-commodity "): ")))
comm)
(if (and (> (length str) 0)
(ledger-split-commodity-string str))
(progn
(setq comm (ledger-split-commodity-string str))
(if (cadr comm)
comm
(list (car comm) ledger-reconcile-default-commodity))))))
(ledger-split-commodity-string str))
(progn
(setq comm (ledger-split-commodity-string str))
(if (cadr comm)
comm
(list (car comm) ledger-reconcile-default-commodity))))))
(provide 'ldg-commodities)

164
lisp/ldg-complete.el
View file

@ -34,8 +34,8 @@
;; with pcomplete. See pcomplete-parse-arguments-function for
;; details
(let* ((begin (save-excursion
(ledger-thing-at-point) ;; leave point at beginning of thing under point
(point)))
(ledger-thing-at-point) ;; leave point at beginning of thing under point
(point)))
(end (point))
begins args)
;; to support end of line metadata
@ -65,42 +65,42 @@
(unless (and (>= origin (match-beginning 0))
(< origin (match-end 0)))
(setq payees-list (cons (match-string-no-properties 3)
payees-list))))) ;; add the payee
;; to the list
payees-list))))) ;; add the payee
;; to the list
(pcomplete-uniqify-list (nreverse payees-list))))
(defun ledger-find-accounts-in-buffer ()
(interactive)
(let ((origin (point))
accounts
(account-tree (list t))
(account-elements nil)
(seed-regex (ledger-account-any-status-with-seed-regex
(regexp-quote (car pcomplete-args)))))
(save-excursion
(goto-char (point-min))
(interactive)
(let ((origin (point))
accounts
(account-tree (list t))
(account-elements nil)
(seed-regex (ledger-account-any-status-with-seed-regex
(regexp-quote (car pcomplete-args)))))
(save-excursion
(goto-char (point-min))
(dolist (account
(delete-dups
(progn
(while (re-search-forward seed-regex nil t)
(unless (between origin (match-beginning 0) (match-end 0))
(setq accounts (cons (match-string-no-properties 2) accounts))))
accounts)))
(let ((root account-tree))
(dolist (account
(delete-dups
(progn
(while (re-search-forward seed-regex nil t)
(unless (between origin (match-beginning 0) (match-end 0))
(setq accounts (cons (match-string-no-properties 2) accounts))))
accounts)))
(let ((root account-tree))
(setq account-elements
(split-string
account ":"))
(while account-elements
(let ((xact (assoc (car account-elements) root)))
(if xact
(setq root (cdr xact))
(setq xact (cons (car account-elements) (list t)))
(nconc root (list xact))
(setq root (cdr xact))))
(setq account-elements (cdr account-elements))))))
account-tree))
(split-string
account ":"))
(while account-elements
(let ((xact (assoc (car account-elements) root)))
(if xact
(setq root (cdr xact))
(setq xact (cons (car account-elements) (list t)))
(nconc root (list xact))
(setq root (cdr xact))))
(setq account-elements (cdr account-elements))))))
account-tree))
(defun ledger-find-metadata-in-buffer ()
"Search through buffer and build list of metadata.
@ -129,19 +129,19 @@ Return list."
(setq prefix (concat prefix (and prefix ":")
(car elements))
root (cdr xact))
(setq root nil elements nil)))
(setq root nil elements nil)))
(setq elements (cdr elements)))
(setq root (delete (list (car elements) t) root))
(and root
(sort
(mapcar (function
(lambda (x)
(let ((term (if prefix
(concat prefix ":" (car x))
(car x))))
(if (> (length (cdr x)) 1)
(concat term ":")
term))))
(let ((term (if prefix
(concat prefix ":" (car x))
(car x))))
(if (> (length (cdr x)) 1)
(concat term ":")
term))))
(cdr root))
'string-lessp))))
@ -155,39 +155,39 @@ Return list."
(delete
(caar (ledger-parse-arguments))
(ledger-payees-in-buffer)) ;; this completes against payee names
(progn
(let ((text (buffer-substring-no-properties
(line-beginning-position)
(line-end-position))))
(delete-region (line-beginning-position)
(line-end-position))
(condition-case nil
(ledger-add-transaction text t)
(error nil)))
(forward-line)
(goto-char (line-end-position))
(search-backward ";" (line-beginning-position) t)
(skip-chars-backward " \t0123456789.,")
(throw 'pcompleted t)))
(ledger-accounts)))))
(progn
(let ((text (buffer-substring-no-properties
(line-beginning-position)
(line-end-position))))
(delete-region (line-beginning-position)
(line-end-position))
(condition-case nil
(ledger-add-transaction text t)
(error nil)))
(forward-line)
(goto-char (line-end-position))
(search-backward ";" (line-beginning-position) t)
(skip-chars-backward " \t0123456789.,")
(throw 'pcompleted t)))
(ledger-accounts)))))
(defun ledger-fully-complete-xact ()
"Completes a transaction if there is another matching payee in the buffer.
Does not use ledger xact"
(interactive)
(let* ((name (caar (ledger-parse-arguments)))
(rest-of-name name)
xacts)
(rest-of-name name)
xacts)
(save-excursion
(when (eq 'transaction (ledger-thing-at-point))
(delete-region (point) (+ (length name) (point)))
;; Search backward for a matching payee
(delete-region (point) (+ (length name) (point)))
;; Search backward for a matching payee
(when (re-search-backward
(concat "^[0-9/.=-]+\\(\\s-+\\*\\)?\\(\\s-+(.*?)\\)?\\s-+\\(.*"
(regexp-quote name) ".*\\)" ) nil t)
(setq rest-of-name (match-string 3))
(setq rest-of-name (match-string 3))
;; Start copying the postings
(forward-line)
(forward-line)
(while (looking-at ledger-account-any-status-regex)
(setq xacts (cons (buffer-substring-no-properties
(line-beginning-position)
@ -198,7 +198,7 @@ Does not use ledger xact"
;; Insert rest-of-name and the postings
(when xacts
(save-excursion
(insert rest-of-name ?\n)
(insert rest-of-name ?\n)
(while xacts
(insert (car xacts) ?\n)
(setq xacts (cdr xacts))))
@ -227,30 +227,30 @@ ledger-magic-tab would cycle properly"
(push (car (last pcomplete-current-completions))
pcomplete-current-completions)
(setcdr (last pcomplete-current-completions 2) nil))
(nconc pcomplete-current-completions
(list (car pcomplete-current-completions)))
(setq pcomplete-current-completions
(cdr pcomplete-current-completions)))
(nconc pcomplete-current-completions
(list (car pcomplete-current-completions)))
(setq pcomplete-current-completions
(cdr pcomplete-current-completions)))
(pcomplete-insert-entry pcomplete-last-completion-stub
(car pcomplete-current-completions)
nil pcomplete-last-completion-raw))
(setq pcomplete-current-completions nil
pcomplete-last-completion-raw nil)
(catch 'pcompleted
(let* ((pcomplete-stub)
pcomplete-seen pcomplete-norm-func
pcomplete-args pcomplete-last pcomplete-index
(pcomplete-autolist pcomplete-autolist)
(pcomplete-suffix-list pcomplete-suffix-list)
(completions (pcomplete-completions))
(result (pcomplete-do-complete pcomplete-stub completions)))
(and result
(not (eq (car result) 'listed))
(cdr result)
(pcomplete-insert-entry pcomplete-stub (cdr result)
(memq (car result)
'(sole shortest))
pcomplete-last-completion-raw))))))
(setq pcomplete-current-completions nil
pcomplete-last-completion-raw nil)
(catch 'pcompleted
(let* ((pcomplete-stub)
pcomplete-seen pcomplete-norm-func
pcomplete-args pcomplete-last pcomplete-index
(pcomplete-autolist pcomplete-autolist)
(pcomplete-suffix-list pcomplete-suffix-list)
(completions (pcomplete-completions))
(result (pcomplete-do-complete pcomplete-stub completions)))
(and result
(not (eq (car result) 'listed))
(cdr result)
(pcomplete-insert-entry pcomplete-stub (cdr result)
(memq (car result)
'(sole shortest))
pcomplete-last-completion-raw))))))
(provide 'ldg-complete)

16
lisp/ldg-context.el
View file

@ -51,14 +51,14 @@
(concat (symbol-name e) "-string")))))) "[ \t]*$")))
(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)
`'(,(concat (dolist (e elements regex-string)
(setq regex-string
(concat regex-string
(eval
(intern
(concat (symbol-name e) "-string")))))) "[ \t]*$")
(setq regex-string
(concat regex-string
(eval
(intern
(concat (symbol-name e) "-string")))))) "[ \t]*$")
,elements)))
(defmacro single-line-config (&rest elements)
@ -68,8 +68,8 @@
(defconst ledger-line-config
(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 payee)))
(single-line-config date nil status nil code nil payee)
(single-line-config date nil status nil payee)))
(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)

16
lisp/ldg-init.el
View file

@ -38,7 +38,7 @@
(let ((matchb (match-beginning 0)) ;; save the match data, string-match stamp on it
(matche (match-end 0)))
(end-of-line)
(setq environment-alist
(setq environment-alist
(append environment-alist
(list (cons (let ((flag (buffer-substring-no-properties (+ 2 matchb) matche)))
(if (string-match "[ \t\n\r]+\\'" flag)
@ -55,13 +55,13 @@
(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
(ledger-init-parse-initialization init-base-name)
(when (and ledger-init-file-name
(file-exists-p ledger-init-file-name)
(file-readable-p ledger-init-file-name))
(find-file-noselect ledger-init-file-name)
(setq ledger-environment-alist
(ledger-init-parse-initialization init-base-name))
(kill-buffer init-base-name)))))
(when (and ledger-init-file-name
(file-exists-p ledger-init-file-name)
(file-readable-p ledger-init-file-name))
(find-file-noselect ledger-init-file-name)
(setq ledger-environment-alist
(ledger-init-parse-initialization init-base-name))
(kill-buffer init-base-name)))))
(provide 'ldg-init)

260
lisp/ldg-mode.el
View file

@ -41,31 +41,31 @@
(defun ledger-read-account-with-prompt (prompt)
(let* ((context (ledger-context-at-point))
(default (if (and (eq (ledger-context-line-type context) 'acct-transaction)
(eq (ledger-context-current-field context) 'account))
(regexp-quote (ledger-context-field-value context 'account))
nil)))
(default (if (and (eq (ledger-context-line-type context) 'acct-transaction)
(eq (ledger-context-current-field context) 'account))
(regexp-quote (ledger-context-field-value context 'account))
nil)))
(ledger-read-string-with-default prompt default)))
(defun ledger-read-string-with-default (prompt default)
"Return user supplied string after PROMPT, or DEFAULT."
(read-string (concat prompt
(if default
(concat " (" default "): ")
": "))
nil 'ledger-minibuffer-history default))
(if default
(concat " (" default "): ")
": "))
nil 'ledger-minibuffer-history default))
(defun ledger-display-balance-at-point ()
"Display the cleared-or-pending balance.
And calculate the target-delta of the account being reconciled."
(interactive)
(let* ((account (ledger-read-account-with-prompt "Account balance to show"))
(buffer (current-buffer))
(balance (with-temp-buffer
(ledger-exec-ledger buffer (current-buffer) "cleared" account)
(if (> (buffer-size) 0)
(buffer-substring-no-properties (point-min) (1- (point-max)))
(concat account " is empty.")))))
(buffer (current-buffer))
(balance (with-temp-buffer
(ledger-exec-ledger buffer (current-buffer) "cleared" account)
(if (> (buffer-size) 0)
(buffer-substring-no-properties (point-min) (1- (point-max)))
(concat account " is empty.")))))
(when 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."
(interactive)
(let* ((buffer (current-buffer))
(balance (with-temp-buffer
(ledger-exec-ledger buffer (current-buffer) "stats")
(buffer-substring-no-properties (point-min) (1- (point-max))))))
(balance (with-temp-buffer
(ledger-exec-ledger buffer (current-buffer) "stats")
(buffer-substring-no-properties (point-min) (1- (point-max))))))
(when balance
(message balance))))
@ -84,144 +84,146 @@ And calculate the target-delta of the account being reconciled."
"Decide what to with with <TAB>.
Can indent, complete or align depending on context."
(interactive "p")
(if (= (point) (line-beginning-position))
(indent-to ledger-post-account-alignment-column)
(if (and (> (point) 1)
(looking-back "\\([^ \t]\\)" 1))
(ledger-pcomplete interactively)
(ledger-post-align-postings))))
(if (= (point) (line-beginning-position))
(indent-to ledger-post-account-alignment-column)
(if (and (> (point) 1)
(looking-back "\\([^ \t]\\)" 1))
(ledger-pcomplete interactively)
(ledger-post-align-postings))))
(defvar ledger-mode-abbrev-table)
(defun ledger-insert-effective-date ()
(interactive)
(let ((context (car (ledger-context-at-point)))
(date-string (format-time-string (cdr (assoc "date-format" ledger-environment-alist)))))
(cond ((eq 'xact context)
(beginning-of-line)
(insert date-string "="))
((eq 'acct-transaction context)
(end-of-line)
(insert " ; [=" date-string "]")))))
(date-string (format-time-string (cdr (assoc "date-format" ledger-environment-alist)))))
(cond ((eq 'xact context)
(beginning-of-line)
(insert date-string "="))
((eq 'acct-transaction context)
(end-of-line)
(insert " ; [=" date-string "]")))))
(defun ledger-mode-remove-extra-lines ()
(goto-char (point-min))
(while (re-search-forward "\n\n\\(\n\\)+" nil t)
(replace-match "\n\n")))
(goto-char (point-min))
(while (re-search-forward "\n\n\\(\n\\)+" nil t)
(replace-match "\n\n")))
(defun ledger-mode-clean-buffer ()
"indent, remove multiple linfe feeds and sort the buffer"
(interactive)
(ledger-sort-buffer)
(ledger-post-align-postings (point-min) (point-max))
(ledger-mode-remove-extra-lines))
"indent, remove multiple linfe feeds and sort the buffer"
(interactive)
(ledger-sort-buffer)
(ledger-post-align-postings (point-min) (point-max))
(ledger-mode-remove-extra-lines))
;;;###autoload
(define-derived-mode ledger-mode text-mode "Ledger"
"A mode for editing ledger data files."
(ledger-check-version)
(ledger-post-setup)
"A mode for editing ledger data files."
(ledger-check-version)
(ledger-check-schedule-available)
(ledger-post-setup)
(set (make-local-variable 'comment-start) " ; ")
(set (make-local-variable 'comment-end) "")
(set (make-local-variable 'indent-tabs-mode) nil)
(set (make-local-variable 'comment-start) " ; ")
(set (make-local-variable 'comment-end) "")
(set (make-local-variable 'indent-tabs-mode) nil)
(if (boundp 'font-lock-defaults)
(set (make-local-variable 'font-lock-defaults)
'(ledger-font-lock-keywords nil t)))
(setq font-lock-extend-region-functions
(list #'font-lock-extend-region-wholelines))
(setq font-lock-multiline nil)
(if (boundp 'font-lock-defaults)
(set (make-local-variable 'font-lock-defaults)
'(ledger-font-lock-keywords nil t)))
(setq font-lock-extend-region-functions
(list #'font-lock-extend-region-wholelines))
(setq font-lock-multiline nil)
(set (make-local-variable 'pcomplete-parse-arguments-function)
'ledger-parse-arguments)
(set (make-local-variable 'pcomplete-command-completion-function)
'ledger-complete-at-point)
(set (make-local-variable 'pcomplete-termination-string) "")
(set (make-local-variable 'pcomplete-parse-arguments-function)
'ledger-parse-arguments)
(set (make-local-variable 'pcomplete-command-completion-function)
'ledger-complete-at-point)
(set (make-local-variable 'pcomplete-termination-string) "")
(add-hook 'post-command-hook 'ledger-highlight-xact-under-point nil t)
(add-hook 'before-revert-hook 'ledger-occur-remove-all-overlays nil t)
(make-variable-buffer-local 'highlight-overlay)
(add-hook 'post-command-hook 'ledger-highlight-xact-under-point nil t)
(add-hook 'before-revert-hook 'ledger-occur-remove-all-overlays nil t)
(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)))
(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 ?c)] 'ledger-toggle-current)
(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 ?f)] 'ledger-occur)
(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 ?r)] 'ledger-reconcile)
(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 ?u)] 'ledger-schedule-upcoming)
(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 ?l)] 'ledger-display-ledger-stats)
(define-key map [(control ?c) (control ?q)] 'ledger-post-align-xact)
(let ((map (current-local-map)))
(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 ?c)] 'ledger-toggle-current)
(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 ?f)] 'ledger-occur)
(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 ?r)] 'ledger-reconcile)
(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 ?u)] 'ledger-schedule-upcoming)
(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 ?l)] 'ledger-display-ledger-stats)
(define-key map [(control ?c) (control ?q)] 'ledger-post-align-xact)
(define-key map [tab] 'ledger-magic-tab)
(define-key map [(control tab)] 'ledger-post-align-xact)
(define-key map [(control ?i)] 'ledger-magic-tab)
(define-key map [(control ?c) tab] 'ledger-fully-complete-xact)
(define-key map [(control ?c) (control ?i)] 'ledger-fully-complete-xact)
(define-key map [tab] 'ledger-magic-tab)
(define-key map [(control tab)] 'ledger-post-align-xact)
(define-key map [(control ?i)] 'ledger-magic-tab)
(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 ?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 ?g)] 'ledger-report-goto)
(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 ?s)] 'ledger-report-save)
(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 ?g)] 'ledger-report-goto)
(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 ?s)] 'ledger-report-save)
(define-key map [(meta ?p)] 'ledger-post-prev-xact)
(define-key map [(meta ?n)] 'ledger-post-next-xact)
(define-key map [(meta ?p)] 'ledger-post-prev-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 ldg-menu] (cons "Ledger" map))
(define-key map [menu-bar] (make-sparse-keymap "ldg-menu"))
(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-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-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-run] '(menu-item "Run Report" ledger-report :enable ledger-works))
(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-year] '(menu-item "Set Year" ledger-set-year :enable ledger-works))
(define-key map [cust] '(menu-item "Customize Ledger Mode" (lambda ()
(interactive)
(customize-group 'ledger))))
(define-key map [sep1] '("--"))
(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-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-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-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 [sep2] '(menu-item "--"))
(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-xact] '(menu-item "Toggle Current Transaction" ledger-toggle-current-transaction))
(define-key map [sep4] '(menu-item "--"))
(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 [sep6] '(menu-item "--"))
(define-key map [edit-amount] '(menu-item "Calc on Amount" ledger-post-edit-amount))
(define-key map [sep] '(menu-item "--"))
(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 [add-xact] '(menu-item "Add Transaction (ledger xact)" ledger-add-transaction :enable ledger-works))
(define-key map [sep3] '(menu-item "--"))
(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))))
(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-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-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 [sep5] '(menu-item "--"))
(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 [cust] '(menu-item "Customize Ledger Mode" (lambda ()
(interactive)
(customize-group 'ledger))))
(define-key map [sep1] '("--"))
(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-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-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-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 [sep2] '(menu-item "--"))
(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-xact] '(menu-item "Toggle Current Transaction" ledger-toggle-current-transaction))
(define-key map [sep4] '(menu-item "--"))
(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 [sep6] '(menu-item "--"))
(define-key map [edit-amount] '(menu-item "Calc on Amount" ledger-post-edit-amount))
(define-key map [sep] '(menu-item "--"))
(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 [add-xact] '(menu-item "Add Transaction (ledger xact)" ledger-add-transaction :enable ledger-works))
(define-key map [generate-scheduled] '(menu-item "Show Upcoming Transactions" ledger-schedule-upcoming :enable ledger-schedule-available))
(define-key map [sep3] '(menu-item "--"))
(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))))

94
lisp/ldg-occur.el
View file

@ -39,7 +39,7 @@
(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)
@ -65,19 +65,19 @@
When REGEX is nil, unhide everything, and remove higlight"
(set-buffer buffer)
(setq ledger-occur-mode
(if (or (null regex)
(zerop (length regex)))
nil
(concat " Ledger-Narrowed: " regex)))
(if (or (null regex)
(zerop (length regex)))
nil
(concat " Ledger-Narrowed: " regex)))
(force-mode-line-update)
(ledger-occur-remove-overlays)
(when ledger-occur-mode
(ledger-occur-create-overlays
(ledger-occur-compress-matches
(ledger-occur-find-matches regex)))
(setq ledger-occur-last-match regex)
(if (get-buffer-window buffer)
(select-window (get-buffer-window buffer))))
(ledger-occur-create-overlays
(ledger-occur-compress-matches
(ledger-occur-find-matches regex)))
(setq ledger-occur-last-match regex)
(if (get-buffer-window buffer)
(select-window (get-buffer-window buffer))))
(recenter))
(defun ledger-occur (regex)
@ -90,7 +90,7 @@ When REGEX is nil, unhide everything, and remove higlight"
(if ledger-occur-mode
(list nil)
(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)))
(defun ledger-occur-prompt ()
@ -108,32 +108,32 @@ When REGEX is nil, unhide everything, and remove higlight"
(if (= (line-number-at-pos pos1)
(line-number-at-pos pos2))
(buffer-substring-no-properties pos1 pos2)))
(current-word))))
(current-word))))
prompt))
(defun ledger-occur-make-visible-overlay (beg end)
(let ((ovl (make-overlay beg end (current-buffer))))
(overlay-put ovl ledger-occur-overlay-property-name t)
(overlay-put ovl 'face 'ledger-occur-xact-face)))
(let ((ovl (make-overlay beg end (current-buffer))))
(overlay-put ovl ledger-occur-overlay-property-name t)
(overlay-put ovl 'face 'ledger-occur-xact-face)))
(defun ledger-occur-make-invisible-overlay (beg end)
(let ((ovl (make-overlay beg end (current-buffer))))
(overlay-put ovl ledger-occur-overlay-property-name t)
(overlay-put ovl 'invisible t)))
(let ((ovl (make-overlay beg end (current-buffer))))
(overlay-put ovl ledger-occur-overlay-property-name t)
(overlay-put ovl 'invisible t)))
(defun ledger-occur-create-overlays (ovl-bounds)
"Create the overlays for the visible transactions.
Argument OVL-BOUNDS contains bounds for the transactions to be left visible."
(let* ((beg (caar ovl-bounds))
(end (cadar ovl-bounds)))
(ledger-occur-make-invisible-overlay (point-min) (1- beg))
(dolist (visible (cdr ovl-bounds))
(ledger-occur-make-visible-overlay beg end)
(ledger-occur-make-invisible-overlay (1+ end) (1- (car visible)))
(setq beg (car visible))
(setq end (cadr visible)))
(ledger-occur-make-invisible-overlay (1+ end) (point-max))))
(let* ((beg (caar ovl-bounds))
(end (cadar ovl-bounds)))
(ledger-occur-make-invisible-overlay (point-min) (1- beg))
(dolist (visible (cdr ovl-bounds))
(ledger-occur-make-visible-overlay beg end)
(ledger-occur-make-invisible-overlay (1+ end) (1- (car visible)))
(setq beg (car visible))
(setq end (cadr visible)))
(ledger-occur-make-invisible-overlay (1+ end) (point-max))))
(defun ledger-occur-quit-buffer (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."
(interactive)
(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))
(defun ledger-occur-find-matches (regex)
@ -157,35 +157,35 @@ Used for coordinating `ledger-occur' with other buffers, like reconcile."
(goto-char (point-min))
;; Set initial values for variables
(let (curpoint
endpoint
(lines (list)))
endpoint
(lines (list)))
;; Search loop
(while (not (eobp))
(setq curpoint (point))
;; if something found
(when (setq endpoint (re-search-forward regex nil 'end))
(save-excursion
(let ((bounds (ledger-find-xact-extents (match-beginning 0))))
(push bounds lines)
(setq curpoint (cadr bounds)))) ;; move to the end of
;; the xact, no need to
;; search inside it more
(let ((bounds (ledger-find-xact-extents (match-beginning 0))))
(push bounds lines)
(setq curpoint (cadr bounds)))) ;; move to the end of
;; the xact, no need to
;; search inside it more
(goto-char curpoint))
(forward-line 1))
(setq lines (nreverse lines)))))
(defun ledger-occur-compress-matches (buffer-matches)
"identify sequential xacts to reduce number of overlays required"
(let ((points (list))
(current-beginning (caar buffer-matches))
(current-end (cadar buffer-matches)))
(dolist (match (cdr buffer-matches))
(if (< (- (car match) current-end) 2)
(setq current-end (cadr match))
(push (list current-beginning current-end) points)
(setq current-beginning (car match))
(setq current-end (cadr match))))
(nreverse (push (list current-beginning current-end) points))))
"identify sequential xacts to reduce number of overlays required"
(let ((points (list))
(current-beginning (caar buffer-matches))
(current-end (cadar buffer-matches)))
(dolist (match (cdr buffer-matches))
(if (< (- (car match) current-end) 2)
(setq current-end (cadr match))
(push (list current-beginning current-end) points)
(setq current-beginning (car match))
(setq current-end (cadr match))))
(nreverse (push (list current-beginning current-end) points))))
(provide 'ldg-occur)

148
lisp/ldg-post.el
View file

@ -44,10 +44,10 @@
(defcustom ledger-post-use-completion-engine :built-in
"Which completion engine to use, :iswitchb or :ido chose those engines,
:built-in uses built-in Ledger-mode completion"
:type '(radio (const :tag "built in completion" :built-in)
(const :tag "ido completion" :ido)
(const :tag "iswitchb completion" :iswitchb) )
:group 'ledger-post)
:type '(radio (const :tag "built in completion" :built-in)
(const :tag "ido completion" :ido)
(const :tag "iswitchb completion" :iswitchb) )
:group 'ledger-post)
(defun ledger-post-all-accounts ()
"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
to choose from."
(cond ((eq ledger-post-use-completion-engine :iswitchb)
(let* ((iswitchb-use-virtual-buffers nil)
(iswitchb-make-buflist-hook
(lambda ()
(setq iswitchb-temp-buflist choices))))
(iswitchb-read-buffer prompt)))
((eq ledger-post-use-completion-engine :ido)
(ido-completing-read prompt choices))
(t
(completing-read prompt choices))))
(let* ((iswitchb-use-virtual-buffers nil)
(iswitchb-make-buflist-hook
(lambda ()
(setq iswitchb-temp-buflist choices))))
(iswitchb-read-buffer prompt)))
((eq ledger-post-use-completion-engine :ido)
(ido-completing-read prompt choices))
(t
(completing-read prompt choices))))
(defvar ledger-post-current-list nil)
@ -102,12 +102,12 @@ to choose from."
(match-end ledger-regex-post-line-group-account))
(insert account)
(cond
((> existing-len account-len)
(insert (make-string (- existing-len account-len) ? )))
((< existing-len account-len)
(dotimes (n (- account-len existing-len))
(if (looking-at "[ \t]\\( [ \t]\\|\t\\)")
(delete-char 1)))))))
((> existing-len account-len)
(insert (make-string (- existing-len account-len) ? )))
((< existing-len account-len)
(dotimes (n (- account-len existing-len))
(if (looking-at "[ \t]\\( [ \t]\\|\t\\)")
(delete-char 1)))))))
(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.
Return the column of the beginning of the account and leave point
at beginning of account"
(if (> end (point))
(when (re-search-forward ledger-account-any-status-regex (1+ end) t)
;; the 1+ is to make sure we can catch the newline
(if (match-beginning 1)
(goto-char (match-beginning 1))
(goto-char (match-beginning 2)))
(current-column))))
(if (> end (point))
(when (re-search-forward ledger-account-any-status-regex (1+ end) t)
;; the 1+ is to make sure we can catch the newline
(if (match-beginning 1)
(goto-char (match-beginning 1))
(goto-char (match-beginning 2)))
(current-column))))
(defun ledger-post-align-xact (pos)
(interactive "d")
(let ((bounds (ledger-find-xact-extents pos)))
(ledger-post-align-postings (car bounds) (cadr bounds))))
(interactive "d")
(let ((bounds (ledger-find-xact-extents pos)))
(ledger-post-align-postings (car bounds) (cadr bounds))))
(defun ledger-post-align-postings (&optional beg end)
"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
(if (or (not (mark))
(not (use-region-p)))
(set-mark (point)))
(not (use-region-p)))
(set-mark (point)))
(let* ((inhibit-modification-hooks t)
(mark-first (< (mark) (point)))
(begin-region (if beg
beg
(if mark-first (mark) (point))))
(end-region (if end
end
(if mark-first (point) (mark))))
acct-start-column acct-end-column acct-adjust amt-width
(lines-left 1))
(mark-first (< (mark) (point)))
(begin-region (if beg
beg
(if mark-first (mark) (point))))
(end-region (if end
end
(if mark-first (point) (mark))))
acct-start-column acct-end-column acct-adjust amt-width
(lines-left 1))
;; Condition point and mark to the beginning and end of lines
(goto-char end-region)
(setq end-region (line-end-position))
(goto-char begin-region)
(goto-char
(setq begin-region
(line-beginning-position)))
(line-beginning-position)))
;; This is the guts of the alignment loop
(while (and (or (setq acct-start-column (ledger-next-account (line-end-position)))
lines-left)
(< (point) end-region))
(when acct-start-column
(setq acct-end-column (save-excursion
(goto-char (match-end 2))
(current-column)))
(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
(if (> acct-adjust 0)
(insert (make-string acct-adjust ? ))
(delete-char acct-adjust)))
(when (setq amt-width (ledger-next-amount (line-end-position)))
(if (/= 0 (setq amt-adjust (- (if (> (- ledger-post-amount-alignment-column amt-width)
(+ 2 acct-end-column))
ledger-post-amount-alignment-column ;;we have room
(+ acct-end-column 2 amt-width))
amt-width
(current-column))))
(if (> amt-adjust 0)
(insert (make-string amt-adjust ? ))
(delete-char amt-adjust)))))
(forward-line)
(setq lines-left (not (eobp))))
lines-left)
(< (point) end-region))
(when acct-start-column
(setq acct-end-column (save-excursion
(goto-char (match-end 2))
(current-column)))
(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
(if (> acct-adjust 0)
(insert (make-string acct-adjust ? ))
(delete-char acct-adjust)))
(when (setq amt-width (ledger-next-amount (line-end-position)))
(if (/= 0 (setq amt-adjust (- (if (> (- ledger-post-amount-alignment-column amt-width)
(+ 2 acct-end-column))
ledger-post-amount-alignment-column ;;we have room
(+ acct-end-column 2 amt-width))
amt-width
(current-column))))
(if (> amt-adjust 0)
(insert (make-string amt-adjust ? ))
(delete-char amt-adjust)))))
(forward-line)
(setq lines-left (not (eobp))))
(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)))
;; determine if there is an amount to edit
(if end-of-amount
(let ((val (ledger-string-to-number (match-string 0))))
(goto-char (match-beginning 0))
(delete-region (match-beginning 0) (match-end 0))
(calc)
(calc-eval val 'push)) ;; edit the amount
(progn ;;make sure there are two spaces after the account name and go to calc
(if (search-backward " " (- (point) 3) t)
(goto-char (line-end-position))
(insert " "))
(calc))))))
(let ((val (ledger-string-to-number (match-string 0))))
(goto-char (match-beginning 0))
(delete-region (match-beginning 0) (match-end 0))
(calc)
(calc-eval val 'push)) ;; edit the amount
(progn ;;make sure there are two spaces after the account name and go to calc
(if (search-backward " " (- (point) 3) t)
(goto-char (line-end-position))
(insert " "))
(calc))))))
(defun ledger-post-prev-xact ()
"Move point to the previous transaction."

396
lisp/ldg-reconcile.el
View file

@ -33,7 +33,7 @@
(defvar ledger-target nil)
(defgroup ledger-reconcile nil
"Options for Ledger-mode reconciliation"
"Options for Ledger-mode reconciliation"
:group 'ledger)
(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
"If true then toggle between uncleared and pending.
reconcile-finish will mark all pending posting cleared."
:type 'boolean
:group 'ledger-reconcile)
:type 'boolean
:group 'ledger-reconcile)
(defcustom ledger-reconcile-default-date-format "%Y/%m/%d"
"Default date format for the reconcile buffer"
@ -73,7 +73,7 @@ reconcile-finish will mark all pending posting cleared."
:group 'ledger-reconcile)
(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)
"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
;; specify the individual fields in the command line.
(if (ledger-exec-ledger buffer (current-buffer)
"balance" "--limit" "cleared or pending" "--empty" "--collapse"
"--format" "%(display_total)" account)
(ledger-split-commodity-string
(buffer-substring-no-properties (point-min) (point-max))))))
"balance" "--limit" "cleared or pending" "--empty" "--collapse"
"--format" "%(display_total)" account)
(ledger-split-commodity-string
(buffer-substring-no-properties (point-min) (point-max))))))
(defun ledger-display-balance ()
"Display the cleared-or-pending balance.
@ -98,12 +98,12 @@ And calculate the target-delta of the account being reconciled."
(interactive)
(let* ((pending (ledger-reconcile-get-cleared-or-pending-balance ledger-buf ledger-acct)))
(when pending
(if ledger-target
(message "Pending balance: %s, Difference from target: %s"
(ledger-commodity-to-string pending)
(ledger-commodity-to-string (-commodity ledger-target pending)))
(message "Pending balance: %s"
(ledger-commodity-to-string pending))))))
(if ledger-target
(message "Pending balance: %s, Difference from target: %s"
(ledger-commodity-to-string pending)
(ledger-commodity-to-string (-commodity ledger-target pending)))
(message "Pending balance: %s"
(ledger-commodity-to-string pending))))))
(defun is-stdin (file)
"True if ledger FILE is standard input."
@ -127,27 +127,27 @@ And calculate the target-delta of the account being reconciled."
status)
(when (ledger-reconcile-get-buffer where)
(with-current-buffer (ledger-reconcile-get-buffer where)
(ledger-goto-line (cdr where))
(forward-char)
(setq status (ledger-toggle-current (if ledger-reconcile-toggle-to-pending
'pending
'cleared))))
;; remove the existing face and add the new face
(ledger-goto-line (cdr where))
(forward-char)
(setq status (ledger-toggle-current (if ledger-reconcile-toggle-to-pending
'pending
'cleared))))
;; remove the existing face and add the new face
(remove-text-properties (line-beginning-position)
(line-end-position)
(list 'face))
(line-end-position)
(list 'face))
(cond ((eq status 'pending)
(add-text-properties (line-beginning-position)
(line-end-position)
(list 'face 'ledger-font-reconciler-pending-face )))
((eq status 'cleared)
(add-text-properties (line-beginning-position)
(line-end-position)
(list 'face 'ledger-font-reconciler-cleared-face )))
(t
(add-text-properties (line-beginning-position)
(line-end-position)
(list 'face 'ledger-font-reconciler-uncleared-face )))))
(add-text-properties (line-beginning-position)
(line-end-position)
(list 'face 'ledger-font-reconciler-pending-face )))
((eq status 'cleared)
(add-text-properties (line-beginning-position)
(line-end-position)
(list 'face 'ledger-font-reconciler-cleared-face )))
(t
(add-text-properties (line-beginning-position)
(line-end-position)
(list 'face 'ledger-font-reconciler-uncleared-face )))))
(forward-line)
(beginning-of-line)
(ledger-display-balance)))
@ -159,18 +159,18 @@ Return the number of uncleared xacts found."
(let ((inhibit-read-only t))
(erase-buffer)
(prog1
(ledger-do-reconcile ledger-reconcile-sort-key)
(ledger-do-reconcile ledger-reconcile-sort-key)
(set-buffer-modified-p t))))
(defun ledger-reconcile-refresh-after-save ()
"Refresh the recon-window after the ledger buffer is saved."
(let ((curbuf (current-buffer))
(curpoint (point))
(recon-buf (get-buffer ledger-recon-buffer-name)))
(curpoint (point))
(recon-buf (get-buffer ledger-recon-buffer-name)))
(when (buffer-live-p recon-buf)
(with-current-buffer recon-buf
(ledger-reconcile-refresh)
(set-buffer-modified-p nil))
(ledger-reconcile-refresh)
(set-buffer-modified-p nil))
(select-window (get-buffer-window curbuf))
(goto-char curpoint))))
@ -200,19 +200,19 @@ Return the number of uncleared xacts found."
(progn
(beginning-of-line)
(let* ((where (get-text-property (1+ (point)) 'where))
(target-buffer (if where
(ledger-reconcile-get-buffer where)
nil))
(cur-win (get-buffer-window (get-buffer ledger-recon-buffer-name))))
(target-buffer (if where
(ledger-reconcile-get-buffer where)
nil))
(cur-win (get-buffer-window (get-buffer ledger-recon-buffer-name))))
(when target-buffer
(switch-to-buffer-other-window target-buffer)
(ledger-goto-line (cdr where))
(forward-char)
(recenter)
(ledger-highlight-xact-under-point)
(forward-char -1)
(if (and come-back cur-win)
(select-window cur-win))))))
(switch-to-buffer-other-window target-buffer)
(ledger-goto-line (cdr where))
(forward-char)
(recenter)
(ledger-highlight-xact-under-point)
(forward-char -1)
(if (and come-back cur-win)
(select-window cur-win))))))
(defun ledger-reconcile-save ()
"Save the ledger buffer."
@ -220,7 +220,7 @@ Return the number of uncleared xacts found."
(let ((curpoint (point)))
(dolist (buf (cons ledger-buf ledger-bufs))
(with-current-buffer buf
(save-buffer)))
(save-buffer)))
(with-current-buffer (get-buffer ledger-recon-buffer-name)
(set-buffer-modified-p nil)
(ledger-display-balance)
@ -243,94 +243,94 @@ and exit reconcile mode"
(ledger-toggle-current 'cleared))))
(forward-line 1)))
(ledger-reconcile-save)
(ledger-reconcile-quit))
(ledger-reconcile-quit))
(defun ledger-reconcile-quit ()
"Quit the reconcile window without saving ledger buffer."
(interactive)
(let ((recon-buf (get-buffer ledger-recon-buffer-name))
buf)
buf)
(if recon-buf
(with-current-buffer recon-buf
(ledger-reconcile-quit-cleanup)
(setq buf ledger-buf)
;; Make sure you delete the window before you delete the buffer,
;; otherwise, madness ensues
(delete-window (get-buffer-window recon-buf))
(kill-buffer recon-buf)
(set-window-buffer (selected-window) buf)))))
(with-current-buffer recon-buf
(ledger-reconcile-quit-cleanup)
(setq buf ledger-buf)
;; Make sure you delete the window before you delete the buffer,
;; otherwise, madness ensues
(delete-window (get-buffer-window recon-buf))
(kill-buffer recon-buf)
(set-window-buffer (selected-window) buf)))))
(defun ledger-reconcile-quit-cleanup ()
"Cleanup all hooks established by reconcile mode."
(interactive)
(let ((buf ledger-buf))
(if (buffer-live-p buf)
(with-current-buffer buf
(remove-hook 'after-save-hook 'ledger-reconcile-refresh-after-save t)
(when ledger-narrow-on-reconcile
(ledger-occur-quit-buffer buf)
(ledger-highlight-xact-under-point))))))
(with-current-buffer buf
(remove-hook 'after-save-hook 'ledger-reconcile-refresh-after-save t)
(when ledger-narrow-on-reconcile
(ledger-occur-quit-buffer buf)
(ledger-highlight-xact-under-point))))))
(defun ledger-marker-where-xact-is (emacs-xact posting)
"Find the position of the EMACS-XACT in the `ledger-buf'.
POSTING is used in `ledger-clear-whole-transactions' is nil."
(let ((buf (if (is-stdin (nth 0 emacs-xact))
ledger-buf
(find-file-noselect (nth 0 emacs-xact)))))
ledger-buf
(find-file-noselect (nth 0 emacs-xact)))))
(cons
buf
(if ledger-clear-whole-transactions
(nth 1 emacs-xact) ;; return line-no of xact
(nth 0 posting))))) ;; return line-no of posting
(nth 1 emacs-xact) ;; return line-no of xact
(nth 0 posting))))) ;; return line-no of posting
(defun ledger-do-reconcile (&optional sort)
"Return the number of uncleared transactions in the account and display them in the *Reconcile* buffer."
(let* ((buf ledger-buf)
(account ledger-acct)
(ledger-success nil)
(sort-by (if sort
sort
"(date)"))
(ledger-success nil)
(sort-by (if sort
sort
"(date)"))
(xacts
(with-temp-buffer
(when (ledger-exec-ledger buf (current-buffer)
"--uncleared" "--real" "emacs" "--sort" sort-by account)
(setq ledger-success t)
(goto-char (point-min))
(unless (eobp)
(if (looking-at "(")
(read (current-buffer)))))))) ;current-buffer is the *temp* created above
(when (ledger-exec-ledger buf (current-buffer)
"--uncleared" "--real" "emacs" "--sort" sort-by account)
(setq ledger-success t)
(goto-char (point-min))
(unless (eobp)
(if (looking-at "(")
(read (current-buffer)))))))) ;current-buffer is the *temp* created above
(if (and ledger-success (> (length xacts) 0))
(let ((date-format (cdr (assoc "date-format" ledger-environment-alist))))
(dolist (xact xacts)
(dolist (posting (nthcdr 5 xact))
(let ((beg (point))
(where (ledger-marker-where-xact-is xact posting)))
(insert (format "%s %-4s %-30s %-30s %15s\n"
(format-time-string (if date-format
date-format
ledger-reconcile-default-date-format) (nth 2 xact))
(if (nth 3 xact)
(nth 3 xact)
"")
(nth 4 xact) (nth 1 posting) (nth 2 posting)))
(if (nth 3 posting)
(if (eq (nth 3 posting) 'pending)
(set-text-properties beg (1- (point))
(list 'face 'ledger-font-reconciler-pending-face
'where where))
(set-text-properties beg (1- (point))
(list 'face 'ledger-font-reconciler-cleared-face
'where where)))
(set-text-properties beg (1- (point))
(list 'face 'ledger-font-reconciler-uncleared-face
'where where)))) ))
(goto-char (point-max))
(delete-char -1)) ;gets rid of the extra line feed at the bottom of the list
(if ledger-success
(insert (concat "There are no uncleared entries for " account))
(insert "Ledger has reported a problem. Check *Ledger Error* buffer.")))
(let ((date-format (cdr (assoc "date-format" ledger-environment-alist))))
(dolist (xact xacts)
(dolist (posting (nthcdr 5 xact))
(let ((beg (point))
(where (ledger-marker-where-xact-is xact posting)))
(insert (format "%s %-4s %-30s %-30s %15s\n"
(format-time-string (if date-format
date-format
ledger-reconcile-default-date-format) (nth 2 xact))
(if (nth 3 xact)
(nth 3 xact)
"")
(nth 4 xact) (nth 1 posting) (nth 2 posting)))
(if (nth 3 posting)
(if (eq (nth 3 posting) 'pending)
(set-text-properties beg (1- (point))
(list 'face 'ledger-font-reconciler-pending-face
'where where))
(set-text-properties beg (1- (point))
(list 'face 'ledger-font-reconciler-cleared-face
'where where)))
(set-text-properties beg (1- (point))
(list 'face 'ledger-font-reconciler-uncleared-face
'where where)))) ))
(goto-char (point-max))
(delete-char -1)) ;gets rid of the extra line feed at the bottom of the list
(if ledger-success
(insert (concat "There are no uncleared entries for " account))
(insert "Ledger has reported a problem. Check *Ledger Error* buffer.")))
(goto-char (point-min))
(set-buffer-modified-p nil)
(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
moved and recentered. If they aren't strange things happen."
(let ((recon-window (get-buffer-window (get-buffer ledger-recon-buffer-name))))
(when recon-window
(fit-window-to-buffer recon-window)
(with-current-buffer buf
(add-hook 'kill-buffer-hook 'ledger-reconcile-quit nil t)
(if (get-buffer-window buf)
(select-window (get-buffer-window buf)))
(goto-char (point-max))
(recenter -1))
(select-window recon-window)
(ledger-reconcile-visit t))
(add-hook 'post-command-hook 'ledger-reconcile-track-xact nil t)))
(let ((recon-window (get-buffer-window (get-buffer ledger-recon-buffer-name))))
(when recon-window
(fit-window-to-buffer recon-window)
(with-current-buffer buf
(add-hook 'kill-buffer-hook 'ledger-reconcile-quit nil t)
(if (get-buffer-window buf)
(select-window (get-buffer-window buf)))
(goto-char (point-max))
(recenter -1))
(select-window recon-window)
(ledger-reconcile-visit t))
(add-hook 'post-command-hook 'ledger-reconcile-track-xact nil t)))
(defun ledger-reconcile-track-xact ()
"Force the ledger buffer to recenter on the transaction at point in the reconcile buffer."
(if (and ledger-buffer-tracks-reconcile-buffer
(member this-command (list 'next-line
'previous-line
'mouse-set-point
'ledger-reconcile-toggle
'end-of-buffer
'beginning-of-buffer)))
(member this-command (list 'next-line
'previous-line
'mouse-set-point
'ledger-reconcile-toggle
'end-of-buffer
'beginning-of-buffer)))
(save-excursion
(ledger-reconcile-visit t))))
(ledger-reconcile-visit t))))
(defun ledger-reconcile-open-windows (buf 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."
(interactive)
(let ((account (ledger-read-account-with-prompt "Account to reconcile"))
(buf (current-buffer))
(buf (current-buffer))
(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
(with-current-buffer rbuf
(set 'ledger-acct account) ;; already buffer local
(when (not (eq buf rbuf))
;; called from some other ledger-mode buffer
(ledger-reconcile-quit-cleanup)
(set 'ledger-buf buf)) ;; should already be buffer-local
(with-current-buffer rbuf
(set 'ledger-acct account) ;; already buffer local
(when (not (eq buf rbuf))
;; called from some other ledger-mode buffer
(ledger-reconcile-quit-cleanup)
(set 'ledger-buf buf)) ;; should already be buffer-local
(unless (get-buffer-window rbuf)
(ledger-reconcile-open-windows buf rbuf)))
(unless (get-buffer-window rbuf)
(ledger-reconcile-open-windows buf rbuf)))
;; no recon-buffer, starting from scratch.
;; no recon-buffer, starting from scratch.
(with-current-buffer (setq rbuf
(get-buffer-create ledger-recon-buffer-name))
(ledger-reconcile-open-windows buf rbuf)
(ledger-reconcile-mode)
(make-local-variable 'ledger-target)
(set (make-local-variable 'ledger-buf) buf)
(set (make-local-variable 'ledger-acct) account)))
(with-current-buffer (setq rbuf
(get-buffer-create ledger-recon-buffer-name))
(ledger-reconcile-open-windows buf rbuf)
(ledger-reconcile-mode)
(make-local-variable 'ledger-target)
(set (make-local-variable 'ledger-buf) buf)
(set (make-local-variable 'ledger-acct) account)))
;; Narrow the ledger buffer
(with-current-buffer rbuf
(save-excursion
(if ledger-narrow-on-reconcile
(ledger-occur-mode account ledger-buf)))
(if ledger-narrow-on-reconcile
(ledger-occur-mode account ledger-buf)))
(if (> (ledger-reconcile-refresh) 0)
(ledger-reconcile-change-target))
(ledger-reconcile-change-target))
(ledger-display-balance))))
(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)))
(defmacro ledger-reconcile-change-sort-key-and-refresh (sort-by)
`(lambda ()
(interactive)
`(lambda ()
(interactive)
(setq ledger-reconcile-sort-key ,sort-by)
(ledger-reconcile-refresh)))
(setq ledger-reconcile-sort-key ,sort-by)
(ledger-reconcile-refresh)))
(define-derived-mode ledger-reconcile-mode text-mode "Reconcile"
"A mode for reconciling ledger entries."
(let ((map (make-sparse-keymap)))
(define-key map [(control ?m)] 'ledger-reconcile-visit)
(define-key map [return] 'ledger-reconcile-visit)
(define-key map [(control ?l)] 'ledger-reconcile-refresh)
(define-key map [(control ?c) (control ?c)] 'ledger-reconcile-finish)
(define-key map [? ] 'ledger-reconcile-toggle)
(define-key map [?a] 'ledger-reconcile-add)
(define-key map [?d] 'ledger-reconcile-delete)
(define-key map [?g] 'ledger-reconcile);
(define-key map [?n] 'next-line)
(define-key map [?p] 'previous-line)
(define-key map [?t] 'ledger-reconcile-change-target)
(define-key map [?s] 'ledger-reconcile-save)
(define-key map [?q] 'ledger-reconcile-quit)
(define-key map [?b] 'ledger-display-balance)
"A mode for reconciling ledger entries."
(let ((map (make-sparse-keymap)))
(define-key map [(control ?m)] 'ledger-reconcile-visit)
(define-key map [return] 'ledger-reconcile-visit)
(define-key map [(control ?l)] 'ledger-reconcile-refresh)
(define-key map [(control ?c) (control ?c)] 'ledger-reconcile-finish)
(define-key map [? ] 'ledger-reconcile-toggle)
(define-key map [?a] 'ledger-reconcile-add)
(define-key map [?d] 'ledger-reconcile-delete)
(define-key map [?g] 'ledger-reconcile);
(define-key map [?n] 'next-line)
(define-key map [?p] 'previous-line)
(define-key map [?t] 'ledger-reconcile-change-target)
(define-key map [?s] 'ledger-reconcile-save)
(define-key map [?q] 'ledger-reconcile-quit)
(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 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 sep1] '("--"))
(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 nex] '("Next Entry" . next-line))
(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 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 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-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 sep4] '("--"))
(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 sep5] '("--"))
(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 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 sav] '("Save" . ledger-reconcile-save))
(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 qui] '("Quit" . ledger-reconcile-quit))
(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 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 sep2] '("--"))
(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 tog] '("Toggle Entry" . ledger-reconcile-toggle))
(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-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 sep4] '("--"))
(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 sep5] '("--"))
(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 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 sav] '("Save" . ledger-reconcile-save))
(use-local-map map)))
(use-local-map map)))
(provide 'ldg-reconcile)

85
lisp/ldg-schedule.el
View file

@ -20,7 +20,7 @@
;; Boston, MA 02111-1307, USA.
;;; Commentary:
;;
;;
;; This module provides for automatically adding transactions to a
;; ledger buffer on a periodic basis. Recurrence expressions are
;; inspired by Martin Fowler's "Recurring Events for Calendars",
@ -49,14 +49,20 @@
:type 'integer
:group 'ledger-schedule)
(defcustom ledger-schedule-file "~/FinanceData/ledger-schedule.ledger"
(defcustom ledger-schedule-file "~/ledger-schedule.ledger"
"File to find scheduled transactions."
:type 'file
:group 'ledger-schedule)
(defvar ledger-schedule-available nil)
(defsubst between (val low 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)
"Return number of days in the MONTH, MONTH is from 1 to 12.
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)))
;; Macros to handle date expressions
(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.
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 (decode-time date)))
(and (eq (nth 6 ,decoded) ,day-of-week)
(between (nth 3 ,decoded)
,(* (1- count) 7)
(between (nth 3 ,decoded)
,(* (1- count) 7)
,(* count 7))))))
((< count 0)
((< count 0)
(let ((days-in-month (gensym))
(decoded (gensym)))
`(let* ((,decoded (decode-time date))
(,days-in-month (ledger-schedule-days-in-month
(nth 4 ,decoded)
(,days-in-month (ledger-schedule-days-in-month
(nth 4 ,decoded)
(nth 5 ,decoded))))
(and (eq (nth 6 ,decoded) ,day-of-week)
(between (nth 3 ,decoded)
(+ ,days-in-month ,(* count 7))
(between (nth 3 ,decoded)
(+ ,days-in-month ,(* count 7))
(+ ,days-in-month ,(* (1+ count) 7)))))))
(t
(error "COUNT out of range, COUNT=%S" count)))
(error "Invalid argument to ledger-schedule-day-in-month-macro %S %S"
count
(error "Invalid argument to ledger-schedule-day-in-month-macro %S %S"
count
day-of-week)))
(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 "")
(transaction nil)
(xact-start (match-end 0)))
(setq date-descriptors
(setq date-descriptors
(ledger-schedule-read-descriptor-tree
(buffer-substring-no-properties
(match-beginning 0)
(buffer-substring-no-properties
(match-beginning 0)
(match-end 0))))
(forward-paragraph)
(setq transaction (list date-descriptors
@ -150,7 +156,7 @@ the transaction should be logged for that day."
(point))))
(setq xact-list (cons transaction xact-list))))
xact-list)))
(defun ledger-schedule-replace-brackets ()
"Replace all brackets with parens"
(goto-char (point-min))
@ -166,7 +172,7 @@ the transaction should be logged for that day."
"\\([\*]\\|\\([0-3][0-9]\\)\\|"
"\\([0-5]"
"\\(\\(Su\\)\\|"
"\\(Mo\\)\\|"
"\\(Mo\\)\\|"
"\\(Tu\\)\\|"
"\\(We\\)\\|"
"\\(Th\\)\\|"
@ -182,19 +188,19 @@ returns true if the date meets the requirements"
;; Replace brackets with parens
(insert descriptor-string)
(ledger-schedule-replace-brackets)
(goto-char (point-max))
;; double quote all the descriptors for string processing later
(while (re-search-backward ledger-schedule-descriptor-regex nil t) ;; Day slot
(goto-char
(goto-char
(match-end 0))
(insert ?\")
(goto-char (match-beginning 0))
(insert "\"" )))
;; read the descriptor string into a lisp object the transform the
;; string descriptor into useable things
(ledger-schedule-transform-auto-tree
(ledger-schedule-transform-auto-tree
(read (buffer-substring-no-properties (point-min) (point-max))))))
(defun ledger-schedule-transform-auto-tree (descriptor-string-list)
@ -207,7 +213,7 @@ returns true if the date meets the requirements"
(if (consp newcar)
(setq newcar (ledger-schedule-transform-auto-tree (car descriptor-string-list))))
;; newcar may be a cons now, after ledger-schedule-transfrom-auto-tree
(if (consp newcar)
(if (consp newcar)
(push newcar result)
;; this is where we actually turn the string descriptor into useful lisp
(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
;; the lambda function as list to be executed by funcall
`(lambda (date)
`(lambda (date)
,(nconc (list 'or) (nreverse result) descriptor-string-list)))))
(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)))))
(defun ledger-schedule-constrain-month (str)
(let ((month-match t))
(let ((month-match t))
(cond ((string= str "*")
month-match) ;; always match
((/= 0 (setq month-match (string-to-number str)))
@ -291,35 +297,10 @@ returns true if the date meets the requirements"
(ledger-mode))
(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 ()
(interactive)
(ledger-schedule-create-auto-buffer
(ledger-schedule-scan-transactions ledger-schedule-file)
(ledger-schedule-create-auto-buffer
(ledger-schedule-scan-transactions ledger-schedule-file)
ledger-schedule-look-backward
ledger-schedule-look-forward
(current-buffer)))

80
lisp/ldg-sort.el
View file

@ -49,7 +49,7 @@
(save-excursion
(goto-char (point-min))
(if (ledger-sort-find-start)
(delete-region (match-beginning 0) (match-end 0))))
(delete-region (match-beginning 0) (match-end 0))))
(beginning-of-line)
(insert "\n; Ledger-mode: Start sort\n\n"))
@ -58,7 +58,7 @@
(save-excursion
(goto-char (point-min))
(if (ledger-sort-find-end)
(delete-region (match-beginning 0) (match-end 0))))
(delete-region (match-beginning 0) (match-end 0))))
(beginning-of-line)
(insert "\n; Ledger-mode: End sort\n\n"))
@ -69,57 +69,57 @@
(defun ledger-sort-region (beg end)
"Sort the region from BEG to END in chronological order."
(interactive "r") ;; load beg and end from point and mark
;; automagically
;; automagically
(let ((new-beg beg)
(new-end end)
point-delta
(bounds (ledger-find-xact-extents (point)))
target-xact)
(new-end end)
point-delta
(bounds (ledger-find-xact-extents (point)))
target-xact)
(setq point-delta (- (point) (car bounds)))
(setq target-xact (buffer-substring (car bounds) (cadr bounds)))
(setq inhibit-modification-hooks t)
(setq point-delta (- (point) (car bounds)))
(setq target-xact (buffer-substring (car bounds) (cadr bounds)))
(setq inhibit-modification-hooks t)
(save-excursion
(save-restriction
(goto-char beg)
(ledger-next-record-function) ;; make sure point is at the
;; beginning of a xact
(setq new-beg (point))
(goto-char end)
(ledger-next-record-function) ;; make sure end of region is at
;; the beginning of next record
;; after the region
(setq new-end (point))
(narrow-to-region new-beg new-end)
(goto-char new-beg)
(goto-char beg)
(ledger-next-record-function) ;; make sure point is at the
;; beginning of a xact
(setq new-beg (point))
(goto-char end)
(ledger-next-record-function) ;; make sure end of region is at
;; the beginning of next record
;; after the region
(setq new-end (point))
(narrow-to-region new-beg new-end)
(goto-char new-beg)
(let ((inhibit-field-text-motion t))
(sort-subr
nil
'ledger-next-record-function
'ledger-end-record-function
'ledger-sort-startkey))))
(let ((inhibit-field-text-motion t))
(sort-subr
nil
'ledger-next-record-function
'ledger-end-record-function
'ledger-sort-startkey))))
(goto-char (point-min))
(re-search-forward (regexp-quote target-xact))
(goto-char (+ (match-beginning 0) point-delta))
(goto-char (point-min))
(re-search-forward (regexp-quote target-xact))
(goto-char (+ (match-beginning 0) point-delta))
(setq inhibit-modification-hooks nil)))
(defun ledger-sort-buffer ()
"Sort the entire buffer."
(interactive)
(let (sort-start
sort-end)
(save-excursion
(goto-char (point-min))
(setq sort-start (ledger-sort-find-start)
sort-end (ledger-sort-find-end)))
sort-end)
(save-excursion
(goto-char (point-min))
(setq sort-start (ledger-sort-find-start)
sort-end (ledger-sort-find-end)))
(ledger-sort-region (if sort-start
sort-start
(point-min))
(if sort-end
sort-end
(point-max)))))
sort-start
(point-min))
(if sort-end
sort-end
(point-max)))))
(provide 'ldg-sort)

110
lisp/ldg-xact.el
View file

@ -46,28 +46,28 @@ within the transaction."
(save-excursion
(goto-char pos)
(list (progn
(backward-paragraph)
(if (/= (point) (point-min))
(forward-line))
(line-beginning-position))
(progn
(forward-paragraph)
(line-beginning-position)))))
(backward-paragraph)
(if (/= (point) (point-min))
(forward-line))
(line-beginning-position))
(progn
(forward-paragraph)
(line-beginning-position)))))
(defun ledger-highlight-xact-under-point ()
"Move the highlight overlay to the current transaction."
(if ledger-highlight-xact-under-point
(let ((exts (ledger-find-xact-extents (point)))
(ovl highlight-overlay))
(if (not highlight-overlay)
(setq ovl
(setq highlight-overlay
(make-overlay (car exts)
(cadr exts)
(current-buffer) t nil)))
(move-overlay ovl (car exts) (cadr exts)))
(overlay-put ovl 'face 'ledger-font-xact-highlight-face)
(overlay-put ovl 'priority 100))))
(ovl highlight-overlay))
(if (not highlight-overlay)
(setq ovl
(setq highlight-overlay
(make-overlay (car exts)
(cadr exts)
(current-buffer) t nil)))
(move-overlay ovl (car exts) (cadr exts)))
(overlay-put ovl 'face 'ledger-font-xact-highlight-face)
(overlay-put ovl 'priority 100))))
(defun ledger-xact-payee ()
"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)))
(if (eq (ledger-context-line-type context-info) 'xact)
(ledger-context-field-value context-info 'payee)
nil))))
nil))))
(defun ledger-time-less-p (t1 t2)
"Say whether time value T1 is less than time value T2."
@ -93,7 +93,7 @@ MOMENT is an encoded date"
(function
(lambda (start date mark desc)
(if (ledger-time-less-p moment date)
(throw 'found t)))))))
(throw 'found t)))))))
(defun ledger-xact-iterate-transactions (callback)
"Iterate through each transaction call CALLBACK for each."
@ -105,19 +105,19 @@ MOMENT is an encoded date"
(let ((found-y-p (match-string 2)))
(if found-y-p
(setq current-year (string-to-number found-y-p)) ;; a Y directive was found
(let ((start (match-beginning 0))
(year (match-string 4))
(month (string-to-number (match-string 5)))
(day (string-to-number (match-string 6)))
(mark (match-string 7))
(code (match-string 8))
(desc (match-string 9)))
(if (and year (> (length year) 0))
(setq year (string-to-number year)))
(funcall callback start
(encode-time 0 0 0 day month
(or year current-year))
mark desc)))))
(let ((start (match-beginning 0))
(year (match-string 4))
(month (string-to-number (match-string 5)))
(day (string-to-number (match-string 6)))
(mark (match-string 7))
(code (match-string 8))
(desc (match-string 9)))
(if (and year (> (length year) 0))
(setq year (string-to-number year)))
(funcall callback start
(encode-time 0 0 0 day month
(or year current-year))
mark desc)))))
(forward-line))))
(defsubst ledger-goto-line (line-number)
@ -128,8 +128,8 @@ MOMENT is an encoded date"
(defun ledger-year-and-month ()
(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)
"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)
'ledger-minibuffer-history)))
(let* ((here (point))
(extents (ledger-find-xact-extents (point)))
(transaction (buffer-substring-no-properties (car extents) (cadr extents)))
encoded-date)
(extents (ledger-find-xact-extents (point)))
(transaction (buffer-substring-no-properties (car extents) (cadr extents)))
encoded-date)
(if (string-match ledger-iso-date-regexp date)
(setq encoded-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 2 date)))))
(setq encoded-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 2 date)))))
(ledger-xact-find-slot encoded-date)
(insert transaction "\n")
(backward-paragraph 2)
@ -179,20 +179,20 @@ correct chronological place in the buffer."
(string-to-number (match-string 2 date)))))
(ledger-xact-find-slot date)))
(if (> (length args) 1)
(save-excursion
(insert
(with-temp-buffer
(setq exit-code
(apply #'ledger-exec-ledger ledger-buf (current-buffer) "xact"
(mapcar 'eval args)))
(goto-char (point-min))
(if (looking-at "Error: ")
(error (concat "Error in ledger-add-transaction: " (buffer-string)))
(buffer-string)))
"\n"))
(progn
(insert (car args) " \n\n")
(end-of-line -1)))))
(save-excursion
(insert
(with-temp-buffer
(setq exit-code
(apply #'ledger-exec-ledger ledger-buf (current-buffer) "xact"
(mapcar 'eval args)))
(goto-char (point-min))
(if (looking-at "Error: ")
(error (concat "Error in ledger-add-transaction: " (buffer-string)))
(buffer-string)))
"\n"))
(progn
(insert (car args) " \n\n")
(end-of-line -1)))))
(provide 'ldg-xact)