Merge branch 'next'
This commit is contained in:
John Wiegley
commit
5f1a858941
30 changed files with 1848 additions and 188 deletions
156
lisp/ldg-complete.el
Normal file
156
lisp/ldg-complete.el
Normal file
|
|
@ -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)
|
||||
34
lisp/ldg-exec.el
Normal file
34
lisp/ldg-exec.el
Normal file
|
|
@ -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)
|
||||
117
lisp/ldg-mode.el
Normal file
117
lisp/ldg-mode.el
Normal file
|
|
@ -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)
|
||||
56
lisp/ldg-new.el
Normal file
56
lisp/ldg-new.el
Normal file
|
|
@ -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
|
||||
136
lisp/ldg-post.el
136
lisp/ldg-post.el
|
|
@ -9,51 +9,70 @@
|
|||
:type 'boolean
|
||||
:group 'ledger-post)
|
||||
|
||||
(defcustom ledger-post-amount-alignment-column 52
|
||||
"If non-nil, ."
|
||||
:type 'integer
|
||||
:group 'ledger-post)
|
||||
|
||||
(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-all-accounts ()
|
||||
(let ((origin (point))
|
||||
(ledger-post-list nil)
|
||||
account elements)
|
||||
(save-excursion
|
||||
(goto-char (point-min))
|
||||
(while (re-search-forward ledger-post-line-regexp nil t)
|
||||
(unless (and (>= origin (match-beginning 0))
|
||||
(< origin (match-end 0)))
|
||||
(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)
|
||||
|
||||
(defvar ledger-post-current-list nil)
|
||||
|
||||
(defun ledger-post-find-all ()
|
||||
(let ((origin (point))
|
||||
(ledger-post-list nil)
|
||||
account-path elements)
|
||||
(save-excursion
|
||||
(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))
|
||||
(unless (string-match "\\`\\s-*;" account-path)
|
||||
(add-to-list 'ledger-post-list account-path))))
|
||||
(setq ledger-post-current-list
|
||||
(nreverse ledger-post-list)))))
|
||||
|
||||
(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)
|
||||
|
|
|
|||
141
lisp/ldg-reconcile.el
Normal file
141
lisp/ldg-reconcile.el
Normal file
|
|
@ -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)))
|
||||
|
|
@ -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")
|
||||
`(rx (and (regexp ,ledger-date-regexp)
|
||||
(? (and ?= (regexp ,ledger-date-regexp))))))
|
||||
"Match a compound date, of the form ACTUAL=EFFECTIVE"
|
||||
(actual date)
|
||||
(effective date))
|
||||
|
||||
(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))
|
||||
(ledger-define-regexp state
|
||||
(rx (group (any ?! ?*)))
|
||||
"Match a transaction or posting's \"state\" character.")
|
||||
|
||||
(defconst ledger-regex-state
|
||||
(rx (group (any ?! ?*))))
|
||||
(ledger-define-regexp code
|
||||
(rx (and ?\( (group (+? (not (any ?\))))) ?\)))
|
||||
"Match the transaction code.")
|
||||
|
||||
(defconst ledger-regex-state-group 1)
|
||||
(defconst ledger-regex-state-group--count 1)
|
||||
(ledger-define-regexp long-space
|
||||
(rx (and (*? blank)
|
||||
(or (and ? (or ? ?\t)) ?\t)))
|
||||
"Match a \"long space\".")
|
||||
|
||||
(defconst ledger-regex-code
|
||||
(rx (and ?\( (group (+? (not (any ?\))))) ?\))))
|
||||
(ledger-define-regexp note
|
||||
(rx (group (+ nonl)))
|
||||
"")
|
||||
|
||||
(defconst ledger-regex-code-group 1)
|
||||
(defconst ledger-regex-code-group--count 1)
|
||||
(ledger-define-regexp end-note
|
||||
(macroexpand
|
||||
`(rx (and (regexp ,ledger-long-space-regexp) ?\;
|
||||
(regexp ,ledger-note-regexp))))
|
||||
"")
|
||||
|
||||
(defconst ledger-regex-long-space
|
||||
(rx (and (*? space)
|
||||
(or (and ? (or ? ?\t)) ?\t))))
|
||||
(ledger-define-regexp full-note
|
||||
(macroexpand
|
||||
`(rx (and line-start (+ blank)
|
||||
?\; (regexp ,ledger-note-regexp))))
|
||||
"")
|
||||
|
||||
(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)))))
|
||||
|
||||
(defconst ledger-regex-full-note-group
|
||||
ledger-regex-note-group)
|
||||
(defconst ledger-regex-full-note-group--count
|
||||
ledger-regex-note-group--count)
|
||||
|
||||
(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))))
|
||||
(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))
|
||||
|
||||
(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))
|
||||
(ledger-define-regexp account
|
||||
(rx (group (and (not (any blank ?\[ ?\( ?: ?\;)) (*? nonl))))
|
||||
"")
|
||||
|
||||
(defun ledger-regex-xact-line-actual-date
|
||||
(&optional string)
|
||||
(match-string ledger-regex-xact-line-group-actual-date string))
|
||||
(ledger-define-regexp account-kind
|
||||
(rx (group (? (any ?\[ ?\())))
|
||||
"")
|
||||
|
||||
(defconst ledger-regex-account
|
||||
(rx (group (and (not (any ?:)) (*? nonl)))))
|
||||
|
||||
(defconst ledger-regex-full-account
|
||||
(ledger-define-regexp full-account
|
||||
(macroexpand
|
||||
`(rx (and (group (? (any ?\[ ?\))))
|
||||
(regexp ,ledger-regex-account)
|
||||
(? (any ?\] ?\)))))))
|
||||
`(rx (and (regexp ,ledger-account-kind-regexp)
|
||||
(regexp ,ledger-account-regexp)
|
||||
(? (any ?\] ?\))))))
|
||||
""
|
||||
(kind account-kind)
|
||||
(name account))
|
||||
|
||||
(defconst ledger-regex-commodity
|
||||
(rx (or (and ?\" (+ (not (any ?\"))) ?\")
|
||||
(not (any space ?\n
|
||||
digit
|
||||
?- ?\[ ?\]
|
||||
?. ?, ?\; ?+ ?* ?/ ?^ ?? ?: ?& ?| ?! ?=
|
||||
?\< ?\> ?\{ ?\} ?\( ?\) ?@)))))
|
||||
(ledger-define-regexp commodity
|
||||
(rx (group
|
||||
(or (and ?\" (+ (not (any ?\"))) ?\")
|
||||
(not (any blank ?\n
|
||||
digit
|
||||
?- ?\[ ?\]
|
||||
?. ?, ?\; ?+ ?* ?/ ?^ ?? ?: ?& ?| ?! ?=
|
||||
?\< ?\> ?\{ ?\} ?\( ?\) ?@)))))
|
||||
"")
|
||||
|
||||
(defconst ledger-regex-amount
|
||||
(rx (and (? ?-)
|
||||
(and (+ digit)
|
||||
(*? (and (any ?. ?,) (+ digit))))
|
||||
(? (and (any ?. ?,) (+ digit))))))
|
||||
(ledger-define-regexp amount
|
||||
(rx (group
|
||||
(and (? ?-)
|
||||
(and (+ digit)
|
||||
(*? (and (any ?. ?,) (+ digit))))
|
||||
(? (and (any ?. ?,) (+ digit))))))
|
||||
"")
|
||||
|
||||
(defconst ledger-regex-commoditized-amount
|
||||
(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))))))
|
||||
`(rx (group
|
||||
(or (and (regexp ,ledger-commodity-regexp)
|
||||
(*? blank)
|
||||
(regexp ,ledger-amount-regexp))
|
||||
(and (regexp ,ledger-amount-regexp)
|
||||
(*? blank)
|
||||
(regexp ,ledger-commodity-regexp))))))
|
||||
"")
|
||||
|
||||
(defconst ledger-regex-commodity-annotations
|
||||
(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)
|
||||
|
|
|
|||
66
lisp/ldg-register.el
Normal file
66
lisp/ldg-register.el
Normal file
|
|
@ -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)
|
||||
448
lisp/ldg-report.el
Normal file
448
lisp/ldg-report.el
Normal file
|
|
@ -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))))
|
||||
189
lisp/ldg-state.el
Normal file
189
lisp/ldg-state.el
Normal file
|
|
@ -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)
|
||||
20
lisp/ldg-xact.el
Normal file
20
lisp/ldg-xact.el
Normal file
|
|
@ -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))))))
|
||||
|
||||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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':
|
||||
|
|
|
|||
|
|
@ -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':
|
||||
|
|
|
|||
|
|
@ -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()) {
|
||||
|
|
|
|||
20
src/expr.cc
20
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)
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
52
src/op.cc
52
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;
|
||||
|
|
|
|||
1
src/op.h
1
src/op.h
|
|
@ -105,6 +105,7 @@ public:
|
|||
O_DEFINE,
|
||||
O_LOOKUP,
|
||||
O_CALL,
|
||||
O_EXPAND,
|
||||
O_MATCH,
|
||||
|
||||
BINARY_OPERATORS,
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
||||
|
|
|
|||
48
src/post.cc
48
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':
|
||||
|
|
|
|||
12
src/print.cc
12
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()) -
|
||||
|
|
|
|||
|
|
@ -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':
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
11
src/scope.h
11
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();
|
||||
}
|
||||
|
|
|
|||
31
src/value.cc
31
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;
|
||||
|
|
|
|||
29
src/value.h
29
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
|
||||
|
|
@ -722,6 +729,22 @@ public:
|
|||
storage->data = val;
|
||||
}
|
||||
|
||||
/**
|
||||
* 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
|
||||
|
|
@ -908,6 +931,8 @@ public:
|
|||
return _("a sequence");
|
||||
case SCOPE:
|
||||
return _("a scope");
|
||||
case EXPR:
|
||||
return _("a expr");
|
||||
default:
|
||||
assert(false);
|
||||
break;
|
||||
|
|
|
|||
38
src/xact.cc
38
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>);
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue