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

Merge pull request #292 from thdox/fix-lisp-indentation

Browse source 
Thank Thierry,
   I don't know when these got messed up but I have been meaning to do just this for some time.
This commit is contained in:
Craig Earls 2014-05-17 08:14:23 -07:00
commit 6a8b2a5fb0
18 changed files with 1146 additions and 1146 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

114
lisp/ledger-commodities.el
View file

@ -42,75 +42,75 @@ This is a cheap way of getting around floating point silliness in subtraction"
"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)))
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))))
(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]")))
(ledger-split-commodity-string st))
(split-string str "[\n\r]")))
(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)))
(error "Can't subtract different commodities %S from %S" c2 c1)))
(defun +commodity (c1 c2)
"Add C1 and C2, ensuring their commodities match."
(if (string= (cadr c1) (cadr c2))
(list (+ (car c1) (car c2)) (cadr c1))
(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)
(let (new-str)
(concat (dolist (ch (append str nil) new-str)
(unless (= ch char)
(setq new-str (append new-str (list ch))))))))
(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 ?,))))
(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)))
@ -128,22 +128,22 @@ Returns a list with (value commodity)."
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)))
(commodity (cadr c1)))
(if (> (length commodity) 1)
(concat str " " commodity)
(concat commodity " " str))))
(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 'ledger-commodities)

194
lisp/ledger-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,7 +65,7 @@
(unless (and (>= origin (match-beginning 0))
(< origin (match-end 0)))
(setq payees-list (cons (match-string-no-properties 3)
payees-list))))) ;; add the payee
payees-list))))) ;; add the payee
;; to the list
(pcomplete-uniqify-list (nreverse payees-list))))
@ -73,33 +73,33 @@
(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)))))
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))
(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))))))
(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 ()
@ -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,44 +155,44 @@ 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-trim-trailing-whitespace (str)
(let ((s str))
(when (string-match "[ \t]*$" s)
(replace-match "" nil nil s))))
(let ((s str))
(when (string-match "[ \t]*$" s)
(replace-match "" nil nil s))))
(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 (ledger-trim-trailing-whitespace (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)
@ -203,7 +203,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))))
@ -214,54 +214,54 @@ Does not use ledger xact"
(defcustom ledger-complete-ignore-case t
"Non-nil means that ledger-complete-at-point will be case-insensitive"
:type 'boolean
:group 'ledger)
"Non-nil means that ledger-complete-at-point will be case-insensitive"
:type 'boolean
:group 'ledger)
(defun ledger-pcomplete (&optional interactively)
"Complete rip-off of pcomplete from pcomplete.el, only added
ledger-magic-tab in the previous commands list so that
ledger-magic-tab would cycle properly"
(interactive "p")
(let ((pcomplete-ignore-case ledger-complete-ignore-case))
(if (and interactively
pcomplete-cycle-completions
pcomplete-current-completions
(memq last-command '(ledger-magic-tab
ledger-pcomplete
pcomplete-expand-and-complete
pcomplete-reverse)))
(progn
(delete-backward-char pcomplete-last-completion-length)
(if (eq this-command 'pcomplete-reverse)
(progn
(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)))
(pcomplete-insert-entry pcomplete-last-completion-stub
(car pcomplete-current-completions)
nil pcomplete-last-completion-raw))
(let ((pcomplete-ignore-case ledger-complete-ignore-case))
(if (and interactively
pcomplete-cycle-completions
pcomplete-current-completions
(memq last-command '(ledger-magic-tab
ledger-pcomplete
pcomplete-expand-and-complete
pcomplete-reverse)))
(progn
(delete-backward-char pcomplete-last-completion-length)
(if (eq this-command 'pcomplete-reverse)
(progn
(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)))
(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)
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)))))))
(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 'ledger-complete)

24
lisp/ledger-context.el
View file

@ -54,16 +54,16 @@
(defconst ledger-line-config
(list (list 'xact (list (ledger-single-line-config date nil status nil code nil payee nil comment)
(ledger-single-line-config date nil status nil code nil payee)
(ledger-single-line-config date nil status nil payee)))
(list 'acct-transaction (list (ledger-single-line-config indent comment)
(ledger-single-line-config indent status account nil commodity amount nil comment)
(ledger-single-line-config indent status account nil commodity amount)
(ledger-single-line-config indent status account nil amount nil commodity comment)
(ledger-single-line-config indent status account nil amount nil commodity)
(ledger-single-line-config indent status account nil amount)
(ledger-single-line-config indent status account nil comment)
(ledger-single-line-config indent status account)))))
(ledger-single-line-config date nil status nil code nil payee)
(ledger-single-line-config date nil status nil payee)))
(list 'acct-transaction (list (ledger-single-line-config indent comment)
(ledger-single-line-config indent status account nil commodity amount nil comment)
(ledger-single-line-config indent status account nil commodity amount)
(ledger-single-line-config indent status account nil amount nil commodity comment)
(ledger-single-line-config indent status account nil amount nil commodity)
(ledger-single-line-config indent status account nil amount)
(ledger-single-line-config indent status account nil comment)
(ledger-single-line-config indent status account)))))
(defun ledger-extract-context-info (line-type pos)
"Get context info for current line with LINE-TYPE.
@ -97,7 +97,7 @@ Leave point at the beginning of the thing under point"
(let ((here (point)))
(goto-char (line-beginning-position))
(cond ((looking-at "^[0-9/.=-]+\\(\\s-+\\*\\)?\\(\\s-+(.+?)\\)?\\s-+")
(goto-char (match-end 0))
(goto-char (match-end 0))
'transaction)
((looking-at "^\\s-+\\([*!]\\s-+\\)?[[(]?\\([^\\s-]\\)")
(goto-char (match-beginning 2))
@ -162,7 +162,7 @@ specified line, returns nil."
(let ((left (forward-line offset)))
(if (not (equal left 0))
nil
(ledger-context-at-point)))))
(ledger-context-at-point)))))
(defun ledger-context-line-type (context-info)
(nth 0 context-info))

60
lisp/ledger-exec.el
View file

@ -36,9 +36,9 @@
:group 'ledger)
(defcustom ledger-mode-should-check-version t
"Should Ledger-mode verify that the executable is working"
:type 'boolean
:group 'ledger-exec)
"Should Ledger-mode verify that the executable is working"
:type 'boolean
:group 'ledger-exec)
(defcustom ledger-binary-path "ledger"
"Path to the ledger executable."
@ -56,26 +56,26 @@
(with-current-buffer ledger-output-buffer
(goto-char (point-min))
(if (and (> (buffer-size) 1) (looking-at (regexp-quote "While")))
nil ;; failure, there is an error starting with "While"
ledger-output-buffer)))
nil ;; failure, there is an error starting with "While"
ledger-output-buffer)))
(defun ledger-exec-ledger (input-buffer &optional output-buffer &rest args)
"Run Ledger using INPUT-BUFFER and optionally capturing output in OUTPUT-BUFFER with ARGS."
(if (null ledger-binary-path)
(error "The variable `ledger-binary-path' has not been set")
(let ((buf (or input-buffer (current-buffer)))
(outbuf (or output-buffer
(generate-new-buffer " *ledger-tmp*"))))
(with-current-buffer buf
(let ((coding-system-for-write 'utf-8)
(coding-system-for-read 'utf-8))
(apply #'call-process-region
(append (list (point-min) (point-max)
ledger-binary-path nil outbuf nil "-f" "-")
args)))
(if (ledger-exec-success-p outbuf)
outbuf
(ledger-exec-handle-error outbuf))))))
(let ((buf (or input-buffer (current-buffer)))
(outbuf (or output-buffer
(generate-new-buffer " *ledger-tmp*"))))
(with-current-buffer buf
(let ((coding-system-for-write 'utf-8)
(coding-system-for-read 'utf-8))
(apply #'call-process-region
(append (list (point-min) (point-max)
ledger-binary-path nil outbuf nil "-f" "-")
args)))
(if (ledger-exec-success-p outbuf)
outbuf
(ledger-exec-handle-error outbuf))))))
(defun ledger-version-greater-p (needed)
"Verify the ledger binary is usable for `ledger-mode' (version greater than NEEDED)."
@ -83,24 +83,24 @@
(version-strings '()))
(with-temp-buffer
(when (ledger-exec-ledger (current-buffer) (current-buffer) "--version")
(goto-char (point-min))
(delete-horizontal-space)
(setq version-strings (split-string
(buffer-substring-no-properties (point)
(point-max))))
(if (and (string-match (regexp-quote "Ledger") (car version-strings))
(or (string= needed (cadr version-strings))
(string< needed (cadr version-strings))))
t ;; success
nil))))) ;;failure
(goto-char (point-min))
(delete-horizontal-space)
(setq version-strings (split-string
(buffer-substring-no-properties (point)
(point-max))))
(if (and (string-match (regexp-quote "Ledger") (car version-strings))
(or (string= needed (cadr version-strings))
(string< needed (cadr version-strings))))
t ;; success
nil))))) ;;failure
(defun ledger-check-version ()
"Verify that ledger works and is modern enough."
(interactive)
(if ledger-mode-should-check-version
(if (setq ledger-works (ledger-version-greater-p ledger-version-needed))
(message "Good Ledger Version")
(message "Bad Ledger Version"))))
(message "Good Ledger Version")
(message "Bad Ledger Version"))))
(provide 'ledger-exec)

72
lisp/ledger-fonts.el
View file

@ -30,108 +30,108 @@
(defgroup ledger-faces nil "Ledger mode highlighting" :group 'ledger)
(defface ledger-font-payee-uncleared-face
`((t :foreground "#dc322f" :weight bold ))
`((t :foreground "#dc322f" :weight bold ))
"Default face for Ledger"
:group 'ledger-faces)
(defface ledger-font-payee-cleared-face
`((t :foreground "#657b83" :weight normal ))
`((t :foreground "#657b83" :weight normal ))
"Default face for cleared (*) transactions"
:group 'ledger-faces)
(defface ledger-font-xact-highlight-face
`((((background dark)) :background "#1a1a1a" )
(t :background "#eee8d5"))
`((((background dark)) :background "#1a1a1a" )
(t :background "#eee8d5"))
"Default face for transaction under point"
:group 'ledger-faces)
(defface ledger-font-pending-face
`((t :foreground "#cb4b16" :weight normal ))
`((t :foreground "#cb4b16" :weight normal ))
"Default face for pending (!) transactions"
:group 'ledger-faces)
(defface ledger-font-other-face
`((t :foreground "#657b83" ))
`((t :foreground "#657b83" ))
"Default face for other transactions"
:group 'ledger-faces)
(defface ledger-font-posting-account-face
`((t :foreground "#268bd2" ))
`((t :foreground "#268bd2" ))
"Face for Ledger accounts"
:group 'ledger-faces)
(defface ledger-font-posting-account-cleared-face
`((t :foreground "#657b83" ))
`((t :foreground "#657b83" ))
"Face for Ledger accounts"
:group 'ledger-faces)
(defface ledger-font-posting-account-pending-face
`((t :foreground "#cb4b16" ))
`((t :foreground "#cb4b16" ))
"Face for Ledger accounts"
:group 'ledger-faces)
(defface ledger-font-posting-amount-face
`((t :foreground "#cb4b16" ))
`((t :foreground "#cb4b16" ))
"Face for Ledger amounts"
:group 'ledger-faces)
(defface ledger-occur-narrowed-face
`((t :foreground "grey70" :invisible t ))
`((t :foreground "grey70" :invisible t ))
"Default face for Ledger occur mode hidden transactions"
:group 'ledger-faces)
(defface ledger-occur-xact-face
`((((background dark)) :background "#1a1a1a" )
(t :background "#eee8d5" ))
`((((background dark)) :background "#1a1a1a" )
(t :background "#eee8d5" ))
"Default face for Ledger occur mode shown transactions"
:group 'ledger-faces)
(defface ledger-font-comment-face
`((t :foreground "#93a1a1" :slant italic))
`((t :foreground "#93a1a1" :slant italic))
"Face for Ledger comments"
:group 'ledger-faces)
(defface ledger-font-reconciler-uncleared-face
`((t :foreground "#dc322f" :weight bold ))
`((t :foreground "#dc322f" :weight bold ))
"Default face for uncleared transactions in the reconcile window"
:group 'ledger-faces)
(defface ledger-font-reconciler-cleared-face
`((t :foreground "#657b83" :weight normal ))
`((t :foreground "#657b83" :weight normal ))
"Default face for cleared (*) transactions in the reconcile window"
:group 'ledger-faces)
(defface ledger-font-reconciler-pending-face
`((t :foreground "#cb4b16" :weight normal ))
`((t :foreground "#cb4b16" :weight normal ))
"Default face for pending (!) transactions in the reconcile window"
:group 'ledger-faces)
(defface ledger-font-report-clickable-face
`((t :foreground "#cb4b16" :weight normal ))
`((t :foreground "#cb4b16" :weight normal ))
"Default face for pending (!) transactions in the reconcile window"
:group 'ledger-faces)
(defvar ledger-font-lock-keywords
`( ;; (,ledger-other-entries-regex 1
;; ledger-font-other-face)
(,ledger-comment-regex 0
'ledger-font-comment-face)
(,ledger-multiline-comment-regex 0 'ledger-font-comment-face)
(,ledger-payee-pending-regex 2
'ledger-font-payee-pending-face) ; Works
(,ledger-payee-cleared-regex 2
'ledger-font-payee-cleared-face) ; Works
(,ledger-payee-uncleared-regex 2
'ledger-font-payee-uncleared-face) ; Works
(,ledger-account-cleared-regex 2
'ledger-font-posting-account-cleared-face) ; Works
(,ledger-account-pending-regex 2
'ledger-font-posting-account-pending-face) ; Works
(,ledger-account-any-status-regex 2
'ledger-font-posting-account-face) ; Works
(,ledger-other-entries-regex 1
'ledger-font-other-face))
;; ledger-font-other-face)
(,ledger-comment-regex 0
'ledger-font-comment-face)
(,ledger-multiline-comment-regex 0 'ledger-font-comment-face)
(,ledger-payee-pending-regex 2
'ledger-font-payee-pending-face) ; Works
(,ledger-payee-cleared-regex 2
'ledger-font-payee-cleared-face) ; Works
(,ledger-payee-uncleared-regex 2
'ledger-font-payee-uncleared-face) ; Works
(,ledger-account-cleared-regex 2
'ledger-font-posting-account-cleared-face) ; Works
(,ledger-account-pending-regex 2
'ledger-font-posting-account-pending-face) ; Works
(,ledger-account-any-status-regex 2
'ledger-font-posting-account-face) ; Works
(,ledger-other-entries-regex 1
'ledger-font-other-face))
"Expressions to highlight in Ledger mode.")

42
lisp/ledger-init.el
View file

@ -37,34 +37,34 @@
(let (environment-alist)
(goto-char (point-min))
(while (re-search-forward ledger-init-string-regex nil t )
(let ((matchb (match-beginning 0)) ;; save the match data, string-match stamp on it
(matche (match-end 0)))
(end-of-line)
(setq environment-alist
(append environment-alist
(list (cons (let ((flag (buffer-substring-no-properties (+ 2 matchb) matche)))
(if (string-match "[ \t\n\r]+\\'" flag)
(replace-match "" t t flag)
flag))
(let ((value (buffer-substring-no-properties matche (point) )))
(if (> (length value) 0)
value
t))))))))
(let ((matchb (match-beginning 0)) ;; save the match data, string-match stamp on it
(matche (match-end 0)))
(end-of-line)
(setq environment-alist
(append environment-alist
(list (cons (let ((flag (buffer-substring-no-properties (+ 2 matchb) matche)))
(if (string-match "[ \t\n\r]+\\'" flag)
(replace-match "" t t flag)
flag))
(let ((value (buffer-substring-no-properties matche (point) )))
(if (> (length value) 0)
value
t))))))))
environment-alist)))
(defun ledger-init-load-init-file ()
(interactive)
(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
(setq ledger-environment-alist
(setq ledger-environment-alist
(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 'ledger-init)

172
lisp/ledger-mode.el
View file

@ -60,17 +60,17 @@
(defun ledger-mode-dump-variable (var)
(if var
(insert (format " %s: %S\n" (symbol-name var) (eval var)))))
(insert (format " %s: %S\n" (symbol-name var) (eval var)))))
(defun ledger-mode-dump-group (group)
"Dump GROUP customizations to current buffer"
(let ((members (custom-group-members group nil)))
(dolist (member members)
(cond ((eq (cadr member) 'custom-group)
(insert (format "Group %s:\n" (symbol-name (car member))))
(ledger-mode-dump-group (car member)))
((eq (cadr member) 'custom-variable)
(ledger-mode-dump-variable (car member)))))))
(insert (format "Group %s:\n" (symbol-name (car member))))
(ledger-mode-dump-group (car member)))
((eq (cadr member) 'custom-variable)
(ledger-mode-dump-variable (car member)))))))
(defun ledger-mode-dump-configuration ()
"Dump all customizations"
@ -93,10 +93,10 @@
(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-date (prompt)
@ -114,22 +114,22 @@
(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))))
@ -138,9 +138,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))))
@ -150,17 +150,17 @@ 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 (and (> (point) 1)
(looking-back "\\([^ \t]\\)" 1))
(ledger-pcomplete interactively)
(ledger-post-align-postings))))
(defvar ledger-mode-abbrev-table)
(defvar ledger-date-string-today
(format-time-string (or
(cdr (assoc "date-format" ledger-environment-alist))
ledger-default-date-format)))
(cdr (assoc "date-format" ledger-environment-alist))
ledger-default-date-format)))
(defun ledger-remove-effective-date ()
"Removes the effective date from a transaction or posting."
@ -228,47 +228,47 @@ With a prefix argument, remove the effective date. "
(defvar ledger-mode-syntax-table
(let ((table (make-syntax-table)))
;; Support comments via the syntax table
(modify-syntax-entry ?\; "< b" table)
(modify-syntax-entry ?\n "> b" table)
table)
"Syntax table for `ledger-mode' buffers.")
(let ((table (make-syntax-table)))
;; Support comments via the syntax table
(modify-syntax-entry ?\; "< b" table)
(modify-syntax-entry ?\n "> b" table)
table)
"Syntax table for `ledger-mode' buffers.")
(defvar ledger-mode-map
(let ((map (make-sparse-keymap)))
(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 [(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)
map)
"Keymap for `ledger-mode'.")
@ -315,35 +315,35 @@ With a prefix argument, remove the effective date. "
;;;###autoload
(define-derived-mode ledger-mode text-mode "Ledger"
"A mode for editing ledger data files."
(ledger-check-version)
(ledger-schedule-check-available)
(ledger-post-setup)
"A mode for editing ledger data files."
(ledger-check-version)
(ledger-schedule-check-available)
(ledger-post-setup)
(set-syntax-table ledger-mode-syntax-table)
(set (make-local-variable 'comment-start) "; ")
(set (make-local-variable 'comment-end) "")
(set (make-local-variable 'indent-tabs-mode) nil)
(set-syntax-table ledger-mode-syntax-table)
(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)
(add-hook 'completion-at-point-functions 'pcomplete-completions-at-point nil t)
(set (make-local-variable 'pcomplete-parse-arguments-function)
'ledger-parse-arguments)
(set (make-local-variable 'pcomplete-command-completion-function)
'ledger-complete-at-point)
(add-hook 'completion-at-point-functions 'pcomplete-completions-at-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 'post-command-hook 'ledger-highlight-xact-under-point nil t)
(add-hook 'before-revert-hook 'ledger-occur-remove-all-overlays nil t)
(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))
(defun ledger-set-year (newyear)

46
lisp/ledger-occur.el
View file

@ -65,10 +65,10 @@
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
@ -77,7 +77,7 @@ When REGEX is nil, unhide everything, and remove higlight"
(ledger-occur-find-matches regex)))
(setq ledger-occur-last-match regex)
(if (get-buffer-window buffer)
(select-window (get-buffer-window buffer))))
(select-window (get-buffer-window buffer))))
(recenter))
(defun ledger-occur (regex)
@ -89,8 +89,8 @@ When REGEX is nil, unhide everything, and remove higlight"
(interactive
(if ledger-occur-mode
(list nil)
(list (read-string (concat "Regexp<" (ledger-occur-prompt) ">: ")
nil 'ledger-occur-history (ledger-occur-prompt)))))
(list (read-string (concat "Regexp<" (ledger-occur-prompt) ">: ")
nil 'ledger-occur-history (ledger-occur-prompt)))))
(ledger-occur-mode regex (current-buffer)))
(defun ledger-occur-prompt ()
@ -108,7 +108,7 @@ 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))
@ -126,7 +126,7 @@ When REGEX is nil, unhide everything, and remove higlight"
"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)))
(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)
@ -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,19 +157,19 @@ 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)))))
@ -177,14 +177,14 @@ Used for coordinating `ledger-occur' with other buffers, like reconcile."
(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)))
(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))))
(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 'ledger-occur)

134
lisp/ledger-post.el
View file

@ -45,8 +45,8 @@
"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) )
(const :tag "ido completion" :ido)
(const :tag "iswitchb completion" :iswitchb) )
:group 'ledger-post)
(defun ledger-post-all-accounts ()
@ -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)))
@ -131,11 +131,11 @@ 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))))
;; 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")
@ -150,52 +150,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))))
@ -209,16 +209,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-string (match-string 0)))
(goto-char (match-beginning 0))
(delete-region (match-beginning 0) (match-end 0))
(calc)
(calc-eval val-string '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-string (match-string 0)))
(goto-char (match-beginning 0))
(delete-region (match-beginning 0) (match-end 0))
(calc)
(calc-eval val-string '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."

334
lisp/ledger-reconcile.el
View file

@ -76,9 +76,9 @@ reconcile-finish will mark all pending posting cleared."
:group 'ledger-reconcile)
(defcustom ledger-reconcile-sort-key "(date)"
"Default key for sorting reconcile buffer. For no sorting by default, use '(0)'."
:type 'string
:group 'ledger-reconcile)
"Default key for sorting reconcile buffer. For no sorting by default, use '(0)'."
:type 'string
:group 'ledger-reconcile)
(defcustom ledger-reconcile-insert-effective-date nil
"If t, prompt for effective date when clearing transactions during reconciliation."
@ -97,10 +97,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.
@ -109,11 +109,11 @@ And calculate the target-delta of the account being reconciled."
(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))))))
(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 ledger-is-stdin (file)
"True if ledger FILE is standard input."
@ -126,7 +126,7 @@ And calculate the target-delta of the account being reconciled."
"Return a buffer from WHERE the transaction is."
(if (bufferp (car where))
(car where)
(error "Function ledger-reconcile-get-buffer: Buffer not set")))
(error "Function ledger-reconcile-get-buffer: Buffer not set")))
(defun ledger-reconcile-toggle ()
"Toggle the current transaction, and mark the recon window."
@ -137,30 +137,30 @@ 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)))
(when ledger-reconcile-insert-effective-date
;; Ask for effective date & insert it
(ledger-insert-effective-date)))
(ledger-goto-line (cdr where))
(forward-char)
(setq status (ledger-toggle-current (if ledger-reconcile-toggle-to-pending
'pending
'cleared)))
(when ledger-reconcile-insert-effective-date
;; Ask for effective date & insert it
(ledger-insert-effective-date)))
;; 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)))
@ -172,18 +172,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))))
@ -206,7 +206,7 @@ Return the number of uncleared xacts found."
(goto-char (line-beginning-position))
(delete-region (point) (1+ (line-end-position)))
(set-buffer-modified-p t))
(ledger-reconcile-refresh))))
(ledger-reconcile-refresh))))
(defun ledger-reconcile-visit (&optional come-back)
"Recenter ledger buffer on transaction and COME-BACK if non-nil."
@ -214,19 +214,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."
@ -234,7 +234,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)
@ -264,88 +264,88 @@ and exit reconcile mode"
"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 (ledger-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 (or (cdr (assoc "date-format" ledger-environment-alist))
ledger-default-date-format)))
(dolist (xact xacts)
(dolist (posting (nthcdr 5 xact))
(let ((beg (point))
(where (ledger-marker-where-xact-is xact posting)))
(insert (format "%s %-4s %-50s %-30s %15s\n"
(format-time-string date-format (nth 2 xact))
(if (nth 3 xact)
(nth 3 xact)
"")
(truncate-string-to-width
(nth 4 xact) 49)
(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 (or (cdr (assoc "date-format" ledger-environment-alist))
ledger-default-date-format)))
(dolist (xact xacts)
(dolist (posting (nthcdr 5 xact))
(let ((beg (point))
(where (ledger-marker-where-xact-is xact posting)))
(insert (format "%s %-4s %-50s %-30s %15s\n"
(format-time-string date-format (nth 2 xact))
(if (nth 3 xact)
(nth 3 xact)
"")
(truncate-string-to-width
(nth 4 xact) 49)
(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)
@ -363,11 +363,11 @@ moved and recentered. If they aren't strange things happen."
(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))
(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)))
@ -375,59 +375,59 @@ moved and recentered. If they aren't strange things happen."
(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."
(if ledger-reconcile-force-window-bottom
;;create the *Reconcile* window directly below the ledger buffer.
(set-window-buffer (split-window (get-buffer-window buf) nil nil) rbuf)
(pop-to-buffer rbuf)))
(pop-to-buffer rbuf)))
(defun ledger-reconcile ()
"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)
(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)
@ -445,31 +445,31 @@ moved and recentered. If they aren't strange things happen."
(ledger-reconcile-refresh)))
(defvar ledger-reconcile-mode-map
(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)
(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 ?o)] (ledger-reconcile-change-sort-key-and-refresh "(0)"))
(define-key map [(control ?c) (control ?o)] (ledger-reconcile-change-sort-key-and-refresh "(0)"))
(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)"))
map)
"Keymap for `ledger-reconcile-mode'.")
(define-key map [(control ?c) (control ?p)] (ledger-reconcile-change-sort-key-and-refresh "(payee)"))
map)
"Keymap for `ledger-reconcile-mode'.")
(easy-menu-define ledger-reconcile-mode-menu ledger-reconcile-mode-map
"Ledger reconcile menu"
@ -500,7 +500,7 @@ moved and recentered. If they aren't strange things happen."
))
(define-derived-mode ledger-reconcile-mode text-mode "Reconcile"
"A mode for reconciling ledger entries.")
"A mode for reconciling ledger entries.")
(provide 'ledger-reconcile)

362
lisp/ledger-regex.el
View file

@ -26,12 +26,12 @@
(defconst ledger-amount-regex
(concat "\\( \\|\t\\| \t\\)[ \t]*-?"
"\\([A-Z$€£_]+ *\\)?"
"\\(-?[0-9,\\.]+?\\)"
"\\(.[0-9]+\\)?"
"\\( *[[:word:]€£_\"]+\\)?"
"\\([ \t]*[@={]@?[^\n;]+?\\)?"
"\\([ \t]+;.+?\\|[ \t]*\\)?$"))
"\\([A-Z$€£_]+ *\\)?"
"\\(-?[0-9,\\.]+?\\)"
"\\(.[0-9]+\\)?"
"\\( *[[:word:]€£_\"]+\\)?"
"\\([ \t]*[@={]@?[^\n;]+?\\)?"
"\\([ \t]+;.+?\\|[ \t]*\\)?$"))
(defconst ledger-amount-decimal-comma-regex
"-?[1-9][0-9.]*[,]?[0-9]*")
@ -83,10 +83,10 @@
(defmacro ledger-define-regexp (name regex docs &rest args)
"Simplify the creation of a Ledger regex and helper functions."
(let ((defs
(list
`(defconst
,(intern (concat "ledger-" (symbol-name name) "-regexp"))
,(eval regex))))
(list
`(defconst
,(intern (concat "ledger-" (symbol-name name) "-regexp"))
,(eval regex))))
(addend 0) last-group)
(if (null args)
(progn
@ -94,242 +94,242 @@
defs
(list
`(defconst
,(intern
(concat "ledger-regex-" (symbol-name name) "-group"))
,(intern
(concat "ledger-regex-" (symbol-name name) "-group"))
1)))
(nconc
defs
(list
`(defconst
,(intern (concat "ledger-regex-" (symbol-name name)
"-group--count"))
,(intern (concat "ledger-regex-" (symbol-name name)
"-group--count"))
1)))
(nconc
defs
(list
`(defmacro
,(intern (concat "ledger-regex-" (symbol-name name)))
(&optional string)
,(intern (concat "ledger-regex-" (symbol-name name)))
(&optional string)
,(format "Return the match string for the %s" name)
(match-string
,(intern (concat "ledger-regex-" (symbol-name name)
"-group"))
string)))))
(dolist (arg args)
(let (var grouping target)
(if (symbolp arg)
(setq var arg target arg)
(assert (listp arg))
(if (= 2 (length arg))
(setq var (car arg)
target (cadr arg))
(setq var (car arg)
grouping (cadr arg)
target (caddr arg))))
(dolist (arg args)
(let (var grouping target)
(if (symbolp arg)
(setq var arg target arg)
(assert (listp arg))
(if (= 2 (length arg))
(setq var (car arg)
target (cadr arg))
(setq var (car arg)
grouping (cadr arg)
target (caddr arg))))
(if (and last-group
(not (eq last-group (or grouping target))))
(incf addend
(symbol-value
(intern-soft (concat "ledger-regex-"
(symbol-name last-group)
"-group--count")))))
(nconc
defs
(list
`(defconst
,(intern (concat "ledger-regex-" (symbol-name name)
"-group-" (symbol-name var)))
,(+ addend
(symbol-value
(intern-soft
(if grouping
(concat "ledger-regex-" (symbol-name grouping)
"-group-" (symbol-name target))
(concat "ledger-regex-" (symbol-name target)
"-group"))))))))
(nconc
defs
(list
`(defmacro
,(intern (concat "ledger-regex-" (symbol-name name)
"-" (symbol-name var)))
(&optional string)
,(format "Return the sub-group match for the %s %s."
name var)
(match-string
,(intern (concat "ledger-regex-" (symbol-name name)
"-group-" (symbol-name var)))
string))))
(if (and last-group
(not (eq last-group (or grouping target))))
(incf addend
(symbol-value
(intern-soft (concat "ledger-regex-"
(symbol-name last-group)
"-group--count")))))
(nconc
defs
(list
`(defconst
,(intern (concat "ledger-regex-" (symbol-name name)
"-group-" (symbol-name var)))
,(+ addend
(symbol-value
(intern-soft
(if grouping
(concat "ledger-regex-" (symbol-name grouping)
"-group-" (symbol-name target))
(concat "ledger-regex-" (symbol-name target)
"-group"))))))))
(nconc
defs
(list
`(defmacro
,(intern (concat "ledger-regex-" (symbol-name name)
"-" (symbol-name var)))
(&optional string)
,(format "Return the sub-group match for the %s %s."
name var)
(match-string
,(intern (concat "ledger-regex-" (symbol-name name)
"-group-" (symbol-name var)))
string))))
(setq last-group (or grouping target))))
(setq last-group (or grouping target))))
(nconc defs
(list
`(defconst ,(intern (concat "ledger-regex-" (symbol-name name)
"-group--count"))
,(length args)))))
(nconc defs
(list
`(defconst ,(intern (concat "ledger-regex-" (symbol-name name)
"-group--count"))
,(length args)))))
(cons 'progn defs)))
(put 'ledger-define-regexp 'lisp-indent-function 1)
(ledger-define-regexp iso-date
( let ((sep '(or ?- ?/)))
(rx (group
(and (? (and (group (= 4 num)))
(eval sep))
(group (and num (? num)))
(eval sep)
(group (and num (? num)))))))
"Match a single date, in its 'written' form.")
( let ((sep '(or ?- ?/)))
(rx (group
(and (? (and (group (= 4 num)))
(eval sep))
(group (and num (? num)))
(eval sep)
(group (and num (? num)))))))
"Match a single date, in its 'written' form.")
(ledger-define-regexp full-date
(macroexpand
`(rx (and (regexp ,ledger-iso-date-regexp)
(? (and ?= (regexp ,ledger-iso-date-regexp))))))
"Match a compound date, of the form ACTUAL=EFFECTIVE"
(actual iso-date)
(effective iso-date))
(macroexpand
`(rx (and (regexp ,ledger-iso-date-regexp)
(? (and ?= (regexp ,ledger-iso-date-regexp))))))
"Match a compound date, of the form ACTUAL=EFFECTIVE"
(actual iso-date)
(effective iso-date))
(ledger-define-regexp state
(rx (group (any ?! ?*)))
"Match a transaction or posting's \"state\" character.")
(rx (group (any ?! ?*)))
"Match a transaction or posting's \"state\" character.")
(ledger-define-regexp code
(rx (and ?\( (group (+? (not (any ?\))))) ?\)))
"Match the transaction code.")
(rx (and ?\( (group (+? (not (any ?\))))) ?\)))
"Match the transaction code.")
(ledger-define-regexp long-space
(rx (and (*? blank)
(or (and ? (or ? ?\t)) ?\t)))
"Match a \"long space\".")
(rx (and (*? blank)
(or (and ? (or ? ?\t)) ?\t)))
"Match a \"long space\".")
(ledger-define-regexp note
(rx (group (+ nonl)))
"")
(rx (group (+ nonl)))
"")
(ledger-define-regexp end-note
(macroexpand
`(rx (and (regexp ,ledger-long-space-regexp) ?\;
(regexp ,ledger-note-regexp))))
"")
(macroexpand
`(rx (and (regexp ,ledger-long-space-regexp) ?\;
(regexp ,ledger-note-regexp))))
"")
(ledger-define-regexp full-note
(macroexpand
`(rx (and line-start (+ blank)
?\; (regexp ,ledger-note-regexp))))
"")
(macroexpand
`(rx (and line-start (+ blank)
?\; (regexp ,ledger-note-regexp))))
"")
(ledger-define-regexp xact-line
(macroexpand
`(rx (and line-start
(regexp ,ledger-full-date-regexp)
(? (and (+ blank) (regexp ,ledger-state-regexp)))
(? (and (+ blank) (regexp ,ledger-code-regexp)))
(+ blank) (+? nonl)
(? (regexp ,ledger-end-note-regexp))
line-end)))
"Match a transaction's first line (and optional notes)."
(actual-date full-date actual)
(effective-date full-date effective)
state
code
(note end-note))
(macroexpand
`(rx (and line-start
(regexp ,ledger-full-date-regexp)
(? (and (+ blank) (regexp ,ledger-state-regexp)))
(? (and (+ blank) (regexp ,ledger-code-regexp)))
(+ blank) (+? nonl)
(? (regexp ,ledger-end-note-regexp))
line-end)))
"Match a transaction's first line (and optional notes)."
(actual-date full-date actual)
(effective-date full-date effective)
state
code
(note end-note))
(ledger-define-regexp account
(rx (group (and (not (any blank ?\[ ?\( ?: ?\;)) (*? nonl))))
"")
(rx (group (and (not (any blank ?\[ ?\( ?: ?\;)) (*? nonl))))
"")
(ledger-define-regexp account-kind
(rx (group (? (any ?\[ ?\())))
"")
(rx (group (? (any ?\[ ?\())))
"")
(ledger-define-regexp full-account
(macroexpand
`(rx (and (regexp ,ledger-account-kind-regexp)
(regexp ,ledger-account-regexp)
(? (any ?\] ?\))))))
""
(kind account-kind)
(name account))
(macroexpand
`(rx (and (regexp ,ledger-account-kind-regexp)
(regexp ,ledger-account-regexp)
(? (any ?\] ?\))))))
""
(kind account-kind)
(name account))
(ledger-define-regexp commodity
(rx (group
(or (and ?\" (+ (not (any ?\"))) ?\")
(not (any blank ?\n
digit
?- ?\[ ?\]
?. ?, ?\; ?+ ?* ?/ ?^ ?? ?: ?& ?| ?! ?=
?\< ?\> ?\{ ?\} ?\( ?\) ?@)))))
"")
(rx (group
(or (and ?\" (+ (not (any ?\"))) ?\")
(not (any blank ?\n
digit
?- ?\[ ?\]
?. ?, ?\; ?+ ?* ?/ ?^ ?? ?: ?& ?| ?! ?=
?\< ?\> ?\{ ?\} ?\( ?\) ?@)))))
"")
(ledger-define-regexp amount
(rx (group
(and (? ?-)
(and (+ digit)
(*? (and (any ?. ?,) (+ digit))))
(? (and (any ?. ?,) (+ digit))))))
"")
(rx (group
(and (? ?-)
(and (+ digit)
(*? (and (any ?. ?,) (+ digit))))
(? (and (any ?. ?,) (+ digit))))))
"")
(ledger-define-regexp commoditized-amount
(macroexpand
`(rx (group
(or (and (regexp ,ledger-commodity-regexp)
(*? blank)
(regexp ,ledger-amount-regexp))
(and (regexp ,ledger-amount-regexp)
(*? blank)
(regexp ,ledger-commodity-regexp))))))
"")
(macroexpand
`(rx (group
(or (and (regexp ,ledger-commodity-regexp)
(*? blank)
(regexp ,ledger-amount-regexp))
(and (regexp ,ledger-amount-regexp)
(*? blank)
(regexp ,ledger-commodity-regexp))))))
"")
(ledger-define-regexp commodity-annotations
(macroexpand
`(rx (* (+ blank)
(or (and ?\{ (regexp ,ledger-commoditized-amount-regexp) ?\})
(and ?\[ (regexp ,ledger-iso-date-regexp) ?\])
(and ?\( (not (any ?\))) ?\))))))
"")
(macroexpand
`(rx (* (+ blank)
(or (and ?\{ (regexp ,ledger-commoditized-amount-regexp) ?\})
(and ?\[ (regexp ,ledger-iso-date-regexp) ?\])
(and ?\( (not (any ?\))) ?\))))))
"")
(ledger-define-regexp cost
(macroexpand
`(rx (and (or "@" "@@") (+ blank)
(regexp ,ledger-commoditized-amount-regexp))))
"")
(macroexpand
`(rx (and (or "@" "@@") (+ blank)
(regexp ,ledger-commoditized-amount-regexp))))
"")
(ledger-define-regexp balance-assertion
(macroexpand
`(rx (and ?= (+ blank)
(regexp ,ledger-commoditized-amount-regexp))))
"")
(macroexpand
`(rx (and ?= (+ blank)
(regexp ,ledger-commoditized-amount-regexp))))
"")
(ledger-define-regexp full-amount
(macroexpand `(rx (group (+? (not (any ?\;))))))
"")
(macroexpand `(rx (group (+? (not (any ?\;))))))
"")
(ledger-define-regexp post-line
(macroexpand
`(rx (and line-start (+ blank)
(? (and (regexp ,ledger-state-regexp) (* blank)))
(regexp ,ledger-full-account-regexp)
(? (and (regexp ,ledger-long-space-regexp)
(regexp ,ledger-full-amount-regexp)))
(? (regexp ,ledger-end-note-regexp))
line-end)))
""
state
(account-kind full-account kind)
(account full-account name)
(amount full-amount)
(note end-note))
(macroexpand
`(rx (and line-start (+ blank)
(? (and (regexp ,ledger-state-regexp) (* blank)))
(regexp ,ledger-full-account-regexp)
(? (and (regexp ,ledger-long-space-regexp)
(regexp ,ledger-full-amount-regexp)))
(? (regexp ,ledger-end-note-regexp))
line-end)))
""
state
(account-kind full-account kind)
(account full-account name)
(amount full-amount)
(note end-note))
(defconst ledger-iterate-regex
(concat "\\(\\(?:Y\\|year\\)\\s-+\\([0-9]+\\)\\|" ;; Catches a Y/year directive
ledger-iso-date-regexp
"\\([ *!]+\\)" ;; mark
"\\((.*)\\)?" ;; code
"\\(.*\\)" ;; desc
"\\)"))
ledger-iso-date-regexp
"\\([ *!]+\\)" ;; mark
"\\((.*)\\)?" ;; code
"\\(.*\\)" ;; desc
"\\)"))
(provide 'ledger-regex)

118
lisp/ledger-report.el
View file

@ -50,7 +50,7 @@ the substitution. See the documentation of the individual functions
in that variable for more information on the behavior of each
specifier."
:type '(repeat (list (string :tag "Report Name")
(string :tag "Command Line")))
(string :tag "Command Line")))
:group 'ledger-report)
(defcustom ledger-report-format-specifiers
@ -231,7 +231,7 @@ used to generate the buffer, navigating the buffer, etc."
end of a ledger file which is included in some other file."
(if ledger-master-file
(expand-file-name ledger-master-file)
(buffer-file-name)))
(buffer-file-name)))
(defun ledger-report-payee-format-specifier ()
"Substitute a payee name.
@ -261,16 +261,16 @@ used to generate the buffer, navigating the buffer, etc."
(let ((expanded-cmd report-cmd))
(set-match-data (list 0 0))
(while (string-match "%(\\([^)]*\\))" expanded-cmd (if (> (length expanded-cmd) (match-end 0))
(match-end 0)
(1- (length expanded-cmd))))
(let* ((specifier (match-string 1 expanded-cmd))
(f (cdr (assoc specifier ledger-report-format-specifiers))))
(if f
(setq expanded-cmd (replace-match
(save-match-data
(with-current-buffer ledger-buf
(shell-quote-argument (funcall f))))
t t expanded-cmd)))))
(match-end 0)
(1- (length expanded-cmd))))
(let* ((specifier (match-string 1 expanded-cmd))
(f (cdr (assoc specifier ledger-report-format-specifiers))))
(if f
(setq expanded-cmd (replace-match
(save-match-data
(with-current-buffer ledger-buf
(shell-quote-argument (funcall f))))
t t expanded-cmd)))))
expanded-cmd)))
(defun ledger-report-cmd (report-name edit)
@ -286,8 +286,8 @@ Optional EDIT the command."
(or (string-empty-p report-name)
(ledger-report-name-exists report-name)
(progn
(ledger-reports-add report-name report-cmd)
(ledger-reports-custom-save)))
(ledger-reports-add report-name report-cmd)
(ledger-reports-custom-save)))
report-cmd))
(defun ledger-do-report (cmd)
@ -299,32 +299,32 @@ Optional EDIT the command."
"\n\n")
(let ((data-pos (point))
(register-report (string-match " reg\\(ister\\)? " cmd))
files-in-report)
files-in-report)
(shell-command
;; --subtotal does not produce identifiable transactions, so don't
;; prepend location information for them
(if (and register-report
(not (string-match "--subtotal" cmd)))
(concat cmd " --prepend-format='%(filename):%(beg_line):'")
cmd)
(not (string-match "--subtotal" cmd)))
(concat cmd " --prepend-format='%(filename):%(beg_line):'")
cmd)
t nil)
(when register-report
(goto-char data-pos)
(while (re-search-forward "^\\(/[^:]+\\)?:\\([0-9]+\\)?:" nil t)
(let ((file (match-string 1))
(line (string-to-number (match-string 2))))
(delete-region (match-beginning 0) (match-end 0))
(when file
(set-text-properties (line-beginning-position) (line-end-position)
(list 'ledger-source (cons file (save-window-excursion
(save-excursion
(find-file file)
(widen)
(ledger-goto-line line)
(point-marker))))))
(add-text-properties (line-beginning-position) (line-end-position)
(list 'face 'ledger-font-report-clickable-face))
(end-of-line)))))
(let ((file (match-string 1))
(line (string-to-number (match-string 2))))
(delete-region (match-beginning 0) (match-end 0))
(when file
(set-text-properties (line-beginning-position) (line-end-position)
(list 'ledger-source (cons file (save-window-excursion
(save-excursion
(find-file file)
(widen)
(ledger-goto-line line)
(point-marker))))))
(add-text-properties (line-beginning-position) (line-end-position)
(list 'face 'ledger-font-report-clickable-face))
(end-of-line)))))
(goto-char data-pos)))
@ -332,21 +332,21 @@ Optional EDIT the command."
"Visit the transaction under point in the report window."
(interactive)
(let* ((prop (get-text-property (point) 'ledger-source))
(file (if prop (car prop)))
(line-or-marker (if prop (cdr prop))))
(file (if prop (car prop)))
(line-or-marker (if prop (cdr prop))))
(when (and file line-or-marker)
(find-file-other-window file)
(widen)
(if (markerp line-or-marker)
(goto-char line-or-marker)
(goto-char (point-min))
(forward-line (1- line-or-marker))
(re-search-backward "^[0-9]+")
(beginning-of-line)
(let ((start-of-txn (point)))
(forward-paragraph)
(narrow-to-region start-of-txn (point))
(backward-paragraph))))))
(goto-char line-or-marker)
(goto-char (point-min))
(forward-line (1- line-or-marker))
(re-search-backward "^[0-9]+")
(beginning-of-line)
(let ((start-of-txn (point)))
(forward-paragraph)
(narrow-to-region start-of-txn (point))
(backward-paragraph))))))
(defun ledger-report-goto ()
"Goto the ledger report buffer."
@ -401,22 +401,22 @@ Optional EDIT the command."
(setq ledger-report-name (ledger-report-read-new-name)))
(if (setq existing-name (ledger-report-name-exists ledger-report-name))
(cond ((y-or-n-p (format "Overwrite existing report named '%s'? "
ledger-report-name))
(if (string-equal
ledger-report-cmd
(car (cdr (assq existing-name ledger-reports))))
(message "Nothing to save. Current command is identical to existing saved one")
(progn
(setq ledger-reports
(assq-delete-all existing-name ledger-reports))
(ledger-reports-add ledger-report-name ledger-report-cmd)
(ledger-reports-custom-save))))
(t
(progn
(setq ledger-report-name (ledger-report-read-new-name))
(ledger-reports-add ledger-report-name ledger-report-cmd)
(ledger-reports-custom-save)))))))
(cond ((y-or-n-p (format "Overwrite existing report named '%s'? "
ledger-report-name))
(if (string-equal
ledger-report-cmd
(car (cdr (assq existing-name ledger-reports))))
(message "Nothing to save. Current command is identical to existing saved one")
(progn
(setq ledger-reports
(assq-delete-all existing-name ledger-reports))
(ledger-reports-add ledger-report-name ledger-report-cmd)
(ledger-reports-custom-save))))
(t
(progn
(setq ledger-report-name (ledger-report-read-new-name))
(ledger-reports-add ledger-report-name ledger-report-cmd)
(ledger-reports-custom-save)))))))
(provide 'ledger-report)

252
lisp/ledger-schedule.el
View file

@ -62,17 +62,17 @@
(and (>= val low) (<= val high)))
(defun ledger-schedule-check-available ()
(setq ledger-schedule-available (and ledger-schedule-file
(file-exists-p ledger-schedule-file))))
(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"
(if (between month 1 12)
(if (and year (date-leap-year-p year) (= 2 month))
29
(nth (1- month) '(31 28 31 30 31 30 31 31 30 31 30 31)))
(error "Month out of range, MONTH=%S" month)))
29
(nth (1- month) '(31 28 31 30 31 30 31 31 30 31 30 31)))
(error "Month out of range, MONTH=%S" month)))
;; Macros to handle date expressions
@ -83,51 +83,51 @@ month. Negative COUNT starts from the end of the month. (EQ
COUNT 0) means EVERY day-of-week (eg. every Saturday)"
(if (and (between count -6 6) (between day-of-week 0 6))
(cond ((zerop count) ;; Return true if day-of-week matches
`(eq (nth 6 (decode-time date)) ,day-of-week))
((> count 0) ;; Positive count
(let ((decoded (gensym)))
`(let ((,decoded (decode-time date)))
(and (eq (nth 6 ,decoded) ,day-of-week)
(between (nth 3 ,decoded)
,(* (1- count) 7)
,(* count 7))))))
((< 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)
(nth 5 ,decoded))))
(and (eq (nth 6 ,decoded) ,day-of-week)
(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
day-of-week)))
`(eq (nth 6 (decode-time date)) ,day-of-week))
((> count 0) ;; Positive count
(let ((decoded (gensym)))
`(let ((,decoded (decode-time date)))
(and (eq (nth 6 ,decoded) ,day-of-week)
(between (nth 3 ,decoded)
,(* (1- count) 7)
,(* count 7))))))
((< 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)
(nth 5 ,decoded))))
(and (eq (nth 6 ,decoded) ,day-of-week)
(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
day-of-week)))
(defun ledger-schedule-constrain-every-count-day (day-of-week skip start-date)
"Return a form that is true for every DAY skipping SKIP, starting on START.
For example every second Friday, regardless of month."
(let ((start-day (nth 6 (decode-time (eval start-date)))))
(if (eq start-day day-of-week) ;; good, can proceed
`(zerop (mod (- (time-to-days date) ,(time-to-days (eval start-date))) ,(* skip 7)))
(error "START-DATE day of week doesn't match DAY-OF-WEEK"))))
(if (eq start-day day-of-week) ;; good, can proceed
`(zerop (mod (- (time-to-days date) ,(time-to-days (eval start-date))) ,(* skip 7)))
(error "START-DATE day of week doesn't match DAY-OF-WEEK"))))
(defun ledger-schedule-constrain-date-range (month1 day1 month2 day2)
"Return a form of DATE that is true if DATE falls between MONTH1 DAY1 and MONTH2 DAY2."
(let ((decoded (gensym))
(target-month (gensym))
(target-day (gensym)))
(target-month (gensym))
(target-day (gensym)))
`(let* ((,decoded (decode-time date))
(,target-month (nth 4 decoded))
(,target-day (nth 3 decoded)))
(,target-month (nth 4 decoded))
(,target-day (nth 3 decoded)))
(and (and (> ,target-month ,month1)
(< ,target-month ,month2))
(and (> ,target-day ,day1)
(< ,target-day ,day2))))))
(< ,target-month ,month2))
(and (> ,target-day ,day1)
(< ,target-day ,day2))))))
(defun ledger-schedule-is-holiday (date)
@ -140,46 +140,46 @@ the transaction should be logged for that day."
(interactive "fFile name: ")
(let ((xact-list (list)))
(with-current-buffer
(find-file-noselect schedule-file)
(find-file-noselect schedule-file)
(goto-char (point-min))
(while (re-search-forward "^\\[\\(.*\\)\\] " nil t)
(let ((date-descriptor "")
(transaction nil)
(xact-start (match-end 0)))
(setq date-descriptors
(ledger-schedule-read-descriptor-tree
(buffer-substring-no-properties
(match-beginning 0)
(match-end 0))))
(forward-paragraph)
(setq transaction (list date-descriptors
(buffer-substring-no-properties
xact-start
(point))))
(setq xact-list (cons transaction xact-list))))
xact-list)))
(let ((date-descriptor "")
(transaction nil)
(xact-start (match-end 0)))
(setq date-descriptors
(ledger-schedule-read-descriptor-tree
(buffer-substring-no-properties
(match-beginning 0)
(match-end 0))))
(forward-paragraph)
(setq transaction (list date-descriptors
(buffer-substring-no-properties
xact-start
(point))))
(setq xact-list (cons transaction xact-list))))
xact-list)))
(defun ledger-schedule-replace-brackets ()
"Replace all brackets with parens"
(goto-char (point-min))
(while (search-forward "]" nil t)
(replace-match ")" nil t))
(goto-char (point-min))
(while (search-forward "[" nil t)
(replace-match "(" nil t)))
"Replace all brackets with parens"
(goto-char (point-min))
(while (search-forward "]" nil t)
(replace-match ")" nil t))
(goto-char (point-min))
(while (search-forward "[" nil t)
(replace-match "(" nil t)))
(defvar ledger-schedule-descriptor-regex
(concat "\\(20[0-9][0-9]\\|[\*]\\)[/\\-]" ;; Year slot
"\\([\*EO]\\|[01][0-9]\\)[/\\-]" ;; Month slot
"\\([\*]\\|\\([0-3][0-9]\\)\\|"
"\\([0-5]"
"\\(\\(Su\\)\\|"
"\\(Mo\\)\\|"
"\\(Tu\\)\\|"
"\\(We\\)\\|"
"\\(Th\\)\\|"
"\\(Fr\\)\\|"
"\\(Sa\\)\\)\\)\\)"))
(concat "\\(20[0-9][0-9]\\|[\*]\\)[/\\-]" ;; Year slot
"\\([\*EO]\\|[01][0-9]\\)[/\\-]" ;; Month slot
"\\([\*]\\|\\([0-3][0-9]\\)\\|"
"\\([0-5]"
"\\(\\(Su\\)\\|"
"\\(Mo\\)\\|"
"\\(Tu\\)\\|"
"\\(We\\)\\|"
"\\(Th\\)\\|"
"\\(Fr\\)\\|"
"\\(Sa\\)\\)\\)\\)"))
(defun ledger-schedule-read-descriptor-tree (descriptor-string)
"Take a date DESCRIPTOR-STRING and return a function of date that
@ -194,11 +194,11 @@ returns true if the date meets the requirements"
(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
(match-end 0))
(insert ?\")
(goto-char (match-beginning 0))
(insert "\"" )))
(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
@ -206,30 +206,30 @@ returns true if the date meets the requirements"
(read (buffer-substring-no-properties (point-min) (point-max))))))
(defun ledger-schedule-transform-auto-tree (descriptor-string-list)
"Takes a lisp list of date descriptor strings, TREE, and returns a string with a lambda function of date."
;; use funcall to use the lambda function spit out here
"Takes a lisp list of date descriptor strings, TREE, and returns a string with a lambda function of date."
;; use funcall to use the lambda function spit out here
(if (consp descriptor-string-list)
(let (result)
(while (consp descriptor-string-list)
(let ((newcar (car descriptor-string-list)))
(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)
(push newcar result)
;; this is where we actually turn the string descriptor into useful lisp
(push (ledger-schedule-compile-constraints newcar) result)) )
(setq descriptor-string-list (cdr descriptor-string-list)))
(while (consp descriptor-string-list)
(let ((newcar (car descriptor-string-list)))
(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)
(push newcar result)
;; this is where we actually turn the string descriptor into useful lisp
(push (ledger-schedule-compile-constraints newcar) result)) )
(setq descriptor-string-list (cdr descriptor-string-list)))
;; 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)
,(nconc (list 'or) (nreverse result) descriptor-string-list)))))
;; 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)
,(nconc (list 'or) (nreverse result) descriptor-string-list)))))
(defun ledger-schedule-compile-constraints (descriptor-string)
"Return a list with the year, month and day fields split"
(let ((fields (split-string descriptor-string "[/\\-]" t))
constrain-year constrain-month constrain-day)
constrain-year constrain-month constrain-day)
(setq constrain-year (ledger-schedule-constrain-year (nth 0 fields)))
(setq constrain-month (ledger-schedule-constrain-month (nth 1 fields)))
(setq constrain-day (ledger-schedule-constrain-day (nth 2 fields)))
@ -239,32 +239,32 @@ returns true if the date meets the requirements"
(defun ledger-schedule-constrain-year (str)
(let ((year-match t))
(cond ((string= str "*")
year-match)
((/= 0 (setq year-match (string-to-number str)))
`(eq (nth 5 (decode-time date)) ,year-match))
(t
(error "Improperly specified year constraint: %s" str)))))
year-match)
((/= 0 (setq year-match (string-to-number str)))
`(eq (nth 5 (decode-time date)) ,year-match))
(t
(error "Improperly specified year constraint: %s" str)))))
(defun ledger-schedule-constrain-month (str)
(let ((month-match t))
(cond ((string= str "*")
month-match) ;; always match
((/= 0 (setq month-match (string-to-number str)))
(if (between month-match 1 12) ;; no month specified, assume 31 days.
`(eq (nth 4 (decode-time date)) ,month-match)
(error "ledger-schedule-constrain-numerical-month: month out of range %S" month-match)))
(t
(error "Improperly specified month constraint: %s" str)))))
month-match) ;; always match
((/= 0 (setq month-match (string-to-number str)))
(if (between month-match 1 12) ;; no month specified, assume 31 days.
`(eq (nth 4 (decode-time date)) ,month-match)
(error "ledger-schedule-constrain-numerical-month: month out of range %S" month-match)))
(t
(error "Improperly specified month constraint: %s" str)))))
(defun ledger-schedule-constrain-day (str)
(let ((day-match t))
(cond ((string= str "*")
t)
((/= 0 (setq day-match (string-to-number str)))
`(eq (nth 3 (decode-time date)) ,day-match))
(t
(error "Improperly specified day constraint: %s" str)))))
t)
((/= 0 (setq day-match (string-to-number str)))
`(eq (nth 3 (decode-time date)) ,day-match))
(t
(error "Improperly specified day constraint: %s" str)))))
(defun ledger-schedule-parse-date-descriptor (descriptor)
"Parse the date descriptor, return the evaluator"
@ -273,31 +273,31 @@ returns true if the date meets the requirements"
(defun ledger-schedule-list-upcoming-xacts (candidate-items early horizon)
"Search CANDIDATE-ITEMS for xacts that occur within the period today - EARLY to today + HORIZON"
(let ((start-date (time-subtract (current-time) (days-to-time early)))
test-date items)
test-date items)
(loop for day from 0 to (+ early horizon) by 1 do
(setq test-date (time-add start-date (days-to-time day)))
(dolist (candidate candidate-items items)
(if (funcall (car candidate) test-date)
(setq items (append items (list (list test-date (cadr candidate))))))))
(setq test-date (time-add start-date (days-to-time day)))
(dolist (candidate candidate-items items)
(if (funcall (car candidate) test-date)
(setq items (append items (list (list test-date (cadr candidate))))))))
items))
(defun ledger-schedule-already-entered (candidate buffer)
(let ((target-date (format-time-string date-format (car candidate)))
(target-payee (cadr candidate)))
(target-payee (cadr candidate)))
nil))
(defun ledger-schedule-create-auto-buffer (candidate-items early horizon ledger-buf)
"Format CANDIDATE-ITEMS for display."
(let ((candidates (ledger-schedule-list-upcoming-xacts candidate-items early horizon))
(schedule-buf (get-buffer-create ledger-schedule-buffer-name))
(date-format (or (cdr (assoc "date-format" ledger-environment-alist))
ledger-default-date-format)))
(schedule-buf (get-buffer-create ledger-schedule-buffer-name))
(date-format (or (cdr (assoc "date-format" ledger-environment-alist))
ledger-default-date-format)))
(with-current-buffer schedule-buf
(erase-buffer)
(dolist (candidate candidates)
(if (not (ledger-schedule-already-entered candidate ledger-buf))
(insert (format-time-string date-format (car candidate) ) " " (cadr candidate) "\n")))
(ledger-mode))
(dolist (candidate candidates)
(if (not (ledger-schedule-already-entered candidate ledger-buf))
(insert (format-time-string date-format (car candidate) ) " " (cadr candidate) "\n")))
(ledger-mode))
(length candidates)))
(defun ledger-schedule-upcoming (file look-backward look-forward)
@ -315,7 +315,7 @@ Use a prefix arg to change the default value"
(list (read-file-name "Schedule File: " () ledger-schedule-file t)
(read-number "Look backward: " ledger-schedule-look-backward)
(read-number "Look forward: " ledger-schedule-look-forward))
(list ledger-schedule-file ledger-schedule-look-backward ledger-schedule-look-forward)))
(list ledger-schedule-file ledger-schedule-look-backward ledger-schedule-look-forward)))
(ledger-schedule-create-auto-buffer
(ledger-schedule-scan-transactions file)
look-backward

62
lisp/ledger-sort.el
View file

@ -30,7 +30,7 @@
"Move point to next transaction."
(if (re-search-forward ledger-payee-any-status-regex nil t)
(goto-char (match-beginning 0))
(goto-char (point-max))))
(goto-char (point-max))))
(defun ledger-end-record-function ()
"Move point to end of transaction."
@ -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"))
@ -71,34 +71,34 @@
(interactive "r") ;; load beg and end from point and mark
;; 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)
(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))
@ -109,17 +109,17 @@
"Sort the entire buffer."
(interactive)
(let (sort-start
sort-end)
sort-end)
(save-excursion
(goto-char (point-min))
(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
sort-start
(point-min))
(if sort-end
sort-end
(point-max)))))
sort-start
(point-min))
(if sort-end
sort-end
(point-max)))))
(provide 'ledger-sort)

158
lisp/ledger-state.el
View file

@ -54,16 +54,16 @@
"Return the char representation of STATE."
(if state
(if (eq state 'pending)
"!"
"*")
""))
"!"
"*")
""))
(defun ledger-state-from-char (state-char)
"Get state from STATE-CHAR."
(cond ((eql state-char ?\!) 'pending)
((eql state-char ?\*) 'cleared)
((eql state-char ?\;) 'comment)
(t nil)))
((eql state-char ?\*) 'cleared)
((eql state-char ?\;) 'comment)
(t nil)))
(defun ledger-toggle-current-posting (&optional style)
"Toggle the cleared status of the transaction under point.
@ -82,12 +82,12 @@ dropped."
;; Uncompact the xact, to make it easier to toggle the
;; transaction
(save-excursion ;; this excursion checks state of entire
;; transaction and unclears if marked
;; transaction and unclears if marked
(goto-char (car bounds)) ;; beginning of xact
(skip-chars-forward "0-9./=\\-") ;; skip the date
(skip-chars-forward " \t") ;; skip the white space after the date
(skip-chars-forward " \t") ;; skip the white space after the date
(setq cur-status (and (member (char-after) '(?\* ?\!))
(ledger-state-from-char (char-after))))
(ledger-state-from-char (char-after))))
;;if cur-status if !, or * then delete the marker
(when cur-status
(let ((here (point)))
@ -98,15 +98,15 @@ dropped."
(if (search-forward " " (line-end-position) t)
(insert (make-string width ? ))))))
(forward-line)
;; Shift the cleared/pending status to the postings
;; Shift the cleared/pending status to the postings
(while (looking-at "[ \t]")
(skip-chars-forward " \t")
(when (not (eq (ledger-state-from-char (char-after)) 'comment))
(insert (ledger-char-from-state cur-status) " ")
(if (search-forward " " (line-end-position) t)
(delete-char 2)))
(forward-line))
(setq new-status nil)))
(when (not (eq (ledger-state-from-char (char-after)) 'comment))
(insert (ledger-char-from-state cur-status) " ")
(if (search-forward " " (line-end-position) t)
(delete-char 2)))
(forward-line))
(setq new-status nil)))
;;this excursion toggles the posting status
(save-excursion
@ -114,40 +114,40 @@ dropped."
(goto-char (line-beginning-position))
(when (looking-at "[ \t]")
(skip-chars-forward " \t")
(let ((here (point))
(cur-status (ledger-state-from-char (char-after))))
(skip-chars-forward "*! ")
(let ((width (- (point) here)))
(when (> width 0)
(delete-region here (point))
(save-excursion
(if (search-forward " " (line-end-position) t)
(insert (make-string width ? ))))))
(let (inserted)
(if cur-status
(if (and style (eq style 'cleared))
(progn
(insert "* ")
(setq inserted 'cleared)))
(if (and style (eq style 'pending))
(progn
(insert "! ")
(setq inserted 'pending))
(progn
(insert "* ")
(setq inserted 'cleared))))
(if (and inserted
(re-search-forward "\\(\t\\| [ \t]\\)"
(line-end-position) t))
(cond
((looking-at "\t")
(delete-char 1))
((looking-at " [ \t]")
(delete-char 2))
((looking-at " ")
(delete-char 1))))
(setq new-status inserted))))
(skip-chars-forward " \t")
(let ((here (point))
(cur-status (ledger-state-from-char (char-after))))
(skip-chars-forward "*! ")
(let ((width (- (point) here)))
(when (> width 0)
(delete-region here (point))
(save-excursion
(if (search-forward " " (line-end-position) t)
(insert (make-string width ? ))))))
(let (inserted)
(if cur-status
(if (and style (eq style 'cleared))
(progn
(insert "* ")
(setq inserted 'cleared)))
(if (and style (eq style 'pending))
(progn
(insert "! ")
(setq inserted 'pending))
(progn
(insert "* ")
(setq inserted 'cleared))))
(if (and inserted
(re-search-forward "\\(\t\\| [ \t]\\)"
(line-end-position) t))
(cond
((looking-at "\t")
(delete-char 1))
((looking-at " [ \t]")
(delete-char 2))
((looking-at " ")
(delete-char 1))))
(setq new-status inserted))))
(setq inhibit-modification-hooks nil))
;; This excursion cleans up the xact so that it displays
@ -162,12 +162,12 @@ dropped."
(while (and (not hetero) (looking-at "[ \t]"))
(skip-chars-forward " \t")
(let ((cur-status (ledger-state-from-char (char-after))))
(if (not (eq cur-status 'comment))
(if first
(setq state cur-status
first nil)
(if (not (eq state cur-status))
(setq hetero t)))))
(if (not (eq cur-status 'comment))
(if first
(setq state cur-status
first nil)
(if (not (eq state cur-status))
(setq hetero t)))))
(forward-line))
(when (and (not hetero) (not (eq state nil)))
(goto-char (car bounds))
@ -185,18 +185,18 @@ dropped."
(forward-line))
(goto-char (car bounds))
(skip-chars-forward "0-9./=\\-") ;; Skip the date
(skip-chars-forward " \t") ;; Skip the white space
(skip-chars-forward " \t") ;; Skip the white space
(insert (ledger-char-from-state state) " ")
(setq new-status state)
(setq new-status state)
(if (re-search-forward "\\(\t\\| [ \t]\\)"
(line-end-position) t)
(cond
((looking-at "\t")
(delete-char 1))
((looking-at " [ \t]")
(delete-char 2))
((looking-at " ")
(delete-char 1)))))))
((looking-at "\t")
(delete-char 1))
((looking-at " [ \t]")
(delete-char 2))
((looking-at " ")
(delete-char 1)))))))
new-status))
(defun ledger-toggle-current (&optional style)
@ -216,30 +216,30 @@ dropped."
(forward-line)
(goto-char (line-beginning-position))))
(ledger-toggle-current-transaction style))
(ledger-toggle-current-posting style)))
(ledger-toggle-current-posting style)))
(defun ledger-toggle-current-transaction (&optional style)
"Toggle the transaction at point using optional STYLE."
(interactive)
(save-excursion
(when (or (looking-at "^[0-9]")
(re-search-backward "^[0-9]" nil t))
(re-search-backward "^[0-9]" nil t))
(skip-chars-forward "0-9./=\\-")
(delete-horizontal-space)
(if (or (eq (ledger-state-from-char (char-after)) 'pending)
(eq (ledger-state-from-char (char-after)) 'cleared))
(progn
(delete-char 1)
(when (and style (eq style 'cleared))
(insert " *")
'cleared))
(if (and style (eq style 'pending))
(progn
(insert " ! ")
'pending)
(progn
(insert " * ")
'cleared))))))
(eq (ledger-state-from-char (char-after)) 'cleared))
(progn
(delete-char 1)
(when (and style (eq style 'cleared))
(insert " *")
'cleared))
(if (and style (eq style 'pending))
(progn
(insert " ! ")
'pending)
(progn
(insert " * ")
'cleared))))))
(provide 'ledger-state)

8
lisp/ledger-test.el
View file

@ -98,9 +98,9 @@
(ledger-mode)
(if input
(insert input)
(insert "2012-03-17 Payee\n")
(insert " Expenses:Food $20\n")
(insert " Assets:Cash\n"))
(insert "2012-03-17 Payee\n")
(insert " Expenses:Food $20\n")
(insert " Assets:Cash\n"))
(insert "\ntest reg\n")
(if output
(insert output))
@ -121,7 +121,7 @@
(let ((prev-directory default-directory))
(cd ledger-source-directory)
(unwind-protect
(async-shell-command (format "\"%s\" %s" command args))
(async-shell-command (format "\"%s\" %s" command args))
(cd prev-directory)))))))
(provide 'ledger-test)

34
lisp/ledger-texi.el
View file

@ -20,18 +20,18 @@
;; MA 02110-1301 USA.
(defgroup ledger-texi nil
"Options for working on Ledger texi documentation"
:group 'ledger)
"Options for working on Ledger texi documentation"
:group 'ledger)
(defcustom ledger-texi-sample-doc-path "~/ledger/doc/sample.dat"
"Location for sample data to be used in texi tests"
:type 'file
:group 'ledger-texi)
"Location for sample data to be used in texi tests"
:type 'file
:group 'ledger-texi)
(defcustom ledger-texi-normalization-args "--args-only --columns 80"
"texi normalization for producing ledger output"
:type 'string
:group 'ledger-texi)
"texi normalization for producing ledger output"
:type 'string
:group 'ledger-texi)
(defun ledger-update-test ()
(interactive)
@ -104,17 +104,17 @@
(if (string-match "\\$LEDGER" command)
(replace-match (format "%s -f \"%s\" %s" ledger-binary-path
data-file ledger-texi-normalization-args) t t command)
(concat (format "%s -f \"%s\" %s " ledger-binary-path
data-file ledger-texi-normalization-args) command)))
(concat (format "%s -f \"%s\" %s " ledger-binary-path
data-file ledger-texi-normalization-args) command)))
(defun ledger-texi-invoke-command (command)
(with-temp-buffer (shell-command command t (current-buffer))
(if (= (point-min) (point-max))
(progn
(push-mark nil t)
(message "Command '%s' yielded no result at %d" command (point))
(ding))
(buffer-string))))
(if (= (point-min) (point-max))
(progn
(push-mark nil t)
(message "Command '%s' yielded no result at %d" command (point))
(ding))
(buffer-string))))
(defun ledger-texi-write-test-data (name input)
(let ((path (expand-file-name name temporary-file-directory)))
@ -159,7 +159,7 @@
(let ((section-name (if (string= section "smex")
"smallexample"
"example"))
"example"))
(output (ledger-texi-invoke-command
(ledger-texi-expand-command command data-file))))
(insert "@" section-name ?\n output

106
lisp/ledger-xact.el
View file

@ -47,28 +47,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 ledger-xact-highlight-overlay))
(if (not ledger-xact-highlight-overlay)
(setq ovl
(setq ledger-xact-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 ledger-xact-highlight-overlay))
(if (not ledger-xact-highlight-overlay)
(setq ovl
(setq ledger-xact-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."
@ -78,7 +78,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."
@ -114,19 +114,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)
@ -137,7 +137,7 @@ MOMENT is an encoded date"
(defun ledger-year-and-month ()
(let ((sep (if ledger-use-iso-dates
"-"
"/")))
"/")))
(concat ledger-year sep ledger-month sep)))
(defun ledger-copy-transaction-at-point (date)
@ -145,14 +145,14 @@ MOMENT is an encoded date"
(interactive (list
(ledger-read-date "Copy to date: ")))
(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)
@ -191,20 +191,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 'ledger-xact)