summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJohn Wiegley <johnw@newartisans.com>2010-05-12 04:32:02 -0400
committerJohn Wiegley <johnw@newartisans.com>2010-05-12 04:32:02 -0400
commit5f1a858941adc17fcf714c7b6b176aeae727c436 (patch)
tree846efb794cb76fdc4c63fa4c6ab554b83af49f07
parent7ca8149ec5c7fa88d98df83e6260210372223036 (diff)
parentcb047c013df0eaf1c5e9edd67bbb6b6fa537d2a0 (diff)
downloadfork-ledger-5f1a858941adc17fcf714c7b6b176aeae727c436.tar.gz
fork-ledger-5f1a858941adc17fcf714c7b6b176aeae727c436.tar.bz2
fork-ledger-5f1a858941adc17fcf714c7b6b176aeae727c436.zip
Merge branch 'next'
-rw-r--r--lisp/ldg-complete.el156
-rw-r--r--lisp/ldg-exec.el34
-rw-r--r--lisp/ldg-mode.el117
-rw-r--r--lisp/ldg-new.el56
-rw-r--r--lisp/ldg-post.el126
-rw-r--r--lisp/ldg-reconcile.el141
-rw-r--r--lisp/ldg-regex.el361
-rw-r--r--lisp/ldg-register.el66
-rw-r--r--lisp/ldg-report.el448
-rw-r--r--lisp/ldg-state.el189
-rw-r--r--lisp/ldg-xact.el20
-rw-r--r--lisp/ledger.el2
-rw-r--r--src/account.cc34
-rw-r--r--src/commodity.cc4
-rw-r--r--src/convert.cc7
-rw-r--r--src/expr.cc20
-rw-r--r--src/generate.cc8
-rw-r--r--src/interactive.cc4
-rw-r--r--src/interactive.h13
-rw-r--r--src/op.cc52
-rw-r--r--src/op.h1
-rw-r--r--src/parser.cc5
-rw-r--r--src/post.cc48
-rw-r--r--src/print.cc12
-rw-r--r--src/report.cc16
-rw-r--r--src/report.h1
-rw-r--r--src/scope.h11
-rw-r--r--src/value.cc31
-rw-r--r--src/value.h29
-rw-r--r--src/xact.cc38
30 files changed, 1855 insertions, 195 deletions
diff --git a/lisp/ldg-complete.el b/lisp/ldg-complete.el
new file mode 100644
index 00000000..33a734b3
--- /dev/null
+++ b/lisp/ldg-complete.el
@@ -0,0 +1,156 @@
+;;(require 'esh-util)
+;;(require 'esh-arg)
+(require 'pcomplete)
+
+;; In-place completion support
+
+(defun ledger-thing-at-point ()
+ (let ((here (point)))
+ (goto-char (line-beginning-position))
+ (cond ((looking-at "^[0-9/.=-]+\\(\\s-+\\*\\)?\\(\\s-+(.+?)\\)?\\s-+")
+ (goto-char (match-end 0))
+ 'entry)
+ ((looking-at "^\\s-+\\([*!]\\s-+\\)?[[(]?\\(.\\)")
+ (goto-char (match-beginning 2))
+ 'transaction)
+ ((looking-at "^\\(sun\\|mon\\|tue\\|wed\\|thu\\|fri\\|sat\\)\\s-+")
+ (goto-char (match-end 0))
+ 'entry)
+ (t
+ (ignore (goto-char here))))))
+
+(defun ledger-parse-arguments ()
+ "Parse whitespace separated arguments in the current region."
+ (let* ((info (save-excursion
+ (cons (ledger-thing-at-point) (point))))
+ (begin (cdr info))
+ (end (point))
+ begins args)
+ (save-excursion
+ (goto-char begin)
+ (when (< (point) end)
+ (skip-chars-forward " \t\n")
+ (setq begins (cons (point) begins))
+ (setq args (cons (buffer-substring-no-properties
+ (car begins) end)
+ args)))
+ (cons (reverse args) (reverse begins)))))
+
+(defun ledger-entries ()
+ (let ((origin (point))
+ entries-list)
+ (save-excursion
+ (goto-char (point-min))
+ (while (re-search-forward
+ (concat "^[0-9/.=-]+\\(\\s-+\\*\\)?\\(\\s-+(.*?)\\)?\\s-+"
+ "\\(.+?\\)\\(\t\\|\n\\| [ \t]\\)") nil t)
+ (unless (and (>= origin (match-beginning 0))
+ (< origin (match-end 0)))
+ (setq entries-list (cons (match-string-no-properties 3)
+ entries-list)))))
+ (pcomplete-uniqify-list (nreverse entries-list))))
+
+(defvar ledger-account-tree nil)
+
+(defun ledger-find-accounts ()
+ (let ((origin (point)) account-path elements)
+ (save-excursion
+ (setq ledger-account-tree (list t))
+ (goto-char (point-min))
+ (while (re-search-forward
+ "^[ \t]+\\([*!]\\s-+\\)?[[(]?\\(.+?\\)\\(\t\\|\n\\| [ \t]\\)" nil t)
+ (unless (and (>= origin (match-beginning 0))
+ (< origin (match-end 0)))
+ (setq account-path (match-string-no-properties 2))
+ (setq elements (split-string account-path ":"))
+ (let ((root ledger-account-tree))
+ (while elements
+ (let ((entry (assoc (car elements) root)))
+ (if entry
+ (setq root (cdr entry))
+ (setq entry (cons (car elements) (list t)))
+ (nconc root (list entry))
+ (setq root (cdr entry))))
+ (setq elements (cdr elements)))))))))
+
+(defun ledger-accounts ()
+ (ledger-find-accounts)
+ (let* ((current (caar (ledger-parse-arguments)))
+ (elements (and current (split-string current ":")))
+ (root ledger-account-tree)
+ (prefix nil))
+ (while (cdr elements)
+ (let ((entry (assoc (car elements) root)))
+ (if entry
+ (setq prefix (concat prefix (and prefix ":")
+ (car elements))
+ root (cdr entry))
+ (setq root nil elements nil)))
+ (setq elements (cdr elements)))
+ (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))))
+ (cdr root))
+ 'string-lessp))))
+
+(defun ledger-complete-at-point ()
+ "Do appropriate completion for the thing at point"
+ (interactive)
+ (while (pcomplete-here
+ (if (eq (save-excursion
+ (ledger-thing-at-point)) 'entry)
+ (if (null current-prefix-arg)
+ (ledger-entries) ; this completes against entry names
+ (progn
+ (let ((text (buffer-substring (line-beginning-position)
+ (line-end-position))))
+ (delete-region (line-beginning-position)
+ (line-end-position))
+ (condition-case err
+ (ledger-add-entry text t)
+ ((error)
+ (insert text))))
+ (forward-line)
+ (goto-char (line-end-position))
+ (search-backward ";" (line-beginning-position) t)
+ (skip-chars-backward " \t0123456789.,")
+ (throw 'pcompleted t)))
+ (ledger-accounts)))))
+
+(defun ledger-fully-complete-entry ()
+ "Do appropriate completion for the thing at point"
+ (interactive)
+ (let ((name (caar (ledger-parse-arguments)))
+ xacts)
+ (save-excursion
+ (when (eq 'entry (ledger-thing-at-point))
+ (when (re-search-backward
+ (concat "^[0-9/.=-]+\\(\\s-+\\*\\)?\\(\\s-+(.*?)\\)?\\s-+"
+ (regexp-quote name) "\\(\t\\|\n\\| [ \t]\\)") nil t)
+ (forward-line)
+ (while (looking-at "^\\s-+")
+ (setq xacts (cons (buffer-substring-no-properties
+ (line-beginning-position)
+ (line-end-position))
+ xacts))
+ (forward-line))
+ (setq xacts (nreverse xacts)))))
+ (when xacts
+ (save-excursion
+ (insert ?\n)
+ (while xacts
+ (insert (car xacts) ?\n)
+ (setq xacts (cdr xacts))))
+ (forward-line)
+ (goto-char (line-end-position))
+ (if (re-search-backward "\\(\t\\| [ \t]\\)" nil t)
+ (goto-char (match-end 0))))))
+
+(provide 'ldg-complete)
diff --git a/lisp/ldg-exec.el b/lisp/ldg-exec.el
new file mode 100644
index 00000000..3881f8e9
--- /dev/null
+++ b/lisp/ldg-exec.el
@@ -0,0 +1,34 @@
+(defgroup ledger-exec nil
+ "Interface to the Ledger command-line accounting program."
+ :group 'ledger)
+
+(defcustom ledger-binary-path "ledger"
+ "Path to the ledger executable."
+ :type 'file
+ :group 'ledger)
+
+(defun ledger-exec-ledger (input-buffer &optional output-buffer &rest args)
+ "Run Ledger."
+ (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)))
+ outbuf)))
+
+(defun ledger-exec-read (&optional input-buffer &rest args)
+ (with-current-buffer
+ (apply #'ledger-exec-ledger input-buffer nil "emacs" args)
+ (goto-char (point-min))
+ (prog1
+ (read (current-buffer))
+ (kill-buffer (current-buffer)))))
+
+(provide 'ldg-exec)
diff --git a/lisp/ldg-mode.el b/lisp/ldg-mode.el
new file mode 100644
index 00000000..973b891c
--- /dev/null
+++ b/lisp/ldg-mode.el
@@ -0,0 +1,117 @@
+(defcustom ledger-default-acct-transaction-indent " "
+ "Default indentation for account transactions in an entry."
+ :type 'string
+ :group 'ledger)
+
+(defvar bold 'bold)
+(defvar ledger-font-lock-keywords
+ '(("\\( \\| \\|^\\)\\(;.*\\)" 2 font-lock-comment-face)
+ ("^[0-9]+[-/.=][-/.=0-9]+\\s-+\\(([^)]+)\\s-+\\)?\\([^*].+?\\)\\(\\( ;\\| ;\\|$\\)\\)" 2 bold)
+ ;;("^[0-9]+[-/.=][-/.=0-9]+\\s-+\\(([^)]+)\\s-+\\)?\\([*].+?\\)\\(\\( ;\\| ;\\|$\\)\\)"
+ ;; 2 font-lock-type-face)
+ ("^\\s-+\\([*]\\s-*\\)?\\(\\([[(]\\)?[^*:
+ ]+?:[^]);
+ ]+?\\([])]\\)?\\)\\( \\| \\|$\\)"
+ 2 font-lock-keyword-face)
+ ("^\\([~=].+\\)" 1 font-lock-function-name-face)
+ ("^\\([A-Za-z]+ .+\\)" 1 font-lock-function-name-face))
+ "Expressions to highlight in Ledger mode.")
+
+(defvar ledger-mode-abbrev-table)
+
+;;;###autoload
+(define-derived-mode ledger-mode text-mode "Ledger"
+ "A mode for editing ledger data files."
+ (ledger-post-setup)
+
+ (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)))
+
+ (set (make-local-variable 'pcomplete-parse-arguments-function)
+ 'ledger-parse-arguments)
+ (set (make-local-variable 'pcomplete-command-completion-function)
+ 'ledger-complete-at-point)
+ (set (make-local-variable 'pcomplete-termination-string) "")
+
+ (let ((map (current-local-map)))
+ (define-key map [(control ?c) (control ?a)] 'ledger-add-entry)
+ (define-key map [(control ?c) (control ?d)] 'ledger-delete-current-entry)
+ (define-key map [(control ?c) (control ?y)] 'ledger-set-year)
+ (define-key map [(control ?c) (control ?m)] 'ledger-set-month)
+ (define-key map [(control ?c) (control ?c)] 'ledger-toggle-current)
+ (define-key map [(control ?c) (control ?e)] 'ledger-toggle-current-entry)
+ (define-key map [(control ?c) (control ?r)] 'ledger-reconcile)
+ (define-key map [(control ?c) (control ?s)] 'ledger-sort)
+ (define-key map [tab] 'pcomplete)
+ (define-key map [(control ?i)] 'pcomplete)
+ (define-key map [(control ?c) tab] 'ledger-fully-complete-entry)
+ (define-key map [(control ?c) (control ?i)] 'ledger-fully-complete-entry)))
+
+(defun ledger-time-less-p (t1 t2)
+ "Say whether time value T1 is less than time value T2."
+ (or (< (car t1) (car t2))
+ (and (= (car t1) (car t2))
+ (< (nth 1 t1) (nth 1 t2)))))
+
+(defun ledger-time-subtract (t1 t2)
+ "Subtract two time values.
+Return the difference in the format of a time value."
+ (let ((borrow (< (cadr t1) (cadr t2))))
+ (list (- (car t1) (car t2) (if borrow 1 0))
+ (- (+ (if borrow 65536 0) (cadr t1)) (cadr t2)))))
+
+(defun ledger-find-slot (moment)
+ (catch 'found
+ (ledger-iterate-entries
+ (function
+ (lambda (start date mark desc)
+ (if (ledger-time-less-p moment date)
+ (throw 'found t)))))))
+
+(defun ledger-add-entry (entry-text &optional insert-at-point)
+ (interactive "sEntry: ")
+ (let* ((args (with-temp-buffer
+ (insert entry-text)
+ (eshell-parse-arguments (point-min) (point-max))))
+ (ledger-buf (current-buffer))
+ exit-code)
+ (unless insert-at-point
+ (let ((date (car args)))
+ (if (string-match "\\([0-9]+\\)/\\([0-9]+\\)/\\([0-9]+\\)" date)
+ (setq date
+ (encode-time 0 0 0 (string-to-number (match-string 3 date))
+ (string-to-number (match-string 2 date))
+ (string-to-number (match-string 1 date)))))
+ (ledger-find-slot date)))
+ (save-excursion
+ (insert
+ (with-temp-buffer
+ (setq exit-code
+ (apply #'ledger-run-ledger ledger-buf "entry"
+ (mapcar 'eval args)))
+ (goto-char (point-min))
+ (if (looking-at "Error: ")
+ (error (buffer-string))
+ (buffer-string)))
+ "\n"))))
+
+(defun ledger-current-entry-bounds ()
+ (save-excursion
+ (when (or (looking-at "^[0-9]")
+ (re-search-backward "^[0-9]" nil t))
+ (let ((beg (point)))
+ (while (not (eolp))
+ (forward-line))
+ (cons (copy-marker beg) (point-marker))))))
+
+(defun ledger-delete-current-entry ()
+ (interactive)
+ (let ((bounds (ledger-current-entry-bounds)))
+ (delete-region (car bounds) (cdr bounds))))
+
+(provide 'ldg-mode)
diff --git a/lisp/ldg-new.el b/lisp/ldg-new.el
new file mode 100644
index 00000000..84863c95
--- /dev/null
+++ b/lisp/ldg-new.el
@@ -0,0 +1,56 @@
+;;; ledger.el --- Helper code for use with the "ledger" command-line tool
+
+;; Copyright (C) 2003-2010 John Wiegley (johnw AT gnu DOT org)
+
+;; Emacs Lisp Archive Entry
+;; Filename: ledger.el
+;; Version: 3.0
+;; Date: Mon 12-Apr-2010
+;; Keywords: data
+;; Author: John Wiegley (johnw AT gnu DOT org)
+;; Maintainer: John Wiegley (johnw AT gnu DOT org)
+;; Description: Helper code for using my "ledger" command-line tool
+;; URL: http://www.newartisans.com/johnw/emacs.html
+;; Compatibility: Emacs22,Emacs23,Emacs24
+
+;; 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., 59 Temple Place - Suite 330, Boston,
+;; MA 02111-1307, USA.
+
+;;; Commentary:
+
+(require 'ldg-post)
+(require 'ldg-mode)
+(require 'ldg-complete)
+(require 'ldg-state)
+
+;(autoload #'ledger-mode "ldg-mode" nil t)
+;(autoload #'ledger-fully-complete-entry "ldg-complete" nil t)
+;(autoload #'ledger-toggle-current "ldg-state" nil t)
+
+(autoload #'ledger-texi-update-test "ldg-texi" nil t)
+(autoload #'ledger-texi-update-examples "ldg-texi" nil t)
+
+(defgroup ledger nil
+ "Interface to the Ledger command-line accounting program."
+ :group 'data)
+
+(defconst ledger-version "3.0"
+ "The version of ledger.el currently loaded")
+
+(provide 'ledger)
+
+;;; ledger.el ends here
diff --git a/lisp/ldg-post.el b/lisp/ldg-post.el
index 30edd035..492f9467 100644
--- a/lisp/ldg-post.el
+++ b/lisp/ldg-post.el
@@ -9,51 +9,70 @@
:type 'boolean
:group 'ledger-post)
-(declare-function iswitchb-read-buffer "iswitchb"
- (prompt &optional default require-match start matches-set))
-(defvar iswitchb-temp-buflist)
+(defcustom ledger-post-amount-alignment-column 52
+ "If non-nil, ."
+ :type 'integer
+ :group 'ledger-post)
-(defvar ledger-post-current-list nil)
+(defcustom ledger-post-use-iswitchb nil
+ "If non-nil, ."
+ :type 'boolean
+ :group 'ledger-post)
+
+(defcustom ledger-post-use-ido nil
+ "If non-nil, ."
+ :type 'boolean
+ :group 'ledger-post)
-(defun ledger-post-find-all ()
+(defun ledger-post-all-accounts ()
(let ((origin (point))
(ledger-post-list nil)
- account-path elements)
+ account elements)
(save-excursion
(goto-char (point-min))
- (while (re-search-forward
- "^[ \t]+\\([*!]\\s-+\\)?[[(]?\\(.+?\\)\\(\t\\|\n\\| [ \t]\\)" nil t)
+ (while (re-search-forward ledger-post-line-regexp nil t)
(unless (and (>= origin (match-beginning 0))
(< origin (match-end 0)))
- (setq account-path (match-string-no-properties 2))
- (unless (string-match "\\`\\s-*;" account-path)
- (add-to-list 'ledger-post-list account-path))))
- (setq ledger-post-current-list
- (nreverse ledger-post-list)))))
+ (add-to-list 'ledger-post-list (ledger-regex-post-line-account))))
+ (nreverse ledger-post-list))))
+
+(declare-function iswitchb-read-buffer "iswitchb"
+ (prompt &optional default require-match start matches-set))
+(defvar iswitchb-temp-buflist)
(defun ledger-post-completing-read (prompt choices)
"Use iswitchb as a completing-read replacement to choose from choices.
PROMPT is a string to prompt with. CHOICES is a list of strings
to choose from."
- (let* ((iswitchb-use-virtual-buffers nil)
- (iswitchb-make-buflist-hook
- (lambda ()
- (setq iswitchb-temp-buflist choices))))
- (iswitchb-read-buffer prompt)))
+ (cond
+ (ledger-post-use-iswitchb
+ (let* ((iswitchb-use-virtual-buffers nil)
+ (iswitchb-make-buflist-hook
+ (lambda ()
+ (setq iswitchb-temp-buflist choices))))
+ (iswitchb-read-buffer prompt)))
+ (ledger-post-use-ido
+ (ido-completing-read prompt choices))
+ (t
+ (completing-read prompt choices))))
+
+(defvar ledger-post-current-list nil)
(defun ledger-post-pick-account ()
(interactive)
(let* ((account
- (ledger-post-completing-read "Account: "
- (or ledger-post-current-list
- (ledger-post-find-all))))
+ (ledger-post-completing-read
+ "Account: " (or ledger-post-current-list
+ (setq ledger-post-current-list
+ (ledger-post-all-accounts)))))
(account-len (length account))
(pos (point)))
(goto-char (line-beginning-position))
- (when (re-search-forward ledger-regex-post-line (line-end-position) t)
- (let ((existing-len (length (match-string 3))))
- (goto-char (match-beginning 3))
- (delete-region (match-beginning 3) (match-end 3))
+ (when (re-search-forward ledger-post-line-regexp (line-end-position) t)
+ (let ((existing-len (length (ledger-regex-post-line-account))))
+ (goto-char (match-beginning ledger-regex-post-line-group-account))
+ (delete-region (match-beginning ledger-regex-post-line-group-account)
+ (match-end ledger-regex-post-line-group-account))
(insert account)
(cond
((> existing-len account-len)
@@ -64,6 +83,40 @@ to choose from."
(delete-char 1)))))))
(goto-char pos)))
+(defun ledger-next-amount (&optional end)
+ (when (re-search-forward "\\( \\|\t\\| \t\\)[ \t]*-?\\([A-Z$]+ *\\)?\\(-?[0-9,]+?\\)\\(.[0-9]+\\)?\\( *[A-Z$]+\\)?\\([ \t]*@@?[^\n;]+?\\)?\\([ \t]+;.+?\\)?$" (marker-position end) t)
+ (goto-char (match-beginning 0))
+ (skip-syntax-forward " ")
+ (- (or (match-end 4)
+ (match-end 3)) (point))))
+
+(defun ledger-align-amounts (&optional column)
+ "Align amounts in the current region.
+This is done so that the last digit falls in COLUMN, which defaults to 52."
+ (interactive "p")
+ (if (or (null column) (= column 1))
+ (setq column ledger-post-amount-alignment-column))
+ (save-excursion
+ (let* ((mark-first (< (mark) (point)))
+ (begin (if mark-first (mark) (point)))
+ (end (if mark-first (point-marker) (mark-marker)))
+ offset)
+ (goto-char begin)
+ (while (setq offset (ledger-next-amount end))
+ (let ((col (current-column))
+ (target-col (- column offset))
+ adjust)
+ (setq adjust (- target-col col))
+ (if (< col target-col)
+ (insert (make-string (- target-col col) ? ))
+ (move-to-column target-col)
+ (if (looking-back " ")
+ (delete-char (- col target-col))
+ (skip-chars-forward "^ \t")
+ (delete-horizontal-space)
+ (insert " ")))
+ (forward-line))))))
+
(defun ledger-post-align-amount ()
(interactive)
(save-excursion
@@ -76,14 +129,14 @@ to choose from."
(goto-char beg)
(when (< end (line-end-position))
(goto-char (line-beginning-position))
- (if (looking-at ledger-regex-post-line)
+ (if (looking-at ledger-post-line-regexp)
(ledger-post-align-amount)))))
(defun ledger-post-edit-amount ()
(interactive)
(goto-char (line-beginning-position))
- (when (re-search-forward ledger-regex-post-line (line-end-position) t)
- (goto-char (match-end 3))
+ (when (re-search-forward ledger-post-line-regexp (line-end-position) t)
+ (goto-char (match-end ledger-regex-post-line-group-account))
(when (re-search-forward "[-.,0-9]+" (line-end-position) t)
(let ((val (match-string 0)))
(goto-char (match-beginning 0))
@@ -96,17 +149,17 @@ to choose from."
(defun ledger-post-prev-xact ()
(interactive)
(backward-paragraph)
- (when (re-search-backward ledger-regex-xact-line nil t)
+ (when (re-search-backward ledger-xact-line-regexp nil t)
(goto-char (match-beginning 0))
- (re-search-forward ledger-regex-post-line)
- (goto-char (match-end 3))))
+ (re-search-forward ledger-post-line-regexp)
+ (goto-char (match-end ledger-regex-post-line-group-account))))
(defun ledger-post-next-xact ()
(interactive)
- (when (re-search-forward ledger-regex-xact-line nil t)
+ (when (re-search-forward ledger-xact-line-regexp nil t)
(goto-char (match-beginning 0))
- (re-search-forward ledger-regex-post-line)
- (goto-char (match-end 3))))
+ (re-search-forward ledger-post-line-regexp)
+ (goto-char (match-end ledger-regex-post-line-group-account))))
(defun ledger-post-setup ()
(let ((map (current-local-map)))
@@ -115,8 +168,7 @@ to choose from."
(define-key map [(control ?c) (control ?c)] 'ledger-post-pick-account)
(define-key map [(control ?c) (control ?e)] 'ledger-post-edit-amount))
(if ledger-post-auto-adjust-amounts
- (add-hook 'after-change-functions 'ledger-post-maybe-align t t)))
-
-(add-hook 'ledger-mode-hook 'ledger-post-setup)
+ (add-hook 'after-change-functions 'ledger-post-maybe-align t t))
+ (add-hook 'after-save-hook #'(lambda () (setq ledger-post-current-list nil))))
(provide 'ldg-post)
diff --git a/lisp/ldg-reconcile.el b/lisp/ldg-reconcile.el
new file mode 100644
index 00000000..3be882f4
--- /dev/null
+++ b/lisp/ldg-reconcile.el
@@ -0,0 +1,141 @@
+;; Reconcile mode
+
+(defvar ledger-buf nil)
+(defvar ledger-acct nil)
+
+(defun ledger-display-balance ()
+ (let ((buffer ledger-buf)
+ (account ledger-acct))
+ (with-temp-buffer
+ (let ((exit-code (ledger-run-ledger buffer "-C" "balance" account)))
+ (if (/= 0 exit-code)
+ (message "Error determining cleared balance")
+ (goto-char (1- (point-max)))
+ (goto-char (line-beginning-position))
+ (delete-horizontal-space)
+ (message "Cleared balance = %s"
+ (buffer-substring-no-properties (point)
+ (line-end-position))))))))
+
+(defun ledger-reconcile-toggle ()
+ (interactive)
+ (let ((where (get-text-property (point) 'where))
+ (account ledger-acct)
+ (inhibit-read-only t)
+ cleared)
+ (when (or (equal (car where) "<stdin>") (equal (car where) "/dev/stdin"))
+ (with-current-buffer ledger-buf
+ (goto-char (cdr where))
+ (setq cleared (ledger-toggle-current 'pending)))
+ (if cleared
+ (add-text-properties (line-beginning-position)
+ (line-end-position)
+ (list 'face 'bold))
+ (remove-text-properties (line-beginning-position)
+ (line-end-position)
+ (list 'face))))
+ (forward-line)))
+
+(defun ledger-reconcile-refresh ()
+ (interactive)
+ (let ((inhibit-read-only t)
+ (line (count-lines (point-min) (point))))
+ (erase-buffer)
+ (ledger-do-reconcile)
+ (set-buffer-modified-p t)
+ (goto-char (point-min))
+ (forward-line line)))
+
+(defun ledger-reconcile-refresh-after-save ()
+ (let ((buf (get-buffer "*Reconcile*")))
+ (if buf
+ (with-current-buffer buf
+ (ledger-reconcile-refresh)
+ (set-buffer-modified-p nil)))))
+
+(defun ledger-reconcile-add ()
+ (interactive)
+ (with-current-buffer ledger-buf
+ (call-interactively #'ledger-add-entry))
+ (ledger-reconcile-refresh))
+
+(defun ledger-reconcile-delete ()
+ (interactive)
+ (let ((where (get-text-property (point) 'where)))
+ (when (or (equal (car where) "<stdin>") (equal (car where) "/dev/stdin"))
+ (with-current-buffer ledger-buf
+ (goto-char (cdr where))
+ (ledger-delete-current-entry))
+ (let ((inhibit-read-only t))
+ (goto-char (line-beginning-position))
+ (delete-region (point) (1+ (line-end-position)))
+ (set-buffer-modified-p t)))))
+
+(defun ledger-reconcile-visit ()
+ (interactive)
+ (let ((where (get-text-property (point) 'where)))
+ (when (or (equal (car where) "<stdin>") (equal (car where) "/dev/stdin"))
+ (switch-to-buffer-other-window ledger-buf)
+ (goto-char (cdr where)))))
+
+(defun ledger-reconcile-save ()
+ (interactive)
+ (with-current-buffer ledger-buf
+ (save-buffer))
+ (set-buffer-modified-p nil)
+ (ledger-display-balance))
+
+(defun ledger-reconcile-quit ()
+ (interactive)
+ (kill-buffer (current-buffer)))
+
+(defun ledger-reconcile-finish ()
+ (interactive)
+ (save-excursion
+ (goto-char (point-min))
+ (while (not (eobp))
+ (let ((where (get-text-property (point) 'where))
+ (face (get-text-property (point) 'face)))
+ (if (and (eq face 'bold)
+ (or (equal (car where) "<stdin>") (equal (car where) "/dev/stdin")))
+ (with-current-buffer ledger-buf
+ (goto-char (cdr where))
+ (ledger-toggle-current 'cleared))))
+ (forward-line 1)))
+ (ledger-reconcile-save))
+
+(defun ledger-do-reconcile ()
+ )
+
+(defun ledger-reconcile (account)
+ (interactive "sAccount to reconcile: ")
+ (let ((buf (current-buffer))
+ (rbuf (get-buffer "*Reconcile*")))
+ (if rbuf
+ (kill-buffer rbuf))
+ (add-hook 'after-save-hook 'ledger-reconcile-refresh-after-save)
+ (with-current-buffer
+ (pop-to-buffer (get-buffer-create "*Reconcile*"))
+ (ledger-reconcile-mode)
+ (set (make-local-variable 'ledger-buf) buf)
+ (set (make-local-variable 'ledger-acct) account)
+ (ledger-do-reconcile))))
+
+(defvar ledger-reconcile-mode-abbrev-table)
+
+(define-derived-mode ledger-reconcile-mode text-mode "Reconcile"
+ "A mode for reconciling ledger entries."
+ (let ((map (make-sparse-keymap)))
+ (define-key map [(control ?m)] 'ledger-reconcile-visit)
+ (define-key map [return] 'ledger-reconcile-visit)
+ (define-key map [(control ?c) (control ?c)] 'ledger-reconcile-finish)
+ (define-key map [(control ?x) (control ?s)] 'ledger-reconcile-save)
+ (define-key map [(control ?l)] 'ledger-reconcile-refresh)
+ (define-key map [? ] 'ledger-reconcile-toggle)
+ (define-key map [?a] 'ledger-reconcile-add)
+ (define-key map [?d] 'ledger-reconcile-delete)
+ (define-key map [?n] 'next-line)
+ (define-key map [?p] 'previous-line)
+ (define-key map [?s] 'ledger-reconcile-save)
+ (define-key map [?q] 'ledger-reconcile-quit)
+ (use-local-map map)))
diff --git a/lisp/ldg-regex.el b/lisp/ldg-regex.el
index 14c41f63..93ef6b09 100644
--- a/lisp/ldg-regex.el
+++ b/lisp/ldg-regex.el
@@ -1,6 +1,104 @@
(require 'rx)
-(defconst ledger-regex-date
+(eval-when-compile
+ (require 'cl))
+
+(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))))
+ (addend 0) last-group)
+ (if (null args)
+ (progn
+ (nconc
+ defs
+ (list
+ `(defconst
+ ,(intern
+ (concat "ledger-regex-" (symbol-name name) "-group"))
+ 1)))
+ (nconc
+ defs
+ (list
+ `(defconst
+ ,(intern (concat "ledger-regex-" (symbol-name name)
+ "-group--count"))
+ 1)))
+ (nconc
+ defs
+ (list
+ `(defmacro
+ ,(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))))
+
+ (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))))
+
+ (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 date
(let ((sep '(or ?- (any ?. ?/)))) ; can't do (any ?- ?. ?/) due to bug
(rx (group
(and (? (= 4 num)
@@ -10,158 +108,143 @@
(and num (? num))))))
"Match a single date, in its 'written' form.")
-(defconst ledger-regex-date-group 1)
-(defconst ledger-regex-date-group--count 1)
-
-(defconst ledger-regex-full-date
+(ledger-define-regexp full-date
(macroexpand
- `(rx (and (regexp ,ledger-regex-date)
- (? (and ?= (regexp ,ledger-regex-date))))))
- "Match a compound date, of the form ACTUAL=EFFECTIVE")
-
-(defconst ledger-regex-full-date-group-actual
- ledger-regex-date-group)
-(defconst ledger-regex-full-date-group-effective
- (+ ledger-regex-date-group--count
- ledger-regex-date-group))
-(defconst ledger-regex-full-date-group--count
- (* 2 ledger-regex-date-group--count))
-
-(defconst ledger-regex-state
- (rx (group (any ?! ?*))))
-
-(defconst ledger-regex-state-group 1)
-(defconst ledger-regex-state-group--count 1)
-
-(defconst ledger-regex-code
- (rx (and ?\( (group (+? (not (any ?\))))) ?\))))
-
-(defconst ledger-regex-code-group 1)
-(defconst ledger-regex-code-group--count 1)
-
-(defconst ledger-regex-long-space
- (rx (and (*? space)
- (or (and ? (or ? ?\t)) ?\t))))
-
-(defconst ledger-regex-note
- (rx (group (+ nonl))))
-
-(defconst ledger-regex-note-group 1)
-(defconst ledger-regex-note-group--count 1)
-
-(defconst ledger-regex-end-note
- (macroexpand `(rx (and (regexp ,ledger-regex-long-space) ?\;
- (regexp ,ledger-regex-note)))))
-
-(defconst ledger-regex-end-note-group
- ledger-regex-note-group)
-(defconst ledger-regex-end-note-group--count
- ledger-regex-note-group--count)
-
-(defconst ledger-regex-full-note
- (macroexpand `(rx (and line-start (+ space)
- ?\; (regexp ,ledger-regex-note)))))
+ `(rx (and (regexp ,ledger-date-regexp)
+ (? (and ?= (regexp ,ledger-date-regexp))))))
+ "Match a compound date, of the form ACTUAL=EFFECTIVE"
+ (actual date)
+ (effective date))
+
+(ledger-define-regexp state
+ (rx (group (any ?! ?*)))
+ "Match a transaction or posting's \"state\" character.")
+
+(ledger-define-regexp 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\".")
+
+(ledger-define-regexp note
+ (rx (group (+ nonl)))
+ "")
+
+(ledger-define-regexp end-note
+ (macroexpand
+ `(rx (and (regexp ,ledger-long-space-regexp) ?\;
+ (regexp ,ledger-note-regexp))))
+ "")
-(defconst ledger-regex-full-note-group
- ledger-regex-note-group)
-(defconst ledger-regex-full-note-group--count
- ledger-regex-note-group--count)
+(ledger-define-regexp full-note
+ (macroexpand
+ `(rx (and line-start (+ blank)
+ ?\; (regexp ,ledger-note-regexp))))
+ "")
-(defconst ledger-regex-xact-line
+(ledger-define-regexp xact-line
(macroexpand
`(rx (and line-start
- (regexp ,ledger-regex-full-date)
- (? (and (+ space) (regexp ,ledger-regex-state)))
- (? (and (+ space) (regexp ,ledger-regex-code)))
- (+ space) (+? nonl)
- (? (regexp ,ledger-regex-end-note))
- line-end))))
-
-(defconst ledger-regex-xact-line-group-actual-date
- ledger-regex-full-date-group-actual)
-(defconst ledger-regex-xact-line-group-effective-date
- ledger-regex-full-date-group-effective)
-(defconst ledger-regex-xact-line-group-state
- (+ ledger-regex-full-date-group--count
- ledger-regex-state-group))
-(defconst ledger-regex-xact-line-group-code
- (+ ledger-regex-full-date-group--count
- ledger-regex-state-group--count
- ledger-regex-code-group))
-(defconst ledger-regex-xact-line-group-note
- (+ ledger-regex-full-date-group--count
- ledger-regex-state-group--count
- ledger-regex-code-group--count
- ledger-regex-note-group))
-(defconst ledger-regex-full-note-group--count
- (+ ledger-regex-full-date-group--count
- ledger-regex-state-group--count
- ledger-regex-code-group--count
- ledger-regex-note-group--count))
-
-(defun ledger-regex-xact-line-actual-date
- (&optional string)
- (match-string ledger-regex-xact-line-group-actual-date string))
-
-(defconst ledger-regex-account
- (rx (group (and (not (any ?:)) (*? nonl)))))
-
-(defconst ledger-regex-full-account
+ (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))))
+ "")
+
+(ledger-define-regexp account-kind
+ (rx (group (? (any ?\[ ?\())))
+ "")
+
+(ledger-define-regexp full-account
(macroexpand
- `(rx (and (group (? (any ?\[ ?\))))
- (regexp ,ledger-regex-account)
- (? (any ?\] ?\)))))))
-
-(defconst ledger-regex-commodity
- (rx (or (and ?\" (+ (not (any ?\"))) ?\")
- (not (any space ?\n
- digit
- ?- ?\[ ?\]
- ?. ?, ?\; ?+ ?* ?/ ?^ ?? ?: ?& ?| ?! ?=
- ?\< ?\> ?\{ ?\} ?\( ?\) ?@)))))
-
-(defconst ledger-regex-amount
- (rx (and (? ?-)
- (and (+ digit)
- (*? (and (any ?. ?,) (+ digit))))
- (? (and (any ?. ?,) (+ digit))))))
-
-(defconst ledger-regex-commoditized-amount
+ `(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
+ ?- ?\[ ?\]
+ ?. ?, ?\; ?+ ?* ?/ ?^ ?? ?: ?& ?| ?! ?=
+ ?\< ?\> ?\{ ?\} ?\( ?\) ?@)))))
+ "")
+
+(ledger-define-regexp amount
+ (rx (group
+ (and (? ?-)
+ (and (+ digit)
+ (*? (and (any ?. ?,) (+ digit))))
+ (? (and (any ?. ?,) (+ digit))))))
+ "")
+
+(ledger-define-regexp commoditized-amount
(macroexpand
- `(rx (or (and (regexp ,ledger-regex-commodity)
- (*? space)
- (regexp ,ledger-regex-amount))
- (and (regexp ,ledger-regex-amount)
- (*? space)
- (regexp ,ledger-regex-commodity))))))
-
-(defconst ledger-regex-commodity-annotations
+ `(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 (* (+ space)
- (or (and ?\{ (regexp ,ledger-regex-commoditized-amount) ?\})
- (and ?\[ (regexp ,ledger-regex-date) ?\])
- (and ?\( (not (any ?\))) ?\)))))))
+ `(rx (* (+ blank)
+ (or (and ?\{ (regexp ,ledger-commoditized-amount-regexp) ?\})
+ (and ?\[ (regexp ,ledger-date-regexp) ?\])
+ (and ?\( (not (any ?\))) ?\))))))
+ "")
-(defconst ledger-regex-cost
+(ledger-define-regexp cost
(macroexpand
- `(rx (and (or "@" "@@") (+ space)
- (regexp ,ledger-regex-commoditized-amount)))))
+ `(rx (and (or "@" "@@") (+ blank)
+ (regexp ,ledger-commoditized-amount-regexp))))
+ "")
-(defconst ledger-regex-balance-assertion
+(ledger-define-regexp balance-assertion
(macroexpand
- `(rx (and ?= (+ space)
- (regexp ,ledger-regex-commoditized-amount)))))
+ `(rx (and ?= (+ blank)
+ (regexp ,ledger-commoditized-amount-regexp))))
+ "")
-(defconst ledger-regex-full-amount
- (macroexpand `(rx (group (+? (not (any ?\;)))))))
+(ledger-define-regexp full-amount
+ (macroexpand `(rx (group (+? (not (any ?\;))))))
+ "")
-(defconst ledger-regex-post-line
+(ledger-define-regexp post-line
(macroexpand
- `(rx (and line-start
- (? (and (+ space) (regexp ,ledger-regex-state)))
- (+ space) (regexp ,ledger-regex-full-account)
- (+ space) (regexp ,ledger-regex-full-amount)
- (? (regexp ,ledger-regex-end-note))
- line-end))))
+ `(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))
(provide 'ldg-regex)
diff --git a/lisp/ldg-register.el b/lisp/ldg-register.el
new file mode 100644
index 00000000..02e50de9
--- /dev/null
+++ b/lisp/ldg-register.el
@@ -0,0 +1,66 @@
+(require 'ldg-post)
+(require 'ldg-state)
+
+(defgroup ledger-register nil
+ ""
+ :group 'ledger)
+
+(defcustom ledger-register-date-format "%m/%d/%y"
+ "*The date format used for ledger register reports."
+ :type 'string
+ :group 'ledger-register)
+
+(defcustom ledger-register-line-format "%s %-30.30s %-25.25s %15s\n"
+ "*The date format used for ledger register reports."
+ :type 'string
+ :group 'ledger-register)
+
+(defface ledger-register-pending-face
+ '((((background light)) (:weight bold))
+ (((background dark)) (:weight bold)))
+ "Face used to highlight pending entries in a register report."
+ :group 'ledger-register)
+
+(defun ledger-register-render (data-buffer posts)
+ (dolist (post posts)
+ (let ((index 1))
+ (dolist (xact (nthcdr 5 post))
+ (let ((beg (point))
+ (where
+ (with-current-buffer data-buffer
+ (cons
+ (nth 0 post)
+ (if ledger-clear-whole-entries
+ (save-excursion
+ (goto-line (nth 1 post))
+ (point-marker))
+ (save-excursion
+ (goto-line (nth 0 xact))
+ (point-marker)))))))
+ (insert (format ledger-register-line-format
+ (format-time-string ledger-register-date-format
+ (nth 2 post))
+ (nth 4 post) (nth 1 xact) (nth 2 xact)))
+ (if (nth 3 xact)
+ (set-text-properties beg (1- (point))
+ (list 'face 'ledger-register-pending-face
+ 'where where))
+ (set-text-properties beg (1- (point))
+ (list 'where where))))
+ (setq index (1+ index)))))
+ (goto-char (point-min))
+ )
+
+(defun ledger-register-generate (&optional data-buffer &rest args)
+ (let ((buf (or data-buffer (current-buffer))))
+ (with-current-buffer (get-buffer-create "*ledger-register*")
+ (let ((pos (point))
+ (inhibit-read-only t))
+ (erase-buffer)
+ (ledger-register-render buf (apply #'ledger-exec-read buf args))
+ (goto-char pos))
+ (set-buffer-modified-p nil)
+ (toggle-read-only t)
+ (display-buffer (current-buffer) t))))
+
+(provide 'ldg-register)
diff --git a/lisp/ldg-report.el b/lisp/ldg-report.el
new file mode 100644
index 00000000..6fc74f1d
--- /dev/null
+++ b/lisp/ldg-report.el
@@ -0,0 +1,448 @@
+(defcustom ledger-reports
+ '(("bal" "ledger -f %(ledger-file) bal")
+ ("reg" "ledger -f %(ledger-file) reg")
+ ("payee" "ledger -f %(ledger-file) reg -- %(payee)")
+ ("account" "ledger -f %(ledger-file) reg %(account)"))
+ "Definition of reports to run.
+
+Each element has the form (NAME CMDLINE). The command line can
+contain format specifiers that are replaced with context sensitive
+information. Format specifiers have the format '%(<name>)' where
+<name> is an identifier for the information to be replaced. The
+`ledger-report-format-specifiers' alist variable contains a mapping
+from format specifier identifier to a lisp function that implements
+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")))
+ :group 'ledger)
+
+(defcustom ledger-report-format-specifiers
+ '(("ledger-file" . ledger-report-ledger-file-format-specifier)
+ ("payee" . ledger-report-payee-format-specifier)
+ ("account" . ledger-report-account-format-specifier))
+ "Alist mapping ledger report format specifiers to implementing functions
+
+The function is called with no parameters and expected to return the
+text that should replace the format specifier."
+ :type 'alist
+ :group 'ledger)
+
+;;(define-key map [(control ?c) (control ?o) (control ?r)] 'ledger-report)
+;;(define-key map [(control ?c) (control ?o) (control ?g)] 'ledger-report-goto)
+;;(define-key map [(control ?c) (control ?o) (control ?a)] 'ledger-report-redo)
+;;(define-key map [(control ?c) (control ?o) (control ?s)] 'ledger-report-save)
+;;(define-key map [(control ?c) (control ?o) (control ?e)] 'ledger-report-edit)
+;;(define-key map [(control ?c) (control ?o) (control ?k)] 'ledger-report-kill)
+
+;; Ledger report mode
+
+(defvar ledger-report-buffer-name "*Ledger Report*")
+
+(defvar ledger-report-name nil)
+(defvar ledger-report-cmd nil)
+(defvar ledger-report-name-prompt-history nil)
+(defvar ledger-report-cmd-prompt-history nil)
+(defvar ledger-original-window-cfg nil)
+
+(defvar ledger-report-mode-abbrev-table)
+
+(define-derived-mode ledger-report-mode text-mode "Ledger-Report"
+ "A mode for viewing ledger reports."
+ (let ((map (make-sparse-keymap)))
+ (define-key map [? ] 'scroll-up)
+ (define-key map [backspace] 'scroll-down)
+ (define-key map [?r] 'ledger-report-redo)
+ (define-key map [?s] 'ledger-report-save)
+ (define-key map [?k] 'ledger-report-kill)
+ (define-key map [?e] 'ledger-report-edit)
+ (define-key map [?q] 'ledger-report-quit)
+ (define-key map [(control ?c) (control ?l) (control ?r)]
+ 'ledger-report-redo)
+ (define-key map [(control ?c) (control ?l) (control ?S)]
+ 'ledger-report-save)
+ (define-key map [(control ?c) (control ?l) (control ?k)]
+ 'ledger-report-kill)
+ (define-key map [(control ?c) (control ?l) (control ?e)]
+ 'ledger-report-edit)
+ (use-local-map map)))
+
+(defun ledger-report-read-name ()
+ "Read the name of a ledger report to use, with completion.
+
+The empty string and unknown names are allowed."
+ (completing-read "Report name: "
+ ledger-reports nil nil nil
+ 'ledger-report-name-prompt-history nil))
+
+(defun ledger-report (report-name edit)
+ "Run a user-specified report from `ledger-reports'.
+
+Prompts the user for the name of the report to run. If no name is
+entered, the user will be prompted for a command line to run. The
+command line specified or associated with the selected report name
+is run and the output is made available in another buffer for viewing.
+If a prefix argument is given and the user selects a valid report
+name, the user is prompted with the corresponding command line for
+editing before the command is run.
+
+The output buffer will be in `ledger-report-mode', which defines
+commands for saving a new named report based on the command line
+used to generate the buffer, navigating the buffer, etc."
+ (interactive
+ (progn
+ (when (and (buffer-modified-p)
+ (y-or-n-p "Buffer modified, save it? "))
+ (save-buffer))
+ (let ((rname (ledger-report-read-name))
+ (edit (not (null current-prefix-arg))))
+ (list rname edit))))
+ (let ((buf (current-buffer))
+ (rbuf (get-buffer ledger-report-buffer-name))
+ (wcfg (current-window-configuration)))
+ (if rbuf
+ (kill-buffer rbuf))
+ (with-current-buffer
+ (pop-to-buffer (get-buffer-create ledger-report-buffer-name))
+ (ledger-report-mode)
+ (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)
+ (ledger-do-report (ledger-report-cmd report-name edit))
+ (shrink-window-if-larger-than-buffer)
+ (set-buffer-modified-p nil)
+ (setq buffer-read-only t)
+ (message "q to quit; r to redo; e to edit; k to kill; s to save; SPC and DEL to scroll"))))
+
+(defun string-empty-p (s)
+ "Check for the empty string."
+ (string-equal "" s))
+
+(defun ledger-report-name-exists (name)
+ "Check to see if the given report name exists.
+
+If name exists, returns the object naming the report, otherwise returns nil."
+ (unless (string-empty-p name)
+ (car (assoc name ledger-reports))))
+
+(defun ledger-reports-add (name cmd)
+ "Add a new report to `ledger-reports'."
+ (setq ledger-reports (cons (list name cmd) ledger-reports)))
+
+(defun ledger-reports-custom-save ()
+ "Save the `ledger-reports' variable using the customize framework."
+ (customize-save-variable 'ledger-reports ledger-reports))
+
+(defun ledger-report-read-command (report-cmd)
+ "Read the command line to create a report."
+ (read-from-minibuffer "Report command line: "
+ (if (null report-cmd) "ledger " report-cmd)
+ nil nil 'ledger-report-cmd-prompt-history))
+
+(defun ledger-report-ledger-file-format-specifier ()
+ "Substitute the full path to master or current ledger file
+
+The master file name is determined by the ledger-master-file buffer-local
+variable which can be set using file variables. If it is set, it is used,
+otherwise the current buffer file is used."
+ (ledger-master-file))
+
+;; General helper functions
+
+(defvar ledger-master-file nil)
+
+(defun ledger-master-file ()
+ "Return the master file for a ledger file.
+
+The master file is either the file for the current ledger buffer or the
+file specified by the buffer-local variable ledger-master-file. Typically
+this variable would be set in a file local variable comment block at the
+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)))
+
+(defun ledger-read-string-with-default (prompt default)
+ (let ((default-prompt (concat prompt
+ (if default
+ (concat " (" default "): ")
+ ": "))))
+ (read-string default-prompt nil nil default)))
+
+(defun ledger-report-payee-format-specifier ()
+ "Substitute a payee name
+
+The user is prompted to enter a payee and that is substitued. If
+point is in an entry, the payee for that entry is used as the
+default."
+ ;; It is intended copmletion should be available on existing
+ ;; payees, but the list of possible completions needs to be
+ ;; developed to allow this.
+ (ledger-read-string-with-default "Payee" (regexp-quote (ledger-entry-payee))))
+
+(defun ledger-report-account-format-specifier ()
+ "Substitute an account name
+
+The user is prompted to enter an account name, which can be any
+regular expression identifying an account. If point is on an account
+transaction line for an entry, the full account name on that line is
+the default."
+ ;; It is intended completion should be available on existing account
+ ;; names, but it remains to be implemented.
+ (let* ((context (ledger-context-at-point))
+ (default
+ (if (eq (ledger-context-line-type context) 'acct-transaction)
+ (regexp-quote (ledger-context-field-value context 'account))
+ nil)))
+ (ledger-read-string-with-default "Account" default)))
+
+(defun ledger-report-expand-format-specifiers (report-cmd)
+ (let ((expanded-cmd report-cmd))
+ (while (string-match "%(\\([^)]*\\))" 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))
+ (progn
+ (set-window-configuration ledger-original-window-cfg)
+ (error "Invalid ledger report format specifier '%s'" specifier)))))
+ expanded-cmd))
+
+(defun ledger-report-cmd (report-name edit)
+ "Get the command line to run the report."
+ (let ((report-cmd (car (cdr (assoc report-name ledger-reports)))))
+ ;; logic for substitution goes here
+ (when (or (null report-cmd) edit)
+ (setq report-cmd (ledger-report-read-command report-cmd)))
+ (setq report-cmd (ledger-report-expand-format-specifiers report-cmd))
+ (set (make-local-variable 'ledger-report-cmd) report-cmd)
+ (or (string-empty-p report-name)
+ (ledger-report-name-exists report-name)
+ (ledger-reports-add report-name report-cmd)
+ (ledger-reports-custom-save))
+ report-cmd))
+
+(defun ledger-do-report (cmd)
+ "Run a report command line."
+ (goto-char (point-min))
+ (insert (format "Report: %s\n" ledger-report-name)
+ (format "Command: %s\n" cmd)
+ (make-string (- (window-width) 1) ?=)
+ "\n")
+ (shell-command cmd t nil))
+
+(defun ledger-report-goto ()
+ "Goto the ledger report buffer."
+ (interactive)
+ (let ((rbuf (get-buffer ledger-report-buffer-name)))
+ (if (not rbuf)
+ (error "There is no ledger report buffer"))
+ (pop-to-buffer rbuf)
+ (shrink-window-if-larger-than-buffer)))
+
+(defun ledger-report-redo ()
+ "Redo the report in the current ledger report buffer."
+ (interactive)
+ (ledger-report-goto)
+ (setq buffer-read-only nil)
+ (erase-buffer)
+ (ledger-do-report ledger-report-cmd)
+ (setq buffer-read-only nil))
+
+(defun ledger-report-quit ()
+ "Quit the ledger report buffer by burying it."
+ (interactive)
+ (ledger-report-goto)
+ (set-window-configuration ledger-original-window-cfg)
+ (bury-buffer (get-buffer ledger-report-buffer-name)))
+
+(defun ledger-report-kill ()
+ "Kill the ledger report buffer."
+ (interactive)
+ (ledger-report-quit)
+ (kill-buffer (get-buffer ledger-report-buffer-name)))
+
+(defun ledger-report-edit ()
+ "Edit the defined ledger reports."
+ (interactive)
+ (customize-variable 'ledger-reports))
+
+(defun ledger-report-read-new-name ()
+ "Read the name for a new report from the minibuffer."
+ (let ((name ""))
+ (while (string-empty-p name)
+ (setq name (read-from-minibuffer "Report name: " nil nil nil
+ 'ledger-report-name-prompt-history)))
+ name))
+
+(defun ledger-report-save ()
+ "Save the current report command line as a named report."
+ (interactive)
+ (ledger-report-goto)
+ (let (existing-name)
+ (when (string-empty-p ledger-report-name)
+ (setq ledger-report-name (ledger-report-read-new-name)))
+
+ (while (setq existing-name (ledger-report-name-exists ledger-report-name))
+ (cond ((y-or-n-p (format "Overwrite existing report named '%s' "
+ ledger-report-name))
+ (when (string-equal
+ ledger-report-cmd
+ (car (cdr (assq existing-name ledger-reports))))
+ (error "Current command is identical to existing saved one"))
+ (setq ledger-reports
+ (assq-delete-all existing-name ledger-reports)))
+ (t
+ (setq ledger-report-name (ledger-report-read-new-name)))))
+
+ (ledger-reports-add ledger-report-name ledger-report-cmd)
+ (ledger-reports-custom-save)))
+
+(defconst ledger-line-config
+ '((entry
+ (("^\\(\\([0-9][0-9][0-9][0-9]/\\)?[01]?[0-9]/[0123]?[0-9]\\)[ \t]+\\(\\([!*]\\)[ \t]\\)?[ \t]*\\((\\(.*\\))\\)?[ \t]*\\(.*?\\)[ \t]*;\\(.*\\)[ \t]*$"
+ (date nil status nil nil code payee comment))
+ ("^\\(\\([0-9][0-9][0-9][0-9]/\\)?[01]?[0-9]/[0123]?[0-9]\\)[ \t]+\\(\\([!*]\\)[ \t]\\)?[ \t]*\\((\\(.*\\))\\)?[ \t]*\\(.*\\)[ \t]*$"
+ (date nil status nil nil code payee))))
+ (acct-transaction
+ (("\\(^[ \t]+\\)\\(.*?\\)[ \t]+\\([$]\\)\\(-?[0-9]*\\(\\.[0-9]*\\)?\\)[ \t]*;[ \t]*\\(.*?\\)[ \t]*$"
+ (indent account commodity amount nil comment))
+ ("\\(^[ \t]+\\)\\(.*?\\)[ \t]+\\([$]\\)\\(-?[0-9]*\\(\\.[0-9]*\\)?\\)[ \t]*$"
+ (indent account commodity amount nil))
+ ("\\(^[ \t]+\\)\\(.*?\\)[ \t]+\\(-?[0-9]+\\(\\.[0-9]*\\)?\\)[ \t]+\\(.*?\\)[ \t]*;[ \t]*\\(.*?\\)[ \t]*$"
+ (indent account amount nil commodity comment))
+ ("\\(^[ \t]+\\)\\(.*?\\)[ \t]+\\(-?[0-9]+\\(\\.[0-9]*\\)?\\)[ \t]+\\(.*?\\)[ \t]*$"
+ (indent account amount nil commodity))
+ ("\\(^[ \t]+\\)\\(.*?\\)[ \t]+\\(-?\\(\\.[0-9]*\\)\\)[ \t]+\\(.*?\\)[ \t]*;[ \t]*\\(.*?\\)[ \t]*$"
+ (indent account amount nil commodity comment))
+ ("\\(^[ \t]+\\)\\(.*?\\)[ \t]+\\(-?\\(\\.[0-9]*\\)\\)[ \t]+\\(.*?\\)[ \t]*$"
+ (indent account amount nil commodity))
+ ("\\(^[ \t]+\\)\\(.*?\\)[ \t]*;[ \t]*\\(.*?\\)[ \t]*$"
+ (indent account comment))
+ ("\\(^[ \t]+\\)\\(.*?\\)[ \t]*$"
+ (indent account))))))
+
+(defun ledger-extract-context-info (line-type pos)
+ "Get context info for current line.
+
+Assumes point is at beginning of line, and the pos argument specifies
+where the \"users\" point was."
+ (let ((linfo (assoc line-type ledger-line-config))
+ found field fields)
+ (dolist (re-info (nth 1 linfo))
+ (let ((re (nth 0 re-info))
+ (names (nth 1 re-info)))
+ (unless found
+ (when (looking-at re)
+ (setq found t)
+ (dotimes (i (length names))
+ (when (nth i names)
+ (setq fields (append fields
+ (list
+ (list (nth i names)
+ (match-string-no-properties (1+ i))
+ (match-beginning (1+ i))))))))
+ (dolist (f fields)
+ (and (nth 1 f)
+ (>= pos (nth 2 f))
+ (setq field (nth 0 f))))))))
+ (list line-type field fields)))
+
+(defun ledger-context-at-point ()
+ "Return a list describing the context around point.
+
+The contents of the list are the line type, the name of the field
+point containing point, and for selected line types, the content of
+the fields in the line in a association list."
+ (let ((pos (point)))
+ (save-excursion
+ (beginning-of-line)
+ (let ((first-char (char-after)))
+ (cond ((equal (point) (line-end-position))
+ '(empty-line nil nil))
+ ((memq first-char '(?\ ?\t))
+ (ledger-extract-context-info 'acct-transaction pos))
+ ((memq first-char '(?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9))
+ (ledger-extract-context-info 'entry pos))
+ ((equal first-char ?\=)
+ '(automated-entry nil nil))
+ ((equal first-char ?\~)
+ '(period-entry nil nil))
+ ((equal first-char ?\!)
+ '(command-directive))
+ ((equal first-char ?\;)
+ '(comment nil nil))
+ ((equal first-char ?Y)
+ '(default-year nil nil))
+ ((equal first-char ?P)
+ '(commodity-price nil nil))
+ ((equal first-char ?N)
+ '(price-ignored-commodity nil nil))
+ ((equal first-char ?D)
+ '(default-commodity nil nil))
+ ((equal first-char ?C)
+ '(commodity-conversion nil nil))
+ ((equal first-char ?i)
+ '(timeclock-i nil nil))
+ ((equal first-char ?o)
+ '(timeclock-o nil nil))
+ ((equal first-char ?b)
+ '(timeclock-b nil nil))
+ ((equal first-char ?h)
+ '(timeclock-h nil nil))
+ (t
+ '(unknown nil nil)))))))
+
+(defun ledger-context-other-line (offset)
+ "Return a list describing context of line offset for existing position.
+
+Offset can be positive or negative. If run out of buffer before reaching
+specified line, returns nil."
+ (save-excursion
+ (let ((left (forward-line offset)))
+ (if (not (equal left 0))
+ nil
+ (ledger-context-at-point)))))
+
+(defun ledger-context-line-type (context-info)
+ (nth 0 context-info))
+
+(defun ledger-context-current-field (context-info)
+ (nth 1 context-info))
+
+(defun ledger-context-field-info (context-info field-name)
+ (assoc field-name (nth 2 context-info)))
+
+(defun ledger-context-field-present-p (context-info field-name)
+ (not (null (ledger-context-field-info context-info field-name))))
+
+(defun ledger-context-field-value (context-info field-name)
+ (nth 1 (ledger-context-field-info context-info field-name)))
+
+(defun ledger-context-field-position (context-info field-name)
+ (nth 2 (ledger-context-field-info context-info field-name)))
+
+(defun ledger-context-field-end-position (context-info field-name)
+ (+ (ledger-context-field-position context-info field-name)
+ (length (ledger-context-field-value context-info field-name))))
+
+(defun ledger-context-goto-field-start (context-info field-name)
+ (goto-char (ledger-context-field-position context-info field-name)))
+
+(defun ledger-context-goto-field-end (context-info field-name)
+ (goto-char (ledger-context-field-end-position context-info field-name)))
+
+(defun ledger-entry-payee ()
+ "Returns the payee of the entry containing point or nil."
+ (let ((i 0))
+ (while (eq (ledger-context-line-type (ledger-context-other-line i)) 'acct-transaction)
+ (setq i (- i 1)))
+ (let ((context-info (ledger-context-other-line i)))
+ (if (eq (ledger-context-line-type context-info) 'entry)
+ (ledger-context-field-value context-info 'payee)
+ nil))))
diff --git a/lisp/ldg-state.el b/lisp/ldg-state.el
new file mode 100644
index 00000000..945d72fe
--- /dev/null
+++ b/lisp/ldg-state.el
@@ -0,0 +1,189 @@
+(defcustom ledger-clear-whole-entries nil
+ "If non-nil, clear whole entries, not individual transactions."
+ :type 'boolean
+ :group 'ledger)
+
+(defun ledger-toggle-state (state &optional style)
+ (if (not (null state))
+ (if (and style (eq style 'cleared))
+ 'cleared)
+ (if (and style (eq style 'pending))
+ 'pending
+ 'cleared)))
+
+(defun ledger-entry-state ()
+ (save-excursion
+ (when (or (looking-at "^[0-9]")
+ (re-search-backward "^[0-9]" nil t))
+ (skip-chars-forward "0-9./=")
+ (skip-syntax-forward " ")
+ (cond ((looking-at "!\\s-*") 'pending)
+ ((looking-at "\\*\\s-*") 'cleared)
+ (t nil)))))
+
+(defun ledger-transaction-state ()
+ (save-excursion
+ (goto-char (line-beginning-position))
+ (skip-syntax-forward " ")
+ (cond ((looking-at "!\\s-*") 'pending)
+ ((looking-at "\\*\\s-*") 'cleared)
+ (t (ledger-entry-state)))))
+
+(defun ledger-toggle-current-transaction (&optional style)
+ "Toggle the cleared status of the transaction under point.
+Optional argument STYLE may be `pending' or `cleared', depending
+on which type of status the caller wishes to indicate (default is
+`cleared').
+This function is rather complicated because it must preserve both
+the overall formatting of the ledger entry, as well as ensuring
+that the most minimal display format is used. This could be
+achieved more certainly by passing the entry to ledger for
+formatting, but doing so causes inline math expressions to be
+dropped."
+ (interactive)
+ (let ((bounds (ledger-current-entry-bounds))
+ clear cleared)
+ ;; Uncompact the entry, to make it easier to toggle the
+ ;; transaction
+ (save-excursion
+ (goto-char (car bounds))
+ (skip-chars-forward "0-9./= \t")
+ (setq cleared (and (member (char-after) '(?\* ?\!))
+ (char-after)))
+ (when cleared
+ (let ((here (point)))
+ (skip-chars-forward "*! ")
+ (let ((width (- (point) here)))
+ (when (> width 0)
+ (delete-region here (point))
+ (if (search-forward " " (line-end-position) t)
+ (insert (make-string width ? ))))))
+ (forward-line)
+ (while (looking-at "[ \t]")
+ (skip-chars-forward " \t")
+ (insert cleared " ")
+ (if (search-forward " " (line-end-position) t)
+ (delete-char 2))
+ (forward-line))))
+ ;; Toggle the individual transaction
+ (save-excursion
+ (goto-char (line-beginning-position))
+ (when (looking-at "[ \t]")
+ (skip-chars-forward " \t")
+ (let ((here (point))
+ (cleared (member (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 cleared
+ (if (and style (eq style 'cleared))
+ (progn
+ (insert "* ")
+ (setq inserted t)))
+ (if (and style (eq style 'pending))
+ (progn
+ (insert "! ")
+ (setq inserted t))
+ (progn
+ (insert "* ")
+ (setq inserted t))))
+ (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 clear inserted)))))
+ ;; Clean up the entry so that it displays minimally
+ (save-excursion
+ (goto-char (car bounds))
+ (forward-line)
+ (let ((first t)
+ (state ? )
+ (hetero nil))
+ (while (and (not hetero) (looking-at "[ \t]"))
+ (skip-chars-forward " \t")
+ (let ((cleared (if (member (char-after) '(?\* ?\!))
+ (char-after)
+ ? )))
+ (if first
+ (setq state cleared
+ first nil)
+ (if (/= state cleared)
+ (setq hetero t))))
+ (forward-line))
+ (when (and (not hetero) (/= state ? ))
+ (goto-char (car bounds))
+ (forward-line)
+ (while (looking-at "[ \t]")
+ (skip-chars-forward " \t")
+ (let ((here (point)))
+ (skip-chars-forward "*! ")
+ (let ((width (- (point) here)))
+ (when (> width 0)
+ (delete-region here (point))
+ (if (re-search-forward "\\(\t\\| [ \t]\\)"
+ (line-end-position) t)
+ (insert (make-string width ? ))))))
+ (forward-line))
+ (goto-char (car bounds))
+ (skip-chars-forward "0-9./= \t")
+ (insert 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)))))))
+ clear))
+
+(defun ledger-toggle-current (&optional style)
+ (interactive)
+ (if (or ledger-clear-whole-entries
+ (eq 'entry (ledger-thing-at-point)))
+ (progn
+ (save-excursion
+ (forward-line)
+ (goto-char (line-beginning-position))
+ (while (and (not (eolp))
+ (save-excursion
+ (not (eq 'entry (ledger-thing-at-point)))))
+ (if (looking-at "\\s-+[*!]")
+ (ledger-toggle-current-transaction nil))
+ (forward-line)
+ (goto-char (line-beginning-position))))
+ (ledger-toggle-current-entry style))
+ (ledger-toggle-current-transaction style)))
+
+(defun ledger-toggle-current-entry (&optional style)
+ (interactive)
+ (let (clear)
+ (save-excursion
+ (when (or (looking-at "^[0-9]")
+ (re-search-backward "^[0-9]" nil t))
+ (skip-chars-forward "0-9./=")
+ (delete-horizontal-space)
+ (if (member (char-after) '(?\* ?\!))
+ (progn
+ (delete-char 1)
+ (if (and style (eq style 'cleared))
+ (insert " *")))
+ (if (and style (eq style 'pending))
+ (insert " ! ")
+ (insert " * "))
+ (setq clear t))))
+ clear))
+
+(provide 'ldg-state)
diff --git a/lisp/ldg-xact.el b/lisp/ldg-xact.el
new file mode 100644
index 00000000..5945632a
--- /dev/null
+++ b/lisp/ldg-xact.el
@@ -0,0 +1,20 @@
+;; A sample entry sorting function, which works if entry dates are of
+;; the form YYYY/mm/dd.
+
+(defun ledger-sort ()
+ (interactive)
+ (save-excursion
+ (goto-char (point-min))
+ (sort-subr
+ nil
+ (function
+ (lambda ()
+ (if (re-search-forward
+ (concat "^[0-9/.=-]+\\(\\s-+\\*\\)?\\(\\s-+(.*?)\\)?\\s-+"
+ "\\(.+?\\)\\(\t\\|\n\\| [ \t]\\)") nil t)
+ (goto-char (match-beginning 0))
+ (goto-char (point-max)))))
+ (function
+ (lambda ()
+ (forward-paragraph))))))
+
diff --git a/lisp/ledger.el b/lisp/ledger.el
index 9fa28781..0aff5eaf 100644
--- a/lisp/ledger.el
+++ b/lisp/ledger.el
@@ -4,7 +4,7 @@
;; Emacs Lisp Archive Entry
;; Filename: ledger.el
-;; Version: 3.0
+;; Version: 2.6.3
;; Date: Fri 18-Jul-2008
;; Keywords: data
;; Author: John Wiegley (johnw AT gnu DOT org)
diff --git a/src/account.cc b/src/account.cc
index 245d61fc..e02d21d7 100644
--- a/src/account.cc
+++ b/src/account.cc
@@ -239,6 +239,36 @@ namespace {
value_t get_parent(account_t& account) {
return value_t(static_cast<scope_t *>(account.parent));
}
+
+ value_t fn_any(call_scope_t& scope)
+ {
+ interactive_t args(scope, "X&X");
+
+ account_t& account(find_scope<account_t>(scope));
+ expr_t& expr(args.get<expr_t&>(0));
+
+ foreach (post_t * p, account.posts) {
+ bind_scope_t bound_scope(scope, *p);
+ if (expr.calc(bound_scope).to_boolean())
+ return true;
+ }
+ return false;
+ }
+
+ value_t fn_all(call_scope_t& scope)
+ {
+ interactive_t args(scope, "X&X");
+
+ account_t& account(find_scope<account_t>(scope));
+ expr_t& expr(args.get<expr_t&>(0));
+
+ foreach (post_t * p, account.posts) {
+ bind_scope_t bound_scope(scope, *p);
+ if (! expr.calc(bound_scope).to_boolean())
+ return false;
+ }
+ return true;
+ }
}
expr_t::ptr_op_t account_t::lookup(const symbol_t::kind_t kind,
@@ -255,6 +285,10 @@ expr_t::ptr_op_t account_t::lookup(const symbol_t::kind_t kind,
return WRAP_FUNCTOR(get_wrapper<&get_account>);
else if (name == "account_base")
return WRAP_FUNCTOR(get_wrapper<&get_account_base>);
+ else if (name == "any")
+ return WRAP_FUNCTOR(&fn_any);
+ else if (name == "all")
+ return WRAP_FUNCTOR(&fn_all);
break;
case 'c':
diff --git a/src/commodity.cc b/src/commodity.cc
index e5f10e34..836a4269 100644
--- a/src/commodity.cc
+++ b/src/commodity.cc
@@ -428,7 +428,9 @@ namespace {
{
switch (buf[0]) {
case 'a':
- return std::strcmp(buf, "and") == 0;
+ return (std::strcmp(buf, "and") == 0 ||
+ std::strcmp(buf, "any") == 0 ||
+ std::strcmp(buf, "all") == 0);
case 'd':
return std::strcmp(buf, "div") == 0;
case 'e':
diff --git a/src/convert.cc b/src/convert.cc
index 6c02cff3..2e6da2f6 100644
--- a/src/convert.cc
+++ b/src/convert.cc
@@ -83,7 +83,7 @@ value_t convert_command(call_scope_t& scope)
}
}
- // Create a flat list o
+ // Create a flat list
xacts_list current_xacts(journal.xacts_begin(), journal.xacts_end());
// Read in the series of transactions from the CSV file
@@ -93,6 +93,11 @@ value_t convert_command(call_scope_t& scope)
csv_reader reader(data);
while (xact_t * xact = reader.read_xact(journal, bucket)) {
+ if (report.HANDLED(invert)) {
+ foreach (post_t * post, xact->posts)
+ post->amount.in_place_negate();
+ }
+
bool matched = false;
post_map_t::iterator i = post_map.find(- xact->posts.front()->amount);
if (i != post_map.end()) {
diff --git a/src/expr.cc b/src/expr.cc
index 79fb3611..f3a30de6 100644
--- a/src/expr.cc
+++ b/src/expr.cc
@@ -39,10 +39,26 @@ namespace ledger {
void expr_t::parse(std::istream& in, const parse_flags_t& flags,
const optional<string>& original_string)
{
- base_type::parse(in, flags, original_string);
-
parser_t parser;
+ istream_pos_type start_pos = in.tellg();
ptr = parser.parse(in, flags, original_string);
+ istream_pos_type end_pos = in.tellg();
+
+ if (original_string) {
+ set_text(*original_string);
+ }
+ else if (end_pos > start_pos) {
+ in.clear();
+ in.seekg(start_pos, std::ios::beg);
+ scoped_array<char> buf
+ (new char[static_cast<std::size_t>(end_pos - start_pos) + 1]);
+ in.read(buf.get(), end_pos - start_pos);
+ buf[end_pos - start_pos] = '\0';
+ set_text(buf.get());
+ }
+ else {
+ set_text("<stream>");
+ }
}
void expr_t::compile(scope_t& scope)
diff --git a/src/generate.cc b/src/generate.cc
index c1eb1d14..9b4c2ee7 100644
--- a/src/generate.cc
+++ b/src/generate.cc
@@ -171,10 +171,10 @@ void generate_posts_iterator::generate_commodity(std::ostream& out)
generate_string(buf, six_gen(), true);
comm = buf.str();
}
- while (comm == "h" || comm == "m" || comm == "s" ||
- comm == "and" || comm == "div" || comm == "false" ||
- comm == "or" || comm == "not" || comm == "true" ||
- comm == "if" || comm == "else");
+ while (comm == "h" || comm == "m" || comm == "s" || comm == "and" ||
+ comm == "any" || comm == "all" || comm == "div" ||
+ comm == "false" || comm == "or" || comm == "not" ||
+ comm == "true" || comm == "if" || comm == "else");
out << comm;
}
diff --git a/src/interactive.cc b/src/interactive.cc
index d0baf07a..9aeb5307 100644
--- a/src/interactive.cc
+++ b/src/interactive.cc
@@ -122,6 +122,10 @@ void interactive_t::verify_arguments() const
label = _("a scope");
wrong_arg = ! next_arg->is_scope();
break;
+ case 'X':
+ label = _("an expression");
+ wrong_arg = ! next_arg->is_expr();
+ break;
case 'S':
label = _("a sequence");
wrong_arg = false;
diff --git a/src/interactive.h b/src/interactive.h
index fbc4ffeb..04c23ae5 100644
--- a/src/interactive.h
+++ b/src/interactive.h
@@ -120,6 +120,19 @@ inline const value_t::sequence_t&
interactive_t::get<const value_t::sequence_t&>(std::size_t index) {
return value_at(index).as_sequence();
}
+template <>
+inline scope_t *
+interactive_t::get<scope_t *>(std::size_t index) {
+ return value_at(index).as_scope();
+}
+template <>
+inline expr_t& interactive_t::get<expr_t&>(std::size_t index) {
+ return value_at(index).as_expr_lval();
+}
+template <>
+inline const expr_t& interactive_t::get<const expr_t&>(std::size_t index) {
+ return value_at(index).as_expr();
+}
template <typename T>
class in_context_t : public interactive_t
diff --git a/src/op.cc b/src/op.cc
index 4020ecff..df222802 100644
--- a/src/op.cc
+++ b/src/op.cc
@@ -38,6 +38,37 @@
namespace ledger {
+namespace {
+ value_t split_cons_expr(expr_t::ptr_op_t op, scope_t& scope,
+ std::vector<expr_t>& exprs)
+ {
+ value_t seq;
+
+ if (op->kind == expr_t::op_t::O_CONS) {
+ exprs.push_back(expr_t(op->left(), &scope));
+ seq.push_back(value_t(exprs.back()));
+
+ expr_t::ptr_op_t next = op->right();
+ while (next) {
+ expr_t::ptr_op_t value_op;
+ if (next->kind == expr_t::op_t::O_CONS) {
+ value_op = next->left();
+ next = next->right();
+ } else {
+ value_op = next;
+ next = NULL;
+ }
+ exprs.push_back(expr_t(value_op, &scope));
+ seq.push_back(value_t(exprs.back()));
+ }
+ } else {
+ exprs.push_back(expr_t(op, &scope));
+ seq.push_back(value_t(exprs.back()));
+ }
+ return seq;
+ }
+}
+
expr_t::ptr_op_t expr_t::op_t::compile(scope_t& scope, const int depth)
{
if (is_ident()) {
@@ -190,11 +221,24 @@ value_t expr_t::op_t::calc(scope_t& scope, ptr_op_t * locus, const int depth)
_("Failed to lookup member '%1'") << right()->as_ident());
break;
- case O_CALL: {
+ case O_CALL:
+ case O_EXPAND: {
call_scope_t call_args(scope);
+ // When evaluating a macro call, these expressions have to live beyond the
+ // call to calc() below.
+ optional<std::vector<expr_t> > args_expr;
- if (has_right())
- call_args.set_args(right()->calc(scope, locus, depth + 1));
+ if (has_right()) {
+ if (kind == O_CALL) {
+ call_args.set_args(right()->calc(scope, locus, depth + 1));
+ } else {
+ // macros defer calculation to the callee
+ args_expr = std::vector<expr_t>();
+ call_args.set_args(split_cons_expr(right()->kind == O_SEQ ?
+ right()->left() : right(),
+ scope, *args_expr));
+ }
+ }
ptr_op_t func = left();
const string& name(func->as_ident());
@@ -592,6 +636,7 @@ bool expr_t::op_t::print(std::ostream& out, const context_t& context) const
break;
case O_CALL:
+ case O_EXPAND:
if (left() && left()->print(out, context))
found = true;
if (has_right()) {
@@ -663,6 +708,7 @@ void expr_t::op_t::dump(std::ostream& out, const int depth) const
case O_DEFINE: out << "O_DEFINE"; break;
case O_LOOKUP: out << "O_LOOKUP"; break;
case O_CALL: out << "O_CALL"; break;
+ case O_EXPAND: out << "O_EXPAND"; break;
case O_MATCH: out << "O_MATCH"; break;
case O_NOT: out << "O_NOT"; break;
diff --git a/src/op.h b/src/op.h
index 6a69527b..936c11f4 100644
--- a/src/op.h
+++ b/src/op.h
@@ -105,6 +105,7 @@ public:
O_DEFINE,
O_LOOKUP,
O_CALL,
+ O_EXPAND,
O_MATCH,
BINARY_OPERATORS,
diff --git a/src/parser.cc b/src/parser.cc
index 5bb06f84..e8e987cb 100644
--- a/src/parser.cc
+++ b/src/parser.cc
@@ -58,7 +58,10 @@ expr_t::parser_t::parse_value_term(std::istream& in,
// An identifier followed by ( represents a function call
tok = next_token(in, tflags.plus_flags(PARSE_OP_CONTEXT));
if (tok.kind == token_t::LPAREN) {
- ptr_op_t call_node(new op_t(op_t::O_CALL));
+ op_t::kind_t kind = op_t::O_CALL;
+ if (ident == "any" || ident == "all")
+ kind = op_t::O_EXPAND;
+ ptr_op_t call_node(new op_t(kind));
call_node->set_left(node);
node = call_node;
diff --git a/src/post.cc b/src/post.cc
index 41ae04dd..183fb901 100644
--- a/src/post.cc
+++ b/src/post.cc
@@ -291,6 +291,50 @@ namespace {
value_t get_wrapper(call_scope_t& scope) {
return (*Func)(find_scope<post_t>(scope));
}
+
+ value_t fn_any(call_scope_t& scope)
+ {
+ interactive_t args(scope, "X&X");
+
+ post_t& post(find_scope<post_t>(scope));
+ expr_t& expr(args.get<expr_t&>(0));
+
+ foreach (post_t * p, post.xact->posts) {
+ bind_scope_t bound_scope(scope, *p);
+ if (p == &post && args.has(1) &&
+ ! args.get<expr_t&>(1).calc(bound_scope).to_boolean()) {
+ // If the user specifies any(EXPR, false), and the context is a
+ // posting, then that posting isn't considered by the test.
+ ; // skip it
+ }
+ else if (expr.calc(bound_scope).to_boolean()) {
+ return true;
+ }
+ }
+ return false;
+ }
+
+ value_t fn_all(call_scope_t& scope)
+ {
+ interactive_t args(scope, "X&X");
+
+ post_t& post(find_scope<post_t>(scope));
+ expr_t& expr(args.get<expr_t&>(0));
+
+ foreach (post_t * p, post.xact->posts) {
+ bind_scope_t bound_scope(scope, *p);
+ if (p == &post && args.has(1) &&
+ ! args.get<expr_t&>(1).calc(bound_scope).to_boolean()) {
+ // If the user specifies any(EXPR, false), and the context is a
+ // posting, then that posting isn't considered by the test.
+ ; // skip it
+ }
+ else if (! expr.calc(bound_scope).to_boolean()) {
+ return false;
+ }
+ }
+ return true;
+ }
}
expr_t::ptr_op_t post_t::lookup(const symbol_t::kind_t kind,
@@ -307,6 +351,10 @@ expr_t::ptr_op_t post_t::lookup(const symbol_t::kind_t kind,
return WRAP_FUNCTOR(get_account);
else if (name == "account_base")
return WRAP_FUNCTOR(get_wrapper<&get_account_base>);
+ else if (name == "any")
+ return WRAP_FUNCTOR(&fn_any);
+ else if (name == "all")
+ return WRAP_FUNCTOR(&fn_all);
break;
case 'b':
diff --git a/src/print.cc b/src/print.cc
index eb102a87..34f5af51 100644
--- a/src/print.cc
+++ b/src/print.cc
@@ -140,9 +140,15 @@ namespace {
if (slip > 0)
out << string(slip, ' ');
- std::ostringstream amt_str;
- report.scrub(post->amount).print(amt_str, 12, -1, true);
- string amt = amt_str.str();
+ string amt;
+ if (post->amount_expr) {
+ amt = post->amount_expr->text();
+ } else {
+ std::ostringstream amt_str;
+ report.scrub(post->amount).print(amt_str, 12, -1, true);
+ amt = amt_str.str();
+ }
+
string trimmed_amt(amt);
trim_left(trimmed_amt);
int amt_slip = (static_cast<int>(amt.length()) -
diff --git a/src/report.cc b/src/report.cc
index 2189812b..1180c019 100644
--- a/src/report.cc
+++ b/src/report.cc
@@ -443,6 +443,20 @@ value_t report_t::fn_trim(call_scope_t& args)
}
}
+value_t report_t::fn_print(call_scope_t& args)
+{
+ std::ostream& out(output_stream);
+ bool first = true;
+ for (call_scope_t::iterator i = args.begin(); i != args.end(); i++) {
+ if (first)
+ first = false;
+ else
+ out << ' ';
+ (*i).print(out);
+ }
+ return true;
+}
+
value_t report_t::scrub(value_t val)
{
value_t temp(val.strip_annotations(what_to_keep()));
@@ -1117,6 +1131,8 @@ expr_t::ptr_op_t report_t::lookup(const symbol_t::kind_t kind,
return MAKE_FUNCTOR(report_t::fn_percent);
else if (is_eq(p, "price"))
return MAKE_FUNCTOR(report_t::fn_price);
+ else if (is_eq(p, "print"))
+ return MAKE_FUNCTOR(report_t::fn_print);
break;
case 'q':
diff --git a/src/report.h b/src/report.h
index 50071940..6b10dbcc 100644
--- a/src/report.h
+++ b/src/report.h
@@ -144,6 +144,7 @@ public:
value_t fn_is_seq(call_scope_t& scope);
value_t fn_strip(call_scope_t& scope);
value_t fn_trim(call_scope_t& scope);
+ value_t fn_print(call_scope_t& scope);
value_t scrub(value_t val);
value_t fn_scrub(call_scope_t& scope);
value_t fn_quantity(call_scope_t& scope);
diff --git a/src/scope.h b/src/scope.h
index 675fa4e1..30ba6823 100644
--- a/src/scope.h
+++ b/src/scope.h
@@ -241,6 +241,17 @@ public:
args.pop_back();
}
+ typedef value_t::sequence_t::iterator iterator;
+
+ value_t::sequence_t::iterator begin() {
+ return args.begin();
+ }
+ value_t::sequence_t::iterator end() {
+ return args.end();
+ }
+
+ typedef value_t::sequence_t::const_iterator const_iterator;
+
value_t::sequence_t::const_iterator begin() const {
return args.begin();
}
diff --git a/src/value.cc b/src/value.cc
index 54798162..ce9b0e6a 100644
--- a/src/value.cc
+++ b/src/value.cc
@@ -36,6 +36,7 @@
#include "annotate.h"
#include "pool.h"
#include "unistring.h" // for justify()
+#include "op.h"
namespace ledger {
@@ -115,6 +116,8 @@ value_t::operator bool() const
return false;
case SCOPE:
return as_scope() != NULL;
+ case EXPR:
+ return as_expr();
default:
break;
}
@@ -140,6 +143,12 @@ void value_t::set_type(type_t new_type)
}
}
+void value_t::set_expr(const expr_t& val)
+{
+ set_type(EXPR);
+ storage->data = new expr_t(val);
+}
+
bool value_t::to_boolean() const
{
if (is_boolean()) {
@@ -1272,6 +1281,8 @@ bool value_t::is_realzero() const
case SCOPE:
return as_scope() == NULL;
+ case EXPR:
+ return ! as_expr();
default:
throw_(value_error, _("Cannot determine if %1 is really zero") << label());
@@ -1301,6 +1312,8 @@ bool value_t::is_zero() const
case SCOPE:
return as_scope() == NULL;
+ case EXPR:
+ return ! as_expr();
default:
throw_(value_error, _("Cannot determine if %1 is zero") << label());
@@ -1565,6 +1578,7 @@ value_t value_t::strip_annotations(const keep_details_t& what_to_keep) const
case STRING:
case MASK:
case SCOPE:
+ case EXPR:
return *this;
case SEQUENCE: {
@@ -1673,7 +1687,15 @@ void value_t::print(std::ostream& out,
}
case SCOPE:
- out << "<SCOPE>";
+ out << "<#SCOPE>";
+ break;
+ case EXPR:
+ out << "<#EXPR ";
+ if (as_expr())
+ as_expr().print(out);
+ else
+ out << "null";
+ out << ">";
break;
default:
@@ -1743,6 +1765,12 @@ void value_t::dump(std::ostream& out, const bool relaxed) const
case SCOPE:
out << as_scope();
break;
+ case EXPR:
+ if (as_expr())
+ as_expr().dump(out);
+ else
+ out << "null";
+ break;
case SEQUENCE: {
out << '(';
@@ -1855,6 +1883,7 @@ void to_xml(std::ostream& out, const value_t& value)
}
case value_t::SCOPE:
+ case value_t::EXPR:
default:
assert(false);
break;
diff --git a/src/value.h b/src/value.h
index 1c1d8b6c..3252ed65 100644
--- a/src/value.h
+++ b/src/value.h
@@ -57,6 +57,7 @@ namespace ledger {
DECLARE_EXCEPTION(value_error, std::runtime_error);
class scope_t;
+class expr_t;
/**
* @class value_t
@@ -108,7 +109,8 @@ public:
STRING, // a string object
MASK, // a regular expression mask
SEQUENCE, // a vector of value_t objects
- SCOPE // a pointer to a scope
+ SCOPE, // a pointer to a scope
+ EXPR // a pointer to a value expression
};
private:
@@ -135,7 +137,8 @@ private:
string, // STRING
mask_t, // MASK
sequence_t *, // SEQUENCE
- scope_t * // SCOPE
+ scope_t *, // SCOPE
+ expr_t * // EXPR
> data;
type_t type;
@@ -351,6 +354,10 @@ public:
TRACE_CTOR(value_t, "scope_t *");
set_scope(item);
}
+ explicit value_t(const expr_t& item) {
+ TRACE_CTOR(value_t, "const expr_t&");
+ set_expr(item);
+ }
/**
* Destructor. This does not do anything, because the intrusive_ptr
@@ -723,6 +730,22 @@ public:
}
/**
+ * Dealing with expr pointers.
+ */
+ bool is_expr() const {
+ return is_type(EXPR);
+ }
+ expr_t& as_expr_lval() const {
+ VERIFY(is_expr());
+ return *boost::get<expr_t *>(storage->data);
+ }
+ const expr_t& as_expr() const {
+ VERIFY(is_expr());
+ return *boost::get<expr_t *>(storage->data);
+ }
+ void set_expr(const expr_t& val);
+
+ /**
* Data conversion methods. These methods convert a value object to
* its underlying type, where possible. If not possible, an
* exception is thrown.
@@ -908,6 +931,8 @@ public:
return _("a sequence");
case SCOPE:
return _("a scope");
+ case EXPR:
+ return _("a expr");
default:
assert(false);
break;
diff --git a/src/xact.cc b/src/xact.cc
index 1a022387..344f66ea 100644
--- a/src/xact.cc
+++ b/src/xact.cc
@@ -36,6 +36,7 @@
#include "account.h"
#include "journal.h"
#include "pool.h"
+#include "interactive.h"
namespace ledger {
@@ -483,6 +484,36 @@ namespace {
value_t get_wrapper(call_scope_t& scope) {
return (*Func)(find_scope<xact_t>(scope));
}
+
+ value_t fn_any(call_scope_t& scope)
+ {
+ interactive_t args(scope, "X&X");
+
+ post_t& post(find_scope<post_t>(scope));
+ expr_t& expr(args.get<expr_t&>(0));
+
+ foreach (post_t * p, post.xact->posts) {
+ bind_scope_t bound_scope(scope, *p);
+ if (expr.calc(bound_scope).to_boolean())
+ return true;
+ }
+ return false;
+ }
+
+ value_t fn_all(call_scope_t& scope)
+ {
+ interactive_t args(scope, "X&X");
+
+ post_t& post(find_scope<post_t>(scope));
+ expr_t& expr(args.get<expr_t&>(0));
+
+ foreach (post_t * p, post.xact->posts) {
+ bind_scope_t bound_scope(scope, *p);
+ if (! expr.calc(bound_scope).to_boolean())
+ return false;
+ }
+ return true;
+ }
}
expr_t::ptr_op_t xact_t::lookup(const symbol_t::kind_t kind,
@@ -492,6 +523,13 @@ expr_t::ptr_op_t xact_t::lookup(const symbol_t::kind_t kind,
return item_t::lookup(kind, name);
switch (name[0]) {
+ case 'a':
+ if (name == "any")
+ return WRAP_FUNCTOR(&fn_any);
+ else if (name == "all")
+ return WRAP_FUNCTOR(&fn_all);
+ break;
+
case 'c':
if (name == "code")
return WRAP_FUNCTOR(get_wrapper<&get_code>);