summaryrefslogtreecommitdiff
path: root/lisp
diff options
context:
space:
mode:
Diffstat (limited to 'lisp')
-rw-r--r--lisp/ledger-check.el136
-rw-r--r--lisp/ledger-commodities.el20
-rw-r--r--lisp/ledger-complete.el6
-rw-r--r--lisp/ledger-context.el8
-rw-r--r--lisp/ledger-exec.el4
-rw-r--r--lisp/ledger-fontify.el243
-rw-r--r--lisp/ledger-fonts.el2
-rw-r--r--lisp/ledger-init.el6
-rw-r--r--lisp/ledger-mode.el40
-rw-r--r--lisp/ledger-navigate.el164
-rw-r--r--lisp/ledger-occur.el32
-rw-r--r--lisp/ledger-post.el50
-rw-r--r--lisp/ledger-reconcile.el237
-rw-r--r--lisp/ledger-regex.el56
-rw-r--r--lisp/ledger-report.el78
-rw-r--r--lisp/ledger-schedule.el170
-rw-r--r--lisp/ledger-sort.el8
-rw-r--r--lisp/ledger-state.el6
-rw-r--r--lisp/ledger-test.el2
-rw-r--r--lisp/ledger-texi.el2
-rw-r--r--lisp/ledger-xact.el40
21 files changed, 759 insertions, 551 deletions
diff --git a/lisp/ledger-check.el b/lisp/ledger-check.el
new file mode 100644
index 00000000..8eed34ed
--- /dev/null
+++ b/lisp/ledger-check.el
@@ -0,0 +1,136 @@
+;;; ledger-check.el --- Helper code for use with the "ledger" command-line tool
+
+;; Copyright (C) 2015 Craig Earls (enderw88 AT gmail DOT com)
+
+;; This file is not part of GNU Emacs.
+
+;; This is free software; you can redistribute it and/or modify it under
+;; the terms of the GNU General Public License as published by the Free
+;; Software Foundation; either version 2, or (at your option) any later
+;; version.
+;;
+;; This is distributed in the hope that it will be useful, but WITHOUT
+;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+;; for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,
+;; MA 02110-1301 USA.
+
+;;; Commentary:
+;; Provide secial mode to correct errors in ledger when running with --strict and --explicit
+;;
+;; Adapted to ledger mode by Craig Earls <enderw88 at gmail dot com>
+
+;;; Code:
+
+(require 'easymenu)
+(eval-when-compile
+ (require 'cl))
+
+(defvar ledger-check-buffer-name "*Ledger Check*")
+
+
+
+
+(defvar ledger-check-mode-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map [return] 'ledger-report-visit-source)
+ (define-key map [?q] 'ledger-check-quit)
+ map)
+ "Keymap for `ledger-check-mode'.")
+
+(easy-menu-define ledger-check-mode-menu ledger-check-mode-map
+ "Ledger check menu"
+ '("Check"
+; ["Re-run Check" ledger-check-redo]
+ "---"
+ ["Visit Source" ledger-report-visit-source]
+ "---"
+ ["Quit" ledger-check-quit]
+ ))
+
+(define-derived-mode ledger-check-mode text-mode "Ledger-Check"
+ "A mode for viewing ledger errors and warnings.")
+
+
+(defun ledger-do-check ()
+ "Run a check command ."
+ (goto-char (point-min))
+ (let ((data-pos (point))
+ (have-warnings nil))
+ (shell-command
+ ;; ledger balance command will just return empty if you give it
+ ;; an account name that doesn't exist. I will assume that no
+ ;; one will ever have an account named "e342asd2131". If
+ ;; someones does, this will probably still work for them.
+ ;; I should only highlight error and warning lines.
+ "ledger bal e342asd2131 --strict --explicit "
+ t nil)
+ (goto-char data-pos)
+
+ ;; format check report to make it navigate the file
+
+ (while (re-search-forward "^.*: \"\\(.*\\)\", line \\([0-9]+\\)" nil t)
+ (let ((file (match-string 1))
+ (line (string-to-number (match-string 2))))
+ (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-navigate-to-line line)
+ (point-marker))))))
+ (add-text-properties (line-beginning-position) (line-end-position)
+ (list 'face 'ledger-font-report-clickable-face))
+ (setq have-warnings 'true)
+ (end-of-line))))
+ (if (not have-warnings)
+ (insert "No errors or warnings reported."))))
+
+(defun ledger-check-goto ()
+ "Goto the ledger check buffer."
+ (interactive)
+ (let ((rbuf (get-buffer ledger-check-buffer-name)))
+ (if (not rbuf)
+ (error "There is no ledger check buffer"))
+ (pop-to-buffer rbuf)
+ (shrink-window-if-larger-than-buffer)))
+
+(defun ledger-check-quit ()
+ "Quit the ledger check buffer."
+ (interactive)
+ (ledger-check-goto)
+ (set-window-configuration ledger-original-window-cfg)
+ (kill-buffer (get-buffer ledger-check-buffer-name)))
+
+(defun ledger-check-buffer ()
+ "Run a ledge with --explicit and --strict report errors and assist with fixing them.
+
+The output buffer will be in `ledger-check-mode', which defines
+commands for navigating the buffer to the errors found, etc."
+ (interactive
+ (progn
+ (when (and (buffer-modified-p)
+ (y-or-n-p "Buffer modified, save it? "))
+ (save-buffer))))
+ (let ((buf (current-buffer))
+ (cbuf (get-buffer ledger-check-buffer-name))
+ (wcfg (current-window-configuration)))
+ (if cbuf
+ (kill-buffer cbuf))
+ (with-current-buffer
+ (pop-to-buffer (get-buffer-create ledger-check-buffer-name))
+ (ledger-check-mode)
+ (set (make-local-variable 'ledger-original-window-cfg) wcfg)
+ (ledger-do-check)
+ (shrink-window-if-larger-than-buffer)
+ (set-buffer-modified-p nil)
+ (setq buffer-read-only t)
+ (message "q to quit; r to redo; k to kill"))))
+
+
+(provide 'ledger-check)
diff --git a/lisp/ledger-commodities.el b/lisp/ledger-commodities.el
index a0949c21..a6f2fdda 100644
--- a/lisp/ledger-commodities.el
+++ b/lisp/ledger-commodities.el
@@ -1,6 +1,6 @@
;;; ledger-commodities.el --- Helper code for use with the "ledger" command-line tool
-;; Copyright (C) 2003-2015 John Wiegley (johnw AT gnu DOT org)
+;; Copyright (C) 2003-2016 John Wiegley (johnw AT gnu DOT org)
;; This file is not part of GNU Emacs.
@@ -37,6 +37,16 @@
:type 'string
:group 'ledger-reconcile)
+(defun ledger-read-commodity-with-prompt (prompt)
+ "Read commodity name after PROMPT.
+
+Default value is `ledger-reconcile-default-commodity'."
+ (let* ((buffer (current-buffer))
+ (commodities (with-temp-buffer
+ (ledger-exec-ledger buffer (current-buffer) "commodities")
+ (split-string (buffer-string) "\n" t))))
+ (completing-read prompt commodities nil t nil nil ledger-reconcile-default-commodity)))
+
(defun ledger-split-commodity-string (str)
"Split a commoditized string, STR, into two parts.
Returns a list with (value commodity)."
@@ -95,8 +105,8 @@ Returns a list with (value commodity)."
(error "Can't add different commodities, %S to %S" c1 c2)))
(defun ledger-strip (str char)
- "Return STR with CHAR removed."
- (replace-regexp-in-string char "" str))
+ "Return STR with CHAR removed."
+ (replace-regexp-in-string char "" str))
(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"
@@ -109,7 +119,7 @@ Returns a list with (value commodity)."
(string-to-number nstr)))
(defun ledger-number-to-string (n &optional decimal-comma)
- "number-to-string that handles comma as decimal."
+ "number-to-string that handles comma as decimal."
(let ((str (number-to-string n)))
(when (or decimal-comma
(assoc "decimal-comma" ledger-environment-alist))
@@ -128,7 +138,7 @@ longer ones are after the value."
(concat commodity " " str))))
(defun ledger-read-commodity-string (prompt)
- "Read an amount from mini-buffer using PROMPT."
+ "Read an amount from mini-buffer using PROMPT."
(let ((str (read-from-minibuffer
(concat prompt " (" ledger-reconcile-default-commodity "): ")))
comm)
diff --git a/lisp/ledger-complete.el b/lisp/ledger-complete.el
index 8c772b4b..5a4011b9 100644
--- a/lisp/ledger-complete.el
+++ b/lisp/ledger-complete.el
@@ -1,6 +1,6 @@
;;; ledger-complete.el --- Helper code for use with the "ledger" command-line tool
-;; Copyright (C) 2003-2015 John Wiegley (johnw AT gnu DOT org)
+;; Copyright (C) 2003-2016 John Wiegley (johnw AT gnu DOT org)
;; This file is not part of GNU Emacs.
@@ -161,7 +161,7 @@
(ledger-accounts)))))
(defun ledger-trim-trailing-whitespace (str)
- (replace-regexp-in-string "[ \t]*$" "" str))
+ (replace-regexp-in-string "[ \t]*$" "" str))
(defun ledger-fully-complete-xact ()
"Completes a transaction if there is another matching payee in the buffer.
@@ -239,7 +239,7 @@ ledger-magic-tab would cycle properly"
pcomplete-seen pcomplete-norm-func
pcomplete-args pcomplete-last pcomplete-index
pcomplete-autolist
- (completions (pcomplete-completions))
+ (completions (pcomplete-completions))
(result (pcomplete-do-complete pcomplete-stub completions))
(pcomplete-termination-string ""))
(and result
diff --git a/lisp/ledger-context.el b/lisp/ledger-context.el
index 0dfa4645..fb5f4c10 100644
--- a/lisp/ledger-context.el
+++ b/lisp/ledger-context.el
@@ -1,6 +1,6 @@
;;; ledger-context.el --- Helper code for use with the "ledger" command-line tool
-;; Copyright (C) 2003-2015 John Wiegley (johnw AT gnu DOT org)
+;; Copyright (C) 2003-2016 John Wiegley (johnw AT gnu DOT org)
;; This file is not part of GNU Emacs.
@@ -32,10 +32,10 @@
;; `ledger-single-line-config' macro to form the regex and list of
;; elements
(defconst ledger-indent-string "\\(^[ \t]+\\)")
-(defconst ledger-status-string "\\([*! ]?\\)")
+(defconst ledger-status-string "\\(* \\|! \\)?")
(defconst ledger-account-string "[\\[(]?\\(.*?\\)[])]?")
-(defconst ledger-separator-string "\\s-\\s-")
-(defconst ledger-amount-string "\\(-?[0-9]+[\\.,][0-9]*\\)")
+(defconst ledger-separator-string "\\(\\s-\\s-+\\)")
+(defconst ledger-amount-string "\\(-?[0-9]+\\(?:[\\.,][0-9]*\\)?\\)")
(defconst ledger-comment-string "[ \t]*;[ \t]*\\(.*?\\)")
(defconst ledger-nil-string "\\([ \t]\\)")
(defconst ledger-commodity-string "\\(.+?\\)")
diff --git a/lisp/ledger-exec.el b/lisp/ledger-exec.el
index 07c36cac..5440e085 100644
--- a/lisp/ledger-exec.el
+++ b/lisp/ledger-exec.el
@@ -1,6 +1,6 @@
;;; ledger-exec.el --- Helper code for use with the "ledger" command-line tool
-;; Copyright (C) 2003-2015 John Wiegley (johnw AT gnu DOT org)
+;; Copyright (C) 2003-2016 John Wiegley (johnw AT gnu DOT org)
;; This file is not part of GNU Emacs.
@@ -55,7 +55,7 @@
(setq buffer-read-only t)))
(defun ledger-exec-success-p (ledger-output-buffer)
- "Return t if the ledger output in LEDGER-OUTPUT-BUFFER is successful."
+ "Return t if the ledger output in LEDGER-OUTPUT-BUFFER is successful."
(with-current-buffer ledger-output-buffer
(goto-char (point-min))
(if (and (> (buffer-size) 1) (looking-at (regexp-quote "While")))
diff --git a/lisp/ledger-fontify.el b/lisp/ledger-fontify.el
index 8dbe1bd5..076e52b7 100644
--- a/lisp/ledger-fontify.el
+++ b/lisp/ledger-fontify.el
@@ -38,45 +38,46 @@
:group 'ledger)
(defun ledger-fontify-buffer-part (&optional beg end len)
-"Fontify buffer from BEG to END, length LEN."
- (save-excursion
- (unless beg (setq beg (point-min)))
- (unless end (setq end (point-max)))
- (goto-char beg)
- (beginning-of-line)
- (while (< (point) end)
- (cond ((or (looking-at ledger-xact-start-regex)
- (looking-at ledger-posting-regex))
- (ledger-fontify-xact-at (point)))
- ((looking-at ledger-directive-start-regex)
- (ledger-fontify-directive-at (point))))
- (ledger-navigate-next-xact-or-directive))))
+ "Fontify buffer from BEG to END, length LEN."
+ (save-excursion
+ (unless beg (setq beg (point-min)))
+ (unless end (setq end (point-max)))
+ (goto-char beg)
+ (beginning-of-line)
+ (while (< (point) end)
+ (cond ((or (looking-at ledger-xact-start-regex)
+ (looking-at ledger-posting-regex)
+ (looking-at ledger-recurring-line-regexp))
+ (ledger-fontify-xact-at (point)))
+ ((looking-at ledger-directive-start-regex)
+ (ledger-fontify-directive-at (point))))
+ (ledger-navigate-next-xact-or-directive))))
(defun ledger-fontify-xact-at (position)
"Fontify the xact at POSITION."
- (interactive "d")
- (save-excursion
- (goto-char position)
- (let ((extents (ledger-navigate-find-element-extents position))
- (state (ledger-transaction-state)))
- (if (and ledger-fontify-xact-state-overrides state)
- (cond ((eq state 'cleared)
- (ledger-fontify-set-face extents 'ledger-font-xact-cleared-face))
- ((eq state 'pending)
- (ledger-fontify-set-face extents 'ledger-font-xact-pending-face)))
- (ledger-fontify-xact-by-line extents)))))
+ (interactive "d")
+ (save-excursion
+ (goto-char position)
+ (let ((extents (ledger-navigate-find-element-extents position))
+ (state (ledger-transaction-state)))
+ (if (and ledger-fontify-xact-state-overrides state)
+ (cond ((eq state 'cleared)
+ (ledger-fontify-set-face extents 'ledger-font-xact-cleared-face))
+ ((eq state 'pending)
+ (ledger-fontify-set-face extents 'ledger-font-xact-pending-face)))
+ (ledger-fontify-xact-by-line extents)))))
(defun ledger-fontify-xact-by-line (extents)
- "Do line-by-line detailed fontification of xact in EXTENTS."
- (save-excursion
- (ledger-fontify-xact-start (car extents))
- (while (< (point) (cadr extents))
- (if (looking-at "[ \t]+;")
- (ledger-fontify-set-face (list (point) (progn
- (end-of-line)
- (point))) 'ledger-font-comment-face)
- (ledger-fontify-posting (point)))
- (forward-line))))
+ "Do line-by-line detailed fontification of xact in EXTENTS."
+ (save-excursion
+ (ledger-fontify-xact-start (car extents))
+ (while (< (point) (cadr extents))
+ (if (looking-at "[ \t]+;")
+ (ledger-fontify-set-face (list (point) (progn
+ (end-of-line)
+ (point))) 'ledger-font-comment-face)
+ (ledger-fontify-posting (point)))
+ (forward-line))))
(defun ledger-fontify-xact-start (pos)
"POS should be at the beginning of a line starting an xact.
@@ -102,97 +103,97 @@ Fontify the first line of an xact"
(forward-line)))
(defun ledger-fontify-posting (pos)
- "Fontify the posting at POS."
- (let* ((state nil)
- (end-of-line-comment nil)
- (end (progn (end-of-line)
- (point)))
- (start (progn (beginning-of-line)
- (point))))
-
- ;; Look for a posting status flag
- (set-match-data nil 'reseat)
- (re-search-forward " \\([*!]\\) " end t)
- (if (match-string 1)
- (setq state (ledger-state-from-string (match-string 1))))
- (beginning-of-line)
- (re-search-forward "[[:graph:]]\\([ \t][ \t]\\)" end 'end) ;; find the end of the account, or end of line
-
- (when (<= (point) end) ;; we are still on the line
- (ledger-fontify-set-face (list start (point))
- (cond ((eq state 'cleared)
- 'ledger-font-posting-account-cleared-face)
- ((eq state 'pending)
- 'ledger-font-posting-account-pending-face)
- (t
- 'ledger-font-posting-account-face)))
-
-
- (when (< (point) end) ;; there is still more to fontify
- (setq start (point)) ;; update start of next font region
- (setq end-of-line-comment (re-search-forward ";" end 'end)) ;; find the end of the line, or start of a comment
- (ledger-fontify-set-face (list start (point) )
- (cond ((eq state 'cleared)
- 'ledger-font-posting-amount-cleared-face)
- ((eq state 'pending)
- 'ledger-font-posting-amount-pending-face)
- (t
- 'ledger-font-posting-amount-face)))
- (when end-of-line-comment
- (setq start (point))
- (end-of-line)
- (ledger-fontify-set-face (list (- start 1) (point)) ;; subtract 1 from start because we passed the semi-colon
- 'ledger-font-comment-face))))))
+ "Fontify the posting at POS."
+ (let* ((state nil)
+ (end-of-line-comment nil)
+ (end (progn (end-of-line)
+ (point)))
+ (start (progn (beginning-of-line)
+ (point))))
+
+ ;; Look for a posting status flag
+ (set-match-data nil 'reseat)
+ (re-search-forward " \\([*!]\\) " end t)
+ (if (match-string 1)
+ (setq state (ledger-state-from-string (match-string 1))))
+ (beginning-of-line)
+ (re-search-forward "[[:graph:]]\\([ \t][ \t]\\)" end 'end) ;; find the end of the account, or end of line
+
+ (when (<= (point) end) ;; we are still on the line
+ (ledger-fontify-set-face (list start (point))
+ (cond ((eq state 'cleared)
+ 'ledger-font-posting-account-cleared-face)
+ ((eq state 'pending)
+ 'ledger-font-posting-account-pending-face)
+ (t
+ 'ledger-font-posting-account-face)))
+
+
+ (when (< (point) end) ;; there is still more to fontify
+ (setq start (point)) ;; update start of next font region
+ (setq end-of-line-comment (re-search-forward ";" end 'end)) ;; find the end of the line, or start of a comment
+ (ledger-fontify-set-face (list start (point) )
+ (cond ((eq state 'cleared)
+ 'ledger-font-posting-amount-cleared-face)
+ ((eq state 'pending)
+ 'ledger-font-posting-amount-pending-face)
+ (t
+ 'ledger-font-posting-amount-face)))
+ (when end-of-line-comment
+ (setq start (point))
+ (end-of-line)
+ (ledger-fontify-set-face (list (- start 1) (point)) ;; subtract 1 from start because we passed the semi-colon
+ 'ledger-font-comment-face))))))
(defun ledger-fontify-directive-at (pos)
- "Fontify the directive at POS."
- (let ((extents (ledger-navigate-find-element-extents pos))
- (face 'ledger-font-default-face))
- (cond ((looking-at "=")
- (setq face 'ledger-font-auto-xact-face))
- ((looking-at "~")
- (setq face 'ledger-font-periodic-xact-face))
- ((looking-at "[;#%|\\*]")
- (setq face 'ledger-font-comment-face))
- ((looking-at "\\(year\\)\\|Y")
- (setq face 'ledger-font-year-directive-face))
- ((looking-at "account")
- (setq face 'ledger-font-account-directive-face))
- ((looking-at "apply")
- (setq face 'ledger-font-apply-directive-face))
- ((looking-at "alias")
- (setq face 'ledger-font-alias-directive-face))
- ((looking-at "assert")
- (setq face 'ledger-font-assert-directive-face))
- ((looking-at "\\(bucket\\)\\|A")
- (setq face 'ledger-font-bucket-directive-face))
- ((looking-at "capture")
- (setq face 'ledger-font-capture-directive-face))
- ((looking-at "check")
- (setq face 'ledger-font-check-directive-face))
- ((looking-at "commodity")
- (setq face 'ledger-font-commodity-directive-face))
- ((looking-at "define")
- (setq face 'ledger-font-define-directive-face))
- ((looking-at "end")
- (setq face 'ledger-font-end-directive-face))
- ((looking-at "expr")
- (setq face 'ledger-font-expr-directive-face))
- ((looking-at "fixed")
- (setq face 'ledger-font-fixed-directive-face))
- ((looking-at "include")
- (setq face 'ledger-font-include-directive-face))
- ((looking-at "payee")
- (setq face 'ledger-font-payee-directive-face))
- ((looking-at "P")
- (setq face 'ledger-font-price-directive-face))
- ((looking-at "tag")
- (setq face 'ledger-font-tag-directive-face)))
- (ledger-fontify-set-face extents face)))
+ "Fontify the directive at POS."
+ (let ((extents (ledger-navigate-find-element-extents pos))
+ (face 'ledger-font-default-face))
+ (cond ((looking-at "=")
+ (setq face 'ledger-font-auto-xact-face))
+ ((looking-at "~")
+ (setq face 'ledger-font-periodic-xact-face))
+ ((looking-at "[;#%|\\*]")
+ (setq face 'ledger-font-comment-face))
+ ((looking-at "\\(year\\)\\|Y")
+ (setq face 'ledger-font-year-directive-face))
+ ((looking-at "account")
+ (setq face 'ledger-font-account-directive-face))
+ ((looking-at "apply")
+ (setq face 'ledger-font-apply-directive-face))
+ ((looking-at "alias")
+ (setq face 'ledger-font-alias-directive-face))
+ ((looking-at "assert")
+ (setq face 'ledger-font-assert-directive-face))
+ ((looking-at "\\(bucket\\)\\|A")
+ (setq face 'ledger-font-bucket-directive-face))
+ ((looking-at "capture")
+ (setq face 'ledger-font-capture-directive-face))
+ ((looking-at "check")
+ (setq face 'ledger-font-check-directive-face))
+ ((looking-at "commodity")
+ (setq face 'ledger-font-commodity-directive-face))
+ ((looking-at "define")
+ (setq face 'ledger-font-define-directive-face))
+ ((looking-at "end")
+ (setq face 'ledger-font-end-directive-face))
+ ((looking-at "expr")
+ (setq face 'ledger-font-expr-directive-face))
+ ((looking-at "fixed")
+ (setq face 'ledger-font-fixed-directive-face))
+ ((looking-at "include")
+ (setq face 'ledger-font-include-directive-face))
+ ((looking-at "payee")
+ (setq face 'ledger-font-payee-directive-face))
+ ((looking-at "P")
+ (setq face 'ledger-font-price-directive-face))
+ ((looking-at "tag")
+ (setq face 'ledger-font-tag-directive-face)))
+ (ledger-fontify-set-face extents face)))
(defun ledger-fontify-set-face (extents face)
- "Set the text in EXTENTS to FACE."
- (put-text-property (car extents) (cadr extents) 'face face))
+ "Set the text in EXTENTS to FACE."
+ (put-text-property (car extents) (cadr extents) 'face face))
(provide 'ledger-fontify)
diff --git a/lisp/ledger-fonts.el b/lisp/ledger-fonts.el
index 8bdecdb3..60450e20 100644
--- a/lisp/ledger-fonts.el
+++ b/lisp/ledger-fonts.el
@@ -1,6 +1,6 @@
;;; ledger-fonts.el --- Helper code for use with the "ledger" command-line tool
-;; Copyright (C) 2003-2015 John Wiegley (johnw AT gnu DOT org)
+;; Copyright (C) 2003-2016 John Wiegley (johnw AT gnu DOT org)
;; This file is not part of GNU Emacs.
diff --git a/lisp/ledger-init.el b/lisp/ledger-init.el
index 49d74098..0141d2e7 100644
--- a/lisp/ledger-init.el
+++ b/lisp/ledger-init.el
@@ -1,6 +1,6 @@
;;; ledger-init.el --- Helper code for use with the "ledger" command-line tool
-;; Copyright (C) 2003-2015 John Wiegley (johnw AT gnu DOT org)
+;; Copyright (C) 2003-2016 John Wiegley (johnw AT gnu DOT org)
;; This file is not part of GNU Emacs.
@@ -35,7 +35,7 @@
(defvar ledger-default-date-format "%Y/%m/%d")
(defun ledger-init-parse-initialization (buffer)
- "Parse the .ledgerrc file in BUFFER."
+ "Parse the .ledgerrc file in BUFFER."
(with-current-buffer buffer
(let (environment-alist)
(goto-char (point-min))
@@ -56,7 +56,7 @@
environment-alist)))
(defun ledger-init-load-init-file ()
- "Load and parse the .ledgerrc file."
+ "Load and parse the .ledgerrc 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
diff --git a/lisp/ledger-mode.el b/lisp/ledger-mode.el
index 4e2beff6..7e30c350 100644
--- a/lisp/ledger-mode.el
+++ b/lisp/ledger-mode.el
@@ -1,6 +1,6 @@
;;; ledger-mode.el --- Helper code for use with the "ledger" command-line tool
-;; Copyright (C) 2003-2015 John Wiegley (johnw AT gnu DOT org)
+;; Copyright (C) 2003-2016 John Wiegley (johnw AT gnu DOT org)
;; This file is not part of GNU Emacs.
@@ -49,6 +49,7 @@
(require 'ledger-texi)
(require 'ledger-xact)
(require 'ledger-schedule)
+(require 'ledger-check)
;;; Code:
@@ -63,7 +64,7 @@
(defun ledger-mode-dump-variable (var)
"Format VAR for dump to buffer."
- (if var
+ (if var
(insert (format " %s: %S\n" (symbol-name var) (eval var)))))
(defun ledger-mode-dump-group (group)
@@ -78,7 +79,7 @@
(defun ledger-mode-dump-configuration ()
"Dump all customizations."
- (interactive)
+ (interactive)
(find-file "ledger-mode-dump")
(ledger-mode-dump-group 'ledger))
@@ -99,11 +100,11 @@
(defun ledger-read-account-with-prompt (prompt)
"Read an account from the minibuffer with PROMPT."
- (let ((context (ledger-context-at-point)))
+ (let ((context (ledger-context-at-point)))
(ledger-read-string-with-default prompt
- (if (eq (ledger-context-current-field context) 'account)
- (regexp-quote (ledger-context-field-value context 'account))
- nil))))
+ (if (eq (ledger-context-current-field context) 'account)
+ (regexp-quote (ledger-context-field-value context 'account))
+ nil))))
(defun ledger-read-date (prompt)
"Return user-supplied date after `PROMPT', defaults to today."
@@ -125,14 +126,19 @@
": "))
nil 'ledger-minibuffer-history default))
-(defun ledger-display-balance-at-point ()
+(defun ledger-display-balance-at-point (&optional arg)
"Display the cleared-or-pending balance.
-And calculate the target-delta of the account being reconciled."
- (interactive)
+And calculate the target-delta of the account being reconciled.
+
+With prefix argument \\[universal-argument] ask for the target commodity and convert
+the balance into that."
+ (interactive "P")
(let* ((account (ledger-read-account-with-prompt "Account balance to show"))
+ (target-commodity (when arg (ledger-read-commodity-with-prompt "Target commodity: ")))
(buffer (current-buffer))
(balance (with-temp-buffer
- (ledger-exec-ledger buffer (current-buffer) "cleared" account)
+ (apply 'ledger-exec-ledger buffer (current-buffer) "cleared" account
+ (when target-commodity (list "-X" target-commodity)))
(if (> (buffer-size) 0)
(buffer-substring-no-properties (point-min) (1- (point-max)))
(concat account " is empty.")))))
@@ -159,7 +165,7 @@ Can indent, complete or align depending on context."
(if (and (> (point) 1)
(looking-back "\\([^ \t]\\)" 1))
(ledger-pcomplete interactively)
- (ledger-post-align-postings))))
+ (ledger-post-align-postings (line-beginning-position) (line-end-position)))))
(defvar ledger-mode-abbrev-table)
@@ -222,7 +228,7 @@ With a prefix argument, remove the effective date."
(defun ledger-mode-remove-extra-lines ()
"Get rid of multiple empty lines."
- (goto-char (point-min))
+ (goto-char (point-min))
(while (re-search-forward "\n\n\\(\n\\)+" nil t)
(replace-match "\n\n")))
@@ -285,6 +291,7 @@ With a prefix argument, remove the effective date."
(define-key map [(meta ?p)] 'ledger-navigate-prev-xact-or-directive)
(define-key map [(meta ?n)] 'ledger-navigate-next-xact-or-directive)
+ (define-key map [(meta ?q)] 'ledger-post-align-dwim)
map)
"Keymap for `ledger-mode'.")
@@ -310,6 +317,7 @@ With a prefix argument, remove the effective date."
["Copy Trans at Point" ledger-copy-transaction-at-point]
"---"
["Clean-up Buffer" ledger-mode-clean-buffer]
+ ["Check Buffer" ledger-check-buffer ledger-works]
["Align Region" ledger-post-align-postings mark-active]
["Align Xact" ledger-post-align-xact]
["Sort Region" ledger-sort-region mark-active]
@@ -338,10 +346,10 @@ With a prefix argument, remove the effective date."
'(ledger-font-lock-keywords t t nil nil
(font-lock-fontify-region-function . ledger-fontify-buffer-part))))
- (set (make-local-variable 'pcomplete-parse-arguments-function) 'ledger-parse-arguments)
- (set (make-local-variable 'pcomplete-command-completion-function) 'ledger-complete-at-point)
+ (set (make-local-variable 'pcomplete-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 'after-save-hook 'ledger-report-redo)
+ (add-hook 'after-save-hook 'ledger-report-redo)
(add-hook 'post-command-hook 'ledger-highlight-xact-under-point nil t)
diff --git a/lisp/ledger-navigate.el b/lisp/ledger-navigate.el
index 904faf8c..7ac440f7 100644
--- a/lisp/ledger-navigate.el
+++ b/lisp/ledger-navigate.el
@@ -39,49 +39,49 @@
(goto-char (point-max))))
(defun ledger-navigate-start-xact-or-directive-p ()
- "Return t if at the beginning of an empty or all-whitespace line."
- (not (looking-at "[ \t]\\|\\(^$\\)")))
+ "Return t if at the beginning of an empty or all-whitespace line."
+ (not (looking-at "[ \t]\\|\\(^$\\)")))
(defun ledger-navigate-next-xact-or-directive ()
- "Move to the beginning of the next xact or directive."
- (interactive)
- (beginning-of-line)
- (if (ledger-navigate-start-xact-or-directive-p) ; if we are the start of an xact, move forward to the next xact
- (progn
- (forward-line)
- (if (not (ledger-navigate-start-xact-or-directive-p)) ; we have moved forward and are not at another xact, recurse forward
- (ledger-navigate-next-xact-or-directive)))
- (while (not (or (eobp) ; we didn't start off at the beginning of an xact
- (ledger-navigate-start-xact-or-directive-p)))
- (forward-line))))
+ "Move to the beginning of the next xact or directive."
+ (interactive)
+ (beginning-of-line)
+ (if (ledger-navigate-start-xact-or-directive-p) ; if we are the start of an xact, move forward to the next xact
+ (progn
+ (forward-line)
+ (if (not (ledger-navigate-start-xact-or-directive-p)) ; we have moved forward and are not at another xact, recurse forward
+ (ledger-navigate-next-xact-or-directive)))
+ (while (not (or (eobp) ; we didn't start off at the beginning of an xact
+ (ledger-navigate-start-xact-or-directive-p)))
+ (forward-line))))
(defun ledger-navigate-prev-xact-or-directive ()
"Move point to beginning of previous xact."
- (interactive)
- (let ((context (car (ledger-context-at-point))))
- (when (equal context 'acct-transaction)
- (ledger-navigate-beginning-of-xact))
- (beginning-of-line)
- (re-search-backward "^[[:graph:]]" nil t)))
+ (interactive)
+ (let ((context (car (ledger-context-at-point))))
+ (when (equal context 'acct-transaction)
+ (ledger-navigate-beginning-of-xact))
+ (beginning-of-line)
+ (re-search-backward "^[[:graph:]]" nil t)))
(defun ledger-navigate-beginning-of-xact ()
- "Move point to the beginning of the current xact."
- (interactive)
- ;; need to start at the beginning of a line incase we are in the first line of an xact already.
- (beginning-of-line)
- (let ((sreg (concat "^\\(=\\|~\\|" ledger-iso-date-regexp "\\)")))
- (unless (looking-at sreg)
- (re-search-backward sreg nil t)
- (beginning-of-line)))
- (point))
+ "Move point to the beginning of the current xact."
+ (interactive)
+ ;; need to start at the beginning of a line incase we are in the first line of an xact already.
+ (beginning-of-line)
+ (let ((sreg (concat "^\\(=\\|~\\|" ledger-iso-date-regexp "\\)")))
+ (unless (looking-at sreg)
+ (re-search-backward sreg nil t)
+ (beginning-of-line)))
+ (point))
(defun ledger-navigate-end-of-xact ()
"Move point to end of xact."
- (interactive)
+ (interactive)
(ledger-navigate-next-xact-or-directive)
- (re-search-backward ".$")
- (end-of-line)
- (point))
+ (re-search-backward ".$")
+ (end-of-line)
+ (point))
(defun ledger-navigate-to-line (line-number)
"Rapidly move point to line LINE-NUMBER."
@@ -95,61 +95,61 @@ Requires empty line separating xacts."
(save-excursion
(goto-char pos)
(list (ledger-navigate-beginning-of-xact)
- (ledger-navigate-end-of-xact))))
+ (ledger-navigate-end-of-xact))))
(defun ledger-navigate-find-directive-extents (pos)
"Return the extents of the directive at POS."
- (goto-char pos)
- (let ((begin (progn (beginning-of-line)
- (point)))
- (end (progn (end-of-line)
- (+ 1 (point)))))
- ;; handle block comments here
- (beginning-of-line)
- (if (looking-at " *;")
- (progn
- (while (and (looking-at " *;")
- (> (point) (point-min)))
- (forward-line -1))
- ;; We are either at the beginning of the buffer, or we found
- ;; a line outside the comment. If we are not at the
- ;; beginning of the buffer then we need to move forward a
- ;; line.
- (if (> (point) (point-min))
- (progn (forward-line 1)
- (beginning-of-line)))
- (setq begin (point))
- (goto-char pos)
- (beginning-of-line)
- (while (and (looking-at " *;")
- (< (point) (point-max)))
- (forward-line 1))
- (setq end (point))))
- (list begin end)))
+ (goto-char pos)
+ (let ((begin (progn (beginning-of-line)
+ (point)))
+ (end (progn (end-of-line)
+ (+ 1 (point)))))
+ ;; handle block comments here
+ (beginning-of-line)
+ (if (looking-at " *;")
+ (progn
+ (while (and (looking-at " *;")
+ (> (point) (point-min)))
+ (forward-line -1))
+ ;; We are either at the beginning of the buffer, or we found
+ ;; a line outside the comment. If we are not at the
+ ;; beginning of the buffer then we need to move forward a
+ ;; line.
+ (if (> (point) (point-min))
+ (progn (forward-line 1)
+ (beginning-of-line)))
+ (setq begin (point))
+ (goto-char pos)
+ (beginning-of-line)
+ (while (and (looking-at " *;")
+ (< (point) (point-max)))
+ (forward-line 1))
+ (setq end (point))))
+ (list begin end)))
(defun ledger-navigate-block-comment (pos)
"Move past the block comment at POS, and return its extents."
- (interactive "d")
- (goto-char pos)
- (let ((begin (progn (beginning-of-line)
- (point)))
- (end (progn (end-of-line)
- (point))))
- ;; handle block comments here
- (beginning-of-line)
- (if (looking-at " *;")
- (progn
- (while (and (looking-at " *;")
- (> (point) (point-min)))
- (forward-line -1))
- (setq begin (point))
- (goto-char pos)
- (beginning-of-line)
- (while (and (looking-at " *;")
- (< (point) (point-max)))
- (forward-line 1))
- (setq end (point))))
- (list begin end)))
+ (interactive "d")
+ (goto-char pos)
+ (let ((begin (progn (beginning-of-line)
+ (point)))
+ (end (progn (end-of-line)
+ (point))))
+ ;; handle block comments here
+ (beginning-of-line)
+ (if (looking-at " *;")
+ (progn
+ (while (and (looking-at " *;")
+ (> (point) (point-min)))
+ (forward-line -1))
+ (setq begin (point))
+ (goto-char pos)
+ (beginning-of-line)
+ (while (and (looking-at " *;")
+ (< (point) (point-max)))
+ (forward-line 1))
+ (setq end (point))))
+ (list begin end)))
(defun ledger-navigate-find-element-extents (pos)
@@ -158,7 +158,7 @@ Requires empty line separating xacts."
(save-excursion
(goto-char pos)
(beginning-of-line)
- (if (looking-at "[ =~0-9]")
+ (if (looking-at "[ =~0-9\\[]")
(ledger-navigate-find-xact-extents pos)
(ledger-navigate-find-directive-extents pos))))
diff --git a/lisp/ledger-occur.el b/lisp/ledger-occur.el
index 32a1bd96..0df2f1a9 100644
--- a/lisp/ledger-occur.el
+++ b/lisp/ledger-occur.el
@@ -1,6 +1,6 @@
;;; ledger-occur.el --- Helper code for use with the "ledger" command-line tool
-;; Copyright (C) 2003-2015 John Wiegley (johnw AT gnu DOT org)
+;; Copyright (C) 2003-2016 John Wiegley (johnw AT gnu DOT org)
;; This file is not part of GNU Emacs.
@@ -120,7 +120,7 @@ currently active."
Argument OVL-BOUNDS contains bounds for the transactions to be left visible."
(let* ((beg (caar ovl-bounds))
(end (cadar ovl-bounds)))
- (ledger-occur-remove-overlays)
+ (ledger-occur-remove-overlays)
(ledger-occur-make-invisible-overlay (point-min) (1- beg))
(dolist (visible (cdr ovl-bounds))
(ledger-occur-make-visible-overlay beg end)
@@ -145,25 +145,25 @@ Argument OVL-BOUNDS contains bounds for the transactions to be left visible."
(while (not (eobp))
;; if something found
(when (setq endpoint (re-search-forward regex nil 'end))
- (setq bounds (ledger-navigate-find-element-extents endpoint))
- (push bounds lines)
- ;; move to the end of the xact, no need to search inside it more
+ (setq bounds (ledger-navigate-find-element-extents endpoint))
+ (push bounds lines)
+ ;; move to the end of the xact, no need to search inside it more
(goto-char (cadr bounds))))
(nreverse lines))))
(defun ledger-occur-compress-matches (buffer-matches)
"identify sequential xacts to reduce number of overlays required"
- (if buffer-matches
- (let ((points (list))
- (current-beginning (caar buffer-matches))
- (current-end (cadar buffer-matches)))
- (dolist (match (cdr buffer-matches))
- (if (< (- (car match) current-end) 2)
- (setq current-end (cadr match))
- (push (list current-beginning current-end) points)
- (setq current-beginning (car match))
- (setq current-end (cadr match))))
- (nreverse (push (list current-beginning current-end) points)))))
+ (if buffer-matches
+ (let ((points (list))
+ (current-beginning (caar buffer-matches))
+ (current-end (cadar buffer-matches)))
+ (dolist (match (cdr buffer-matches))
+ (if (< (- (car match) current-end) 2)
+ (setq current-end (cadr match))
+ (push (list current-beginning current-end) points)
+ (setq current-beginning (car match))
+ (setq current-end (cadr match))))
+ (nreverse (push (list current-beginning current-end) points)))))
(provide 'ledger-occur)
diff --git a/lisp/ledger-post.el b/lisp/ledger-post.el
index 5665885b..973f2260 100644
--- a/lisp/ledger-post.el
+++ b/lisp/ledger-post.el
@@ -1,6 +1,6 @@
;;; ledger-post.el --- Helper code for use with the "ledger" command-line tool
-;; Copyright (C) 2003-2015 John Wiegley (johnw AT gnu DOT org)
+;; Copyright (C) 2003-2016 John Wiegley (johnw AT gnu DOT org)
;; This file is not part of GNU Emacs.
@@ -43,6 +43,16 @@
:type 'integer
:group 'ledger-post)
+(defcustom ledger-post-amount-alignment-at :end
+ "Position at which the amount is ailgned.
+
+Can be :end to align on the last number of the amount (can be
+followed by unaligned commodity) or :decimal to align at the
+decimal separator."
+ :type '(radio (const :tag "align at the end of amount" :end)
+ (const :tag "align at the decimal separator" :decimal))
+ :group 'ledger-post)
+
(defcustom ledger-post-use-completion-engine :built-in
"Which completion engine to use, :iswitchb or :ido chose those engines.
:built-in uses built-in Ledger-mode completion"
@@ -81,8 +91,11 @@ point at beginning of the commodity."
(when (re-search-forward ledger-amount-regex end t)
(goto-char (match-beginning 0))
(skip-syntax-forward " ")
- (- (or (match-end 4)
- (match-end 3)) (point)))))
+ (cond
+ ((eq ledger-post-amount-alignment-at :end)
+ (- (or (match-end 4) (match-end 3)) (point)))
+ ((eq ledger-post-amount-alignment-at :decimal)
+ (- (match-end 3) (point)))))))
(defun ledger-next-account (&optional end)
"Move to the beginning of the posting, or status marker, limit to END.
@@ -97,28 +110,20 @@ at beginning of account"
(current-column))))
(defun ledger-post-align-xact (pos)
- "Align all the posting in the xact at POS."
- (interactive "d")
+ "Align all the posting in the xact at POS."
+ (interactive "d")
(let ((bounds (ledger-navigate-find-xact-extents pos)))
(ledger-post-align-postings (car bounds) (cadr bounds))))
-(defun ledger-post-align-postings (&optional beg end)
- "Align all accounts and amounts between BEG and END, or the current line."
- (interactive)
+(defun ledger-post-align-postings (beg end)
+ "Align all accounts and amounts between BEG and END, or the current region, or, if no region, the current line."
+ (interactive "r")
(save-excursion
- (if (or (not (mark))
- (not (use-region-p)))
- (set-mark (point)))
-
(let ((inhibit-modification-hooks t)
- (mark-first (< (mark) (point)))
acct-start-column acct-end-column acct-adjust amt-width amt-adjust
(lines-left 1))
- (unless beg (setq beg (if mark-first (mark) (point))))
- (unless end (setq end (if mark-first (mark) (point))))
-
;; Extend region to whole lines
(let ((start-marker (set-marker (make-marker) (save-excursion
(goto-char beg)
@@ -156,6 +161,19 @@ at beginning of account"
(setq lines-left (not (eobp)))))
(setq inhibit-modification-hooks nil))))
+(defun ledger-post-align-dwim ()
+ "Align all the posting of the current xact or the current region.
+
+If the point is in a comment, fill the comment paragraph as
+regular text."
+ (interactive)
+ (cond
+ ((nth 4 (syntax-ppss))
+ (call-interactively 'ledger-post-align-postings)
+ (fill-paragraph))
+ ((use-region-p) (call-interactively 'ledger-post-align-postings))
+ (t (call-interactively 'ledger-post-align-xact))))
+
(defun ledger-post-edit-amount ()
"Call 'calc-mode' and push the amount in the posting to the top of stack."
(interactive)
diff --git a/lisp/ledger-reconcile.el b/lisp/ledger-reconcile.el
index b76700b0..7ac8f2c4 100644
--- a/lisp/ledger-reconcile.el
+++ b/lisp/ledger-reconcile.el
@@ -1,6 +1,6 @@
;;; ledger-reconcile.el --- Helper code for use with the "ledger" command-line tool
-;; Copyright (C) 2003-2015 John Wiegley (johnw AT gnu DOT org)
+;; Copyright (C) 2003-2016 John Wiegley (johnw AT gnu DOT org)
;; This file is not part of GNU Emacs.
@@ -91,7 +91,7 @@ Default is ledger-default-date-format."
:group 'ledger-reconcile)
(defcustom ledger-reconcile-buffer-header "Reconciling account %s\n\n"
- "Default header string for the reconcile buffer.
+ "Default header string for the reconcile buffer.
If non-nil, the name of the account being reconciled will be substituted
into the '%s'. If nil, no header will be displayed."
@@ -99,7 +99,7 @@ If non-nil, the name of the account being reconciled will be substituted
:group 'ledger-reconcile)
(defcustom ledger-reconcile-buffer-line-format "%(date)s %-4(code)s %-50(payee)s %-30(account)s %15(amount)s\n"
- "Format string for the ledger reconcile posting format.
+ "Format string for the ledger reconcile posting format.
Available fields are date, status, code, payee, account,
amount. The format for each field is %WIDTH(FIELD), WIDTH can be
preced by a minus sign which mean to left justify and pad the
@@ -132,18 +132,23 @@ Possible values are '(date)', '(amount)', '(payee)' or '(0)' for no sorting, i.e
:type 'boolean
:group 'ledger-reconcile)
+(defcustom ledger-reconcile-finish-force-quit nil
+ "If t, will force closing reconcile window after \\[ledger-reconcile-finish]."
+ :type 'boolean
+ :group 'ledger-reconcile)
+
;; s-functions below are copied from Magnars' s.el
;; prefix ledger-reconcile- is added to not conflict with s.el
(defun ledger-reconcile-s-pad-left (len padding s)
"If S is shorter than LEN, pad it with PADDING on the left."
(let ((extra (max 0 (- len (length s)))))
(concat (make-string extra (string-to-char padding))
- s)))
+ s)))
(defun ledger-reconcile-s-pad-right (len padding s)
"If S is shorter than LEN, pad it with PADDING on the right."
(let ((extra (max 0 (- len (length s)))))
(concat s
- (make-string extra (string-to-char padding)))))
+ (make-string extra (string-to-char padding)))))
(defun ledger-reconcile-s-left (len s)
"Return up to the LEN first chars of S."
(if (> (length s) len)
@@ -153,7 +158,7 @@ Possible values are '(date)', '(amount)', '(payee)' or '(0)' for no sorting, i.e
"Return up to the LEN last chars of S."
(let ((l (length s)))
(if (> l len)
- (substring s (- l len) l)
+ (substring s (- l len) l)
s)))
(defun ledger-reconcile-truncate-right (str len)
@@ -267,9 +272,9 @@ Return the number of uncleared xacts found."
(with-current-buffer recon-buf
(ledger-reconcile-refresh)
(set-buffer-modified-p nil))
- (when curbufwin
- (select-window curbufwin)
- (goto-char curpoint)))))
+ (when curbufwin
+ (select-window curbufwin)
+ (goto-char curpoint)))))
(defun ledger-reconcile-add ()
"Use ledger xact to add a new transaction."
@@ -295,40 +300,40 @@ Return the number of uncleared xacts found."
(defun ledger-reconcile-visit (&optional come-back)
"Recenter ledger buffer on transaction and COME-BACK if non-nil."
(interactive)
- (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))))
- (when target-buffer
- (switch-to-buffer-other-window target-buffer)
- (ledger-navigate-to-line (cdr where))
- (forward-char)
- (recenter)
- (ledger-highlight-xact-under-point)
- (forward-char -1)
- (when (and come-back cur-win)
- (select-window cur-win)
- (get-buffer ledger-recon-buffer-name)))))
+ (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))))
+ (when target-buffer
+ (switch-to-buffer-other-window target-buffer)
+ (ledger-navigate-to-line (cdr where))
+ (forward-char)
+ (recenter)
+ (ledger-highlight-xact-under-point)
+ (forward-char -1)
+ (when (and come-back cur-win)
+ (select-window cur-win)
+ (get-buffer ledger-recon-buffer-name)))))
(defun ledger-reconcile-save ()
"Save the ledger buffer."
(interactive)
- (let ((cur-buf (current-buffer))
- (cur-point (point)))
- (dolist (buf (cons ledger-buf ledger-bufs))
- (with-current-buffer buf
- (basic-save-buffer)))
- (switch-to-buffer-other-window cur-buf)
- (goto-char cur-point)))
+ (let ((cur-buf (current-buffer))
+ (cur-point (point)))
+ (dolist (buf (cons ledger-buf ledger-bufs))
+ (with-current-buffer buf
+ (basic-save-buffer)))
+ (switch-to-buffer-other-window cur-buf)
+ (goto-char cur-point)))
(defun ledger-reconcile-finish ()
"Mark all pending posting or transactions as cleared.
Depends on ledger-reconcile-clear-whole-transactions, save the buffers
-and exit reconcile mode"
+and exit reconcile mode if `ledger-reconcile-finish-force-quit'"
(interactive)
(save-excursion
(goto-char (point-min))
@@ -341,7 +346,8 @@ and exit reconcile mode"
(ledger-toggle-current 'cleared))))
(forward-line 1)))
(ledger-reconcile-save)
- (ledger-reconcile-quit))
+ (when ledger-reconcile-finish-force-quit
+ (ledger-reconcile-quit)))
(defun ledger-reconcile-quit ()
@@ -383,55 +389,55 @@ POSTING is used in `ledger-clear-whole-transactions' is nil."
(nth 0 posting))))) ;; return line-no of posting
(defun ledger-reconcile-compile-format-string (fstr)
- "Return a function that implements the format string in FSTR."
- (let (fields
- (start 0))
- (while (string-match "(\\(.*?\\))" fstr start)
- (setq fields (cons (intern (match-string 1 fstr)) fields))
- (setq start (match-end 0)))
- (setq fields (list* 'format (replace-regexp-in-string "(.*?)" "" fstr) (nreverse fields)))
- `(lambda (date code status payee account amount)
- ,fields)))
+ "Return a function that implements the format string in FSTR."
+ (let (fields
+ (start 0))
+ (while (string-match "(\\(.*?\\))" fstr start)
+ (setq fields (cons (intern (match-string 1 fstr)) fields))
+ (setq start (match-end 0)))
+ (setq fields (list* 'format (replace-regexp-in-string "(.*?)" "" fstr) (nreverse fields)))
+ `(lambda (date code status payee account amount)
+ ,fields)))
(defun ledger-reconcile-format-posting (beg where fmt date code status payee account amount)
- "Format posting for the reconcile buffer."
- (insert (funcall fmt date code status payee account amount))
-
- ; Set face depending on cleared status
- (if status
- (if (eq status '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))))
+ "Format posting for the reconcile buffer."
+ (insert (funcall fmt date code status payee account amount))
+
+ ; Set face depending on cleared status
+ (if status
+ (if (eq status '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))))
(defun ledger-reconcile-format-xact (xact fmt)
- "Format XACT using FMT."
- (let ((date-format (or (cdr (assoc "date-format" ledger-environment-alist))
- ledger-default-date-format)))
- (dolist (posting (nthcdr 5 xact))
- (let ((beg (point))
- (where (ledger-marker-where-xact-is xact posting)))
- (ledger-reconcile-format-posting beg
- where
- fmt
- (format-time-string date-format (nth 2 xact)) ; date
- (if (nth 3 xact) (nth 3 xact) "") ; code
- (nth 3 posting) ; status
+ "Format XACT using FMT."
+ (let ((date-format (or (cdr (assoc "date-format" ledger-environment-alist))
+ ledger-default-date-format)))
+ (dolist (posting (nthcdr 5 xact))
+ (let ((beg (point))
+ (where (ledger-marker-where-xact-is xact posting)))
+ (ledger-reconcile-format-posting beg
+ where
+ fmt
+ (format-time-string date-format (nth 2 xact)) ; date
+ (if (nth 3 xact) (nth 3 xact) "") ; code
+ (nth 3 posting) ; status
(ledger-reconcile-truncate-right
- (nth 4 xact) ; payee
- ledger-reconcile-buffer-payee-max-chars)
+ (nth 4 xact) ; payee
+ ledger-reconcile-buffer-payee-max-chars)
(ledger-reconcile-truncate-left
- (nth 1 posting) ; account
- ledger-reconcile-buffer-account-max-chars)
- (nth 2 posting)))))) ; amount
+ (nth 1 posting) ; account
+ ledger-reconcile-buffer-account-max-chars)
+ (nth 2 posting)))))) ; amount
(defun ledger-do-reconcile (&optional sort)
"SORT the uncleared transactions in the account and display them in the *Reconcile* buffer.
@@ -451,10 +457,11 @@ Return a count of the uncleared transactions."
(unless (eobp)
(if (looking-at "(")
(read (current-buffer))))))) ;current-buffer is the *temp* created above
- (fmt (ledger-reconcile-compile-format-string ledger-reconcile-buffer-line-format)))
+ (fmt (ledger-reconcile-compile-format-string ledger-reconcile-buffer-line-format)))
(if (and ledger-success (> (length xacts) 0))
(progn
- (insert (format ledger-reconcile-buffer-header account))
+ (if ledger-reconcile-buffer-header
+ (insert (format ledger-reconcile-buffer-header account)))
(dolist (xact xacts)
(ledger-reconcile-format-xact xact fmt))
(goto-char (point-max))
@@ -507,11 +514,11 @@ moved and recentered. If they aren't strange things happen."
(pop-to-buffer rbuf)))
(defun ledger-reconcile-check-valid-account (account)
- "Check to see if ACCOUNT exists in the ledger file"
- (if (> (length account) 0)
- (save-excursion
- (goto-char (point-min))
- (search-forward account nil t))))
+ "Check to see if ACCOUNT exists in the ledger file"
+ (if (> (length account) 0)
+ (save-excursion
+ (goto-char (point-min))
+ (search-forward account nil t))))
(defun ledger-reconcile ()
"Start reconciling, prompt for account."
@@ -520,38 +527,38 @@ moved and recentered. If they aren't strange things happen."
(buf (current-buffer))
(rbuf (get-buffer ledger-recon-buffer-name)))
- (when (ledger-reconcile-check-valid-account account)
- (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)
- (setq ledger-buf buf)) ;; should already be buffer-local
-
- (unless (get-buffer-window rbuf)
- (ledger-reconcile-open-windows buf rbuf)))
-
- ;; 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)))
-
- ;; Narrow the ledger buffer
- (with-current-buffer rbuf
- (save-excursion
- (if ledger-narrow-on-reconcile
- (ledger-occur account)))
- (if (> (ledger-reconcile-refresh) 0)
- (ledger-reconcile-change-target))
- (ledger-display-balance)))))
+ (when (ledger-reconcile-check-valid-account account)
+ (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)
+ (setq ledger-buf buf)) ;; should already be buffer-local
+
+ (unless (get-buffer-window rbuf)
+ (ledger-reconcile-open-windows buf rbuf)))
+
+ ;; 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)))
+
+ ;; Narrow the ledger buffer
+ (with-current-buffer rbuf
+ (save-excursion
+ (if ledger-narrow-on-reconcile
+ (ledger-occur account)))
+ (if (> (ledger-reconcile-refresh) 0)
+ (ledger-reconcile-change-target))
+ (ledger-display-balance)))))
(defvar ledger-reconcile-mode-abbrev-table)
@@ -562,7 +569,7 @@ moved and recentered. If they aren't strange things happen."
(defmacro ledger-reconcile-change-sort-key-and-refresh (sort-by)
"Set the sort-key to SORT-BY."
- `(lambda ()
+ `(lambda ()
(interactive)
(setq ledger-reconcile-sort-key ,sort-by)
diff --git a/lisp/ledger-regex.el b/lisp/ledger-regex.el
index 41231845..83c59feb 100644
--- a/lisp/ledger-regex.el
+++ b/lisp/ledger-regex.el
@@ -1,6 +1,6 @@
;;; ledger-regex.el --- Helper code for use with the "ledger" command-line tool
-;; Copyright (C) 2003-2015 John Wiegley (johnw AT gnu DOT org)
+;; Copyright (C) 2003-2016 John Wiegley (johnw AT gnu DOT org)
;; This file is not part of GNU Emacs.
@@ -27,8 +27,14 @@
(defconst ledger-amount-regex
(concat "\\( \\|\t\\| \t\\)[ \t]*-?"
"\\([A-Z$€£₹_(]+ *\\)?"
- "\\(-?[0-9,\\.]+?\\)"
- "\\(.[0-9)]+\\)?"
+ ;; We either match just a number after the commodity with no
+ ;; decimal or thousand separators or a number with thousand
+ ;; separators. If we have a decimal part starting with `,'
+ ;; or `.', because the match is non-greedy, it must leave at
+ ;; least one of those symbols for the following capture
+ ;; group, which then finishes the decimal part.
+ "\\(-?\\(?:[0-9]+\\|[0-9,.]+?\\)\\)"
+ "\\([,.][0-9)]+\\)?"
"\\( *[[:word:]€£₹_\"]+\\)?"
"\\([ \t]*[@={]@?[^\n;]+?\\)?"
"\\([ \t]+;.+?\\|[ \t]*\\)?$"))
@@ -108,8 +114,8 @@
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)
@@ -153,9 +159,9 @@
defs
(list
`(defmacro
- ,(intern (concat "ledger-regex-" (symbol-name name)
- "-" (symbol-name var)))
- (&optional string)
+ ,(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
@@ -238,6 +244,22 @@
code
(note end-note))
+(ledger-define-regexp recurring-line
+ (macroexpand
+ `(rx (and line-start
+ (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))))
"")
@@ -333,8 +355,8 @@
"\\)"))
(defconst ledger-xact-start-regex
- (concat "^" ledger-iso-date-regexp ;; subexp 1
- "\\(=" ledger-iso-date-regexp "\\)?"
+ (concat "^" ledger-iso-date-regexp ;; subexp 1
+ "\\(=" ledger-iso-date-regexp "\\)?"
))
(defconst ledger-xact-after-date-regex
@@ -345,17 +367,17 @@
))
(defconst ledger-posting-regex
- (concat "^[ \t]+ ?" ;; initial white space
- "\\([*!]\\)? ?" ;; state, subexpr 1
- "\\([[:print:]]+\\([ \t][ \t]\\)\\)" ;; account, subexpr 2
- "\\([^;\n]*\\)" ;; amount, subexpr 4
- "\\(.*\\)" ;; comment, subexpr 5
- ))
+ (concat "^[ \t]+ ?" ;; initial white space
+ "\\([*!]\\)? ?" ;; state, subexpr 1
+ "\\([[:print:]]+\\([ \t][ \t]\\)\\)" ;; account, subexpr 2
+ "\\([^;\n]*\\)" ;; amount, subexpr 4
+ "\\(.*\\)" ;; comment, subexpr 5
+ ))
(defconst ledger-directive-start-regex
- "[=~;#%|\\*[A-Za-z]")
+ "[=~;#%|\\*[A-Za-z]")
(provide 'ledger-regex)
diff --git a/lisp/ledger-report.el b/lisp/ledger-report.el
index 4131b92a..83c287eb 100644
--- a/lisp/ledger-report.el
+++ b/lisp/ledger-report.el
@@ -1,6 +1,6 @@
;;; ledger-report.el --- Helper code for use with the "ledger" command-line tool
-;; Copyright (C) 2003-2015 John Wiegley (johnw AT gnu DOT org)
+;; Copyright (C) 2003-2016 John Wiegley (johnw AT gnu DOT org)
;; This file is not part of GNU Emacs.
@@ -62,7 +62,7 @@ specifier."
'(("ledger-file" . ledger-report-ledger-file-format-specifier)
("payee" . ledger-report-payee-format-specifier)
("account" . ledger-report-account-format-specifier)
- ("tagname" . ledger-report-tagname-format-specifier)
+ ("tagname" . ledger-report-tagname-format-specifier)
("tagvalue" . ledger-report-tagvalue-format-specifier))
"An alist mapping ledger report format specifiers to implementing functions.
@@ -72,14 +72,14 @@ text that should replace the format specifier."
:group 'ledger-report)
(defcustom ledger-report-auto-refresh t
- "If t then automatically rerun the report when the ledger buffer is saved."
- :type 'boolean
- :group 'ledger-report)
+ "If t then automatically rerun the report when the ledger buffer is saved."
+ :type 'boolean
+ :group 'ledger-report)
(defcustom ledger-report-auto-refresh-sticky-cursor nil
- "If t then try to place cursor at same relative position as it was before auto-refresh."
- :type 'boolean
- :group 'ledger-report)
+ "If t then try to place cursor at same relative position as it was before auto-refresh."
+ :type 'boolean
+ :group 'ledger-report)
(defvar ledger-report-buffer-name "*Ledger Report*")
@@ -96,10 +96,10 @@ text that should replace the format specifier."
(defvar ledger-report-cursor-line-number nil)
(defun ledger-report-reverse-report ()
- "Reverse the order of the report."
- (interactive)
- (ledger-report-reverse-lines)
- (setq ledger-report-is-reversed (not ledger-report-is-reversed)))
+ "Reverse the order of the report."
+ (interactive)
+ (ledger-report-reverse-lines)
+ (setq ledger-report-is-reversed (not ledger-report-is-reversed)))
(defun ledger-report-reverse-lines ()
(goto-char (point-min))
@@ -208,7 +208,7 @@ used to generate the buffer, navigating the buffer, etc."
(set (make-local-variable 'ledger-buf) buf)
(set (make-local-variable 'ledger-report-name) report-name)
(set (make-local-variable 'ledger-original-window-cfg) wcfg)
- (set (make-local-variable 'ledger-report-is-reversed) nil)
+ (set (make-local-variable 'ledger-report-is-reversed) nil)
(ledger-do-report (ledger-report-cmd report-name edit))
(shrink-window-if-larger-than-buffer)
(set-buffer-modified-p nil)
@@ -392,30 +392,30 @@ Optional EDIT the command."
(defun ledger-report-redo ()
"Redo the report in the current ledger report buffer."
(interactive)
- (let ((cur-buf (current-buffer)))
- (if (and ledger-report-auto-refresh
- (or (string= (format-mode-line 'mode-name) "Ledger")
- (string= (format-mode-line 'mode-name) "Ledger-Report"))
- (get-buffer ledger-report-buffer-name))
- (progn
-
- (pop-to-buffer (get-buffer ledger-report-buffer-name))
- (shrink-window-if-larger-than-buffer)
- (setq buffer-read-only nil)
- (setq ledger-report-cursor-line-number (line-number-at-pos))
- (erase-buffer)
- (ledger-do-report ledger-report-cmd)
- (setq buffer-read-only nil)
- (if ledger-report-is-reversed (ledger-report-reverse-lines))
- (if ledger-report-auto-refresh-sticky-cursor (forward-line (- ledger-report-cursor-line-number 5)))
- (pop-to-buffer cur-buf)))))
+ (let ((cur-buf (current-buffer)))
+ (if (and ledger-report-auto-refresh
+ (or (string= (format-mode-line 'mode-name) "Ledger")
+ (string= (format-mode-line 'mode-name) "Ledger-Report"))
+ (get-buffer ledger-report-buffer-name))
+ (progn
+
+ (pop-to-buffer (get-buffer ledger-report-buffer-name))
+ (shrink-window-if-larger-than-buffer)
+ (setq buffer-read-only nil)
+ (setq ledger-report-cursor-line-number (line-number-at-pos))
+ (erase-buffer)
+ (ledger-do-report ledger-report-cmd)
+ (setq buffer-read-only nil)
+ (if ledger-report-is-reversed (ledger-report-reverse-lines))
+ (if ledger-report-auto-refresh-sticky-cursor (forward-line (- ledger-report-cursor-line-number 5)))
+ (pop-to-buffer cur-buf)))))
(defun ledger-report-quit ()
- "Quit the ledger report buffer."
- (interactive)
- (ledger-report-goto)
- (set-window-configuration ledger-original-window-cfg)
- (kill-buffer (get-buffer ledger-report-buffer-name)))
+ "Quit the ledger report buffer."
+ (interactive)
+ (ledger-report-goto)
+ (set-window-configuration ledger-original-window-cfg)
+ (kill-buffer (get-buffer ledger-report-buffer-name)))
(defun ledger-report-edit-reports ()
"Edit the defined ledger reports."
@@ -423,10 +423,10 @@ Optional EDIT the command."
(customize-variable 'ledger-reports))
(defun ledger-report-edit-report ()
- "Edit the current report command in the mini buffer and re-run the report."
- (interactive)
- (setq ledger-report-cmd (ledger-report-read-command ledger-report-cmd))
- (ledger-report-redo))
+ "Edit the current report command in the mini buffer and re-run the report."
+ (interactive)
+ (setq ledger-report-cmd (ledger-report-read-command ledger-report-cmd))
+ (ledger-report-redo))
(defun ledger-report-read-new-name ()
"Read the name for a new report from the minibuffer."
diff --git a/lisp/ledger-schedule.el b/lisp/ledger-schedule.el
index 39237ffb..ae08ad36 100644
--- a/lisp/ledger-schedule.el
+++ b/lisp/ledger-schedule.el
@@ -62,21 +62,21 @@
:group 'ledger-schedule)
(defcustom ledger-schedule-week-days '(("Mo" 1)
- ("Tu" 2)
- ("We" 3)
- ("Th" 4)
- ("Fr" 5)
- ("Sa" 6)
- ("Su" 7))
- "List of weekday abbreviations. There must be exactly seven
+ ("Tu" 2)
+ ("We" 3)
+ ("Th" 4)
+ ("Fr" 5)
+ ("Sa" 6)
+ ("Su" 7))
+ "List of weekday abbreviations. There must be exactly seven
entries each with a two character abbreviation for a day and the
number of that day in the week. "
- :type '(alist :value-type (group integer))
- :group 'ledger-schedule)
+ :type '(alist :value-type (group integer))
+ :group 'ledger-schedule)
(defsubst between (val low high)
- "Return TRUE if VAL > LOW and < HIGH."
- (and (>= val low) (<= val high)))
+ "Return TRUE if VAL > LOW and < HIGH."
+ (and (>= val low) (<= val high)))
(defun ledger-schedule-days-in-month (month year)
"Return number of days in the MONTH, MONTH is from 1 to 12.
@@ -88,8 +88,8 @@ If YEAR is nil, assume it is not a leap year"
(error "Month out of range, MONTH=%S" month)))
(defun ledger-schedule-encode-day-of-week (day-string)
- "Return the numerical day of week corresponding to DAY-STRING."
- (cadr (assoc day-string ledger-schedule-week-days)))
+ "Return the numerical day of week corresponding to DAY-STRING."
+ (cadr (assoc day-string ledger-schedule-week-days)))
;; Macros to handle date expressions
@@ -175,10 +175,10 @@ the transaction should be logged for that day."
xact-list)))
(defun ledger-schedule-read-descriptor-tree (descriptor-string)
- "Read DESCRIPTOR-STRING and return a form that evaluates dates."
- (ledger-schedule-transform-auto-tree
- (split-string
- (substring descriptor-string 1 (string-match "]" descriptor-string)) " ")))
+ "Read DESCRIPTOR-STRING and return a form that evaluates dates."
+ (ledger-schedule-transform-auto-tree
+ (split-string
+ (substring descriptor-string 1 (string-match "]" descriptor-string)) " ")))
(defun ledger-schedule-transform-auto-tree (descriptor-string-list)
"Take DESCRIPTOR-STRING-LIST, and return a string with a lambda function of date."
@@ -204,84 +204,86 @@ the transaction should be logged for that day."
(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)))
- (if (string-match "[A-Za-z]" descriptor-string)
- (ledger-schedule-constrain-day (nth 0 fields) (nth 1 fields) (nth 2 fields))
- (list 'and
- (ledger-schedule-constrain-day (nth 0 fields) (nth 1 fields) (nth 2 fields))
- (ledger-schedule-constrain-year (nth 0 fields) (nth 1 fields) (nth 2 fields))
- (ledger-schedule-constrain-month (nth 0 fields) (nth 1 fields) (nth 2 fields))))))
+ (list 'and
+ (ledger-schedule-constrain-day (nth 0 fields) (nth 1 fields) (nth 2 fields))
+ (ledger-schedule-constrain-year (nth 0 fields) (nth 1 fields) (nth 2 fields))
+ (ledger-schedule-constrain-month (nth 0 fields) (nth 1 fields) (nth 2 fields)))))
(defun ledger-schedule-constrain-year (year-desc month-desc day-desc)
- "Return a form that constrains the year.
+ "Return a form that constrains the year.
YEAR-DESC, MONT-DESC, and DAY-DESC are the string portions of the
date descriptor."
- (cond ((string= year-desc "*") t)
- ((/= 0 (string-to-number year-desc))
- `(memq (nth 5 (decode-time date)) ',(mapcar 'string-to-number (split-string year-desc ","))))
- (t
- (error "Improperly specified year constraint: %s %s %s" year-desc month-desc day-desc))))
+ (cond
+ ((string-match "[A-Za-z]" day-desc) t) ; there is an advanced day descriptor which overrides the year
+ ((string= year-desc "*") t)
+ ((/= 0 (string-to-number year-desc))
+ `(memq (nth 5 (decode-time date)) ',(mapcar 'string-to-number (split-string year-desc ","))))
+ (t
+ (error "Improperly specified year constraint: %s %s %s" year-desc month-desc day-desc))))
(defun ledger-schedule-constrain-month (year-desc month-desc day-desc)
- "Return a form that constrains the month.
+ "Return a form that constrains the month.
YEAR-DESC, MONT-DESC, and DAY-DESC are the string portions of the
date descriptor."
- (cond ((string= month-desc "*")
- t) ;; always match
- ((string= month-desc "E") ;; Even
- `(evenp (nth 4 (decode-time date))))
- ((string= month-desc "O") ;; Odd
- `(oddp (nth 4 (decode-time date))))
- ((/= 0 (string-to-number month-desc)) ;; Starts with number
- `(memq (nth 4 (decode-time date)) ',(mapcar 'string-to-number (split-string month-desc ","))))
- (t
- (error "Improperly specified month constraint: %s %s %s" year-desc month-desc day-desc))))
+ (cond
+ ((string-match "[A-Za-z]" day-desc) t) ; there is an advanced day descriptor which overrides the month
+ ((string= month-desc "*")
+ t) ;; always match
+ ((string= month-desc "E") ;; Even
+ `(evenp (nth 4 (decode-time date))))
+ ((string= month-desc "O") ;; Odd
+ `(oddp (nth 4 (decode-time date))))
+ ((/= 0 (string-to-number month-desc)) ;; Starts with number
+ `(memq (nth 4 (decode-time date)) ',(mapcar 'string-to-number (split-string month-desc ","))))
+ (t
+ (error "Improperly specified month constraint: %s %s %s" year-desc month-desc day-desc))))
(defun ledger-schedule-constrain-day (year-desc month-desc day-desc)
- "Return a form that constrains the day.
+ "Return a form that constrains the day.
YEAR-DESC, MONT-DESC, and DAY-DESC are the string portions of the
date descriptor."
- (cond ((string= day-desc "*")
- t)
- ((string-match "[A-Za-z]" day-desc) ;; There is something other than digits and commas
- (ledger-schedule-parse-complex-date year-desc month-desc day-desc))
- ((/= 0 (string-to-number day-desc))
- `(memq (nth 3 (decode-time date)) ',(mapcar 'string-to-number (split-string day-desc ","))))
- (t
- (error "Improperly specified day constraint: %s %s %s" year-desc month-desc day-desc))))
+ (cond ((string= day-desc "*")
+ t)
+ ((string-match "[A-Za-z]" day-desc) ;; There is something other than digits and commas
+ (ledger-schedule-parse-complex-date year-desc month-desc day-desc))
+ ((/= 0 (string-to-number day-desc))
+ `(memq (nth 3 (decode-time date)) ',(mapcar 'string-to-number (split-string day-desc ","))))
+ (t
+ (error "Improperly specified day constraint: %s %s %s" year-desc month-desc day-desc))))
(defun ledger-schedule-parse-complex-date (year-desc month-desc day-desc)
- "Parse day descriptors that have repeats."
- (let ((years (mapcar 'string-to-number (split-string year-desc ",")))
- (months (mapcar 'string-to-number (split-string month-desc ",")))
- (day-parts (split-string day-desc "+"))
- (every-nth (string-match "+" day-desc)))
- (if every-nth
- (let ((base-day (string-to-number (car day-parts)))
- (increment (string-to-number (substring (cadr day-parts) 0
- (string-match "[A-Za-z]" (cadr day-parts)))))
- (day-of-week (ledger-schedule-encode-day-of-week
- (substring (cadr day-parts) (string-match "[A-Za-z]" (cadr day-parts))))))
- (ledger-schedule-constrain-every-count-day day-of-week increment (encode-time 0 0 0 base-day (car months) (car years))))
- (let ((count (string-to-number (substring (car day-parts) 0 1)))
- (day-of-week (ledger-schedule-encode-day-of-week
- (substring (car day-parts) (string-match "[A-Za-z]" (car day-parts))))))
- (ledger-schedule-constrain-day-in-month count day-of-week)))))
+ "Parse day descriptors that have repeats."
+ (let ((years (mapcar 'string-to-number (split-string year-desc ",")))
+ (months (mapcar 'string-to-number (split-string month-desc ",")))
+ (day-parts (split-string day-desc "+"))
+ (every-nth (string-match "+" day-desc)))
+ (if every-nth
+ (let ((base-day (string-to-number (car day-parts)))
+ (increment (string-to-number (substring (cadr day-parts) 0
+ (string-match "[A-Za-z]" (cadr day-parts)))))
+ (day-of-week (ledger-schedule-encode-day-of-week
+ (substring (cadr day-parts) (string-match "[A-Za-z]" (cadr day-parts))))))
+ (ledger-schedule-constrain-every-count-day day-of-week increment (encode-time 0 0 0 base-day (car months) (car years))))
+ (let ((count (string-to-number (substring (car day-parts) 0 1)))
+ (day-of-week (ledger-schedule-encode-day-of-week
+ (substring (car day-parts) (string-match "[A-Za-z]" (car day-parts))))))
+ (ledger-schedule-constrain-day-in-month count day-of-week)))))
(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)
- (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))))))))
- items))
+ "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)
+ (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))))))))
+ items))
(defun ledger-schedule-create-auto-buffer (candidate-items early horizon ledger-buf)
"Format CANDIDATE-ITEMS for display."
@@ -292,7 +294,7 @@ date descriptor."
(with-current-buffer schedule-buf
(erase-buffer)
(dolist (candidate candidates)
- (insert (format-time-string date-format (car candidate) ) " " (cadr candidate) "\n"))
+ (insert (format-time-string date-format (car candidate) ) " " (cadr candidate) "\n"))
(ledger-mode))
(length candidates)))
@@ -313,15 +315,15 @@ Use a prefix arg to change the default value"
(read-number "Look forward: " ledger-schedule-look-forward))
(list ledger-schedule-file ledger-schedule-look-backward ledger-schedule-look-forward)))
(if (and file
- (file-exists-p file))
- (progn
- (ledger-schedule-create-auto-buffer
- (ledger-schedule-scan-transactions file)
- look-backward
- look-forward
- (current-buffer))
- (pop-to-buffer ledger-schedule-buffer-name))
- (error "Could not find ledger schedule file at %s" file)))
+ (file-exists-p file))
+ (progn
+ (ledger-schedule-create-auto-buffer
+ (ledger-schedule-scan-transactions file)
+ look-backward
+ look-forward
+ (current-buffer))
+ (pop-to-buffer ledger-schedule-buffer-name))
+ (error "Could not find ledger schedule file at %s" file)))
(provide 'ledger-schedule)
diff --git a/lisp/ledger-sort.el b/lisp/ledger-sort.el
index a8f0a0bd..6ed82830 100644
--- a/lisp/ledger-sort.el
+++ b/lisp/ledger-sort.el
@@ -1,6 +1,6 @@
;;; ledger-xact.el --- Helper code for use with the "ledger" command-line tool
-;; Copyright (C) 2003-2015 John Wiegley (johnw AT gnu DOT org)
+;; Copyright (C) 2003-2016 John Wiegley (johnw AT gnu DOT org)
;; This file is not part of GNU Emacs.
@@ -66,7 +66,7 @@
(defun ledger-sort-region (beg end)
"Sort the region from BEG to END in chronological order."
(interactive "r") ;; load beg and end from point and mark
- ;; automagically
+ ;; automagically
(let ((new-beg beg)
(new-end end)
point-delta
@@ -79,14 +79,14 @@
(save-excursion
(save-restriction
(goto-char beg)
- ;; make sure point is at the beginning of a xact
+ ;; make sure point is at the beginning of a xact
(ledger-navigate-next-xact)
(unless (looking-at ledger-payee-any-status-regex)
(ledger-navigate-next-xact))
(setq new-beg (point))
(goto-char end)
(ledger-navigate-next-xact)
- ;; make sure end of region is at the beginning of next record
+ ;; 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)
diff --git a/lisp/ledger-state.el b/lisp/ledger-state.el
index 1bc5974d..561df095 100644
--- a/lisp/ledger-state.el
+++ b/lisp/ledger-state.el
@@ -1,6 +1,6 @@
;;; ledger-state.el --- Helper code for use with the "ledger" command-line tool
-;; Copyright (C) 2003-2015 John Wiegley (johnw AT gnu DOT org)
+;; Copyright (C) 2003-2016 John Wiegley (johnw AT gnu DOT org)
;; This file is not part of GNU Emacs.
@@ -116,8 +116,8 @@ dropped."
(when (not (eq (ledger-state-from-char (char-after)) 'comment))
(insert (ledger-char-from-state cur-status) " ")
(if (and (search-forward " " (line-end-position) t)
- (looking-at " "))
- (delete-char 2)))
+ (looking-at " "))
+ (delete-char 2)))
(forward-line))
(setq new-status nil)))
diff --git a/lisp/ledger-test.el b/lisp/ledger-test.el
index da120f63..26811bb3 100644
--- a/lisp/ledger-test.el
+++ b/lisp/ledger-test.el
@@ -1,6 +1,6 @@
;;; ledger-test.el --- Helper code for use with the "ledger" command-line tool
-;; Copyright (C) 2003-2015 John Wiegley (johnw AT gnu DOT org)
+;; Copyright (C) 2003-2016 John Wiegley (johnw AT gnu DOT org)
;; This file is not part of GNU Emacs.
diff --git a/lisp/ledger-texi.el b/lisp/ledger-texi.el
index 75a018b8..5bf8d9a2 100644
--- a/lisp/ledger-texi.el
+++ b/lisp/ledger-texi.el
@@ -1,6 +1,6 @@
;;; ledger-texi.el --- Helper code for use with the "ledger" command-line tool
-;; Copyright (C) 2003-2015 John Wiegley (johnw AT gnu DOT org)
+;; Copyright (C) 2003-2016 John Wiegley (johnw AT gnu DOT org)
;; This file is not part of GNU Emacs.
diff --git a/lisp/ledger-xact.el b/lisp/ledger-xact.el
index 52b89583..f3721e9e 100644
--- a/lisp/ledger-xact.el
+++ b/lisp/ledger-xact.el
@@ -1,6 +1,6 @@
;;; ledger-xact.el --- Helper code for use with the "ledger" command-line tool
-;; Copyright (C) 2003-2015 John Wiegley (johnw AT gnu DOT org)
+;; Copyright (C) 2003-2016 John Wiegley (johnw AT gnu DOT org)
;; This file is not part of GNU Emacs.
@@ -52,20 +52,25 @@
(defvar ledger-xact-highlight-overlay (list))
(make-variable-buffer-local 'ledger-xact-highlight-overlay)
+(defun ledger-highlight-make-overlay ()
+ (let ((ovl (make-overlay 1 1)))
+ (overlay-put ovl 'face 'ledger-font-xact-highlight-face)
+ (overlay-put ovl 'priority '(nil . 99))
+ ovl))
+
(defun ledger-highlight-xact-under-point ()
"Move the highlight overlay to the current transaction."
- (if ledger-highlight-xact-under-point
- (let ((exts (ledger-navigate-find-element-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 '(nil . 99)))))
+ (when ledger-highlight-xact-under-point
+ (unless ledger-xact-highlight-overlay
+ (setq ledger-xact-highlight-overlay (ledger-highlight-make-overlay)))
+ (let ((exts (ledger-navigate-find-element-extents (point))))
+ (let ((b (car exts))
+ (e (cadr exts))
+ (p (point)))
+ (if (and (> (- e b) 1) ; not an empty line
+ (<= p e) (>= p b)) ; point is within the boundaries
+ (move-overlay ledger-xact-highlight-overlay b (+ 1 e))
+ (move-overlay ledger-xact-highlight-overlay 1 1))))))
(defun ledger-xact-payee ()
"Return the payee of the transaction containing point or nil."
@@ -97,9 +102,8 @@ MOMENT is an encoded date"
(when (and (eobp) last-xact-start)
(let ((end (cadr (ledger-navigate-find-xact-extents last-xact-start))))
(goto-char end)
- (if (eobp)
- (insert "\n")
- (forward-line))))))
+ (insert "\n")
+ (forward-line)))))
(defun ledger-xact-iterate-transactions (callback)
"Iterate through each transaction call CALLBACK for each."
@@ -194,8 +198,8 @@ correct chronological place in the buffer."
(goto-char (point-min))
(if (looking-at "Error: ")
(error (concat "Error in ledger-add-transaction: " (buffer-string)))
- (ledger-post-align-postings (point-min) (point-max))
- (buffer-string)))
+ (ledger-post-align-postings (point-min) (point-max))
+ (buffer-string)))
"\n"))
(progn
(insert (car args) " \n\n")
generated by cgit v1.2.3 (git 2.39.1) at 2025-08-07 23:08:41 +0000