From 63ba45dbaab04722cd59bf610ae77b8334ca213d Mon Sep 17 00:00:00 2001 From: Craig Earls Date: Tue, 2 Jul 2013 15:37:33 -0700 Subject: Finished changing name to ledger-* All files and references changed ldg-* to ledger-* --- lisp/ldg-commodities.el | 147 -------------- lisp/ldg-complete.el | 257 ------------------------ lisp/ldg-context.el | 211 -------------------- lisp/ldg-exec.el | 101 ---------- lisp/ldg-fonts.el | 138 ------------- lisp/ldg-init.el | 68 ------- lisp/ldg-mode.el | 298 ---------------------------- lisp/ldg-occur.el | 192 ------------------ lisp/ldg-post.el | 249 ----------------------- lisp/ldg-reconcile.el | 485 --------------------------------------------- lisp/ldg-regex.el | 335 ------------------------------- lisp/ldg-report.el | 419 --------------------------------------- lisp/ldg-schedule.el | 330 ------------------------------ lisp/ldg-sort.el | 126 ------------ lisp/ldg-state.el | 244 ----------------------- lisp/ldg-test.el | 127 ------------ lisp/ldg-texi.el | 172 ---------------- lisp/ldg-xact.el | 200 ------------------- lisp/ledger-commodities.el | 147 ++++++++++++++ lisp/ledger-complete.el | 257 ++++++++++++++++++++++++ lisp/ledger-context.el | 211 ++++++++++++++++++++ lisp/ledger-exec.el | 101 ++++++++++ lisp/ledger-fonts.el | 138 +++++++++++++ lisp/ledger-init.el | 68 +++++++ lisp/ledger-mode.el | 298 ++++++++++++++++++++++++++++ lisp/ledger-occur.el | 192 ++++++++++++++++++ lisp/ledger-post.el | 249 +++++++++++++++++++++++ lisp/ledger-reconcile.el | 485 +++++++++++++++++++++++++++++++++++++++++++++ lisp/ledger-regex.el | 335 +++++++++++++++++++++++++++++++ lisp/ledger-report.el | 419 +++++++++++++++++++++++++++++++++++++++ lisp/ledger-schedule.el | 330 ++++++++++++++++++++++++++++++ lisp/ledger-sort.el | 126 ++++++++++++ lisp/ledger-state.el | 244 +++++++++++++++++++++++ lisp/ledger-test.el | 127 ++++++++++++ lisp/ledger-texi.el | 172 ++++++++++++++++ lisp/ledger-xact.el | 200 +++++++++++++++++++ 36 files changed, 4099 insertions(+), 4099 deletions(-) delete mode 100644 lisp/ldg-commodities.el delete mode 100644 lisp/ldg-complete.el delete mode 100644 lisp/ldg-context.el delete mode 100644 lisp/ldg-exec.el delete mode 100644 lisp/ldg-fonts.el delete mode 100644 lisp/ldg-init.el delete mode 100644 lisp/ldg-mode.el delete mode 100644 lisp/ldg-occur.el delete mode 100644 lisp/ldg-post.el delete mode 100644 lisp/ldg-reconcile.el delete mode 100644 lisp/ldg-regex.el delete mode 100644 lisp/ldg-report.el delete mode 100644 lisp/ldg-schedule.el delete mode 100644 lisp/ldg-sort.el delete mode 100644 lisp/ldg-state.el delete mode 100644 lisp/ldg-test.el delete mode 100644 lisp/ldg-texi.el delete mode 100644 lisp/ldg-xact.el create mode 100644 lisp/ledger-commodities.el create mode 100644 lisp/ledger-complete.el create mode 100644 lisp/ledger-context.el create mode 100644 lisp/ledger-exec.el create mode 100644 lisp/ledger-fonts.el create mode 100644 lisp/ledger-init.el create mode 100644 lisp/ledger-mode.el create mode 100644 lisp/ledger-occur.el create mode 100644 lisp/ledger-post.el create mode 100644 lisp/ledger-reconcile.el create mode 100644 lisp/ledger-regex.el create mode 100644 lisp/ledger-report.el create mode 100644 lisp/ledger-schedule.el create mode 100644 lisp/ledger-sort.el create mode 100644 lisp/ledger-state.el create mode 100644 lisp/ledger-test.el create mode 100644 lisp/ledger-texi.el create mode 100644 lisp/ledger-xact.el (limited to 'lisp') diff --git a/lisp/ldg-commodities.el b/lisp/ldg-commodities.el deleted file mode 100644 index a7f58f40..00000000 --- a/lisp/ldg-commodities.el +++ /dev/null @@ -1,147 +0,0 @@ -;;; ldg-commodities.el --- Helper code for use with the "ledger" command-line tool - -;; Copyright (C) 2003-2013 John Wiegley (johnw AT gnu DOT org) - -;; 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: -;; Helper functions to deal with commoditized numbers. A commoditized -;; number will be a list of value and string where the string contains -;; the commodity - -;;; Code: - -(require 'ldg-regex) - -(defcustom ledger-reconcile-default-commodity "$" - "The default commodity for use in target calculations in ledger reconcile." - :type 'string - :group 'ledger-reconcile) - -(defcustom ledger-scale 10000 - "The 10 ^ maximum number of digits you would expect to appear in your reports. -This is a cheap way of getting around floating point silliness in subtraction") - -(defun ledger-split-commodity-string (str) - "Split a commoditized string, STR, into two parts. -Returns a list with (value commodity)." - (let ((number-regex (if (assoc "decimal-comma" ledger-environment-alist) - ledger-amount-decimal-comma-regex - ledger-amount-decimal-period-regex))) - (if (> (length str) 0) - (with-temp-buffer - (insert str) - (goto-char (point-min)) - (cond - ((re-search-forward "\"\\(.*\\)\"" nil t) ; look for quoted commodities - (let ((com (delete-and-extract-region - (match-beginning 1) - (match-end 1)))) - (if (re-search-forward - number-regex nil t) - (list - (ledger-string-to-number - (delete-and-extract-region (match-beginning 0) (match-end 0))) - com)))) - ((re-search-forward number-regex nil t) - ;; found a number in the current locale, return it in the - ;; car. Anything left over is annotation, the first - ;; thing should be the commodity, separated by - ;; whitespace, return it in the cdr. I can't think of - ;; any counterexamples - (list - (ledger-string-to-number - (delete-and-extract-region (match-beginning 0) (match-end 0))) - (nth 0 (split-string (buffer-substring-no-properties (point-min) (point-max)))))) - ((re-search-forward "0" nil t) - ;; couldn't find a decimal number, look for a single 0, - ;; indicating account with zero balance - (list 0 ledger-reconcile-default-commodity)))) - ;; nothing found, return 0 - (list 0 ledger-reconcile-default-commodity)))) - -(defun ledger-string-balance-to-commoditized-amount (str) - "Return a commoditized amount (val, 'comm') from STR." - ; break any balances with multi commodities into a list - (mapcar #'(lambda (st) - (ledger-split-commodity-string st)) - (split-string str "[\n\r]"))) - -(defun -commodity (c1 c2) - "Subtract C2 from C1, ensuring their commodities match." - (if (string= (cadr c1) (cadr c2)) - ; the scaling below is to get around inexact subtraction results where, for example - ; 1.23 - 4.56 = -3.3299999999999996 instead of -3.33 - (list (/ (- (* ledger-scale (car c1)) (* ledger-scale (car c2))) ledger-scale) (cadr c1)) - (error "Can't subtract different commodities %S from %S" c2 c1))) - -(defun +commodity (c1 c2) - "Add C1 and C2, ensuring their commodities match." - (if (string= (cadr c1) (cadr c2)) - (list (+ (car c1) (car c2)) (cadr c1)) - (error "Can't add different commodities, %S to %S" c1 c2))) - -(defun ledger-strip (str char) - (let (new-str) - (concat (dolist (ch (append str nil) new-str) - (unless (= ch char) - (setq new-str (append new-str (list ch)))))))) - -(defun ledger-string-to-number (str &optional decimal-comma) - "improve builtin string-to-number by handling internationalization, and return nil if number can't be parsed" - (let ((nstr (if (or decimal-comma - (assoc "decimal-comma" ledger-environment-alist)) - (ledger-strip str ?.) - (ledger-strip str ?,)))) - (while (string-match "," nstr) ;if there is a comma now, it is a thousands separator - (setq nstr (replace-match "." nil nil nstr))) - (string-to-number nstr))) - -(defun ledger-number-to-string (n &optional decimal-comma) - (let ((str (number-to-string n))) - (if (or decimal-comma - (assoc "decimal-comma" ledger-environment-alist)) - (while (string-match "\\." str) - (setq str (replace-match "," nil nil str))) - str))) - -(defun ledger-commodity-to-string (c1) - "Return string representing C1. -Single character commodities are placed ahead of the value, -longer ones are after the value." - (let ((str (ledger-number-to-string (car c1))) - (commodity (cadr c1))) - (if (> (length commodity) 1) - (concat str " " commodity) - (concat commodity " " str)))) - -(defun ledger-read-commodity-string (prompt) - (let ((str (read-from-minibuffer - (concat prompt " (" ledger-reconcile-default-commodity "): "))) - comm) - (if (and (> (length str) 0) - (ledger-split-commodity-string str)) - (progn - (setq comm (ledger-split-commodity-string str)) - (if (cadr comm) - comm - (list (car comm) ledger-reconcile-default-commodity)))))) - -(provide 'ldg-commodities) - -;;; ldg-commodities.el ends here diff --git a/lisp/ldg-complete.el b/lisp/ldg-complete.el deleted file mode 100644 index 1bc7588c..00000000 --- a/lisp/ldg-complete.el +++ /dev/null @@ -1,257 +0,0 @@ -;;; ldg-complete.el --- Helper code for use with the "ledger" command-line tool - -;; Copyright (C) 2003-2013 John Wiegley (johnw AT gnu DOT org) - -;; 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: -;; Functions providing payee and account auto complete. - -(require 'pcomplete) - -;; In-place completion support - -;;; Code: - -(defun ledger-parse-arguments () - "Parse whitespace separated arguments in the current region." - ;; this is more complex than it appears to need, so that it can work - ;; with pcomplete. See pcomplete-parse-arguments-function for - ;; details - (let* ((begin (save-excursion - (ledger-thing-at-point) ;; leave point at beginning of thing under point - (point))) - (end (point)) - begins args) - ;; to support end of line metadata - (save-excursion - (when (search-backward ";" - (line-beginning-position) t) - (setq begin (match-beginning 0)))) - (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-payees-in-buffer () - "Scan buffer and return list of all payees." - (let ((origin (point)) - payees-list) - (save-excursion - (goto-char (point-min)) - (while (re-search-forward - ledger-payee-any-status-regex nil t) ;; matches first line - (unless (and (>= origin (match-beginning 0)) - (< origin (match-end 0))) - (setq payees-list (cons (match-string-no-properties 3) - payees-list))))) ;; add the payee - ;; to the list - (pcomplete-uniqify-list (nreverse payees-list)))) - - -(defun ledger-find-accounts-in-buffer () - (interactive) - (let ((origin (point)) - accounts - (account-tree (list t)) - (account-elements nil) - (seed-regex (ledger-account-any-status-with-seed-regex - (regexp-quote (car pcomplete-args))))) - (save-excursion - (goto-char (point-min)) - - (dolist (account - (delete-dups - (progn - (while (re-search-forward seed-regex nil t) - (unless (between origin (match-beginning 0) (match-end 0)) - (setq accounts (cons (match-string-no-properties 2) accounts)))) - accounts))) - (let ((root account-tree)) - (setq account-elements - (split-string - account ":")) - (while account-elements - (let ((xact (assoc (car account-elements) root))) - (if xact - (setq root (cdr xact)) - (setq xact (cons (car account-elements) (list t))) - (nconc root (list xact)) - (setq root (cdr xact)))) - (setq account-elements (cdr account-elements)))))) - account-tree)) - -(defun ledger-find-metadata-in-buffer () - "Search through buffer and build list of metadata. -Return list." - (let ((origin (point)) accounts) - (save-excursion - (setq ledger-account-tree (list t)) - (goto-char (point-min)) - (while (re-search-forward - ledger-metadata-regex - nil t) - (unless (and (>= origin (match-beginning 0)) - (< origin (match-end 0))) - (setq accounts (cons (match-string-no-properties 2) accounts))))) - accounts)) - -(defun ledger-accounts () - "Return a tree of all accounts in the buffer." - (let* ((current (caar (ledger-parse-arguments))) - (elements (and current (split-string current ":"))) - (root (ledger-find-accounts-in-buffer)) - (prefix nil)) - (while (cdr elements) - (let ((xact (assoc (car elements) root))) - (if xact - (setq prefix (concat prefix (and prefix ":") - (car elements)) - root (cdr xact)) - (setq root nil elements nil))) - (setq elements (cdr elements))) - (setq root (delete (list (car elements) t) root)) - (and root - (sort - (mapcar (function - (lambda (x) - (let ((term (if prefix - (concat prefix ":" (car x)) - (car x)))) - (if (> (length (cdr x)) 1) - (concat term ":") - term)))) - (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)) 'transaction) - (if (null current-prefix-arg) - (delete - (caar (ledger-parse-arguments)) - (ledger-payees-in-buffer)) ;; this completes against payee names - (progn - (let ((text (buffer-substring-no-properties - (line-beginning-position) - (line-end-position)))) - (delete-region (line-beginning-position) - (line-end-position)) - (condition-case nil - (ledger-add-transaction text t) - (error nil))) - (forward-line) - (goto-char (line-end-position)) - (search-backward ";" (line-beginning-position) t) - (skip-chars-backward " \t0123456789.,") - (throw 'pcompleted t))) - (ledger-accounts))))) - -(defun ledger-fully-complete-xact () - "Completes a transaction if there is another matching payee in the buffer. -Does not use ledger xact" - (interactive) - (let* ((name (caar (ledger-parse-arguments))) - (rest-of-name name) - xacts) - (save-excursion - (when (eq 'transaction (ledger-thing-at-point)) - (delete-region (point) (+ (length name) (point))) - ;; Search backward for a matching payee - (when (re-search-backward - (concat "^[0-9/.=-]+\\(\\s-+\\*\\)?\\(\\s-+(.*?)\\)?\\s-+\\(.*" - (regexp-quote name) ".*\\)" ) nil t) - (setq rest-of-name (match-string 3)) - ;; Start copying the postings - (forward-line) - (while (looking-at ledger-account-any-status-regex) - (setq xacts (cons (buffer-substring-no-properties - (line-beginning-position) - (line-end-position)) - xacts)) - (forward-line)) - (setq xacts (nreverse xacts))))) - ;; Insert rest-of-name and the postings - (when xacts - (save-excursion - (insert rest-of-name ?\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)))))) - - -(defun ledger-pcomplete (&optional interactively) - "Complete rip-off of pcomplete from pcomplete.el, only added -ledger-magic-tab in the previous commands list so that -ledger-magic-tab would cycle properly" - (interactive "p") - (if (and interactively - pcomplete-cycle-completions - pcomplete-current-completions - (memq last-command '(ledger-magic-tab - ledger-pcomplete - pcomplete-expand-and-complete - pcomplete-reverse))) - (progn - (delete-backward-char pcomplete-last-completion-length) - (if (eq this-command 'pcomplete-reverse) - (progn - (push (car (last pcomplete-current-completions)) - pcomplete-current-completions) - (setcdr (last pcomplete-current-completions 2) nil)) - (nconc pcomplete-current-completions - (list (car pcomplete-current-completions))) - (setq pcomplete-current-completions - (cdr pcomplete-current-completions))) - (pcomplete-insert-entry pcomplete-last-completion-stub - (car pcomplete-current-completions) - nil pcomplete-last-completion-raw)) - (setq pcomplete-current-completions nil - pcomplete-last-completion-raw nil) - (catch 'pcompleted - (let* ((pcomplete-stub) - pcomplete-seen pcomplete-norm-func - pcomplete-args pcomplete-last pcomplete-index - (pcomplete-autolist pcomplete-autolist) - (pcomplete-suffix-list pcomplete-suffix-list) - (completions (pcomplete-completions)) - (result (pcomplete-do-complete pcomplete-stub completions))) - (and result - (not (eq (car result) 'listed)) - (cdr result) - (pcomplete-insert-entry pcomplete-stub (cdr result) - (memq (car result) - '(sole shortest)) - pcomplete-last-completion-raw)))))) - -(provide 'ldg-complete) - -;;; ldg-complete.el ends here diff --git a/lisp/ldg-context.el b/lisp/ldg-context.el deleted file mode 100644 index b0e35115..00000000 --- a/lisp/ldg-context.el +++ /dev/null @@ -1,211 +0,0 @@ -;;; ldg-context.el --- Helper code for use with the "ledger" command-line tool - -;; Copyright (C) 2003-2013 John Wiegley (johnw AT gnu DOT org) - -;; 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: -;; Provide facilities for reflection in ledger buffers - -;;; Code: - -(eval-when-compile - (require 'cl)) - -;; *-string constants are assembled in the single-line-config macro to -;; form the regex and list of elements -(defconst indent-string "\\(^[ \t]+\\)") -(defconst status-string "\\([*! ]?\\)") -(defconst account-string "[\\[(]?\\(.*?\\)[])]?") -(defconst amount-string "[ \t]?\\(-?[0-9]+\\.[0-9]*\\)") -(defconst comment-string "[ \t]*;[ \t]*\\(.*?\\)") -(defconst nil-string "\\([ \t]+\\)") -(defconst commodity-string "\\(.+?\\)") -(defconst date-string "^\\([0-9]\\{4\\}[/-][01]?[0-9][/-][0123]?[0-9]\\)") -(defconst code-string "\\((.*)\\)?") -(defconst payee-string "\\(.*\\)") - -(defmacro line-regex (&rest elements) - (let (regex-string) - (concat (dolist (e elements regex-string) - (setq regex-string - (concat regex-string - (eval - (intern - (concat (symbol-name e) "-string")))))) "[ \t]*$"))) - -(defmacro single-line-config2 (&rest elements) -"Take list of ELEMENTS and return regex and element list for use in context-at-point" - (let (regex-string) - `'(,(concat (dolist (e elements regex-string) - (setq regex-string - (concat regex-string - (eval - (intern - (concat (symbol-name e) "-string")))))) "[ \t]*$") - ,elements))) - -(defmacro single-line-config (&rest elements) - "Take list of ELEMENTS and return regex and element list for use in context-at-point" - `'(,(eval `(line-regex ,@elements)) - ,elements)) - -(defconst ledger-line-config - (list (list 'xact (list (single-line-config date nil status nil code nil payee nil comment) - (single-line-config date nil status nil code nil payee) - (single-line-config date nil status nil payee))) - (list 'acct-transaction (list (single-line-config indent comment) - (single-line-config2 indent status account nil commodity amount nil comment) - (single-line-config2 indent status account nil commodity amount) - (single-line-config2 indent status account nil amount nil commodity comment) - (single-line-config2 indent status account nil amount nil commodity) - (single-line-config2 indent status account nil amount) - (single-line-config2 indent status account nil comment) - (single-line-config2 indent status account))))) - -(defun ledger-extract-context-info (line-type pos) - "Get context info for current line with LINE-TYPE. - -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-thing-at-point () - "Describe thing at points. Return 'transaction, 'posting, or nil. -Leave point at the beginning of the thing under point" - (let ((here (point))) - (goto-char (line-beginning-position)) - (cond ((looking-at "^[0-9/.=-]+\\(\\s-+\\*\\)?\\(\\s-+(.+?)\\)?\\s-+") - (goto-char (match-end 0)) - 'transaction) - ((looking-at "^\\s-+\\([*!]\\s-+\\)?[[(]?\\(.\\)") - (goto-char (match-beginning 2)) - 'posting) - ((looking-at "^\\(sun\\|mon\\|tue\\|wed\\|thu\\|fri\\|sat\\)\\s-+") - (goto-char (match-end 0)) - 'day) - (t - (ignore (goto-char here)))))) - -(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 -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 'xact pos)) - ((equal first-char ?\=) - '(automated-xact nil nil)) - ((equal first-char ?\~) - '(period-xact 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 from 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))) - -(provide 'ldg-context) - -;;; ldg-report.el ends here diff --git a/lisp/ldg-exec.el b/lisp/ldg-exec.el deleted file mode 100644 index f6c3bb54..00000000 --- a/lisp/ldg-exec.el +++ /dev/null @@ -1,101 +0,0 @@ -;;; ldg-exec.el --- Helper code for use with the "ledger" command-line tool - -;; Copyright (C) 2003-2013 John Wiegley (johnw AT gnu DOT org) - -;; 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: -;; Code for executing ledger synchronously. - -;;; Code: - -(defconst ledger-version-needed "3.0.0" - "The version of ledger executable needed for interactive features.") - -(defvar ledger-works nil - "Flag showing whether the ledger binary can support `ledger-mode' interactive features.") - -(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-exec) - -(defun ledger-exec-handle-error (ledger-output) - "Deal with ledger errors contained in LEDGER-OUTPUT." - (with-current-buffer (get-buffer-create "*Ledger Error*") - (insert-buffer-substring ledger-output) - (view-mode) - (setq buffer-read-only t))) - -(defun ledger-exec-success-p (ledger-output-buffer) - (with-current-buffer ledger-output-buffer - (goto-char (point-min)) - (if (and (> (buffer-size) 1) (looking-at (regexp-quote "While"))) - nil ;; failure, there is an error starting with "While" - ledger-output-buffer))) - -(defun ledger-exec-ledger (input-buffer &optional output-buffer &rest args) - "Run Ledger using INPUT-BUFFER and optionally capturing output in OUTPUT-BUFFER with ARGS." - (if (null ledger-binary-path) - (error "The variable `ledger-binary-path' has not been set") - (let ((buf (or input-buffer (current-buffer))) - (outbuf (or output-buffer - (generate-new-buffer " *ledger-tmp*")))) - (with-current-buffer buf - (let ((coding-system-for-write 'utf-8) - (coding-system-for-read 'utf-8)) - (apply #'call-process-region - (append (list (point-min) (point-max) - ledger-binary-path nil outbuf nil "-f" "-") - args))) - (if (ledger-exec-success-p outbuf) - outbuf - (ledger-exec-handle-error outbuf)))))) - -(defun ledger-version-greater-p (needed) - "Verify the ledger binary is usable for `ledger-mode' (version greater than NEEDED)." - (let ((buffer ledger-buf) - (version-strings '())) - (with-temp-buffer - (when (ledger-exec-ledger (current-buffer) (current-buffer) "--version") - (goto-char (point-min)) - (delete-horizontal-space) - (setq version-strings (split-string - (buffer-substring-no-properties (point) - (point-max)))) - (if (and (string-match (regexp-quote "Ledger") (car version-strings)) - (or (string= needed (cadr version-strings)) - (string< needed (cadr version-strings)))) - t ;; success - nil))))) ;;failure - -(defun ledger-check-version () - "Verify that ledger works and is modern enough." - (interactive) - (if (setq ledger-works (ledger-version-greater-p ledger-version-needed)) - (message "Good Ledger Version") - (message "Bad Ledger Version"))) - -(provide 'ldg-exec) - -;;; ldg-exec.el ends here diff --git a/lisp/ldg-fonts.el b/lisp/ldg-fonts.el deleted file mode 100644 index ab0a3317..00000000 --- a/lisp/ldg-fonts.el +++ /dev/null @@ -1,138 +0,0 @@ -;;; ldg-fonts.el --- Helper code for use with the "ledger" command-line tool - -;; Copyright (C) 2003-2013 John Wiegley (johnw AT gnu DOT org) - -;; 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: -;; All of the faces for ledger mode are defined here. - -;;; Code: - -(require 'ldg-regex) - -(defgroup ledger-faces nil "Ledger mode highlighting" :group 'ledger) -(defface ledger-font-payee-uncleared-face - `((t :foreground "#dc322f" :weight bold )) - "Default face for Ledger" - :group 'ledger-faces) - -(defface ledger-font-payee-cleared-face - `((t :foreground "#657b83" :weight normal )) - "Default face for cleared (*) transactions" - :group 'ledger-faces) - -(defface ledger-font-xact-highlight-face - `((t :background "#eee8d5")) - "Default face for transaction under point" - :group 'ledger-faces) - -(defface ledger-font-pending-face - `((t :foreground "#cb4b16" :weight normal )) - "Default face for pending (!) transactions" - :group 'ledger-faces) - -(defface ledger-font-other-face - `((t :foreground "#657b83" )) - "Default face for other transactions" - :group 'ledger-faces) - -(defface ledger-font-posting-account-face - `((t :foreground "#268bd2" )) - "Face for Ledger accounts" - :group 'ledger-faces) - -(defface ledger-font-posting-account-cleared-face - `((t :foreground "#657b83" )) - "Face for Ledger accounts" - :group 'ledger-faces) - -(defface ledger-font-posting-account-pending-face - `((t :foreground "#cb4b16" )) - "Face for Ledger accounts" - :group 'ledger-faces) - -(defface ledger-font-posting-amount-face - `((t :foreground "#cb4b16" )) - "Face for Ledger amounts" - :group 'ledger-faces) - -(defface ledger-occur-narrowed-face - `((t :foreground "grey70" :invisible t )) - "Default face for Ledger occur mode hidden transactions" - :group 'ledger-faces) - -(defface ledger-occur-xact-face - `((t :background "#eee8d5" )) - "Default face for Ledger occur mode shown transactions" - :group 'ledger-faces) - -(defface ledger-font-comment-face - `((t :foreground "#93a1a1" :slant italic)) - "Face for Ledger comments" - :group 'ledger-faces) - -(defface ledger-font-reconciler-uncleared-face - `((t :foreground "#dc322f" :weight bold )) - "Default face for uncleared transactions in the reconcile window" - :group 'ledger-faces) - -(defface ledger-font-reconciler-cleared-face - `((t :foreground "#657b83" :weight normal )) - "Default face for cleared (*) transactions in the reconcile window" - :group 'ledger-faces) - -(defface ledger-font-reconciler-pending-face - `((t :foreground "#cb4b16" :weight normal )) - "Default face for pending (!) transactions in the reconcile window" - :group 'ledger-faces) - -(defface ledger-font-report-clickable-face - `((t :foreground "#cb4b16" :weight normal )) - "Default face for pending (!) transactions in the reconcile window" - :group 'ledger-faces) - - -(defvar ledger-font-lock-keywords - `( ;; (,ledger-other-entries-regex 1 - ;; ledger-font-other-face) - (,ledger-comment-regex 0 - 'ledger-font-comment-face) - (,ledger-multiline-comment-regex 0 'ledger-font-comment-face) - (,ledger-payee-pending-regex 2 - 'ledger-font-payee-pending-face) ; Works - (,ledger-payee-cleared-regex 2 - 'ledger-font-payee-cleared-face) ; Works - (,ledger-payee-uncleared-regex 2 - 'ledger-font-payee-uncleared-face) ; Works - (,ledger-account-cleared-regex 2 - 'ledger-font-posting-account-cleared-face) ; Works - (,ledger-account-pending-regex 2 - 'ledger-font-posting-account-pending-face) ; Works - (,ledger-account-any-status-regex 2 - 'ledger-font-posting-account-face) ; Works - (,ledger-other-entries-regex 1 - 'ledger-font-other-face)) - "Expressions to highlight in Ledger mode.") - - -(provide 'ldg-fonts) - -;;; ldg-fonts.el ends here diff --git a/lisp/ldg-init.el b/lisp/ldg-init.el deleted file mode 100644 index f283c77c..00000000 --- a/lisp/ldg-init.el +++ /dev/null @@ -1,68 +0,0 @@ -;;; ldg-init.el --- Helper code for use with the "ledger" command-line tool - -;; Copyright (C) 2003-2013 John Wiegley (johnw AT gnu DOT org) - -;; 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: -;; Determine the ledger environment - -(require 'ldg-regex) - -(defcustom ledger-init-file-name "~/.ledgerrc" - "Location of the ledger initialization file. nil if you don't have one" - :group 'ledger-exec) - -(defvar ledger-environment-alist nil) - -(defun ledger-init-parse-initialization (buffer) - (with-current-buffer buffer - (let (environment-alist) - (goto-char (point-min)) - (while (re-search-forward ledger-init-string-regex nil t ) - (let ((matchb (match-beginning 0)) ;; save the match data, string-match stamp on it - (matche (match-end 0))) - (end-of-line) - (setq environment-alist - (append environment-alist - (list (cons (let ((flag (buffer-substring-no-properties (+ 2 matchb) matche))) - (if (string-match "[ \t\n\r]+\\'" flag) - (replace-match "" t t flag) - flag)) - (let ((value (buffer-substring-no-properties matche (point) ))) - (if (> (length value) 0) - value - t)))))))) - environment-alist))) - -(defun ledger-init-load-init-file () - (interactive) - (let ((init-base-name (file-name-nondirectory ledger-init-file-name))) - (if (get-buffer init-base-name) ;; init file already loaded, parse it and leave it - (ledger-init-parse-initialization init-base-name) - (when (and ledger-init-file-name - (file-exists-p ledger-init-file-name) - (file-readable-p ledger-init-file-name)) - (find-file-noselect ledger-init-file-name) - (setq ledger-environment-alist - (ledger-init-parse-initialization init-base-name)) - (kill-buffer init-base-name))))) - -(provide 'ldg-init) - -;;; ldg-init.el ends here diff --git a/lisp/ldg-mode.el b/lisp/ldg-mode.el deleted file mode 100644 index 9e5e85e9..00000000 --- a/lisp/ldg-mode.el +++ /dev/null @@ -1,298 +0,0 @@ -;;; ldg-mode.el --- Helper code for use with the "ledger" command-line tool - -;; Copyright (C) 2003-2013 John Wiegley (johnw AT gnu DOT org) - -;; 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: -;; Most of the general ledger-mode code is here. - -;;; Code: - -(require 'ldg-regex) -(require 'esh-util) -(require 'esh-arg) -(require 'ldg-commodities) -(require 'ldg-complete) -(require 'ldg-context) -(require 'ldg-exec) -(require 'ldg-fonts) -(require 'ldg-init) -(require 'ldg-occur) -(require 'ldg-post) -(require 'ldg-reconcile) -(require 'ldg-report) -(require 'ldg-sort) -(require 'ldg-state) -(require 'ldg-test) -(require 'ldg-texi) -(require 'ldg-xact) -(require 'ldg-schedule) - -;;; Code: - -(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.") - -(defconst ledger-mode-version "3.0.0") - -(defun ledger-mode-dump-variable (var) - (if var - (insert (format " %s: %S\n" (symbol-name var) (eval var))))) - -(defun ledger-mode-dump-group (group) - "Dump GROUP customizations to current buffer" - (let ((members (custom-group-members group nil))) - (dolist (member members) - (cond ((eq (cadr member) 'custom-group) - (insert (format "Group %s:\n" (symbol-name (car member)))) - (ledger-mode-dump-group (car member))) - ((eq (cadr member) 'custom-variable) - (ledger-mode-dump-variable (car member))))))) - -(defun ledger-mode-dump-configuration () - "Dump all customizations" - (find-file "ledger-mode-dump") - (ledger-mode-dump-group 'ledger)) - - -(defsubst ledger-current-year () - "The default current year for adding transactions." - (format-time-string "%Y")) -(defsubst ledger-current-month () - "The default current month for adding transactions." - (format-time-string "%m")) - -(defvar ledger-year (ledger-current-year) - "Start a ledger session with the current year, but make it customizable to ease retro-entry.") - -(defvar ledger-month (ledger-current-month) - "Start a ledger session with the current month, but make it customizable to ease retro-entry.") - -(defun ledger-read-account-with-prompt (prompt) - (let* ((context (ledger-context-at-point)) - (default (if (and (eq (ledger-context-line-type context) 'acct-transaction) - (eq (ledger-context-current-field context) 'account)) - (regexp-quote (ledger-context-field-value context 'account)) - nil))) - (ledger-read-string-with-default prompt default))) - -(defun ledger-read-string-with-default (prompt default) - "Return user supplied string after PROMPT, or DEFAULT." - (read-string (concat prompt - (if default - (concat " (" default "): ") - ": ")) - nil 'ledger-minibuffer-history default)) - -(defun ledger-display-balance-at-point () - "Display the cleared-or-pending balance. -And calculate the target-delta of the account being reconciled." - (interactive) - (let* ((account (ledger-read-account-with-prompt "Account balance to show")) - (buffer (current-buffer)) - (balance (with-temp-buffer - (ledger-exec-ledger buffer (current-buffer) "cleared" account) - (if (> (buffer-size) 0) - (buffer-substring-no-properties (point-min) (1- (point-max))) - (concat account " is empty."))))) - (when balance - (message balance)))) - -(defun ledger-display-ledger-stats () - "Display the cleared-or-pending balance. -And calculate the target-delta of the account being reconciled." - (interactive) - (let* ((buffer (current-buffer)) - (balance (with-temp-buffer - (ledger-exec-ledger buffer (current-buffer) "stats") - (buffer-substring-no-properties (point-min) (1- (point-max)))))) - (when balance - (message balance)))) - -(defun ledger-magic-tab (&optional interactively) - "Decide what to with with . -Can indent, complete or align depending on context." - (interactive "p") - (if (= (point) (line-beginning-position)) - (indent-to ledger-post-account-alignment-column) - (if (and (> (point) 1) - (looking-back "\\([^ \t]\\)" 1)) - (ledger-pcomplete interactively) - (ledger-post-align-postings)))) - -(defvar ledger-mode-abbrev-table) - -(defun ledger-insert-effective-date () - (interactive) - (let ((context (car (ledger-context-at-point))) - (date-string (format-time-string (cdr (assoc "date-format" ledger-environment-alist))))) - (cond ((eq 'xact context) - (beginning-of-line) - (insert date-string "=")) - ((eq 'acct-transaction context) - (end-of-line) - (insert " ; [=" date-string "]"))))) - -(defun ledger-mode-remove-extra-lines () - (goto-char (point-min)) - (while (re-search-forward "\n\n\\(\n\\)+" nil t) - (replace-match "\n\n"))) - -(defun ledger-mode-clean-buffer () - "indent, remove multiple linfe feeds and sort the buffer" - (interactive) - (ledger-sort-buffer) - (ledger-post-align-postings (point-min) (point-max)) - (ledger-mode-remove-extra-lines)) - - -;;;###autoload -(define-derived-mode ledger-mode text-mode "Ledger" - "A mode for editing ledger data files." - (ledger-check-version) - (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))) - (setq font-lock-extend-region-functions - (list #'font-lock-extend-region-wholelines)) - (setq font-lock-multiline nil) - - (set (make-local-variable 'pcomplete-parse-arguments-function) - 'ledger-parse-arguments) - (set (make-local-variable 'pcomplete-command-completion-function) - 'ledger-complete-at-point) - (set (make-local-variable 'pcomplete-termination-string) "") - - (add-hook 'post-command-hook 'ledger-highlight-xact-under-point nil t) - (add-hook 'before-revert-hook 'ledger-occur-remove-all-overlays nil t) - (make-variable-buffer-local 'highlight-overlay) - - (ledger-init-load-init-file) - - (set (make-local-variable 'indent-region-function) 'ledger-post-align-postings) - - (let ((map (current-local-map))) - (define-key map [(control ?c) (control ?a)] 'ledger-add-transaction) - (define-key map [(control ?c) (control ?b)] 'ledger-post-edit-amount) - (define-key map [(control ?c) (control ?c)] 'ledger-toggle-current) - (define-key map [(control ?c) (control ?d)] 'ledger-delete-current-transaction) - (define-key map [(control ?c) (control ?e)] 'ledger-toggle-current-transaction) - (define-key map [(control ?c) (control ?f)] 'ledger-occur) - (define-key map [(control ?c) (control ?k)] 'ledger-copy-transaction-at-point) - (define-key map [(control ?c) (control ?m)] 'ledger-set-month) - (define-key map [(control ?c) (control ?r)] 'ledger-reconcile) - (define-key map [(control ?c) (control ?s)] 'ledger-sort-region) - (define-key map [(control ?c) (control ?t)] 'ledger-insert-effective-date) - (define-key map [(control ?c) (control ?u)] 'ledger-schedule-upcoming) - (define-key map [(control ?c) (control ?y)] 'ledger-set-year) - (define-key map [(control ?c) (control ?p)] 'ledger-display-balance-at-point) - (define-key map [(control ?c) (control ?l)] 'ledger-display-ledger-stats) - (define-key map [(control ?c) (control ?q)] 'ledger-post-align-xact) - - (define-key map [tab] 'ledger-magic-tab) - (define-key map [(control tab)] 'ledger-post-align-xact) - (define-key map [(control ?i)] 'ledger-magic-tab) - (define-key map [(control ?c) tab] 'ledger-fully-complete-xact) - (define-key map [(control ?c) (control ?i)] 'ledger-fully-complete-xact) - - (define-key map [(control ?c) (control ?o) (control ?a)] 'ledger-report-redo) - (define-key map [(control ?c) (control ?o) (control ?e)] 'ledger-report-edit) - (define-key map [(control ?c) (control ?o) (control ?g)] 'ledger-report-goto) - (define-key map [(control ?c) (control ?o) (control ?k)] 'ledger-report-kill) - (define-key map [(control ?c) (control ?o) (control ?r)] 'ledger-report) - (define-key map [(control ?c) (control ?o) (control ?s)] 'ledger-report-save) - - (define-key map [(meta ?p)] 'ledger-post-prev-xact) - (define-key map [(meta ?n)] 'ledger-post-next-xact) - - (define-key map [menu-bar] (make-sparse-keymap "ldg-menu")) - (define-key map [menu-bar ldg-menu] (cons "Ledger" map)) - - (define-key map [report-kill] '(menu-item "Kill Report" ledger-report-kill :enable ledger-works)) - (define-key map [report-edit] '(menu-item "Edit Report" ledger-report-edit :enable ledger-works)) - (define-key map [report-save] '(menu-item "Save Report" ledger-report-save :enable ledger-works)) - (define-key map [report-rrun] '(menu-item "Re-run Report" ledger-report-redo :enable ledger-works)) - (define-key map [report-goto] '(menu-item "Goto Report" ledger-report-goto :enable ledger-works)) - (define-key map [report-run] '(menu-item "Run Report" ledger-report :enable ledger-works)) - (define-key map [sep5] '(menu-item "--")) - (define-key map [set-month] '(menu-item "Set Month" ledger-set-month :enable ledger-works)) - (define-key map [set-year] '(menu-item "Set Year" ledger-set-year :enable ledger-works)) - (define-key map [cust] '(menu-item "Customize Ledger Mode" (lambda () - (interactive) - (customize-group 'ledger)))) - (define-key map [sep1] '("--")) - (define-key map [effective-date] '(menu-item "Set effective date" ledger-insert-effective-date)) - (define-key map [sort-end] '(menu-item "Mark Sort End" ledger-sort-insert-end-mark)) - (define-key map [sort-start] '(menu-item "Mark Sort Beginning" ledger-sort-insert-start-mark)) - (define-key map [sort-buff] '(menu-item "Sort Buffer" ledger-sort-buffer)) - (define-key map [sort-reg] '(menu-item "Sort Region" ledger-sort-region :enable mark-active)) - (define-key map [align-xact] '(menu-item "Align Xact" ledger-post-align-xact)) - (define-key map [align-reg] '(menu-item "Align Region" ledger-post-align-postings :enable mark-active)) - (define-key map [clean-buf] '(menu-item "Clean-up Buffer" ledger-mode-clean-buffer)) - (define-key map [sep2] '(menu-item "--")) - (define-key map [copy-xact] '(menu-item "Copy Trans at Point" ledger-copy-transaction-at-point)) - (define-key map [toggle-post] '(menu-item "Toggle Current Posting" ledger-toggle-current)) - (define-key map [toggle-xact] '(menu-item "Toggle Current Transaction" ledger-toggle-current-transaction)) - (define-key map [sep4] '(menu-item "--")) - (define-key map [recon-account] '(menu-item "Reconcile Account" ledger-reconcile :enable ledger-works)) - (define-key map [check-balance] '(menu-item "Check Balance" ledger-display-balance-at-point :enable ledger-works)) - (define-key map [sep6] '(menu-item "--")) - (define-key map [edit-amount] '(menu-item "Calc on Amount" ledger-post-edit-amount)) - (define-key map [sep] '(menu-item "--")) - (define-key map [delete-xact] '(menu-item "Delete Transaction" ledger-delete-current-transaction)) - (define-key map [cmp-xact] '(menu-item "Complete Transaction" ledger-fully-complete-xact)) - (define-key map [add-xact] '(menu-item "Add Transaction (ledger xact)" ledger-add-transaction :enable ledger-works)) - (define-key map [sep3] '(menu-item "--")) - (define-key map [stats] '(menu-item "Ledger Statistics" ledger-display-ledger-stats :enable ledger-works)) - (define-key map [fold-buffer] '(menu-item "Narrow to REGEX" ledger-occur)))) - - - - -(defun ledger-set-year (newyear) - "Set ledger's idea of the current year to the prefix argument NEWYEAR." - (interactive "p") - (if (= newyear 1) - (setq ledger-year (read-string "Year: " (ledger-current-year))) - (setq ledger-year (number-to-string newyear)))) - -(defun ledger-set-month (newmonth) - "Set ledger's idea of the current month to the prefix argument NEWMONTH." - (interactive "p") - (if (= newmonth 1) - (setq ledger-month (read-string "Month: " (ledger-current-month))) - (setq ledger-month (format "%02d" newmonth)))) - - - -(provide 'ledger) - -;;; ldg-mode.el ends here diff --git a/lisp/ldg-occur.el b/lisp/ldg-occur.el deleted file mode 100644 index 451ad1a7..00000000 --- a/lisp/ldg-occur.el +++ /dev/null @@ -1,192 +0,0 @@ -;;; ldg-mode.el --- Helper code for use with the "ledger" command-line tool - -;; Copyright (C) 2003-2013 John Wiegley (johnw AT gnu DOT org) - -;; 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: -;; Provide buffer narrowing to ledger mode. Adapted from original loccur -;; mode by Alexey Veretennikov -;; -;; Adapted to ledger mode by Craig Earls - -;;; Code: - -(defconst ledger-occur-overlay-property-name 'ledger-occur-custom-buffer-grep) - -(defcustom ledger-occur-use-face-shown t - "If non-nil, use a custom face for xacts shown in `ledger-occur' mode using ledger-occur-xact-face." - :type 'boolean - :group 'ledger) -(make-variable-buffer-local 'ledger-occur-use-face-shown) - - -(defvar ledger-occur-mode nil - "name of the minor mode, shown in the mode-line") - -(make-variable-buffer-local 'ledger-occur-mode) - -(or (assq 'ledger-occur-mode minor-mode-alist) - (nconc minor-mode-alist - (list '(ledger-occur-mode ledger-occur-mode)))) - -(defvar ledger-occur-history nil - "History of previously searched expressions for the prompt.") - -(defvar ledger-occur-last-match nil - "Last match found.") -(make-variable-buffer-local 'ledger-occur-last-match) - -(defun ledger-occur-remove-all-overlays () - "Remove all overlays from the ledger buffer." - (interactive) - (remove-overlays)) - -(defun ledger-occur-mode (regex buffer) - "Highlight transactions that match REGEX in BUFFER, hiding others. - -When REGEX is nil, unhide everything, and remove higlight" - (set-buffer buffer) - (setq ledger-occur-mode - (if (or (null regex) - (zerop (length regex))) - nil - (concat " Ledger-Narrowed: " regex))) - (force-mode-line-update) - (ledger-occur-remove-overlays) - (when ledger-occur-mode - (ledger-occur-create-overlays - (ledger-occur-compress-matches - (ledger-occur-find-matches regex))) - (setq ledger-occur-last-match regex) - (if (get-buffer-window buffer) - (select-window (get-buffer-window buffer)))) - (recenter)) - -(defun ledger-occur (regex) - "Perform a simple grep in current buffer for the regular expression REGEX. - - This command hides all xact from the current buffer except - those containing the regular expression REGEX. A second call - of the function unhides lines again" - (interactive - (if ledger-occur-mode - (list nil) - (list (read-string (concat "Regexp<" (ledger-occur-prompt) ">: ") - nil 'ledger-occur-history (ledger-occur-prompt))))) - (ledger-occur-mode regex (current-buffer))) - -(defun ledger-occur-prompt () - "Return the default value of the prompt. - - Default value for prompt is a current word or active - region(selection), if its size is 1 line" - (let ((prompt - (if (and transient-mark-mode - mark-active) - (let ((pos1 (region-beginning)) - (pos2 (region-end))) - ;; Check if the start and the of an active region is on - ;; the same line - (if (= (line-number-at-pos pos1) - (line-number-at-pos pos2)) - (buffer-substring-no-properties pos1 pos2))) - (current-word)))) - prompt)) - - -(defun ledger-occur-make-visible-overlay (beg end) - (let ((ovl (make-overlay beg end (current-buffer)))) - (overlay-put ovl ledger-occur-overlay-property-name t) - (overlay-put ovl 'face 'ledger-occur-xact-face))) - -(defun ledger-occur-make-invisible-overlay (beg end) - (let ((ovl (make-overlay beg end (current-buffer)))) - (overlay-put ovl ledger-occur-overlay-property-name t) - (overlay-put ovl 'invisible t))) - -(defun ledger-occur-create-overlays (ovl-bounds) - "Create the overlays for the visible transactions. -Argument OVL-BOUNDS contains bounds for the transactions to be left visible." - (let* ((beg (caar ovl-bounds)) - (end (cadar ovl-bounds))) - (ledger-occur-make-invisible-overlay (point-min) (1- beg)) - (dolist (visible (cdr ovl-bounds)) - (ledger-occur-make-visible-overlay beg end) - (ledger-occur-make-invisible-overlay (1+ end) (1- (car visible))) - (setq beg (car visible)) - (setq end (cadr visible))) - (ledger-occur-make-invisible-overlay (1+ end) (point-max)))) - -(defun ledger-occur-quit-buffer (buffer) - "Quits hidings transaction in the given BUFFER. -Used for coordinating `ledger-occur' with other buffers, like reconcile." - (set-buffer buffer) - (setq ledger-occur-mode nil) - (force-mode-line-update) - (ledger-occur-remove-overlays) - (recenter)) - -(defun ledger-occur-remove-overlays () - "Remove the transaction hiding overlays." - (interactive) - (remove-overlays (point-min) - (point-max) ledger-occur-overlay-property-name t) - (setq ledger-occur-overlay-list nil)) - -(defun ledger-occur-find-matches (regex) - "Return a list of 2-number tuples describing the beginning and end of transactions meeting REGEX." - (save-excursion - (goto-char (point-min)) - ;; Set initial values for variables - (let (curpoint - endpoint - (lines (list))) - ;; Search loop - (while (not (eobp)) - (setq curpoint (point)) - ;; if something found - (when (setq endpoint (re-search-forward regex nil 'end)) - (save-excursion - (let ((bounds (ledger-find-xact-extents (match-beginning 0)))) - (push bounds lines) - (setq curpoint (cadr bounds)))) ;; move to the end of - ;; the xact, no need to - ;; search inside it more - (goto-char curpoint)) - (forward-line 1)) - (setq lines (nreverse lines))))) - -(defun ledger-occur-compress-matches (buffer-matches) - "identify sequential xacts to reduce number of overlays required" - (let ((points (list)) - (current-beginning (caar buffer-matches)) - (current-end (cadar buffer-matches))) - (dolist (match (cdr buffer-matches)) - (if (< (- (car match) current-end) 2) - (setq current-end (cadr match)) - (push (list current-beginning current-end) points) - (setq current-beginning (car match)) - (setq current-end (cadr match)))) - (nreverse (push (list current-beginning current-end) points)))) - -(provide 'ldg-occur) - -;;; ldg-occur.el ends here diff --git a/lisp/ldg-post.el b/lisp/ldg-post.el deleted file mode 100644 index 693b9e0e..00000000 --- a/lisp/ldg-post.el +++ /dev/null @@ -1,249 +0,0 @@ -;;; ldg-post.el --- Helper code for use with the "ledger" command-line tool - -;; Copyright (C) 2003-2013 John Wiegley (johnw AT gnu DOT org) - -;; 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: -;; Utility functions for dealing with postings. - -(require 'ldg-regex) - -;;; Code: - -(defgroup ledger-post nil - "Options for controlling how Ledger-mode deals with postings and completion" - :group 'ledger) - -(defcustom ledger-post-account-alignment-column 4 - "The column Ledger-mode attempts to align accounts to." - :type 'integer - :group 'ledger-post) - -(defcustom ledger-post-amount-alignment-column 52 - "The column Ledger-mode attempts to align amounts to." - :type 'integer - :group 'ledger-post) - -(defcustom ledger-post-use-completion-engine :built-in - "Which completion engine to use, :iswitchb or :ido chose those engines, -:built-in uses built-in Ledger-mode completion" - :type '(radio (const :tag "built in completion" :built-in) - (const :tag "ido completion" :ido) - (const :tag "iswitchb completion" :iswitchb) ) - :group 'ledger-post) - -(defun ledger-post-all-accounts () - "Return a list of all accounts in the buffer." - (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) - -(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." - (cond ((eq ledger-post-use-completion-engine :iswitchb) - (let* ((iswitchb-use-virtual-buffers nil) - (iswitchb-make-buflist-hook - (lambda () - (setq iswitchb-temp-buflist choices)))) - (iswitchb-read-buffer prompt))) - ((eq ledger-post-use-completion-engine :ido) - (ido-completing-read prompt choices)) - (t - (completing-read prompt choices)))) - -(defvar ledger-post-current-list nil) - -(defun ledger-post-pick-account () - "Insert an account entered by the user." - (interactive) - (let* ((account - (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-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) - (insert (make-string (- existing-len account-len) ? ))) - ((< existing-len account-len) - (dotimes (n (- account-len existing-len)) - (if (looking-at "[ \t]\\( [ \t]\\|\t\\)") - (delete-char 1))))))) - (goto-char pos))) - - - -(defsubst ledger-next-amount (&optional end) - "Move point to the next amount, as long as it is not past END. -Return the width of the amount field as an integer and leave -point at beginning of the commodity." - ;;(beginning-of-line) - (when (re-search-forward ledger-amount-regex end t) - (goto-char (match-beginning 0)) - (skip-syntax-forward " ") - (- (or (match-end 4) - (match-end 3)) (point)))) - - -(defun ledger-next-account (&optional end) - "Move point to the beginning of the next account, or status marker (!*), as long as it is not past END. -Return the column of the beginning of the account and leave point -at beginning of account" - (if (> end (point)) - (when (re-search-forward ledger-account-any-status-regex (1+ end) t) - ;; the 1+ is to make sure we can catch the newline - (if (match-beginning 1) - (goto-char (match-beginning 1)) - (goto-char (match-beginning 2))) - (current-column)))) - -(defun ledger-post-align-xact (pos) - (interactive "d") - (let ((bounds (ledger-find-xact-extents pos))) - (ledger-post-align-postings (car bounds) (cadr bounds)))) - -(defun ledger-post-align-postings (&optional beg end) - "Align all accounts and amounts within region, if there is no -region align the posting on the current line." - (interactive) - (assert (eq major-mode 'ledger-mode)) - - (save-excursion - (if (or (not (mark)) - (not (use-region-p))) - (set-mark (point))) - - (let* ((inhibit-modification-hooks t) - (mark-first (< (mark) (point))) - (begin-region (if beg - beg - (if mark-first (mark) (point)))) - (end-region (if end - end - (if mark-first (point) (mark)))) - acct-start-column acct-end-column acct-adjust amt-width - (lines-left 1)) - ;; Condition point and mark to the beginning and end of lines - (goto-char end-region) - (setq end-region (line-end-position)) - (goto-char begin-region) - (goto-char - (setq begin-region - (line-beginning-position))) - - ;; This is the guts of the alignment loop - (while (and (or (setq acct-start-column (ledger-next-account (line-end-position))) - lines-left) - (< (point) end-region)) - (when acct-start-column - (setq acct-end-column (save-excursion - (goto-char (match-end 2)) - (current-column))) - (when (/= (setq acct-adjust (- ledger-post-account-alignment-column acct-start-column)) 0) - (setq acct-end-column (+ acct-end-column acct-adjust)) ;;adjust the account ending column - (if (> acct-adjust 0) - (insert (make-string acct-adjust ? )) - (delete-char acct-adjust))) - (when (setq amt-width (ledger-next-amount (line-end-position))) - (if (/= 0 (setq amt-adjust (- (if (> (- ledger-post-amount-alignment-column amt-width) - (+ 2 acct-end-column)) - ledger-post-amount-alignment-column ;;we have room - (+ acct-end-column 2 amt-width)) - amt-width - (current-column)))) - (if (> amt-adjust 0) - (insert (make-string amt-adjust ? )) - (delete-char amt-adjust))))) - (forward-line) - (setq lines-left (not (eobp)))) - (setq inhibit-modification-hooks nil)))) - - - -(defun ledger-post-edit-amount () - "Call 'calc-mode' and push the amount in the posting to the top of stack." - (interactive) - (goto-char (line-beginning-position)) - (when (re-search-forward ledger-post-line-regexp (line-end-position) t) - (goto-char (match-end ledger-regex-post-line-group-account)) ;; go to the and of the account - (let ((end-of-amount (re-search-forward "[-.,0-9]+" (line-end-position) t))) - ;; determine if there is an amount to edit - (if end-of-amount - (let ((val (ledger-string-to-number (match-string 0)))) - (goto-char (match-beginning 0)) - (delete-region (match-beginning 0) (match-end 0)) - (calc) - (calc-eval val 'push)) ;; edit the amount - (progn ;;make sure there are two spaces after the account name and go to calc - (if (search-backward " " (- (point) 3) t) - (goto-char (line-end-position)) - (insert " ")) - (calc)))))) - -(defun ledger-post-prev-xact () - "Move point to the previous transaction." - (interactive) - (backward-paragraph) - (when (re-search-backward ledger-xact-line-regexp nil t) - (goto-char (match-beginning 0)) - (re-search-forward ledger-post-line-regexp) - (goto-char (match-end ledger-regex-post-line-group-account)))) - -(defun ledger-post-next-xact () - "Move point to the next transaction." - (interactive) - (when (re-search-forward ledger-xact-line-regexp nil t) - (goto-char (match-beginning 0)) - (re-search-forward ledger-post-line-regexp) - (goto-char (match-end ledger-regex-post-line-group-account)))) - -(defun ledger-post-setup () - "Configure `ledger-mode' to auto-align postings." - (add-hook 'after-save-hook #'(lambda () (setq ledger-post-current-list nil)) t t)) - - - -(provide 'ldg-post) - - - -;;; ldg-post.el ends here diff --git a/lisp/ldg-reconcile.el b/lisp/ldg-reconcile.el deleted file mode 100644 index ae5142b7..00000000 --- a/lisp/ldg-reconcile.el +++ /dev/null @@ -1,485 +0,0 @@ -;;; ldg-reconcile.el --- Helper code for use with the "ledger" command-line tool - -;; Copyright (C) 2003-2013 John Wiegley (johnw AT gnu DOT org) - -;; 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. - -;; Reconcile mode - - -;;; Commentary: -;; Code to handle reconciling Ledger files wiht outside sources - -;;; Code: - -(defvar ledger-buf nil) -(defvar ledger-bufs nil) -(defvar ledger-acct nil) -(defvar ledger-target nil) - -(defgroup ledger-reconcile nil - "Options for Ledger-mode reconciliation" - :group 'ledger) - -(defcustom ledger-recon-buffer-name "*Reconcile*" - "Name to use for reconciliation window." - :group 'ledger-reconcile) - -(defcustom ledger-narrow-on-reconcile t - "If t, limit transactions shown in main buffer to those matching the reconcile regex." - :type 'boolean - :group 'ledger-reconcile) - -(defcustom ledger-buffer-tracks-reconcile-buffer t - "If t, then when the cursor is moved to a new xact in the recon window. -Then that transaction will be shown in its source buffer." - :type 'boolean - :group 'ledger-reconcile) - -(defcustom ledger-reconcile-force-window-bottom nil - "If t make the reconcile window appear along the bottom of the register window and resize." - :type 'boolean - :group 'ledger-reconcile) - -(defcustom ledger-reconcile-toggle-to-pending t - "If true then toggle between uncleared and pending. -reconcile-finish will mark all pending posting cleared." - :type 'boolean - :group 'ledger-reconcile) - -(defcustom ledger-reconcile-default-date-format "%Y/%m/%d" - "Default date format for the reconcile buffer" - :type 'string - :group 'ledger-reconcile) - -(defcustom ledger-reconcile-target-prompt-string "Target amount for reconciliation " - "Default prompt for recon target prompt" - :type 'string - :group 'ledger-reconcile) - -(defvar ledger-reconcile-sort-key "(date)" - "Default key for sorting reconcile buffer") - -(defun ledger-reconcile-get-cleared-or-pending-balance (buffer account) - "Calculate the cleared or pending balance of the account." - - ;; these vars are buffer local, need to hold them for use in the - ;; temp buffer below - - (with-temp-buffer - ;; note that in the line below, the --format option is - ;; separated from the actual format string. emacs does not - ;; split arguments like the shell does, so you need to - ;; specify the individual fields in the command line. - (if (ledger-exec-ledger buffer (current-buffer) - "balance" "--limit" "cleared or pending" "--empty" "--collapse" - "--format" "%(display_total)" account) - (ledger-split-commodity-string - (buffer-substring-no-properties (point-min) (point-max)))))) - -(defun ledger-display-balance () - "Display the cleared-or-pending balance. -And calculate the target-delta of the account being reconciled." - (interactive) - (let* ((pending (ledger-reconcile-get-cleared-or-pending-balance ledger-buf ledger-acct))) - (when pending - (if ledger-target - (message "Pending balance: %s, Difference from target: %s" - (ledger-commodity-to-string pending) - (ledger-commodity-to-string (-commodity ledger-target pending))) - (message "Pending balance: %s" - (ledger-commodity-to-string pending)))))) - -(defun is-stdin (file) - "True if ledger FILE is standard input." - (or - (equal file "") - (equal file "") - (equal file "/dev/stdin"))) - -(defun ledger-reconcile-get-buffer (where) - "Return a buffer from WHERE the transaction is." - (if (bufferp (car where)) - (car where) - (error "Function ledger-reconcile-get-buffer: Buffer not set"))) - -(defun ledger-reconcile-toggle () - "Toggle the current transaction, and mark the recon window." - (interactive) - (beginning-of-line) - (let ((where (get-text-property (point) 'where)) - (inhibit-read-only t) - status) - (when (ledger-reconcile-get-buffer where) - (with-current-buffer (ledger-reconcile-get-buffer where) - (ledger-goto-line (cdr where)) - (forward-char) - (setq status (ledger-toggle-current (if ledger-reconcile-toggle-to-pending - 'pending - 'cleared)))) - ;; remove the existing face and add the new face - (remove-text-properties (line-beginning-position) - (line-end-position) - (list 'face)) - (cond ((eq status 'pending) - (add-text-properties (line-beginning-position) - (line-end-position) - (list 'face 'ledger-font-reconciler-pending-face ))) - ((eq status 'cleared) - (add-text-properties (line-beginning-position) - (line-end-position) - (list 'face 'ledger-font-reconciler-cleared-face ))) - (t - (add-text-properties (line-beginning-position) - (line-end-position) - (list 'face 'ledger-font-reconciler-uncleared-face ))))) - (forward-line) - (beginning-of-line) - (ledger-display-balance))) - -(defun ledger-reconcile-refresh () - "Force the reconciliation window to refresh. -Return the number of uncleared xacts found." - (interactive) - (let ((inhibit-read-only t)) - (erase-buffer) - (prog1 - (ledger-do-reconcile ledger-reconcile-sort-key) - (set-buffer-modified-p t)))) - -(defun ledger-reconcile-refresh-after-save () - "Refresh the recon-window after the ledger buffer is saved." - (let ((curbuf (current-buffer)) - (curpoint (point)) - (recon-buf (get-buffer ledger-recon-buffer-name))) - (when (buffer-live-p recon-buf) - (with-current-buffer recon-buf - (ledger-reconcile-refresh) - (set-buffer-modified-p nil)) - (select-window (get-buffer-window curbuf)) - (goto-char curpoint)))) - -(defun ledger-reconcile-add () - "Use ledger xact to add a new transaction." - (interactive) - (with-current-buffer ledger-buf - (call-interactively #'ledger-add-transaction)) - (ledger-reconcile-refresh)) - -(defun ledger-reconcile-delete () - "Delete the transactions pointed to in the recon window." - (interactive) - (let ((where (get-text-property (point) 'where))) - (when (ledger-reconcile-get-buffer where) - (with-current-buffer (ledger-reconcile-get-buffer where) - (ledger-goto-line (cdr where)) - (ledger-delete-current-transaction)) - (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 (&optional come-back) - "Recenter ledger buffer on transaction and COME-BACK if non-nil." - (interactive) - (progn - (beginning-of-line) - (let* ((where (get-text-property (1+ (point)) 'where)) - (target-buffer (if where - (ledger-reconcile-get-buffer where) - nil)) - (cur-win (get-buffer-window (get-buffer ledger-recon-buffer-name)))) - (when target-buffer - (switch-to-buffer-other-window target-buffer) - (ledger-goto-line (cdr where)) - (forward-char) - (recenter) - (ledger-highlight-xact-under-point) - (forward-char -1) - (if (and come-back cur-win) - (select-window cur-win)))))) - -(defun ledger-reconcile-save () - "Save the ledger buffer." - (interactive) - (let ((curpoint (point))) - (dolist (buf (cons ledger-buf ledger-bufs)) - (with-current-buffer buf - (save-buffer))) - (with-current-buffer (get-buffer ledger-recon-buffer-name) - (set-buffer-modified-p nil) - (ledger-display-balance) - (goto-char curpoint) - (ledger-reconcile-visit t)))) - -(defun ledger-reconcile-finish () - "Mark all pending posting or transactions as cleared. -Depends on ledger-reconcile-clear-whole-transactions, save the buffers -and exit reconcile mode" - (interactive) - (save-excursion - (goto-char (point-min)) - (while (not (eobp)) - (let ((where (get-text-property (point) 'where)) - (face (get-text-property (point) 'face))) - (if (eq face 'ledger-font-reconciler-pending-face) - (with-current-buffer (ledger-reconcile-get-buffer where) - (ledger-goto-line (cdr where)) - (ledger-toggle-current 'cleared)))) - (forward-line 1))) - (ledger-reconcile-save) - (ledger-reconcile-quit)) - - -(defun ledger-reconcile-quit () - "Quit the reconcile window without saving ledger buffer." - (interactive) - (let ((recon-buf (get-buffer ledger-recon-buffer-name)) - buf) - (if recon-buf - (with-current-buffer recon-buf - (ledger-reconcile-quit-cleanup) - (setq buf ledger-buf) - ;; Make sure you delete the window before you delete the buffer, - ;; otherwise, madness ensues - (delete-window (get-buffer-window recon-buf)) - (kill-buffer recon-buf) - (set-window-buffer (selected-window) buf))))) - -(defun ledger-reconcile-quit-cleanup () - "Cleanup all hooks established by reconcile mode." - (interactive) - (let ((buf ledger-buf)) - (if (buffer-live-p buf) - (with-current-buffer buf - (remove-hook 'after-save-hook 'ledger-reconcile-refresh-after-save t) - (when ledger-narrow-on-reconcile - (ledger-occur-quit-buffer buf) - (ledger-highlight-xact-under-point)))))) - -(defun ledger-marker-where-xact-is (emacs-xact posting) - "Find the position of the EMACS-XACT in the `ledger-buf'. -POSTING is used in `ledger-clear-whole-transactions' is nil." - (let ((buf (if (is-stdin (nth 0 emacs-xact)) - ledger-buf - (find-file-noselect (nth 0 emacs-xact))))) - (cons - buf - (if ledger-clear-whole-transactions - (nth 1 emacs-xact) ;; return line-no of xact - (nth 0 posting))))) ;; return line-no of posting - -(defun ledger-do-reconcile (&optional sort) - "Return the number of uncleared transactions in the account and display them in the *Reconcile* buffer." - (let* ((buf ledger-buf) - (account ledger-acct) - (ledger-success nil) - (sort-by (if sort - sort - "(date)")) - (xacts - (with-temp-buffer - (when (ledger-exec-ledger buf (current-buffer) - "--uncleared" "--real" "emacs" "--sort" sort-by account) - (setq ledger-success t) - (goto-char (point-min)) - (unless (eobp) - (if (looking-at "(") - (read (current-buffer)))))))) ;current-buffer is the *temp* created above - (if (and ledger-success (> (length xacts) 0)) - (let ((date-format (cdr (assoc "date-format" ledger-environment-alist)))) - (dolist (xact xacts) - (dolist (posting (nthcdr 5 xact)) - (let ((beg (point)) - (where (ledger-marker-where-xact-is xact posting))) - (insert (format "%s %-4s %-30s %-30s %15s\n" - (format-time-string (if date-format - date-format - ledger-reconcile-default-date-format) (nth 2 xact)) - (if (nth 3 xact) - (nth 3 xact) - "") - (nth 4 xact) (nth 1 posting) (nth 2 posting))) - (if (nth 3 posting) - (if (eq (nth 3 posting) 'pending) - (set-text-properties beg (1- (point)) - (list 'face 'ledger-font-reconciler-pending-face - 'where where)) - (set-text-properties beg (1- (point)) - (list 'face 'ledger-font-reconciler-cleared-face - 'where where))) - (set-text-properties beg (1- (point)) - (list 'face 'ledger-font-reconciler-uncleared-face - 'where where)))) )) - (goto-char (point-max)) - (delete-char -1)) ;gets rid of the extra line feed at the bottom of the list - (if ledger-success - (insert (concat "There are no uncleared entries for " account)) - (insert "Ledger has reported a problem. Check *Ledger Error* buffer."))) - (goto-char (point-min)) - (set-buffer-modified-p nil) - (toggle-read-only t) - - (ledger-reconcile-ensure-xacts-visible) - (length xacts))) - -(defun ledger-reconcile-ensure-xacts-visible () - "Ensures that the last of the visible transactions in the -ledger buffer is at the bottom of the main window. The key to -this is to ensure the window is selected when the buffer point is -moved and recentered. If they aren't strange things happen." - - (let ((recon-window (get-buffer-window (get-buffer ledger-recon-buffer-name)))) - (when recon-window - (fit-window-to-buffer recon-window) - (with-current-buffer buf - (add-hook 'kill-buffer-hook 'ledger-reconcile-quit nil t) - (if (get-buffer-window buf) - (select-window (get-buffer-window buf))) - (goto-char (point-max)) - (recenter -1)) - (select-window recon-window) - (ledger-reconcile-visit t)) - (add-hook 'post-command-hook 'ledger-reconcile-track-xact nil t))) - -(defun ledger-reconcile-track-xact () - "Force the ledger buffer to recenter on the transaction at point in the reconcile buffer." - (if (and ledger-buffer-tracks-reconcile-buffer - (member this-command (list 'next-line - 'previous-line - 'mouse-set-point - 'ledger-reconcile-toggle - 'end-of-buffer - 'beginning-of-buffer))) - (save-excursion - (ledger-reconcile-visit t)))) - -(defun ledger-reconcile-open-windows (buf rbuf) - "Ensure that the ledger buffer BUF is split by RBUF." - (if ledger-reconcile-force-window-bottom - ;;create the *Reconcile* window directly below the ledger buffer. - (set-window-buffer (split-window (get-buffer-window buf) nil nil) rbuf) - (pop-to-buffer rbuf))) - -(defun ledger-reconcile () - "Start reconciling, prompt for account." - (interactive) - (let ((account (ledger-read-account-with-prompt "Account to reconcile")) - (buf (current-buffer)) - (rbuf (get-buffer ledger-recon-buffer-name))) - - (add-hook 'after-save-hook 'ledger-reconcile-refresh-after-save nil t) - - (if rbuf ;; *Reconcile* already exists - (with-current-buffer rbuf - (set 'ledger-acct account) ;; already buffer local - (when (not (eq buf rbuf)) - ;; called from some other ledger-mode buffer - (ledger-reconcile-quit-cleanup) - (set 'ledger-buf buf)) ;; should already be buffer-local - - (unless (get-buffer-window rbuf) - (ledger-reconcile-open-windows buf rbuf))) - - ;; no recon-buffer, starting from scratch. - - (with-current-buffer (setq rbuf - (get-buffer-create ledger-recon-buffer-name)) - (ledger-reconcile-open-windows buf rbuf) - (ledger-reconcile-mode) - (make-local-variable 'ledger-target) - (set (make-local-variable 'ledger-buf) buf) - (set (make-local-variable 'ledger-acct) account))) - - ;; Narrow the ledger buffer - (with-current-buffer rbuf - (save-excursion - (if ledger-narrow-on-reconcile - (ledger-occur-mode account ledger-buf))) - (if (> (ledger-reconcile-refresh) 0) - (ledger-reconcile-change-target)) - (ledger-display-balance)))) - -(defvar ledger-reconcile-mode-abbrev-table) - -(defun ledger-reconcile-change-target () - "Change the target amount for the reconciliation process." - (interactive) - (setq ledger-target (ledger-read-commodity-string ledger-reconcile-target-prompt-string))) - -(defmacro ledger-reconcile-change-sort-key-and-refresh (sort-by) - `(lambda () - (interactive) - - (setq ledger-reconcile-sort-key ,sort-by) - (ledger-reconcile-refresh))) - -(define-derived-mode ledger-reconcile-mode text-mode "Reconcile" - "A mode for reconciling ledger entries." - (let ((map (make-sparse-keymap))) - (define-key map [(control ?m)] 'ledger-reconcile-visit) - (define-key map [return] 'ledger-reconcile-visit) - (define-key map [(control ?l)] 'ledger-reconcile-refresh) - (define-key map [(control ?c) (control ?c)] 'ledger-reconcile-finish) - (define-key map [? ] 'ledger-reconcile-toggle) - (define-key map [?a] 'ledger-reconcile-add) - (define-key map [?d] 'ledger-reconcile-delete) - (define-key map [?g] 'ledger-reconcile); - (define-key map [?n] 'next-line) - (define-key map [?p] 'previous-line) - (define-key map [?t] 'ledger-reconcile-change-target) - (define-key map [?s] 'ledger-reconcile-save) - (define-key map [?q] 'ledger-reconcile-quit) - (define-key map [?b] 'ledger-display-balance) - - (define-key map [(control ?c) (control ?a)] (ledger-reconcile-change-sort-key-and-refresh "(amount)")) - - (define-key map [(control ?c) (control ?d)] (ledger-reconcile-change-sort-key-and-refresh "(date)")) - - (define-key map [(control ?c) (control ?p)] (ledger-reconcile-change-sort-key-and-refresh "(payee)")) - - (define-key map [menu-bar] (make-sparse-keymap "ldg-recon-menu")) - (define-key map [menu-bar ldg-recon-menu] (cons "Reconcile" map)) - (define-key map [menu-bar ldg-recon-menu qui] '("Quit" . ledger-reconcile-quit)) - (define-key map [menu-bar ldg-recon-menu sep1] '("--")) - (define-key map [menu-bar ldg-recon-menu pre] '("Previous Entry" . previous-line)) - (define-key map [menu-bar ldg-recon-menu vis] '("Visit Source" . ledger-reconcile-visit)) - (define-key map [menu-bar ldg-recon-menu nex] '("Next Entry" . next-line)) - (define-key map [menu-bar ldg-recon-menu sep2] '("--")) - (define-key map [menu-bar ldg-recon-menu del] '("Delete Entry" . ledger-reconcile-delete)) - (define-key map [menu-bar ldg-recon-menu add] '("Add Entry" . ledger-reconcile-add)) - (define-key map [menu-bar ldg-recon-menu tog] '("Toggle Entry" . ledger-reconcile-toggle)) - (define-key map [menu-bar ldg-recon-menu sep3] '("--")) - (define-key map [menu-bar ldg-recon-menu sort-amt] `("Sort by amount" . ,(ledger-reconcile-change-sort-key-and-refresh "(amount)"))) - (define-key map [menu-bar ldg-recon-menu sort-pay] `("Sort by date" . ,(ledger-reconcile-change-sort-key-and-refresh "(date)"))) - (define-key map [menu-bar ldg-recon-menu sort-dat] `("Sort by payee" . ,(ledger-reconcile-change-sort-key-and-refresh "(payee)"))) - (define-key map [menu-bar ldg-recon-menu sep4] '("--")) - (define-key map [menu-bar ldg-recon-menu bal] '("Show Cleared Balance" . ledger-display-balance)) - (define-key map [menu-bar ldg-recon-menu tgt] '("Change Target Balance" . ledger-reconcile-change-target)) - (define-key map [menu-bar ldg-recon-menu sep5] '("--")) - (define-key map [menu-bar ldg-recon-menu rna] '("Reconcile New Account" . ledger-reconcile)) - (define-key map [menu-bar ldg-recon-menu sep6] '("--")) - (define-key map [menu-bar ldg-recon-menu fin] '("Finish" . ledger-reconcile-finish)) - (define-key map [menu-bar ldg-recon-menu ref] '("Refresh" . ledger-reconcile-refresh)) - (define-key map [menu-bar ldg-recon-menu sav] '("Save" . ledger-reconcile-save)) - - (use-local-map map))) - -(provide 'ldg-reconcile) - -;;; ldg-reconcile.el ends here diff --git a/lisp/ldg-regex.el b/lisp/ldg-regex.el deleted file mode 100644 index ab875579..00000000 --- a/lisp/ldg-regex.el +++ /dev/null @@ -1,335 +0,0 @@ -;;; ldg-regex.el --- Helper code for use with the "ledger" command-line tool - -;; Copyright (C) 2003-2013 John Wiegley (johnw AT gnu DOT org) - -;; 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. - -(require 'rx) - -(eval-when-compile - (require 'cl)) - -(defconst ledger-amount-regex - (concat "\\( \\|\t\\| \t\\)[ \t]*-?" - "\\([A-Z$€£_]+ *\\)?" - "\\(-?[0-9,]+?\\)" - "\\(.[0-9]+\\)?" - "\\( *[[:word:]€£_\"]+\\)?" - "\\([ \t]*[@={]@?[^\n;]+?\\)?" - "\\([ \t]+;.+?\\|[ \t]*\\)?$")) - -(defconst ledger-amount-decimal-comma-regex - "-?[1-9][0-9.]*[,]?[0-9]*") - -(defconst ledger-amount-decimal-period-regex - "-?[1-9][0-9,]*[.]?[0-9]*") - -(defconst ledger-other-entries-regex - "\\(^[~=A-Za-z].+\\)+") - -(defconst ledger-comment-regex - "^[;#|\\*%].*\\|[ \t]+;.*") - -(defconst ledger-multiline-comment-start-regex - "^!comment$") -(defconst ledger-multiline-comment-end-regex - "^!end_comment$") -(defconst ledger-multiline-comment-regex - "^!comment\n\\(.*\n\\)*?!end_comment$") - -(defconst ledger-payee-any-status-regex - "^[0-9]+[-/][-/.=0-9]+\\(\\s-+\\*\\)?\\(\\s-+(.*?)\\)?\\s-+\\(.+?\\)\\s-*\\(;\\|$\\)") - -(defconst ledger-payee-pending-regex - "^[0-9]+[-/][-/.=0-9]+\\s-\\!\\s-+\\(([^)]+)\\s-+\\)?\\([^*].+?\\)\\s-*\\(;\\|$\\)") - -(defconst ledger-payee-cleared-regex - "^[0-9]+[-/][-/.=0-9]+\\s-\\*\\s-+\\(([^)]+)\\s-+\\)?\\([^*].+?\\)\\s-*\\(;\\|$\\)") - -(defconst ledger-payee-uncleared-regex - "^[0-9]+[-/][-/.=0-9]+\\s-+\\(([^)]+)\\s-+\\)?\\([^*].+?\\)\\s-*\\(;\\|$\\)") - -(defconst ledger-init-string-regex - "^--.+?\\($\\|[ ]\\)") - -(defconst ledger-account-any-status-regex - "^[ \t]+\\([*!]\\s-+\\)?\\([[(]?.+?\\)\\(\t\\|\n\\| [ \t]\\)") - -(defun ledger-account-any-status-with-seed-regex (seed) - (concat "^[ \t]+\\([*!]\\s-+\\)?\\([[(]?" seed ".+?\\)\\(\t\\|\n\\| [ \t]\\)")) - -(defconst ledger-account-pending-regex - "\\(^[ \t]+\\)\\(!\\s-*.*?\\)\\( \\|\t\\|$\\)") - -(defconst ledger-account-cleared-regex - "\\(^[ \t]+\\)\\(*\\s-*.*?\\)\\( \\|\t\\|$\\)") - - -(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 iso-date - ( let ((sep '(or ?- ?/))) - (rx (group - (and (group (? (= 4 num))) - (eval sep) - (group (and num (? num))) - (eval sep) - (group (and num (? num))))))) - "Match a single date, in its 'written' form.") - -(ledger-define-regexp full-date - (macroexpand - `(rx (and (regexp ,ledger-iso-date-regexp) - (? (and ?= (regexp ,ledger-iso-date-regexp)))))) - "Match a compound date, of the form ACTUAL=EFFECTIVE" - (actual iso-date) - (effective iso-date)) - -(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)))) - "") - -(ledger-define-regexp full-note - (macroexpand - `(rx (and line-start (+ blank) - ?\; (regexp ,ledger-note-regexp)))) - "") - -(ledger-define-regexp xact-line - (macroexpand - `(rx (and line-start - (regexp ,ledger-full-date-regexp) - (? (and (+ blank) (regexp ,ledger-state-regexp))) - (? (and (+ blank) (regexp ,ledger-code-regexp))) - (+ blank) (+? nonl) - (? (regexp ,ledger-end-note-regexp)) - line-end))) - "Match a transaction's first line (and optional notes)." - (actual-date full-date actual) - (effective-date full-date effective) - state - code - (note end-note)) - -(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 (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 (group - (or (and (regexp ,ledger-commodity-regexp) - (*? blank) - (regexp ,ledger-amount-regexp)) - (and (regexp ,ledger-amount-regexp) - (*? blank) - (regexp ,ledger-commodity-regexp)))))) - "") - -(ledger-define-regexp commodity-annotations - (macroexpand - `(rx (* (+ blank) - (or (and ?\{ (regexp ,ledger-commoditized-amount-regexp) ?\}) - (and ?\[ (regexp ,ledger-iso-date-regexp) ?\]) - (and ?\( (not (any ?\))) ?\)))))) - "") - -(ledger-define-regexp cost - (macroexpand - `(rx (and (or "@" "@@") (+ blank) - (regexp ,ledger-commoditized-amount-regexp)))) - "") - -(ledger-define-regexp balance-assertion - (macroexpand - `(rx (and ?= (+ blank) - (regexp ,ledger-commoditized-amount-regexp)))) - "") - -(ledger-define-regexp full-amount - (macroexpand `(rx (group (+? (not (any ?\;)))))) - "") - -(ledger-define-regexp post-line - (macroexpand - `(rx (and line-start (+ blank) - (? (and (regexp ,ledger-state-regexp) (* blank))) - (regexp ,ledger-full-account-regexp) - (? (and (regexp ,ledger-long-space-regexp) - (regexp ,ledger-full-amount-regexp))) - (? (regexp ,ledger-end-note-regexp)) - line-end))) - "" - state - (account-kind full-account kind) - (account full-account name) - (amount full-amount) - (note end-note)) - -(defconst ledger-iterate-regex - (concat "\\(Y\\s-+\\([0-9]+\\)\\|" ;; Catches a Y directive - ledger-iso-date-regexp - "\\([ *!]+\\)" ;; mark - "\\((.*)\\)?" ;; code - "\\(.*\\)" ;; desc - "\\)")) - -(provide 'ldg-regex) diff --git a/lisp/ldg-report.el b/lisp/ldg-report.el deleted file mode 100644 index 9b16522f..00000000 --- a/lisp/ldg-report.el +++ /dev/null @@ -1,419 +0,0 @@ -;;; ldg-report.el --- Helper code for use with the "ledger" command-line tool - -;; Copyright (C) 2003-2013 John Wiegley (johnw AT gnu DOT org) - -;; 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: -;; Provide facilities for running and saving reports in emacs - -;;; Code: - -(eval-when-compile - (require 'cl)) - -(defgroup ledger-report nil - "Customization option for the Report buffer" - :group 'ledger) - -(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 '%()' where - 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-report) - -(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) - ("value" . ledger-report-value-format-specifier)) - "An 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-report) - -(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-saved nil) -(defvar ledger-minibuffer-history nil) -(defvar ledger-report-mode-abbrev-table) - -(defun ledger-report-reverse-lines () - (interactive) - (goto-char (point-min)) - (forward-paragraph) - (forward-line) - (save-excursion - (setq inhibit-read-only t) - (reverse-region (point) (point-max)))) - -(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 [(shift ?r)] 'ledger-report-reverse-lines) - (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) - (define-key map [return] 'ledger-report-visit-source) - - - (define-key map [menu-bar] (make-sparse-keymap "ldg-rep")) - (define-key map [menu-bar ldg-rep] (cons "Reports" map)) - - (define-key map [menu-bar ldg-rep lrq] '("Quit" . ledger-report-quit)) - (define-key map [menu-bar ldg-rep s2] '("--")) - (define-key map [menu-bar ldg-rep lrd] '("Scroll Down" . scroll-down)) - (define-key map [menu-bar ldg-rep vis] '("Visit Source" . ledger-report-visit-source)) - (define-key map [menu-bar ldg-rep lru] '("Scroll Up" . scroll-up)) - (define-key map [menu-bar ldg-rep s1] '("--")) - (define-key map [menu-bar ldg-rep rev] '("Reverse report order" . ledger-report-reverse-lines)) - (define-key map [menu-bar ldg-rep s0] '("--")) - (define-key map [menu-bar ldg-rep lrk] '("Kill Report" . ledger-report-kill)) - (define-key map [menu-bar ldg-rep lrr] '("Re-run Report" . ledger-report-redo)) - (define-key map [menu-bar ldg-rep lre] '("Edit Report" . ledger-report-edit)) - (define-key map [menu-bar ldg-rep lrs] '("Save Report" . ledger-report-save)) - - (use-local-map map))) - -(defun ledger-report-value-format-specifier () - "Return a valid meta-data tag name" - ;; It is intended completion should be available on existing account - ;; names, but it remains to be implemented. - (ledger-read-string-with-default "Value: " nil)) - -(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 REPORT-NAME of the report to run or -EDIT. 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-report-saved) nil) - (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 S 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 NAME and CMD 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 from REPORT-CMD." - (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 variable `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-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 xact, the payee for that xact is used as the - default." - ;; It is intended completion 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-xact-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 - posting line for an xact, 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. - (ledger-read-account-with-prompt "Account")) - -(defun ledger-report-expand-format-specifiers (report-cmd) - "Expand %(account) and %(payee) appearing in REPORT-CMD with thing under point." - (save-match-data - (let ((expanded-cmd report-cmd)) - (set-match-data (list 0 0)) - (while (string-match "%(\\([^)]*\\))" expanded-cmd (if (> (length expanded-cmd) (match-end 0)) - (match-end 0) - (1- (length expanded-cmd)))) - (let* ((specifier (match-string 1 expanded-cmd)) - (f (cdr (assoc specifier ledger-report-format-specifiers)))) - (if f - (setq expanded-cmd (replace-match - (save-match-data - (with-current-buffer ledger-buf - (shell-quote-argument (funcall f)))) - t t expanded-cmd))))) - expanded-cmd))) - -(defun ledger-report-cmd (report-name edit) - "Get the command line to run the report name REPORT-NAME. -Optional EDIT the command." - (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 ledger-report-saved nil)) ;; this is a new report, or edited report - (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) - (progn - (ledger-reports-add report-name report-cmd) - (ledger-reports-custom-save))) - report-cmd)) - -(defun ledger-do-report (cmd) - "Run a report command line CMD." - (goto-char (point-min)) - (insert (format "Report: %s\n" ledger-report-name) - (format "Command: %s\n" cmd) - (make-string (- (window-width) 1) ?=) - "\n\n") - (let ((data-pos (point)) - (register-report (string-match " reg\\(ister\\)? " cmd)) - files-in-report) - (shell-command - ;; --subtotal does not produce identifiable transactions, so don't - ;; prepend location information for them - (if (and register-report - (not (string-match "--subtotal" cmd))) - (concat cmd " --prepend-format='%(filename):%(beg_line):'") - cmd) - t nil) - (when register-report - (goto-char data-pos) - (while (re-search-forward "^\\(/[^:]+\\)?:\\([0-9]+\\)?:" nil t) - (let ((file (match-string 1)) - (line (string-to-number (match-string 2)))) - (delete-region (match-beginning 0) (match-end 0)) - (when file - (set-text-properties (line-beginning-position) (line-end-position) - (list 'ledger-source (cons file (save-window-excursion - (save-excursion - (find-file file) - (widen) - (ledger-goto-line line) - (point-marker)))))) - (add-text-properties (line-beginning-position) (line-end-position) - (list 'face 'ledger-font-report-clickable-face)) - (end-of-line))))) - (goto-char data-pos))) - - -(defun ledger-report-visit-source () - "Visit the transaction under point in the report window." - (interactive) - (let* ((prop (get-text-property (point) 'ledger-source)) - (file (if prop (car prop))) - (line-or-marker (if prop (cdr prop)))) - (when (and file line-or-marker) - (find-file-other-window file) - (widen) - (if (markerp line-or-marker) - (goto-char line-or-marker) - (goto-char (point-min)) - (forward-line (1- line-or-marker)) - (re-search-backward "^[0-9]+") - (beginning-of-line) - (let ((start-of-txn (point))) - (forward-paragraph) - (narrow-to-region start-of-txn (point)) - (backward-paragraph)))))) - -(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))) - - (if (setq existing-name (ledger-report-name-exists ledger-report-name)) - (cond ((y-or-n-p (format "Overwrite existing report named '%s'? " - ledger-report-name)) - (if (string-equal - ledger-report-cmd - (car (cdr (assq existing-name ledger-reports)))) - (message "Nothing to save. Current command is identical to existing saved one") - (progn - (setq ledger-reports - (assq-delete-all existing-name ledger-reports)) - (ledger-reports-add ledger-report-name ledger-report-cmd) - (ledger-reports-custom-save)))) - (t - (progn - (setq ledger-report-name (ledger-report-read-new-name)) - (ledger-reports-add ledger-report-name ledger-report-cmd) - (ledger-reports-custom-save))))))) - -(provide 'ldg-report) - -;;; ldg-report.el ends here diff --git a/lisp/ldg-schedule.el b/lisp/ldg-schedule.el deleted file mode 100644 index 885c0876..00000000 --- a/lisp/ldg-schedule.el +++ /dev/null @@ -1,330 +0,0 @@ -;;; ldg-schedule.el --- Helper code for use with the "ledger" command-line tool - -;; Copyright (C) 2013 Craig Earls (enderw88 at gmail dot com) - -;; This file is not part of GNU Emacs. - -;; This is free software; you can redistribute it and/or modify it -;; under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. -;; -;; This is distributed in the hope that it will be useful, but WITHOUT -;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -;; License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: -;; -;; This module provides for automatically adding transactions to a -;; ledger buffer on a periodic basis. Recurrence expressions are -;; inspired by Martin Fowler's "Recurring Events for Calendars", -;; martinfowler.com/apsupp/recurring.pdf - -;; use (fset 'VARNAME (macro args)) to put the macro definition in the -;; function slot of the symbol VARNAME. Then use VARNAME as the -;; function without have to use funcall. - -(defgroup ledger-schedule nil - "Support for automatically recommendation transactions." - :group 'ledger) - -(defcustom ledger-schedule-buffer-name "*Ledger Schedule*" - "Name for the schedule buffer" - :type 'string - :group 'ledger-schedule) - -(defcustom ledger-schedule-look-backward 7 - "Number of days to look back in time for transactions." - :type 'integer - :group 'ledger-schedule) - -(defcustom ledger-schedule-look-forward 14 - "Number of days auto look forward to recommend transactions" - :type 'integer - :group 'ledger-schedule) - -(defcustom ledger-schedule-file "~/FinanceData/ledger-schedule.ledger" - "File to find scheduled transactions." - :type 'file - :group 'ledger-schedule) - -(defsubst between (val low high) - (and (>= val low) (<= val high))) - -(defun ledger-schedule-days-in-month (month year) - "Return number of days in the MONTH, MONTH is from 1 to 12. -If year is nil, assume it is not a leap year" - (if (between month 1 12) - (if (and year (date-leap-year-p year) (= 2 month)) - 29 - (nth (1- month) '(31 28 31 30 31 30 31 31 30 31 30 31))) - (error "Month out of range, MONTH=%S" month))) - -;; Macros to handle date expressions - -(defun ledger-schedule-constrain-day-in-month (count day-of-week) - "Return a form that evaluates DATE that returns true for the COUNT DAY-OF-WEEK. -For example, return true if date is the 3rd Thursday of the -month. Negative COUNT starts from the end of the month. (EQ -COUNT 0) means EVERY day-of-week (eg. every Saturday)" - (if (and (between count -6 6) (between day-of-week 0 6)) - (cond ((zerop count) ;; Return true if day-of-week matches - `(eq (nth 6 (decode-time date)) ,day-of-week)) - ((> count 0) ;; Positive count - (let ((decoded (gensym))) - `(let ((,decoded (decode-time date))) - (and (eq (nth 6 ,decoded) ,day-of-week) - (between (nth 3 ,decoded) - ,(* (1- count) 7) - ,(* count 7)))))) - ((< count 0) - (let ((days-in-month (gensym)) - (decoded (gensym))) - `(let* ((,decoded (decode-time date)) - (,days-in-month (ledger-schedule-days-in-month - (nth 4 ,decoded) - (nth 5 ,decoded)))) - (and (eq (nth 6 ,decoded) ,day-of-week) - (between (nth 3 ,decoded) - (+ ,days-in-month ,(* count 7)) - (+ ,days-in-month ,(* (1+ count) 7))))))) - (t - (error "COUNT out of range, COUNT=%S" count))) - (error "Invalid argument to ledger-schedule-day-in-month-macro %S %S" - count - day-of-week))) - -(defun ledger-schedule-constrain-every-count-day (day-of-week skip start-date) - "Return a form that is true for every DAY skipping SKIP, starting on START. -For example every second Friday, regardless of month." - (let ((start-day (nth 6 (decode-time (eval start-date))))) - (if (eq start-day day-of-week) ;; good, can proceed - `(zerop (mod (- (time-to-days date) ,(time-to-days (eval start-date))) ,(* skip 7))) - (error "START-DATE day of week doesn't match DAY-OF-WEEK")))) - -(defun ledger-schedule-constrain-date-range (month1 day1 month2 day2) - "Return a form of DATE that is true if DATE falls between MONTH1 DAY1 and MONTH2 DAY2." - (let ((decoded (gensym)) - (target-month (gensym)) - (target-day (gensym))) - `(let* ((,decoded (decode-time date)) - (,target-month (nth 4 decoded)) - (,target-day (nth 3 decoded))) - (and (and (> ,target-month ,month1) - (< ,target-month ,month2)) - (and (> ,target-day ,day1) - (< ,target-day ,day2)))))) - - -(defun ledger-schedule-is-holiday (date) - "Return true if DATE is a holiday.") - -(defun ledger-schedule-scan-transactions (schedule-file) - "Scans AUTO_FILE and returns a list of transactions with date predicates. -The car of each item is a fuction of date that returns true if -the transaction should be logged for that day." - (interactive "fFile name: ") - (let ((xact-list (list))) - (with-current-buffer - (find-file-noselect schedule-file) - (goto-char (point-min)) - (while (re-search-forward "^\\[\\(.*\\)\\] " nil t) - (let ((date-descriptor "") - (transaction nil) - (xact-start (match-end 0))) - (setq date-descriptors - (ledger-schedule-read-descriptor-tree - (buffer-substring-no-properties - (match-beginning 0) - (match-end 0)))) - (forward-paragraph) - (setq transaction (list date-descriptors - (buffer-substring-no-properties - xact-start - (point)))) - (setq xact-list (cons transaction xact-list)))) - xact-list))) - -(defun ledger-schedule-replace-brackets () - "Replace all brackets with parens" - (goto-char (point-min)) - (while (search-forward "]" nil t) - (replace-match ")" nil t)) - (goto-char (point-min)) - (while (search-forward "[" nil t) - (replace-match "(" nil t))) - -(defvar ledger-schedule-descriptor-regex - (concat "\\(20[0-9][0-9]\\|[\*]\\)[/\\-]" ;; Year slot - "\\([\*EO]\\|[01][0-9]\\)[/\\-]" ;; Month slot - "\\([\*]\\|\\([0-3][0-9]\\)\\|" - "\\([0-5]" - "\\(\\(Su\\)\\|" - "\\(Mo\\)\\|" - "\\(Tu\\)\\|" - "\\(We\\)\\|" - "\\(Th\\)\\|" - "\\(Fr\\)\\|" - "\\(Sa\\)\\)\\)\\)")) - -(defun ledger-schedule-read-descriptor-tree (descriptor-string) - "Take a date DESCRIPTOR-STRING and return a function of date that -returns true if the date meets the requirements" - (with-temp-buffer - ;; copy the descriptor string into a temp buffer for manipulation - (let (pos) - ;; Replace brackets with parens - (insert descriptor-string) - (ledger-schedule-replace-brackets) - - (goto-char (point-max)) - ;; double quote all the descriptors for string processing later - (while (re-search-backward ledger-schedule-descriptor-regex nil t) ;; Day slot - (goto-char - (match-end 0)) - (insert ?\") - (goto-char (match-beginning 0)) - (insert "\"" ))) - - ;; read the descriptor string into a lisp object the transform the - ;; string descriptor into useable things - (ledger-schedule-transform-auto-tree - (read (buffer-substring-no-properties (point-min) (point-max)))))) - -(defun ledger-schedule-transform-auto-tree (descriptor-string-list) -"Takes a lisp list of date descriptor strings, TREE, and returns a string with a lambda function of date." -;; use funcall to use the lambda function spit out here - (if (consp descriptor-string-list) - (let (result) - (while (consp descriptor-string-list) - (let ((newcar (car descriptor-string-list))) - (if (consp newcar) - (setq newcar (ledger-schedule-transform-auto-tree (car descriptor-string-list)))) - ;; newcar may be a cons now, after ledger-schedule-transfrom-auto-tree - (if (consp newcar) - (push newcar result) - ;; this is where we actually turn the string descriptor into useful lisp - (push (ledger-schedule-compile-constraints newcar) result)) ) - (setq descriptor-string-list (cdr descriptor-string-list))) - - ;; tie up all the clauses in a big or and lambda, and return - ;; the lambda function as list to be executed by funcall - `(lambda (date) - ,(nconc (list 'or) (nreverse result) descriptor-string-list))))) - -(defun ledger-schedule-compile-constraints (descriptor-string) - "Return a list with the year, month and day fields split" - (let ((fields (split-string descriptor-string "[/\\-]" t)) - constrain-year constrain-month constrain-day) - (setq constrain-year (ledger-schedule-constrain-year (nth 0 fields))) - (setq constrain-month (ledger-schedule-constrain-month (nth 1 fields))) - (setq constrain-day (ledger-schedule-constrain-day (nth 2 fields))) - - (list 'and constrain-year constrain-month constrain-day))) - -(defun ledger-schedule-constrain-year (str) - (let ((year-match t)) - (cond ((string= str "*") - year-match) - ((/= 0 (setq year-match (string-to-number str))) - `(eq (nth 5 (decode-time date)) ,year-match)) - (t - (error "Improperly specified year constraint: " str))))) - -(defun ledger-schedule-constrain-month (str) - - (let ((month-match t)) - (cond ((string= str "*") - month-match) ;; always match - ((/= 0 (setq month-match (string-to-number str))) - (if (between month-match 1 12) ;; no month specified, assume 31 days. - `(eq (nth 4 (decode-time date)) ,month-match) - (error "ledger-schedule-constrain-numerical-month: month out of range %S" month-match))) - (t - (error "Improperly specified month constraint: " str))))) - -(defun ledger-schedule-constrain-day (str) - (let ((day-match t)) - (cond ((string= str "*") - t) - ((/= 0 (setq day-match (string-to-number str))) - `(eq (nth 3 (decode-time date)) ,day-match)) - (t - (error "Improperly specified day constraint: " str))))) - -(defun ledger-schedule-parse-date-descriptor (descriptor) - "Parse the date descriptor, return the evaluator" - (ledger-schedule-compile-constraints descriptor)) - -(defun ledger-schedule-list-upcoming-xacts (candidate-items early horizon) - "Search CANDIDATE-ITEMS for xacts that occur within the period today - EARLY to today + HORIZON" - (let ((start-date (time-subtract (current-time) (days-to-time early))) - test-date items) - (loop for day from 0 to (+ early horizon) by 1 do - (setq test-date (time-add start-date (days-to-time day))) - (dolist (candidate candidate-items items) - (if (funcall (car candidate) test-date) - (setq items (append items (list (list test-date (cadr candidate)))))))) - items)) - -(defun ledger-schedule-already-entered (candidate buffer) - (let ((target-date (format-time-string date-format (car candidate))) - (target-payee (cadr candidate))) - nil)) - -(defun ledger-schedule-create-auto-buffer (candidate-items early horizon ledger-buf) - "Format CANDIDATE-ITEMS for display." - (let ((candidates (ledger-schedule-list-upcoming-xacts candidate-items early horizon)) - (schedule-buf (get-buffer-create ledger-schedule-buffer-name)) - (date-format (cdr (assoc "date-format" ledger-environment-alist)))) - (with-current-buffer schedule-buf - (erase-buffer) - (dolist (candidate candidates) - (if (not (ledger-schedule-already-entered candidate ledger-buf)) - (insert (format-time-string date-format (car candidate) ) " " (cadr candidate) "\n"))) - (ledger-mode)) - (length candidates))) - - -;; -;; Test harnesses for use in ielm -;; -(defvar auto-items) - -(defun ledger-schedule-test ( early horizon) - (ledger-schedule-create-auto-buffer - (ledger-schedule-scan-transactions ledger-schedule-file) - early - horizon - (get-buffer "2013.ledger"))) - - -(defun ledger-schedule-test-predict () - (let ((today (current-time)) - test-date items) - - (loop for day from 0 to ledger-schedule-look-forward by 1 do - (setq test-date (time-add today (days-to-time day))) - (dolist (item auto-items items) - (if (funcall (car item) test-date) - (setq items (append items (list (decode-time test-date) (cdr item))))))) - items)) - -(defun ledger-schedule-upcoming () - (interactive) - (ledger-schedule-create-auto-buffer - (ledger-schedule-scan-transactions ledger-schedule-file) - ledger-schedule-look-backward - ledger-schedule-look-forward - (current-buffer))) - - -(provide 'ldg-schedule) - -;;; ldg-schedule.el ends here diff --git a/lisp/ldg-sort.el b/lisp/ldg-sort.el deleted file mode 100644 index 42b49648..00000000 --- a/lisp/ldg-sort.el +++ /dev/null @@ -1,126 +0,0 @@ -;;; ldg-xact.el --- Helper code for use with the "ledger" command-line tool - -;; Copyright (C) 2003-2013 John Wiegley (johnw AT gnu DOT org) - -;; 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: -;; - -;;; Code: - -(defun ledger-next-record-function () - "Move point to next transaction." - (if (re-search-forward ledger-payee-any-status-regex nil t) - (goto-char (match-beginning 0)) - (goto-char (point-max)))) - -(defun ledger-end-record-function () - "Move point to end of transaction." - (forward-paragraph)) - -(defun ledger-sort-find-start () - (if (re-search-forward ";.*Ledger-mode:.*Start sort" nil t) - (match-end 0))) - -(defun ledger-sort-find-end () - (if (re-search-forward ";.*Ledger-mode:.*End sort" nil t) - (match-end 0))) - -(defun ledger-sort-insert-start-mark () - (interactive) - (save-excursion - (goto-char (point-min)) - (if (ledger-sort-find-start) - (delete-region (match-beginning 0) (match-end 0)))) - (beginning-of-line) - (insert "\n; Ledger-mode: Start sort\n\n")) - -(defun ledger-sort-insert-end-mark () - (interactive) - (save-excursion - (goto-char (point-min)) - (if (ledger-sort-find-end) - (delete-region (match-beginning 0) (match-end 0)))) - (beginning-of-line) - (insert "\n; Ledger-mode: End sort\n\n")) - -(defun ledger-sort-startkey () - "Return the actual date so the sort-subr doesn't sort onthe entire first line." - (buffer-substring-no-properties (point) (+ 10 (point)))) - -(defun ledger-sort-region (beg end) - "Sort the region from BEG to END in chronological order." - (interactive "r") ;; load beg and end from point and mark - ;; automagically - (let ((new-beg beg) - (new-end end) - point-delta - (bounds (ledger-find-xact-extents (point))) - target-xact) - - (setq point-delta (- (point) (car bounds))) - (setq target-xact (buffer-substring (car bounds) (cadr bounds))) - (setq inhibit-modification-hooks t) - (save-excursion - (save-restriction - (goto-char beg) - (ledger-next-record-function) ;; make sure point is at the - ;; beginning of a xact - (setq new-beg (point)) - (goto-char end) - (ledger-next-record-function) ;; make sure end of region is at - ;; the beginning of next record - ;; after the region - (setq new-end (point)) - (narrow-to-region new-beg new-end) - (goto-char new-beg) - - (let ((inhibit-field-text-motion t)) - (sort-subr - nil - 'ledger-next-record-function - 'ledger-end-record-function - 'ledger-sort-startkey)))) - - (goto-char (point-min)) - (re-search-forward (regexp-quote target-xact)) - (goto-char (+ (match-beginning 0) point-delta)) - (setq inhibit-modification-hooks nil))) - -(defun ledger-sort-buffer () - "Sort the entire buffer." - (interactive) - (let (sort-start - sort-end) - (save-excursion - (goto-char (point-min)) - (setq sort-start (ledger-sort-find-start) - sort-end (ledger-sort-find-end))) - (ledger-sort-region (if sort-start - sort-start - (point-min)) - (if sort-end - sort-end - (point-max))))) - -(provide 'ldg-sort) - -;;; ldg-sort.el ends here diff --git a/lisp/ldg-state.el b/lisp/ldg-state.el deleted file mode 100644 index 58777631..00000000 --- a/lisp/ldg-state.el +++ /dev/null @@ -1,244 +0,0 @@ -;;; ldg-state.el --- Helper code for use with the "ledger" command-line tool - -;; Copyright (C) 2003-2013 John Wiegley (johnw AT gnu DOT org) - -;; 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: -;; Utilities for dealing with transaction and posting status. - -;;; Code: - -(defcustom ledger-clear-whole-transactions nil - "If non-nil, clear whole transactions, not individual postings." - :type 'boolean - :group 'ledger) - -(defun ledger-transaction-state () - "Return the state of the transaction at point." - (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-posting-state () - "Return the state of the posting." - (save-excursion - (goto-char (line-beginning-position)) - (skip-syntax-forward " ") - (cond ((looking-at "!\\s-*") 'pending) - ((looking-at "\\*\\s-*") 'cleared) - (t (ledger-transaction-state))))) - -(defun ledger-char-from-state (state) - "Return the char representation of STATE." - (if state - (if (eq state 'pending) - "!" - "*") - "")) - -(defun ledger-state-from-char (state-char) - "Get state from STATE-CHAR." - (cond ((eql state-char ?\!) 'pending) - ((eql state-char ?\*) 'cleared) - ((eql state-char ?\;) 'comment) - (t nil))) - -(defun ledger-toggle-current-posting (&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'). Returns the new status as 'pending 'cleared or nil. -This function is rather complicated because it must preserve both -the overall formatting of the ledger xact, as well as ensuring -that the most minimal display format is used. This could be -achieved more certainly by passing the xact to ledger for -formatting, but doing so causes inline math expressions to be -dropped." - (interactive) - (let ((bounds (ledger-find-xact-extents (point))) - new-status cur-status) - ;; Uncompact the xact, to make it easier to toggle the - ;; transaction - (save-excursion ;; this excursion checks state of entire - ;; transaction and unclears if marked - (goto-char (car bounds)) ;; beginning of xact - (skip-chars-forward "0-9./=\\- \t") ;; skip the date - (setq cur-status (and (member (char-after) '(?\* ?\!)) - (ledger-state-from-char (char-after)))) - ;;if cur-status if !, or * then delete the marker - (when cur-status - (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) - ;; Shift the cleared/pending status to the postings - (while (looking-at "[ \t]") - (skip-chars-forward " \t") - (when (not (eq (ledger-state-from-char (char-after)) 'comment)) - (insert (ledger-char-from-state cur-status) " ") - (if (search-forward " " (line-end-position) t) - (delete-char 2))) - (forward-line)) - (setq new-status nil))) - - ;;this excursion toggles the posting status - (save-excursion - (setq inhibit-modification-hooks t) - - (goto-char (line-beginning-position)) - (when (looking-at "[ \t]") - (skip-chars-forward " \t") - (let ((here (point)) - (cur-status (ledger-state-from-char (char-after)))) - (skip-chars-forward "*! ") - (let ((width (- (point) here))) - (when (> width 0) - (delete-region here (point)) - (save-excursion - (if (search-forward " " (line-end-position) t) - (insert (make-string width ? )))))) - (let (inserted) - (if cur-status - (if (and style (eq style 'cleared)) - (progn - (insert "* ") - (setq inserted 'cleared))) - (if (and style (eq style 'pending)) - (progn - (insert "! ") - (setq inserted 'pending)) - (progn - (insert "* ") - (setq inserted 'cleared)))) - (if (and inserted - (re-search-forward "\\(\t\\| [ \t]\\)" - (line-end-position) t)) - (cond - ((looking-at "\t") - (delete-char 1)) - ((looking-at " [ \t]") - (delete-char 2)) - ((looking-at " ") - (delete-char 1)))) - (setq new-status inserted)))) - (setq inhibit-modification-hooks nil)) - - ;; This excursion cleans up the xact so that it displays - ;; minimally. This means that if all posts are cleared, remove - ;; the marks and clear the entire transaction. - (save-excursion - (goto-char (car bounds)) - (forward-line) - (let ((first t) - (state nil) - (hetero nil)) - (while (and (not hetero) (looking-at "[ \t]")) - (skip-chars-forward " \t") - (let ((cur-status (ledger-state-from-char (char-after)))) - (if (not (eq cur-status 'comment)) - (if first - (setq state cur-status - first nil) - (if (not (eq state cur-status)) - (setq hetero t))))) - (forward-line)) - (when (and (not hetero) (not (eq state nil))) - (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 (ledger-char-from-state state) " ") - (setq new-status state) - (if (re-search-forward "\\(\t\\| [ \t]\\)" - (line-end-position) t) - (cond - ((looking-at "\t") - (delete-char 1)) - ((looking-at " [ \t]") - (delete-char 2)) - ((looking-at " ") - (delete-char 1))))))) - new-status)) - -(defun ledger-toggle-current (&optional style) - "Toggle the current thing at point with optional STYLE." - (interactive) - (if (or ledger-clear-whole-transactions - (eq 'transaction (ledger-thing-at-point))) - (progn - (save-excursion - (forward-line) - (goto-char (line-beginning-position)) - (while (and (not (eolp)) - (save-excursion - (not (eq 'transaction (ledger-thing-at-point))))) - (if (looking-at "\\s-+[*!]") - (ledger-toggle-current-posting style)) - (forward-line) - (goto-char (line-beginning-position)))) - (ledger-toggle-current-transaction style)) - (ledger-toggle-current-posting style))) - -(defun ledger-toggle-current-transaction (&optional style) - "Toggle the transaction at point using optional STYLE." - (interactive) - (save-excursion - (when (or (looking-at "^[0-9]") - (re-search-backward "^[0-9]" nil t)) - (skip-chars-forward "0-9./=\\-") - (delete-horizontal-space) - (if (or (eq (ledger-state-from-char (char-after)) 'pending) - (eq (ledger-state-from-char (char-after)) 'cleared)) - (progn - (delete-char 1) - (when (and style (eq style 'cleared)) - (insert " *") - 'cleared)) - (if (and style (eq style 'pending)) - (progn - (insert " ! ") - 'pending) - (progn - (insert " * ") - 'cleared)))))) - -(provide 'ldg-state) - -;;; ldg-state.el ends here diff --git a/lisp/ldg-test.el b/lisp/ldg-test.el deleted file mode 100644 index 0c571caa..00000000 --- a/lisp/ldg-test.el +++ /dev/null @@ -1,127 +0,0 @@ -;;; ldg-test.el --- Helper code for use with the "ledger" command-line tool - -;; Copyright (C) 2003-2013 John Wiegley (johnw AT gnu DOT org) - -;; 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. - -(defgroup ledger-test nil - "Definitions for the Ledger testing framework" - :group 'ledger) - -(defcustom ledger-source-directory "~/ledger/" - "Directory where the Ledger sources are located." - :type 'directory - :group 'ledger-test) - -(defcustom ledger-test-binary "/Products/ledger/debug/ledger" - "Directory where the Ledger debug binary is located." - :type 'file - :group 'ledger-test) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defun ledger-create-test () - "Create a regression test." - (interactive) - (save-restriction - (org-narrow-to-subtree) - (save-excursion - (let (text beg) - (goto-char (point-min)) - (forward-line 1) - (setq beg (point)) - (search-forward ":PROPERTIES:") - (goto-char (line-beginning-position)) - (setq text (buffer-substring-no-properties beg (point))) - (goto-char (point-min)) - (re-search-forward ":ID:\\s-+\\([^-]+\\)") - (find-file-other-window - (format "~/src/ledger/test/regress/%s.test" (match-string 1))) - (sit-for 0) - (insert text) - (goto-char (point-min)) - (while (not (eobp)) - (goto-char (line-beginning-position)) - (delete-char 3) - (forward-line 1)))))) - -(defun ledger-test-org-narrow-to-entry () - (outline-back-to-heading) - (narrow-to-region (point) (progn (outline-next-heading) (point))) - (goto-char (point-min))) - -(defun ledger-test-create () - (interactive) - (let ((uuid (org-entry-get (point) "ID"))) - (when (string-match "\\`\\([^-]+\\)-" uuid) - (let ((prefix (match-string 1 uuid)) - input output) - (save-restriction - (ledger-test-org-narrow-to-entry) - (goto-char (point-min)) - (while (re-search-forward "#\\+begin_src ledger" nil t) - (goto-char (match-end 0)) - (forward-line 1) - (let ((beg (point))) - (re-search-forward "#\\+end_src") - (setq input - (concat (or input "") - (buffer-substring beg (match-beginning 0)))))) - (goto-char (point-min)) - (while (re-search-forward ":OUTPUT:" nil t) - (goto-char (match-end 0)) - (forward-line 1) - (let ((beg (point))) - (re-search-forward ":END:") - (setq output - (concat (or output "") - (buffer-substring beg (match-beginning 0))))))) - (find-file-other-window - (expand-file-name (concat prefix ".test") - (expand-file-name "test/regress" - ledger-source-directory))) - (ledger-mode) - (if input - (insert input) - (insert "2012-03-17 Payee\n") - (insert " Expenses:Food $20\n") - (insert " Assets:Cash\n")) - (insert "\ntest reg\n") - (if output - (insert output)) - (insert "end test\n"))))) - -(defun ledger-test-run () - (interactive) - (save-excursion - (goto-char (point-min)) - (when (re-search-forward "^test \\(.+?\\)\\( ->.*\\)?$" nil t) - (let ((command (expand-file-name ledger-test-binary)) - (args (format "--args-only --columns=80 --no-color -f \"%s\" %s" - buffer-file-name (match-string 1)))) - (setq args (replace-regexp-in-string "\\$sourcepath" - ledger-source-directory args)) - (kill-new args) - (message "Testing: ledger %s" args) - (let ((prev-directory default-directory)) - (cd ledger-source-directory) - (unwind-protect - (async-shell-command (format "\"%s\" %s" command args)) - (cd prev-directory))))))) - -(provide 'ldg-test) diff --git a/lisp/ldg-texi.el b/lisp/ldg-texi.el deleted file mode 100644 index 84ba34c2..00000000 --- a/lisp/ldg-texi.el +++ /dev/null @@ -1,172 +0,0 @@ -;;; ldg-texi.el --- Helper code for use with the "ledger" command-line tool - -;; Copyright (C) 2003-2013 John Wiegley (johnw AT gnu DOT org) - -;; 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. - -(defgroup ledger-texi nil -"Options for working on Ledger texi documentation" -:group 'ledger) - -(defcustom ledger-texi-sample-doc-path "~/ledger/doc/sample.dat" -"Location for sample data to be used in texi tests" -:type 'file -:group 'ledger-texi) - -(defcustom ledger-texi-normalization-args "--args-only --columns 80" -"texi normalization for producing ledger output" -:type 'string -:group 'ledger-texi) - -(defun ledger-update-test () - (interactive) - (goto-char (point-min)) - (let ((command (buffer-substring (point-min) (line-end-position))) - input) - (re-search-forward "^<<<\n") - (let ((beg (point)) end) - (re-search-forward "^>>>") - (setq end (match-beginning 0)) - (forward-line 1) - (let ((output-beg (point))) - (re-search-forward "^>>>") - (goto-char (match-beginning 0)) - (delete-region output-beg (point)) - (apply #'call-process-region - beg end (expand-file-name "~/Products/ledger/debug/ledger") - nil t nil - "-f" "-" "--args-only" "--columns=80" "--no-color" - (split-string command " ")))))) - -(defun ledger-texi-write-test (name command input output &optional category) - (let ((buf (current-buffer))) - (with-current-buffer (find-file-noselect - (expand-file-name (concat name ".test") category)) - (erase-buffer) - (let ((case-fold-search nil)) - (if (string-match "\\$LEDGER\\s-+" command) - (setq command (replace-match "" t t command))) - (if (string-match " -f \\$\\([-a-z]+\\)" command) - (setq command (replace-match "" t t command)))) - (insert command ?\n) - (insert "<<<" ?\n) - (insert input) - (insert ">>>1" ?\n) - (insert output) - (insert ">>>2" ?\n) - (insert "=== 0" ?\n) - (save-buffer) - (unless (eq buf (current-buffer)) - (kill-buffer (current-buffer)))))) - -(defun ledger-texi-update-test () - (interactive) - (let ((details (ledger-texi-test-details)) - (name (file-name-sans-extension - (file-name-nondirectory (buffer-file-name))))) - (ledger-texi-write-test - name (nth 0 details) - (nth 1 details) - (ledger-texi-invoke-command - (ledger-texi-expand-command - (nth 0 details) - (ledger-texi-write-test-data name (nth 1 details))))))) - -(defun ledger-texi-test-details () - (goto-char (point-min)) - (let ((command (buffer-substring (point) (line-end-position))) - input output) - (re-search-forward "^<<<") - (let ((input-beg (1+ (match-end 0)))) - (re-search-forward "^>>>1") - (let ((output-beg (1+ (match-end 0)))) - (setq input (buffer-substring input-beg (match-beginning 0))) - (re-search-forward "^>>>2") - (setq output (buffer-substring output-beg (match-beginning 0))) - (list command input output))))) - -(defun ledger-texi-expand-command (command data-file) - (if (string-match "\\$LEDGER" command) - (replace-match (format "%s -f \"%s\" %s" ledger-binary-path - data-file ledger-texi-normalization-args) t t command) - (concat (format "%s -f \"%s\" %s " ledger-binary-path - data-file ledger-texi-normalization-args) command))) - -(defun ledger-texi-invoke-command (command) - (with-temp-buffer (shell-command command t (current-buffer)) - (if (= (point-min) (point-max)) - (progn - (push-mark nil t) - (message "Command '%s' yielded no result at %d" command (point)) - (ding)) - (buffer-string)))) - -(defun ledger-texi-write-test-data (name input) - (let ((path (expand-file-name name temporary-file-directory))) - (with-current-buffer (find-file-noselect path) - (erase-buffer) - (insert input) - (save-buffer)) - path)) - -(defun ledger-texi-update-examples () - (interactive) - (save-excursion - (goto-char (point-min)) - (while (re-search-forward "^@c \\(\\(?:sm\\)?ex\\) \\(\\S-+\\): \\(.*\\)" nil t) - (let ((section (match-string 1)) - (example-name (match-string 2)) - (command (match-string 3)) expanded-command - (data-file ledger-texi-sample-doc-path) - input output) - (goto-char (match-end 0)) - (forward-line) - (when (looking-at "@\\(\\(?:small\\)?example\\)") - (let ((beg (point))) - (re-search-forward "^@end \\(\\(?:small\\)?example\\)") - (delete-region beg (1+ (point))))) - - (when (let ((case-fold-search nil)) - (string-match " -f \\$\\([-a-z]+\\)" command)) - (let ((label (match-string 1 command))) - (setq command (replace-match "" t t command)) - (save-excursion - (goto-char (point-min)) - (search-forward (format "@c data: %s" label)) - (re-search-forward "@\\(\\(?:small\\)?example\\)") - (forward-line) - (let ((beg (point))) - (re-search-forward "@end \\(\\(?:small\\)?example\\)") - (setq data-file (ledger-texi-write-test-data - (format "%s.dat" label) - (buffer-substring-no-properties - beg (match-beginning 0)))))))) - - (let ((section-name (if (string= section "smex") - "smallexample" - "example")) - (output (ledger-texi-invoke-command - (ledger-texi-expand-command command data-file)))) - (insert "@" section-name ?\n output - "@end " section-name ?\n)) - - ;; Update the regression test associated with this example - (ledger-texi-write-test example-name command input output - "../test/manual"))))) - -(provide 'ldg-texi) diff --git a/lisp/ldg-xact.el b/lisp/ldg-xact.el deleted file mode 100644 index 37667efa..00000000 --- a/lisp/ldg-xact.el +++ /dev/null @@ -1,200 +0,0 @@ -;;; ldg-xact.el --- Helper code for use with the "ledger" command-line tool - -;; Copyright (C) 2003-2013 John Wiegley (johnw AT gnu DOT org) - -;; 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: -;; Utilities for running ledger synchronously. - -;;; Code: - -(defcustom ledger-highlight-xact-under-point t - "If t highlight xact under point." - :type 'boolean - :group 'ledger) - -(defcustom ledger-use-iso-dates nil - "If non-nil, use the iso-8601 format for dates (YYYY-MM-DD)." - :type 'boolean - :group 'ledger - :safe t) - -(defvar highlight-overlay (list)) - -(defun ledger-find-xact-extents (pos) - "Return point for beginning of xact and and of xact containing position. -Requires empty line separating xacts. Argument POS is a location -within the transaction." - (interactive "d") - (save-excursion - (goto-char pos) - (list (progn - (backward-paragraph) - (if (/= (point) (point-min)) - (forward-line)) - (line-beginning-position)) - (progn - (forward-paragraph) - (line-beginning-position))))) - -(defun ledger-highlight-xact-under-point () - "Move the highlight overlay to the current transaction." - (if ledger-highlight-xact-under-point - (let ((exts (ledger-find-xact-extents (point))) - (ovl highlight-overlay)) - (if (not highlight-overlay) - (setq ovl - (setq highlight-overlay - (make-overlay (car exts) - (cadr exts) - (current-buffer) t nil))) - (move-overlay ovl (car exts) (cadr exts))) - (overlay-put ovl 'face 'ledger-font-xact-highlight-face) - (overlay-put ovl 'priority 100)))) - -(defun ledger-xact-payee () - "Return the payee of the transaction 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) 'xact) - (ledger-context-field-value context-info 'payee) - nil)))) - -(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-xact-find-slot (moment) - "Find the right place in the buffer for a transaction at MOMENT. -MOMENT is an encoded date" - (catch 'found - (ledger-xact-iterate-transactions - (function - (lambda (start date mark desc) - (if (ledger-time-less-p moment date) - (throw 'found t))))))) - -(defun ledger-xact-iterate-transactions (callback) - "Iterate through each transaction call CALLBACK for each." - (goto-char (point-min)) - (let* ((now (current-time)) - (current-year (nth 5 (decode-time now)))) - (while (not (eobp)) - (when (looking-at ledger-iterate-regex) - (let ((found-y-p (match-string 2))) - (if found-y-p - (setq current-year (string-to-number found-y-p)) ;; a Y directive was found - (let ((start (match-beginning 0)) - (year (match-string 4)) - (month (string-to-number (match-string 5))) - (day (string-to-number (match-string 6))) - (mark (match-string 7)) - (code (match-string 8)) - (desc (match-string 9))) - (if (and year (> (length year) 0)) - (setq year (string-to-number year))) - (funcall callback start - (encode-time 0 0 0 day month - (or year current-year)) - mark desc))))) - (forward-line)))) - -(defsubst ledger-goto-line (line-number) - "Rapidly move point to line LINE-NUMBER." - (goto-char (point-min)) - (forward-line (1- line-number))) - -(defun ledger-year-and-month () - (let ((sep (if ledger-use-iso-dates - "-" - "/"))) - (concat ledger-year sep ledger-month sep))) - -(defun ledger-copy-transaction-at-point (date) - "Ask for a new DATE and copy the transaction under point to that date. Leave point on the first amount." - (interactive (list - (read-string "Copy to date: " (ledger-year-and-month) - 'ledger-minibuffer-history))) - (let* ((here (point)) - (extents (ledger-find-xact-extents (point))) - (transaction (buffer-substring-no-properties (car extents) (cadr extents))) - encoded-date) - (if (string-match ledger-iso-date-regexp date) - (setq encoded-date - (encode-time 0 0 0 (string-to-number (match-string 4 date)) - (string-to-number (match-string 3 date)) - (string-to-number (match-string 2 date))))) - (ledger-xact-find-slot encoded-date) - (insert transaction "\n") - (backward-paragraph 2) - (re-search-forward ledger-iso-date-regexp) - (replace-match date) - (ledger-next-amount))) - -(defun ledger-delete-current-transaction (pos) - "Delete the transaction surrounging point." - (interactive "d") - (let ((bounds (ledger-find-xact-extents pos))) - (delete-region (car bounds) (cadr bounds)))) - -(defun ledger-add-transaction (transaction-text &optional insert-at-point) - "Use ledger xact TRANSACTION-TEXT to add a transaction to the buffer. -If INSERT-AT-POINT is non-nil insert the transaction -there, otherwise call `ledger-xact-find-slot' to insert it at the -correct chronological place in the buffer." - (interactive (list - (read-string "Transaction: " (ledger-year-and-month)))) - (let* ((args (with-temp-buffer - (insert transaction-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 ledger-iso-date-regexp date) - (setq date - (encode-time 0 0 0 (string-to-number (match-string 4 date)) - (string-to-number (match-string 3 date)) - (string-to-number (match-string 2 date))))) - (ledger-xact-find-slot date))) - (if (> (length args) 1) - (save-excursion - (insert - (with-temp-buffer - (setq exit-code - (apply #'ledger-exec-ledger ledger-buf (current-buffer) "xact" - (mapcar 'eval args))) - (goto-char (point-min)) - (if (looking-at "Error: ") - (error (concat "Error in ledger-add-transaction: " (buffer-string))) - (buffer-string))) - "\n")) - (progn - (insert (car args) " \n\n") - (end-of-line -1))))) - - -(provide 'ldg-xact) - -;;; ldg-xact.el ends here diff --git a/lisp/ledger-commodities.el b/lisp/ledger-commodities.el new file mode 100644 index 00000000..48d41979 --- /dev/null +++ b/lisp/ledger-commodities.el @@ -0,0 +1,147 @@ +;;; ledger-commodities.el --- Helper code for use with the "ledger" command-line tool + +;; Copyright (C) 2003-2013 John Wiegley (johnw AT gnu DOT org) + +;; 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: +;; Helper functions to deal with commoditized numbers. A commoditized +;; number will be a list of value and string where the string contains +;; the commodity + +;;; Code: + +(require 'ledger-regex) + +(defcustom ledger-reconcile-default-commodity "$" + "The default commodity for use in target calculations in ledger reconcile." + :type 'string + :group 'ledger-reconcile) + +(defcustom ledger-scale 10000 + "The 10 ^ maximum number of digits you would expect to appear in your reports. +This is a cheap way of getting around floating point silliness in subtraction") + +(defun ledger-split-commodity-string (str) + "Split a commoditized string, STR, into two parts. +Returns a list with (value commodity)." + (let ((number-regex (if (assoc "decimal-comma" ledger-environment-alist) + ledger-amount-decimal-comma-regex + ledger-amount-decimal-period-regex))) + (if (> (length str) 0) + (with-temp-buffer + (insert str) + (goto-char (point-min)) + (cond + ((re-search-forward "\"\\(.*\\)\"" nil t) ; look for quoted commodities + (let ((com (delete-and-extract-region + (match-beginning 1) + (match-end 1)))) + (if (re-search-forward + number-regex nil t) + (list + (ledger-string-to-number + (delete-and-extract-region (match-beginning 0) (match-end 0))) + com)))) + ((re-search-forward number-regex nil t) + ;; found a number in the current locale, return it in the + ;; car. Anything left over is annotation, the first + ;; thing should be the commodity, separated by + ;; whitespace, return it in the cdr. I can't think of + ;; any counterexamples + (list + (ledger-string-to-number + (delete-and-extract-region (match-beginning 0) (match-end 0))) + (nth 0 (split-string (buffer-substring-no-properties (point-min) (point-max)))))) + ((re-search-forward "0" nil t) + ;; couldn't find a decimal number, look for a single 0, + ;; indicating account with zero balance + (list 0 ledger-reconcile-default-commodity)))) + ;; nothing found, return 0 + (list 0 ledger-reconcile-default-commodity)))) + +(defun ledger-string-balance-to-commoditized-amount (str) + "Return a commoditized amount (val, 'comm') from STR." + ; break any balances with multi commodities into a list + (mapcar #'(lambda (st) + (ledger-split-commodity-string st)) + (split-string str "[\n\r]"))) + +(defun -commodity (c1 c2) + "Subtract C2 from C1, ensuring their commodities match." + (if (string= (cadr c1) (cadr c2)) + ; the scaling below is to get around inexact subtraction results where, for example + ; 1.23 - 4.56 = -3.3299999999999996 instead of -3.33 + (list (/ (- (* ledger-scale (car c1)) (* ledger-scale (car c2))) ledger-scale) (cadr c1)) + (error "Can't subtract different commodities %S from %S" c2 c1))) + +(defun +commodity (c1 c2) + "Add C1 and C2, ensuring their commodities match." + (if (string= (cadr c1) (cadr c2)) + (list (+ (car c1) (car c2)) (cadr c1)) + (error "Can't add different commodities, %S to %S" c1 c2))) + +(defun ledger-strip (str char) + (let (new-str) + (concat (dolist (ch (append str nil) new-str) + (unless (= ch char) + (setq new-str (append new-str (list ch)))))))) + +(defun ledger-string-to-number (str &optional decimal-comma) + "improve builtin string-to-number by handling internationalization, and return nil if number can't be parsed" + (let ((nstr (if (or decimal-comma + (assoc "decimal-comma" ledger-environment-alist)) + (ledger-strip str ?.) + (ledger-strip str ?,)))) + (while (string-match "," nstr) ;if there is a comma now, it is a thousands separator + (setq nstr (replace-match "." nil nil nstr))) + (string-to-number nstr))) + +(defun ledger-number-to-string (n &optional decimal-comma) + (let ((str (number-to-string n))) + (if (or decimal-comma + (assoc "decimal-comma" ledger-environment-alist)) + (while (string-match "\\." str) + (setq str (replace-match "," nil nil str))) + str))) + +(defun ledger-commodity-to-string (c1) + "Return string representing C1. +Single character commodities are placed ahead of the value, +longer ones are after the value." + (let ((str (ledger-number-to-string (car c1))) + (commodity (cadr c1))) + (if (> (length commodity) 1) + (concat str " " commodity) + (concat commodity " " str)))) + +(defun ledger-read-commodity-string (prompt) + (let ((str (read-from-minibuffer + (concat prompt " (" ledger-reconcile-default-commodity "): "))) + comm) + (if (and (> (length str) 0) + (ledger-split-commodity-string str)) + (progn + (setq comm (ledger-split-commodity-string str)) + (if (cadr comm) + comm + (list (car comm) ledger-reconcile-default-commodity)))))) + +(provide 'ledger-commodities) + +;;; ledger-commodities.el ends here diff --git a/lisp/ledger-complete.el b/lisp/ledger-complete.el new file mode 100644 index 00000000..a8ef9a8a --- /dev/null +++ b/lisp/ledger-complete.el @@ -0,0 +1,257 @@ +;;; ledger-complete.el --- Helper code for use with the "ledger" command-line tool + +;; Copyright (C) 2003-2013 John Wiegley (johnw AT gnu DOT org) + +;; 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: +;; Functions providing payee and account auto complete. + +(require 'pcomplete) + +;; In-place completion support + +;;; Code: + +(defun ledger-parse-arguments () + "Parse whitespace separated arguments in the current region." + ;; this is more complex than it appears to need, so that it can work + ;; with pcomplete. See pcomplete-parse-arguments-function for + ;; details + (let* ((begin (save-excursion + (ledger-thing-at-point) ;; leave point at beginning of thing under point + (point))) + (end (point)) + begins args) + ;; to support end of line metadata + (save-excursion + (when (search-backward ";" + (line-beginning-position) t) + (setq begin (match-beginning 0)))) + (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-payees-in-buffer () + "Scan buffer and return list of all payees." + (let ((origin (point)) + payees-list) + (save-excursion + (goto-char (point-min)) + (while (re-search-forward + ledger-payee-any-status-regex nil t) ;; matches first line + (unless (and (>= origin (match-beginning 0)) + (< origin (match-end 0))) + (setq payees-list (cons (match-string-no-properties 3) + payees-list))))) ;; add the payee + ;; to the list + (pcomplete-uniqify-list (nreverse payees-list)))) + + +(defun ledger-find-accounts-in-buffer () + (interactive) + (let ((origin (point)) + accounts + (account-tree (list t)) + (account-elements nil) + (seed-regex (ledger-account-any-status-with-seed-regex + (regexp-quote (car pcomplete-args))))) + (save-excursion + (goto-char (point-min)) + + (dolist (account + (delete-dups + (progn + (while (re-search-forward seed-regex nil t) + (unless (between origin (match-beginning 0) (match-end 0)) + (setq accounts (cons (match-string-no-properties 2) accounts)))) + accounts))) + (let ((root account-tree)) + (setq account-elements + (split-string + account ":")) + (while account-elements + (let ((xact (assoc (car account-elements) root))) + (if xact + (setq root (cdr xact)) + (setq xact (cons (car account-elements) (list t))) + (nconc root (list xact)) + (setq root (cdr xact)))) + (setq account-elements (cdr account-elements)))))) + account-tree)) + +(defun ledger-find-metadata-in-buffer () + "Search through buffer and build list of metadata. +Return list." + (let ((origin (point)) accounts) + (save-excursion + (setq ledger-account-tree (list t)) + (goto-char (point-min)) + (while (re-search-forward + ledger-metadata-regex + nil t) + (unless (and (>= origin (match-beginning 0)) + (< origin (match-end 0))) + (setq accounts (cons (match-string-no-properties 2) accounts))))) + accounts)) + +(defun ledger-accounts () + "Return a tree of all accounts in the buffer." + (let* ((current (caar (ledger-parse-arguments))) + (elements (and current (split-string current ":"))) + (root (ledger-find-accounts-in-buffer)) + (prefix nil)) + (while (cdr elements) + (let ((xact (assoc (car elements) root))) + (if xact + (setq prefix (concat prefix (and prefix ":") + (car elements)) + root (cdr xact)) + (setq root nil elements nil))) + (setq elements (cdr elements))) + (setq root (delete (list (car elements) t) root)) + (and root + (sort + (mapcar (function + (lambda (x) + (let ((term (if prefix + (concat prefix ":" (car x)) + (car x)))) + (if (> (length (cdr x)) 1) + (concat term ":") + term)))) + (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)) 'transaction) + (if (null current-prefix-arg) + (delete + (caar (ledger-parse-arguments)) + (ledger-payees-in-buffer)) ;; this completes against payee names + (progn + (let ((text (buffer-substring-no-properties + (line-beginning-position) + (line-end-position)))) + (delete-region (line-beginning-position) + (line-end-position)) + (condition-case nil + (ledger-add-transaction text t) + (error nil))) + (forward-line) + (goto-char (line-end-position)) + (search-backward ";" (line-beginning-position) t) + (skip-chars-backward " \t0123456789.,") + (throw 'pcompleted t))) + (ledger-accounts))))) + +(defun ledger-fully-complete-xact () + "Completes a transaction if there is another matching payee in the buffer. +Does not use ledger xact" + (interactive) + (let* ((name (caar (ledger-parse-arguments))) + (rest-of-name name) + xacts) + (save-excursion + (when (eq 'transaction (ledger-thing-at-point)) + (delete-region (point) (+ (length name) (point))) + ;; Search backward for a matching payee + (when (re-search-backward + (concat "^[0-9/.=-]+\\(\\s-+\\*\\)?\\(\\s-+(.*?)\\)?\\s-+\\(.*" + (regexp-quote name) ".*\\)" ) nil t) + (setq rest-of-name (match-string 3)) + ;; Start copying the postings + (forward-line) + (while (looking-at ledger-account-any-status-regex) + (setq xacts (cons (buffer-substring-no-properties + (line-beginning-position) + (line-end-position)) + xacts)) + (forward-line)) + (setq xacts (nreverse xacts))))) + ;; Insert rest-of-name and the postings + (when xacts + (save-excursion + (insert rest-of-name ?\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)))))) + + +(defun ledger-pcomplete (&optional interactively) + "Complete rip-off of pcomplete from pcomplete.el, only added +ledger-magic-tab in the previous commands list so that +ledger-magic-tab would cycle properly" + (interactive "p") + (if (and interactively + pcomplete-cycle-completions + pcomplete-current-completions + (memq last-command '(ledger-magic-tab + ledger-pcomplete + pcomplete-expand-and-complete + pcomplete-reverse))) + (progn + (delete-backward-char pcomplete-last-completion-length) + (if (eq this-command 'pcomplete-reverse) + (progn + (push (car (last pcomplete-current-completions)) + pcomplete-current-completions) + (setcdr (last pcomplete-current-completions 2) nil)) + (nconc pcomplete-current-completions + (list (car pcomplete-current-completions))) + (setq pcomplete-current-completions + (cdr pcomplete-current-completions))) + (pcomplete-insert-entry pcomplete-last-completion-stub + (car pcomplete-current-completions) + nil pcomplete-last-completion-raw)) + (setq pcomplete-current-completions nil + pcomplete-last-completion-raw nil) + (catch 'pcompleted + (let* ((pcomplete-stub) + pcomplete-seen pcomplete-norm-func + pcomplete-args pcomplete-last pcomplete-index + (pcomplete-autolist pcomplete-autolist) + (pcomplete-suffix-list pcomplete-suffix-list) + (completions (pcomplete-completions)) + (result (pcomplete-do-complete pcomplete-stub completions))) + (and result + (not (eq (car result) 'listed)) + (cdr result) + (pcomplete-insert-entry pcomplete-stub (cdr result) + (memq (car result) + '(sole shortest)) + pcomplete-last-completion-raw)))))) + +(provide 'ledger-complete) + +;;; ledger-complete.el ends here diff --git a/lisp/ledger-context.el b/lisp/ledger-context.el new file mode 100644 index 00000000..b1bcd870 --- /dev/null +++ b/lisp/ledger-context.el @@ -0,0 +1,211 @@ +;;; ledger-context.el --- Helper code for use with the "ledger" command-line tool + +;; Copyright (C) 2003-2013 John Wiegley (johnw AT gnu DOT org) + +;; 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: +;; Provide facilities for reflection in ledger buffers + +;;; Code: + +(eval-when-compile + (require 'cl)) + +;; *-string constants are assembled in the single-line-config macro to +;; form the regex and list of elements +(defconst indent-string "\\(^[ \t]+\\)") +(defconst status-string "\\([*! ]?\\)") +(defconst account-string "[\\[(]?\\(.*?\\)[])]?") +(defconst amount-string "[ \t]?\\(-?[0-9]+\\.[0-9]*\\)") +(defconst comment-string "[ \t]*;[ \t]*\\(.*?\\)") +(defconst nil-string "\\([ \t]+\\)") +(defconst commodity-string "\\(.+?\\)") +(defconst date-string "^\\([0-9]\\{4\\}[/-][01]?[0-9][/-][0123]?[0-9]\\)") +(defconst code-string "\\((.*)\\)?") +(defconst payee-string "\\(.*\\)") + +(defmacro line-regex (&rest elements) + (let (regex-string) + (concat (dolist (e elements regex-string) + (setq regex-string + (concat regex-string + (eval + (intern + (concat (symbol-name e) "-string")))))) "[ \t]*$"))) + +(defmacro single-line-config2 (&rest elements) +"Take list of ELEMENTS and return regex and element list for use in context-at-point" + (let (regex-string) + `'(,(concat (dolist (e elements regex-string) + (setq regex-string + (concat regex-string + (eval + (intern + (concat (symbol-name e) "-string")))))) "[ \t]*$") + ,elements))) + +(defmacro single-line-config (&rest elements) + "Take list of ELEMENTS and return regex and element list for use in context-at-point" + `'(,(eval `(line-regex ,@elements)) + ,elements)) + +(defconst ledger-line-config + (list (list 'xact (list (single-line-config date nil status nil code nil payee nil comment) + (single-line-config date nil status nil code nil payee) + (single-line-config date nil status nil payee))) + (list 'acct-transaction (list (single-line-config indent comment) + (single-line-config2 indent status account nil commodity amount nil comment) + (single-line-config2 indent status account nil commodity amount) + (single-line-config2 indent status account nil amount nil commodity comment) + (single-line-config2 indent status account nil amount nil commodity) + (single-line-config2 indent status account nil amount) + (single-line-config2 indent status account nil comment) + (single-line-config2 indent status account))))) + +(defun ledger-extract-context-info (line-type pos) + "Get context info for current line with LINE-TYPE. + +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-thing-at-point () + "Describe thing at points. Return 'transaction, 'posting, or nil. +Leave point at the beginning of the thing under point" + (let ((here (point))) + (goto-char (line-beginning-position)) + (cond ((looking-at "^[0-9/.=-]+\\(\\s-+\\*\\)?\\(\\s-+(.+?)\\)?\\s-+") + (goto-char (match-end 0)) + 'transaction) + ((looking-at "^\\s-+\\([*!]\\s-+\\)?[[(]?\\(.\\)") + (goto-char (match-beginning 2)) + 'posting) + ((looking-at "^\\(sun\\|mon\\|tue\\|wed\\|thu\\|fri\\|sat\\)\\s-+") + (goto-char (match-end 0)) + 'day) + (t + (ignore (goto-char here)))))) + +(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 +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 'xact pos)) + ((equal first-char ?\=) + '(automated-xact nil nil)) + ((equal first-char ?\~) + '(period-xact 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 from 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))) + +(provide 'ledger-context) + +;;; ledger-report.el ends here diff --git a/lisp/ledger-exec.el b/lisp/ledger-exec.el new file mode 100644 index 00000000..34757d99 --- /dev/null +++ b/lisp/ledger-exec.el @@ -0,0 +1,101 @@ +;;; ledger-exec.el --- Helper code for use with the "ledger" command-line tool + +;; Copyright (C) 2003-2013 John Wiegley (johnw AT gnu DOT org) + +;; 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: +;; Code for executing ledger synchronously. + +;;; Code: + +(defconst ledger-version-needed "3.0.0" + "The version of ledger executable needed for interactive features.") + +(defvar ledger-works nil + "Flag showing whether the ledger binary can support `ledger-mode' interactive features.") + +(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-exec) + +(defun ledger-exec-handle-error (ledger-output) + "Deal with ledger errors contained in LEDGER-OUTPUT." + (with-current-buffer (get-buffer-create "*Ledger Error*") + (insert-buffer-substring ledger-output) + (view-mode) + (setq buffer-read-only t))) + +(defun ledger-exec-success-p (ledger-output-buffer) + (with-current-buffer ledger-output-buffer + (goto-char (point-min)) + (if (and (> (buffer-size) 1) (looking-at (regexp-quote "While"))) + nil ;; failure, there is an error starting with "While" + ledger-output-buffer))) + +(defun ledger-exec-ledger (input-buffer &optional output-buffer &rest args) + "Run Ledger using INPUT-BUFFER and optionally capturing output in OUTPUT-BUFFER with ARGS." + (if (null ledger-binary-path) + (error "The variable `ledger-binary-path' has not been set") + (let ((buf (or input-buffer (current-buffer))) + (outbuf (or output-buffer + (generate-new-buffer " *ledger-tmp*")))) + (with-current-buffer buf + (let ((coding-system-for-write 'utf-8) + (coding-system-for-read 'utf-8)) + (apply #'call-process-region + (append (list (point-min) (point-max) + ledger-binary-path nil outbuf nil "-f" "-") + args))) + (if (ledger-exec-success-p outbuf) + outbuf + (ledger-exec-handle-error outbuf)))))) + +(defun ledger-version-greater-p (needed) + "Verify the ledger binary is usable for `ledger-mode' (version greater than NEEDED)." + (let ((buffer ledger-buf) + (version-strings '())) + (with-temp-buffer + (when (ledger-exec-ledger (current-buffer) (current-buffer) "--version") + (goto-char (point-min)) + (delete-horizontal-space) + (setq version-strings (split-string + (buffer-substring-no-properties (point) + (point-max)))) + (if (and (string-match (regexp-quote "Ledger") (car version-strings)) + (or (string= needed (cadr version-strings)) + (string< needed (cadr version-strings)))) + t ;; success + nil))))) ;;failure + +(defun ledger-check-version () + "Verify that ledger works and is modern enough." + (interactive) + (if (setq ledger-works (ledger-version-greater-p ledger-version-needed)) + (message "Good Ledger Version") + (message "Bad Ledger Version"))) + +(provide 'ledger-exec) + +;;; ledger-exec.el ends here diff --git a/lisp/ledger-fonts.el b/lisp/ledger-fonts.el new file mode 100644 index 00000000..28f1f98d --- /dev/null +++ b/lisp/ledger-fonts.el @@ -0,0 +1,138 @@ +;;; ledger-fonts.el --- Helper code for use with the "ledger" command-line tool + +;; Copyright (C) 2003-2013 John Wiegley (johnw AT gnu DOT org) + +;; 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: +;; All of the faces for ledger mode are defined here. + +;;; Code: + +(require 'ledger-regex) + +(defgroup ledger-faces nil "Ledger mode highlighting" :group 'ledger) +(defface ledger-font-payee-uncleared-face + `((t :foreground "#dc322f" :weight bold )) + "Default face for Ledger" + :group 'ledger-faces) + +(defface ledger-font-payee-cleared-face + `((t :foreground "#657b83" :weight normal )) + "Default face for cleared (*) transactions" + :group 'ledger-faces) + +(defface ledger-font-xact-highlight-face + `((t :background "#eee8d5")) + "Default face for transaction under point" + :group 'ledger-faces) + +(defface ledger-font-pending-face + `((t :foreground "#cb4b16" :weight normal )) + "Default face for pending (!) transactions" + :group 'ledger-faces) + +(defface ledger-font-other-face + `((t :foreground "#657b83" )) + "Default face for other transactions" + :group 'ledger-faces) + +(defface ledger-font-posting-account-face + `((t :foreground "#268bd2" )) + "Face for Ledger accounts" + :group 'ledger-faces) + +(defface ledger-font-posting-account-cleared-face + `((t :foreground "#657b83" )) + "Face for Ledger accounts" + :group 'ledger-faces) + +(defface ledger-font-posting-account-pending-face + `((t :foreground "#cb4b16" )) + "Face for Ledger accounts" + :group 'ledger-faces) + +(defface ledger-font-posting-amount-face + `((t :foreground "#cb4b16" )) + "Face for Ledger amounts" + :group 'ledger-faces) + +(defface ledger-occur-narrowed-face + `((t :foreground "grey70" :invisible t )) + "Default face for Ledger occur mode hidden transactions" + :group 'ledger-faces) + +(defface ledger-occur-xact-face + `((t :background "#eee8d5" )) + "Default face for Ledger occur mode shown transactions" + :group 'ledger-faces) + +(defface ledger-font-comment-face + `((t :foreground "#93a1a1" :slant italic)) + "Face for Ledger comments" + :group 'ledger-faces) + +(defface ledger-font-reconciler-uncleared-face + `((t :foreground "#dc322f" :weight bold )) + "Default face for uncleared transactions in the reconcile window" + :group 'ledger-faces) + +(defface ledger-font-reconciler-cleared-face + `((t :foreground "#657b83" :weight normal )) + "Default face for cleared (*) transactions in the reconcile window" + :group 'ledger-faces) + +(defface ledger-font-reconciler-pending-face + `((t :foreground "#cb4b16" :weight normal )) + "Default face for pending (!) transactions in the reconcile window" + :group 'ledger-faces) + +(defface ledger-font-report-clickable-face + `((t :foreground "#cb4b16" :weight normal )) + "Default face for pending (!) transactions in the reconcile window" + :group 'ledger-faces) + + +(defvar ledger-font-lock-keywords + `( ;; (,ledger-other-entries-regex 1 + ;; ledger-font-other-face) + (,ledger-comment-regex 0 + 'ledger-font-comment-face) + (,ledger-multiline-comment-regex 0 'ledger-font-comment-face) + (,ledger-payee-pending-regex 2 + 'ledger-font-payee-pending-face) ; Works + (,ledger-payee-cleared-regex 2 + 'ledger-font-payee-cleared-face) ; Works + (,ledger-payee-uncleared-regex 2 + 'ledger-font-payee-uncleared-face) ; Works + (,ledger-account-cleared-regex 2 + 'ledger-font-posting-account-cleared-face) ; Works + (,ledger-account-pending-regex 2 + 'ledger-font-posting-account-pending-face) ; Works + (,ledger-account-any-status-regex 2 + 'ledger-font-posting-account-face) ; Works + (,ledger-other-entries-regex 1 + 'ledger-font-other-face)) + "Expressions to highlight in Ledger mode.") + + +(provide 'ledger-fonts) + +;;; ledger-fonts.el ends here diff --git a/lisp/ledger-init.el b/lisp/ledger-init.el new file mode 100644 index 00000000..fd06d4c5 --- /dev/null +++ b/lisp/ledger-init.el @@ -0,0 +1,68 @@ +;;; ledger-init.el --- Helper code for use with the "ledger" command-line tool + +;; Copyright (C) 2003-2013 John Wiegley (johnw AT gnu DOT org) + +;; 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: +;; Determine the ledger environment + +(require 'ledger-regex) + +(defcustom ledger-init-file-name "~/.ledgerrc" + "Location of the ledger initialization file. nil if you don't have one" + :group 'ledger-exec) + +(defvar ledger-environment-alist nil) + +(defun ledger-init-parse-initialization (buffer) + (with-current-buffer buffer + (let (environment-alist) + (goto-char (point-min)) + (while (re-search-forward ledger-init-string-regex nil t ) + (let ((matchb (match-beginning 0)) ;; save the match data, string-match stamp on it + (matche (match-end 0))) + (end-of-line) + (setq environment-alist + (append environment-alist + (list (cons (let ((flag (buffer-substring-no-properties (+ 2 matchb) matche))) + (if (string-match "[ \t\n\r]+\\'" flag) + (replace-match "" t t flag) + flag)) + (let ((value (buffer-substring-no-properties matche (point) ))) + (if (> (length value) 0) + value + t)))))))) + environment-alist))) + +(defun ledger-init-load-init-file () + (interactive) + (let ((init-base-name (file-name-nondirectory ledger-init-file-name))) + (if (get-buffer init-base-name) ;; init file already loaded, parse it and leave it + (ledger-init-parse-initialization init-base-name) + (when (and ledger-init-file-name + (file-exists-p ledger-init-file-name) + (file-readable-p ledger-init-file-name)) + (find-file-noselect ledger-init-file-name) + (setq ledger-environment-alist + (ledger-init-parse-initialization init-base-name)) + (kill-buffer init-base-name))))) + +(provide 'ledger-init) + +;;; ledger-init.el ends here diff --git a/lisp/ledger-mode.el b/lisp/ledger-mode.el new file mode 100644 index 00000000..0dce4f61 --- /dev/null +++ b/lisp/ledger-mode.el @@ -0,0 +1,298 @@ +;;; ledger-mode.el --- Helper code for use with the "ledger" command-line tool + +;; Copyright (C) 2003-2013 John Wiegley (johnw AT gnu DOT org) + +;; 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: +;; Most of the general ledger-mode code is here. + +;;; Code: + +(require 'ledger-regex) +(require 'esh-util) +(require 'esh-arg) +(require 'ledger-commodities) +(require 'ledger-complete) +(require 'ledger-context) +(require 'ledger-exec) +(require 'ledger-fonts) +(require 'ledger-init) +(require 'ledger-occur) +(require 'ledger-post) +(require 'ledger-reconcile) +(require 'ledger-report) +(require 'ledger-sort) +(require 'ledger-state) +(require 'ledger-test) +(require 'ledger-texi) +(require 'ledger-xact) +(require 'ledger-schedule) + +;;; Code: + +(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.") + +(defconst ledger-mode-version "3.0.0") + +(defun ledger-mode-dump-variable (var) + (if var + (insert (format " %s: %S\n" (symbol-name var) (eval var))))) + +(defun ledger-mode-dump-group (group) + "Dump GROUP customizations to current buffer" + (let ((members (custom-group-members group nil))) + (dolist (member members) + (cond ((eq (cadr member) 'custom-group) + (insert (format "Group %s:\n" (symbol-name (car member)))) + (ledger-mode-dump-group (car member))) + ((eq (cadr member) 'custom-variable) + (ledger-mode-dump-variable (car member))))))) + +(defun ledger-mode-dump-configuration () + "Dump all customizations" + (find-file "ledger-mode-dump") + (ledger-mode-dump-group 'ledger)) + + +(defsubst ledger-current-year () + "The default current year for adding transactions." + (format-time-string "%Y")) +(defsubst ledger-current-month () + "The default current month for adding transactions." + (format-time-string "%m")) + +(defvar ledger-year (ledger-current-year) + "Start a ledger session with the current year, but make it customizable to ease retro-entry.") + +(defvar ledger-month (ledger-current-month) + "Start a ledger session with the current month, but make it customizable to ease retro-entry.") + +(defun ledger-read-account-with-prompt (prompt) + (let* ((context (ledger-context-at-point)) + (default (if (and (eq (ledger-context-line-type context) 'acct-transaction) + (eq (ledger-context-current-field context) 'account)) + (regexp-quote (ledger-context-field-value context 'account)) + nil))) + (ledger-read-string-with-default prompt default))) + +(defun ledger-read-string-with-default (prompt default) + "Return user supplied string after PROMPT, or DEFAULT." + (read-string (concat prompt + (if default + (concat " (" default "): ") + ": ")) + nil 'ledger-minibuffer-history default)) + +(defun ledger-display-balance-at-point () + "Display the cleared-or-pending balance. +And calculate the target-delta of the account being reconciled." + (interactive) + (let* ((account (ledger-read-account-with-prompt "Account balance to show")) + (buffer (current-buffer)) + (balance (with-temp-buffer + (ledger-exec-ledger buffer (current-buffer) "cleared" account) + (if (> (buffer-size) 0) + (buffer-substring-no-properties (point-min) (1- (point-max))) + (concat account " is empty."))))) + (when balance + (message balance)))) + +(defun ledger-display-ledger-stats () + "Display the cleared-or-pending balance. +And calculate the target-delta of the account being reconciled." + (interactive) + (let* ((buffer (current-buffer)) + (balance (with-temp-buffer + (ledger-exec-ledger buffer (current-buffer) "stats") + (buffer-substring-no-properties (point-min) (1- (point-max)))))) + (when balance + (message balance)))) + +(defun ledger-magic-tab (&optional interactively) + "Decide what to with with . +Can indent, complete or align depending on context." + (interactive "p") + (if (= (point) (line-beginning-position)) + (indent-to ledger-post-account-alignment-column) + (if (and (> (point) 1) + (looking-back "\\([^ \t]\\)" 1)) + (ledger-pcomplete interactively) + (ledger-post-align-postings)))) + +(defvar ledger-mode-abbrev-table) + +(defun ledger-insert-effective-date () + (interactive) + (let ((context (car (ledger-context-at-point))) + (date-string (format-time-string (cdr (assoc "date-format" ledger-environment-alist))))) + (cond ((eq 'xact context) + (beginning-of-line) + (insert date-string "=")) + ((eq 'acct-transaction context) + (end-of-line) + (insert " ; [=" date-string "]"))))) + +(defun ledger-mode-remove-extra-lines () + (goto-char (point-min)) + (while (re-search-forward "\n\n\\(\n\\)+" nil t) + (replace-match "\n\n"))) + +(defun ledger-mode-clean-buffer () + "indent, remove multiple linfe feeds and sort the buffer" + (interactive) + (ledger-sort-buffer) + (ledger-post-align-postings (point-min) (point-max)) + (ledger-mode-remove-extra-lines)) + + +;;;###autoload +(define-derived-mode ledger-mode text-mode "Ledger" + "A mode for editing ledger data files." + (ledger-check-version) + (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))) + (setq font-lock-extend-region-functions + (list #'font-lock-extend-region-wholelines)) + (setq font-lock-multiline nil) + + (set (make-local-variable 'pcomplete-parse-arguments-function) + 'ledger-parse-arguments) + (set (make-local-variable 'pcomplete-command-completion-function) + 'ledger-complete-at-point) + (set (make-local-variable 'pcomplete-termination-string) "") + + (add-hook 'post-command-hook 'ledger-highlight-xact-under-point nil t) + (add-hook 'before-revert-hook 'ledger-occur-remove-all-overlays nil t) + (make-variable-buffer-local 'highlight-overlay) + + (ledger-init-load-init-file) + + (set (make-local-variable 'indent-region-function) 'ledger-post-align-postings) + + (let ((map (current-local-map))) + (define-key map [(control ?c) (control ?a)] 'ledger-add-transaction) + (define-key map [(control ?c) (control ?b)] 'ledger-post-edit-amount) + (define-key map [(control ?c) (control ?c)] 'ledger-toggle-current) + (define-key map [(control ?c) (control ?d)] 'ledger-delete-current-transaction) + (define-key map [(control ?c) (control ?e)] 'ledger-toggle-current-transaction) + (define-key map [(control ?c) (control ?f)] 'ledger-occur) + (define-key map [(control ?c) (control ?k)] 'ledger-copy-transaction-at-point) + (define-key map [(control ?c) (control ?m)] 'ledger-set-month) + (define-key map [(control ?c) (control ?r)] 'ledger-reconcile) + (define-key map [(control ?c) (control ?s)] 'ledger-sort-region) + (define-key map [(control ?c) (control ?t)] 'ledger-insert-effective-date) + (define-key map [(control ?c) (control ?u)] 'ledger-schedule-upcoming) + (define-key map [(control ?c) (control ?y)] 'ledger-set-year) + (define-key map [(control ?c) (control ?p)] 'ledger-display-balance-at-point) + (define-key map [(control ?c) (control ?l)] 'ledger-display-ledger-stats) + (define-key map [(control ?c) (control ?q)] 'ledger-post-align-xact) + + (define-key map [tab] 'ledger-magic-tab) + (define-key map [(control tab)] 'ledger-post-align-xact) + (define-key map [(control ?i)] 'ledger-magic-tab) + (define-key map [(control ?c) tab] 'ledger-fully-complete-xact) + (define-key map [(control ?c) (control ?i)] 'ledger-fully-complete-xact) + + (define-key map [(control ?c) (control ?o) (control ?a)] 'ledger-report-redo) + (define-key map [(control ?c) (control ?o) (control ?e)] 'ledger-report-edit) + (define-key map [(control ?c) (control ?o) (control ?g)] 'ledger-report-goto) + (define-key map [(control ?c) (control ?o) (control ?k)] 'ledger-report-kill) + (define-key map [(control ?c) (control ?o) (control ?r)] 'ledger-report) + (define-key map [(control ?c) (control ?o) (control ?s)] 'ledger-report-save) + + (define-key map [(meta ?p)] 'ledger-post-prev-xact) + (define-key map [(meta ?n)] 'ledger-post-next-xact) + + (define-key map [menu-bar] (make-sparse-keymap "ledger-menu")) + (define-key map [menu-bar ledger-menu] (cons "Ledger" map)) + + (define-key map [report-kill] '(menu-item "Kill Report" ledger-report-kill :enable ledger-works)) + (define-key map [report-edit] '(menu-item "Edit Report" ledger-report-edit :enable ledger-works)) + (define-key map [report-save] '(menu-item "Save Report" ledger-report-save :enable ledger-works)) + (define-key map [report-rrun] '(menu-item "Re-run Report" ledger-report-redo :enable ledger-works)) + (define-key map [report-goto] '(menu-item "Goto Report" ledger-report-goto :enable ledger-works)) + (define-key map [report-run] '(menu-item "Run Report" ledger-report :enable ledger-works)) + (define-key map [sep5] '(menu-item "--")) + (define-key map [set-month] '(menu-item "Set Month" ledger-set-month :enable ledger-works)) + (define-key map [set-year] '(menu-item "Set Year" ledger-set-year :enable ledger-works)) + (define-key map [cust] '(menu-item "Customize Ledger Mode" (lambda () + (interactive) + (customize-group 'ledger)))) + (define-key map [sep1] '("--")) + (define-key map [effective-date] '(menu-item "Set effective date" ledger-insert-effective-date)) + (define-key map [sort-end] '(menu-item "Mark Sort End" ledger-sort-insert-end-mark)) + (define-key map [sort-start] '(menu-item "Mark Sort Beginning" ledger-sort-insert-start-mark)) + (define-key map [sort-buff] '(menu-item "Sort Buffer" ledger-sort-buffer)) + (define-key map [sort-reg] '(menu-item "Sort Region" ledger-sort-region :enable mark-active)) + (define-key map [align-xact] '(menu-item "Align Xact" ledger-post-align-xact)) + (define-key map [align-reg] '(menu-item "Align Region" ledger-post-align-postings :enable mark-active)) + (define-key map [clean-buf] '(menu-item "Clean-up Buffer" ledger-mode-clean-buffer)) + (define-key map [sep2] '(menu-item "--")) + (define-key map [copy-xact] '(menu-item "Copy Trans at Point" ledger-copy-transaction-at-point)) + (define-key map [toggle-post] '(menu-item "Toggle Current Posting" ledger-toggle-current)) + (define-key map [toggle-xact] '(menu-item "Toggle Current Transaction" ledger-toggle-current-transaction)) + (define-key map [sep4] '(menu-item "--")) + (define-key map [recon-account] '(menu-item "Reconcile Account" ledger-reconcile :enable ledger-works)) + (define-key map [check-balance] '(menu-item "Check Balance" ledger-display-balance-at-point :enable ledger-works)) + (define-key map [sep6] '(menu-item "--")) + (define-key map [edit-amount] '(menu-item "Calc on Amount" ledger-post-edit-amount)) + (define-key map [sep] '(menu-item "--")) + (define-key map [delete-xact] '(menu-item "Delete Transaction" ledger-delete-current-transaction)) + (define-key map [cmp-xact] '(menu-item "Complete Transaction" ledger-fully-complete-xact)) + (define-key map [add-xact] '(menu-item "Add Transaction (ledger xact)" ledger-add-transaction :enable ledger-works)) + (define-key map [sep3] '(menu-item "--")) + (define-key map [stats] '(menu-item "Ledger Statistics" ledger-display-ledger-stats :enable ledger-works)) + (define-key map [fold-buffer] '(menu-item "Narrow to REGEX" ledger-occur)))) + + + + +(defun ledger-set-year (newyear) + "Set ledger's idea of the current year to the prefix argument NEWYEAR." + (interactive "p") + (if (= newyear 1) + (setq ledger-year (read-string "Year: " (ledger-current-year))) + (setq ledger-year (number-to-string newyear)))) + +(defun ledger-set-month (newmonth) + "Set ledger's idea of the current month to the prefix argument NEWMONTH." + (interactive "p") + (if (= newmonth 1) + (setq ledger-month (read-string "Month: " (ledger-current-month))) + (setq ledger-month (format "%02d" newmonth)))) + + + +(provide 'ledger) + +;;; ledger-mode.el ends here diff --git a/lisp/ledger-occur.el b/lisp/ledger-occur.el new file mode 100644 index 00000000..33d3a56c --- /dev/null +++ b/lisp/ledger-occur.el @@ -0,0 +1,192 @@ +;;; ledger-mode.el --- Helper code for use with the "ledger" command-line tool + +;; Copyright (C) 2003-2013 John Wiegley (johnw AT gnu DOT org) + +;; 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: +;; Provide buffer narrowing to ledger mode. Adapted from original loccur +;; mode by Alexey Veretennikov +;; +;; Adapted to ledger mode by Craig Earls + +;;; Code: + +(defconst ledger-occur-overlay-property-name 'ledger-occur-custom-buffer-grep) + +(defcustom ledger-occur-use-face-shown t + "If non-nil, use a custom face for xacts shown in `ledger-occur' mode using ledger-occur-xact-face." + :type 'boolean + :group 'ledger) +(make-variable-buffer-local 'ledger-occur-use-face-shown) + + +(defvar ledger-occur-mode nil + "name of the minor mode, shown in the mode-line") + +(make-variable-buffer-local 'ledger-occur-mode) + +(or (assq 'ledger-occur-mode minor-mode-alist) + (nconc minor-mode-alist + (list '(ledger-occur-mode ledger-occur-mode)))) + +(defvar ledger-occur-history nil + "History of previously searched expressions for the prompt.") + +(defvar ledger-occur-last-match nil + "Last match found.") +(make-variable-buffer-local 'ledger-occur-last-match) + +(defun ledger-occur-remove-all-overlays () + "Remove all overlays from the ledger buffer." + (interactive) + (remove-overlays)) + +(defun ledger-occur-mode (regex buffer) + "Highlight transactions that match REGEX in BUFFER, hiding others. + +When REGEX is nil, unhide everything, and remove higlight" + (set-buffer buffer) + (setq ledger-occur-mode + (if (or (null regex) + (zerop (length regex))) + nil + (concat " Ledger-Narrowed: " regex))) + (force-mode-line-update) + (ledger-occur-remove-overlays) + (when ledger-occur-mode + (ledger-occur-create-overlays + (ledger-occur-compress-matches + (ledger-occur-find-matches regex))) + (setq ledger-occur-last-match regex) + (if (get-buffer-window buffer) + (select-window (get-buffer-window buffer)))) + (recenter)) + +(defun ledger-occur (regex) + "Perform a simple grep in current buffer for the regular expression REGEX. + + This command hides all xact from the current buffer except + those containing the regular expression REGEX. A second call + of the function unhides lines again" + (interactive + (if ledger-occur-mode + (list nil) + (list (read-string (concat "Regexp<" (ledger-occur-prompt) ">: ") + nil 'ledger-occur-history (ledger-occur-prompt))))) + (ledger-occur-mode regex (current-buffer))) + +(defun ledger-occur-prompt () + "Return the default value of the prompt. + + Default value for prompt is a current word or active + region(selection), if its size is 1 line" + (let ((prompt + (if (and transient-mark-mode + mark-active) + (let ((pos1 (region-beginning)) + (pos2 (region-end))) + ;; Check if the start and the of an active region is on + ;; the same line + (if (= (line-number-at-pos pos1) + (line-number-at-pos pos2)) + (buffer-substring-no-properties pos1 pos2))) + (current-word)))) + prompt)) + + +(defun ledger-occur-make-visible-overlay (beg end) + (let ((ovl (make-overlay beg end (current-buffer)))) + (overlay-put ovl ledger-occur-overlay-property-name t) + (overlay-put ovl 'face 'ledger-occur-xact-face))) + +(defun ledger-occur-make-invisible-overlay (beg end) + (let ((ovl (make-overlay beg end (current-buffer)))) + (overlay-put ovl ledger-occur-overlay-property-name t) + (overlay-put ovl 'invisible t))) + +(defun ledger-occur-create-overlays (ovl-bounds) + "Create the overlays for the visible transactions. +Argument OVL-BOUNDS contains bounds for the transactions to be left visible." + (let* ((beg (caar ovl-bounds)) + (end (cadar ovl-bounds))) + (ledger-occur-make-invisible-overlay (point-min) (1- beg)) + (dolist (visible (cdr ovl-bounds)) + (ledger-occur-make-visible-overlay beg end) + (ledger-occur-make-invisible-overlay (1+ end) (1- (car visible))) + (setq beg (car visible)) + (setq end (cadr visible))) + (ledger-occur-make-invisible-overlay (1+ end) (point-max)))) + +(defun ledger-occur-quit-buffer (buffer) + "Quits hidings transaction in the given BUFFER. +Used for coordinating `ledger-occur' with other buffers, like reconcile." + (set-buffer buffer) + (setq ledger-occur-mode nil) + (force-mode-line-update) + (ledger-occur-remove-overlays) + (recenter)) + +(defun ledger-occur-remove-overlays () + "Remove the transaction hiding overlays." + (interactive) + (remove-overlays (point-min) + (point-max) ledger-occur-overlay-property-name t) + (setq ledger-occur-overlay-list nil)) + +(defun ledger-occur-find-matches (regex) + "Return a list of 2-number tuples describing the beginning and end of transactions meeting REGEX." + (save-excursion + (goto-char (point-min)) + ;; Set initial values for variables + (let (curpoint + endpoint + (lines (list))) + ;; Search loop + (while (not (eobp)) + (setq curpoint (point)) + ;; if something found + (when (setq endpoint (re-search-forward regex nil 'end)) + (save-excursion + (let ((bounds (ledger-find-xact-extents (match-beginning 0)))) + (push bounds lines) + (setq curpoint (cadr bounds)))) ;; move to the end of + ;; the xact, no need to + ;; search inside it more + (goto-char curpoint)) + (forward-line 1)) + (setq lines (nreverse lines))))) + +(defun ledger-occur-compress-matches (buffer-matches) + "identify sequential xacts to reduce number of overlays required" + (let ((points (list)) + (current-beginning (caar buffer-matches)) + (current-end (cadar buffer-matches))) + (dolist (match (cdr buffer-matches)) + (if (< (- (car match) current-end) 2) + (setq current-end (cadr match)) + (push (list current-beginning current-end) points) + (setq current-beginning (car match)) + (setq current-end (cadr match)))) + (nreverse (push (list current-beginning current-end) points)))) + +(provide 'ledger-occur) + +;;; ledger-occur.el ends here diff --git a/lisp/ledger-post.el b/lisp/ledger-post.el new file mode 100644 index 00000000..447a34f8 --- /dev/null +++ b/lisp/ledger-post.el @@ -0,0 +1,249 @@ +;;; ledger-post.el --- Helper code for use with the "ledger" command-line tool + +;; Copyright (C) 2003-2013 John Wiegley (johnw AT gnu DOT org) + +;; 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: +;; Utility functions for dealing with postings. + +(require 'ledger-regex) + +;;; Code: + +(defgroup ledger-post nil + "Options for controlling how Ledger-mode deals with postings and completion" + :group 'ledger) + +(defcustom ledger-post-account-alignment-column 4 + "The column Ledger-mode attempts to align accounts to." + :type 'integer + :group 'ledger-post) + +(defcustom ledger-post-amount-alignment-column 52 + "The column Ledger-mode attempts to align amounts to." + :type 'integer + :group 'ledger-post) + +(defcustom ledger-post-use-completion-engine :built-in + "Which completion engine to use, :iswitchb or :ido chose those engines, +:built-in uses built-in Ledger-mode completion" + :type '(radio (const :tag "built in completion" :built-in) + (const :tag "ido completion" :ido) + (const :tag "iswitchb completion" :iswitchb) ) + :group 'ledger-post) + +(defun ledger-post-all-accounts () + "Return a list of all accounts in the buffer." + (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) + +(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." + (cond ((eq ledger-post-use-completion-engine :iswitchb) + (let* ((iswitchb-use-virtual-buffers nil) + (iswitchb-make-buflist-hook + (lambda () + (setq iswitchb-temp-buflist choices)))) + (iswitchb-read-buffer prompt))) + ((eq ledger-post-use-completion-engine :ido) + (ido-completing-read prompt choices)) + (t + (completing-read prompt choices)))) + +(defvar ledger-post-current-list nil) + +(defun ledger-post-pick-account () + "Insert an account entered by the user." + (interactive) + (let* ((account + (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-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) + (insert (make-string (- existing-len account-len) ? ))) + ((< existing-len account-len) + (dotimes (n (- account-len existing-len)) + (if (looking-at "[ \t]\\( [ \t]\\|\t\\)") + (delete-char 1))))))) + (goto-char pos))) + + + +(defsubst ledger-next-amount (&optional end) + "Move point to the next amount, as long as it is not past END. +Return the width of the amount field as an integer and leave +point at beginning of the commodity." + ;;(beginning-of-line) + (when (re-search-forward ledger-amount-regex end t) + (goto-char (match-beginning 0)) + (skip-syntax-forward " ") + (- (or (match-end 4) + (match-end 3)) (point)))) + + +(defun ledger-next-account (&optional end) + "Move point to the beginning of the next account, or status marker (!*), as long as it is not past END. +Return the column of the beginning of the account and leave point +at beginning of account" + (if (> end (point)) + (when (re-search-forward ledger-account-any-status-regex (1+ end) t) + ;; the 1+ is to make sure we can catch the newline + (if (match-beginning 1) + (goto-char (match-beginning 1)) + (goto-char (match-beginning 2))) + (current-column)))) + +(defun ledger-post-align-xact (pos) + (interactive "d") + (let ((bounds (ledger-find-xact-extents pos))) + (ledger-post-align-postings (car bounds) (cadr bounds)))) + +(defun ledger-post-align-postings (&optional beg end) + "Align all accounts and amounts within region, if there is no +region align the posting on the current line." + (interactive) + (assert (eq major-mode 'ledger-mode)) + + (save-excursion + (if (or (not (mark)) + (not (use-region-p))) + (set-mark (point))) + + (let* ((inhibit-modification-hooks t) + (mark-first (< (mark) (point))) + (begin-region (if beg + beg + (if mark-first (mark) (point)))) + (end-region (if end + end + (if mark-first (point) (mark)))) + acct-start-column acct-end-column acct-adjust amt-width + (lines-left 1)) + ;; Condition point and mark to the beginning and end of lines + (goto-char end-region) + (setq end-region (line-end-position)) + (goto-char begin-region) + (goto-char + (setq begin-region + (line-beginning-position))) + + ;; This is the guts of the alignment loop + (while (and (or (setq acct-start-column (ledger-next-account (line-end-position))) + lines-left) + (< (point) end-region)) + (when acct-start-column + (setq acct-end-column (save-excursion + (goto-char (match-end 2)) + (current-column))) + (when (/= (setq acct-adjust (- ledger-post-account-alignment-column acct-start-column)) 0) + (setq acct-end-column (+ acct-end-column acct-adjust)) ;;adjust the account ending column + (if (> acct-adjust 0) + (insert (make-string acct-adjust ? )) + (delete-char acct-adjust))) + (when (setq amt-width (ledger-next-amount (line-end-position))) + (if (/= 0 (setq amt-adjust (- (if (> (- ledger-post-amount-alignment-column amt-width) + (+ 2 acct-end-column)) + ledger-post-amount-alignment-column ;;we have room + (+ acct-end-column 2 amt-width)) + amt-width + (current-column)))) + (if (> amt-adjust 0) + (insert (make-string amt-adjust ? )) + (delete-char amt-adjust))))) + (forward-line) + (setq lines-left (not (eobp)))) + (setq inhibit-modification-hooks nil)))) + + + +(defun ledger-post-edit-amount () + "Call 'calc-mode' and push the amount in the posting to the top of stack." + (interactive) + (goto-char (line-beginning-position)) + (when (re-search-forward ledger-post-line-regexp (line-end-position) t) + (goto-char (match-end ledger-regex-post-line-group-account)) ;; go to the and of the account + (let ((end-of-amount (re-search-forward "[-.,0-9]+" (line-end-position) t))) + ;; determine if there is an amount to edit + (if end-of-amount + (let ((val (ledger-string-to-number (match-string 0)))) + (goto-char (match-beginning 0)) + (delete-region (match-beginning 0) (match-end 0)) + (calc) + (calc-eval val 'push)) ;; edit the amount + (progn ;;make sure there are two spaces after the account name and go to calc + (if (search-backward " " (- (point) 3) t) + (goto-char (line-end-position)) + (insert " ")) + (calc)))))) + +(defun ledger-post-prev-xact () + "Move point to the previous transaction." + (interactive) + (backward-paragraph) + (when (re-search-backward ledger-xact-line-regexp nil t) + (goto-char (match-beginning 0)) + (re-search-forward ledger-post-line-regexp) + (goto-char (match-end ledger-regex-post-line-group-account)))) + +(defun ledger-post-next-xact () + "Move point to the next transaction." + (interactive) + (when (re-search-forward ledger-xact-line-regexp nil t) + (goto-char (match-beginning 0)) + (re-search-forward ledger-post-line-regexp) + (goto-char (match-end ledger-regex-post-line-group-account)))) + +(defun ledger-post-setup () + "Configure `ledger-mode' to auto-align postings." + (add-hook 'after-save-hook #'(lambda () (setq ledger-post-current-list nil)) t t)) + + + +(provide 'ledger-post) + + + +;;; ledger-post.el ends here diff --git a/lisp/ledger-reconcile.el b/lisp/ledger-reconcile.el new file mode 100644 index 00000000..4725c6e4 --- /dev/null +++ b/lisp/ledger-reconcile.el @@ -0,0 +1,485 @@ +;;; ledger-reconcile.el --- Helper code for use with the "ledger" command-line tool + +;; Copyright (C) 2003-2013 John Wiegley (johnw AT gnu DOT org) + +;; 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. + +;; Reconcile mode + + +;;; Commentary: +;; Code to handle reconciling Ledger files wiht outside sources + +;;; Code: + +(defvar ledger-buf nil) +(defvar ledger-bufs nil) +(defvar ledger-acct nil) +(defvar ledger-target nil) + +(defgroup ledger-reconcile nil + "Options for Ledger-mode reconciliation" + :group 'ledger) + +(defcustom ledger-recon-buffer-name "*Reconcile*" + "Name to use for reconciliation window." + :group 'ledger-reconcile) + +(defcustom ledger-narrow-on-reconcile t + "If t, limit transactions shown in main buffer to those matching the reconcile regex." + :type 'boolean + :group 'ledger-reconcile) + +(defcustom ledger-buffer-tracks-reconcile-buffer t + "If t, then when the cursor is moved to a new xact in the recon window. +Then that transaction will be shown in its source buffer." + :type 'boolean + :group 'ledger-reconcile) + +(defcustom ledger-reconcile-force-window-bottom nil + "If t make the reconcile window appear along the bottom of the register window and resize." + :type 'boolean + :group 'ledger-reconcile) + +(defcustom ledger-reconcile-toggle-to-pending t + "If true then toggle between uncleared and pending. +reconcile-finish will mark all pending posting cleared." + :type 'boolean + :group 'ledger-reconcile) + +(defcustom ledger-reconcile-default-date-format "%Y/%m/%d" + "Default date format for the reconcile buffer" + :type 'string + :group 'ledger-reconcile) + +(defcustom ledger-reconcile-target-prompt-string "Target amount for reconciliation " + "Default prompt for recon target prompt" + :type 'string + :group 'ledger-reconcile) + +(defvar ledger-reconcile-sort-key "(date)" + "Default key for sorting reconcile buffer") + +(defun ledger-reconcile-get-cleared-or-pending-balance (buffer account) + "Calculate the cleared or pending balance of the account." + + ;; these vars are buffer local, need to hold them for use in the + ;; temp buffer below + + (with-temp-buffer + ;; note that in the line below, the --format option is + ;; separated from the actual format string. emacs does not + ;; split arguments like the shell does, so you need to + ;; specify the individual fields in the command line. + (if (ledger-exec-ledger buffer (current-buffer) + "balance" "--limit" "cleared or pending" "--empty" "--collapse" + "--format" "%(display_total)" account) + (ledger-split-commodity-string + (buffer-substring-no-properties (point-min) (point-max)))))) + +(defun ledger-display-balance () + "Display the cleared-or-pending balance. +And calculate the target-delta of the account being reconciled." + (interactive) + (let* ((pending (ledger-reconcile-get-cleared-or-pending-balance ledger-buf ledger-acct))) + (when pending + (if ledger-target + (message "Pending balance: %s, Difference from target: %s" + (ledger-commodity-to-string pending) + (ledger-commodity-to-string (-commodity ledger-target pending))) + (message "Pending balance: %s" + (ledger-commodity-to-string pending)))))) + +(defun is-stdin (file) + "True if ledger FILE is standard input." + (or + (equal file "") + (equal file "") + (equal file "/dev/stdin"))) + +(defun ledger-reconcile-get-buffer (where) + "Return a buffer from WHERE the transaction is." + (if (bufferp (car where)) + (car where) + (error "Function ledger-reconcile-get-buffer: Buffer not set"))) + +(defun ledger-reconcile-toggle () + "Toggle the current transaction, and mark the recon window." + (interactive) + (beginning-of-line) + (let ((where (get-text-property (point) 'where)) + (inhibit-read-only t) + status) + (when (ledger-reconcile-get-buffer where) + (with-current-buffer (ledger-reconcile-get-buffer where) + (ledger-goto-line (cdr where)) + (forward-char) + (setq status (ledger-toggle-current (if ledger-reconcile-toggle-to-pending + 'pending + 'cleared)))) + ;; remove the existing face and add the new face + (remove-text-properties (line-beginning-position) + (line-end-position) + (list 'face)) + (cond ((eq status 'pending) + (add-text-properties (line-beginning-position) + (line-end-position) + (list 'face 'ledger-font-reconciler-pending-face ))) + ((eq status 'cleared) + (add-text-properties (line-beginning-position) + (line-end-position) + (list 'face 'ledger-font-reconciler-cleared-face ))) + (t + (add-text-properties (line-beginning-position) + (line-end-position) + (list 'face 'ledger-font-reconciler-uncleared-face ))))) + (forward-line) + (beginning-of-line) + (ledger-display-balance))) + +(defun ledger-reconcile-refresh () + "Force the reconciliation window to refresh. +Return the number of uncleared xacts found." + (interactive) + (let ((inhibit-read-only t)) + (erase-buffer) + (prog1 + (ledger-do-reconcile ledger-reconcile-sort-key) + (set-buffer-modified-p t)))) + +(defun ledger-reconcile-refresh-after-save () + "Refresh the recon-window after the ledger buffer is saved." + (let ((curbuf (current-buffer)) + (curpoint (point)) + (recon-buf (get-buffer ledger-recon-buffer-name))) + (when (buffer-live-p recon-buf) + (with-current-buffer recon-buf + (ledger-reconcile-refresh) + (set-buffer-modified-p nil)) + (select-window (get-buffer-window curbuf)) + (goto-char curpoint)))) + +(defun ledger-reconcile-add () + "Use ledger xact to add a new transaction." + (interactive) + (with-current-buffer ledger-buf + (call-interactively #'ledger-add-transaction)) + (ledger-reconcile-refresh)) + +(defun ledger-reconcile-delete () + "Delete the transactions pointed to in the recon window." + (interactive) + (let ((where (get-text-property (point) 'where))) + (when (ledger-reconcile-get-buffer where) + (with-current-buffer (ledger-reconcile-get-buffer where) + (ledger-goto-line (cdr where)) + (ledger-delete-current-transaction)) + (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 (&optional come-back) + "Recenter ledger buffer on transaction and COME-BACK if non-nil." + (interactive) + (progn + (beginning-of-line) + (let* ((where (get-text-property (1+ (point)) 'where)) + (target-buffer (if where + (ledger-reconcile-get-buffer where) + nil)) + (cur-win (get-buffer-window (get-buffer ledger-recon-buffer-name)))) + (when target-buffer + (switch-to-buffer-other-window target-buffer) + (ledger-goto-line (cdr where)) + (forward-char) + (recenter) + (ledger-highlight-xact-under-point) + (forward-char -1) + (if (and come-back cur-win) + (select-window cur-win)))))) + +(defun ledger-reconcile-save () + "Save the ledger buffer." + (interactive) + (let ((curpoint (point))) + (dolist (buf (cons ledger-buf ledger-bufs)) + (with-current-buffer buf + (save-buffer))) + (with-current-buffer (get-buffer ledger-recon-buffer-name) + (set-buffer-modified-p nil) + (ledger-display-balance) + (goto-char curpoint) + (ledger-reconcile-visit t)))) + +(defun ledger-reconcile-finish () + "Mark all pending posting or transactions as cleared. +Depends on ledger-reconcile-clear-whole-transactions, save the buffers +and exit reconcile mode" + (interactive) + (save-excursion + (goto-char (point-min)) + (while (not (eobp)) + (let ((where (get-text-property (point) 'where)) + (face (get-text-property (point) 'face))) + (if (eq face 'ledger-font-reconciler-pending-face) + (with-current-buffer (ledger-reconcile-get-buffer where) + (ledger-goto-line (cdr where)) + (ledger-toggle-current 'cleared)))) + (forward-line 1))) + (ledger-reconcile-save) + (ledger-reconcile-quit)) + + +(defun ledger-reconcile-quit () + "Quit the reconcile window without saving ledger buffer." + (interactive) + (let ((recon-buf (get-buffer ledger-recon-buffer-name)) + buf) + (if recon-buf + (with-current-buffer recon-buf + (ledger-reconcile-quit-cleanup) + (setq buf ledger-buf) + ;; Make sure you delete the window before you delete the buffer, + ;; otherwise, madness ensues + (delete-window (get-buffer-window recon-buf)) + (kill-buffer recon-buf) + (set-window-buffer (selected-window) buf))))) + +(defun ledger-reconcile-quit-cleanup () + "Cleanup all hooks established by reconcile mode." + (interactive) + (let ((buf ledger-buf)) + (if (buffer-live-p buf) + (with-current-buffer buf + (remove-hook 'after-save-hook 'ledger-reconcile-refresh-after-save t) + (when ledger-narrow-on-reconcile + (ledger-occur-quit-buffer buf) + (ledger-highlight-xact-under-point)))))) + +(defun ledger-marker-where-xact-is (emacs-xact posting) + "Find the position of the EMACS-XACT in the `ledger-buf'. +POSTING is used in `ledger-clear-whole-transactions' is nil." + (let ((buf (if (is-stdin (nth 0 emacs-xact)) + ledger-buf + (find-file-noselect (nth 0 emacs-xact))))) + (cons + buf + (if ledger-clear-whole-transactions + (nth 1 emacs-xact) ;; return line-no of xact + (nth 0 posting))))) ;; return line-no of posting + +(defun ledger-do-reconcile (&optional sort) + "Return the number of uncleared transactions in the account and display them in the *Reconcile* buffer." + (let* ((buf ledger-buf) + (account ledger-acct) + (ledger-success nil) + (sort-by (if sort + sort + "(date)")) + (xacts + (with-temp-buffer + (when (ledger-exec-ledger buf (current-buffer) + "--uncleared" "--real" "emacs" "--sort" sort-by account) + (setq ledger-success t) + (goto-char (point-min)) + (unless (eobp) + (if (looking-at "(") + (read (current-buffer)))))))) ;current-buffer is the *temp* created above + (if (and ledger-success (> (length xacts) 0)) + (let ((date-format (cdr (assoc "date-format" ledger-environment-alist)))) + (dolist (xact xacts) + (dolist (posting (nthcdr 5 xact)) + (let ((beg (point)) + (where (ledger-marker-where-xact-is xact posting))) + (insert (format "%s %-4s %-30s %-30s %15s\n" + (format-time-string (if date-format + date-format + ledger-reconcile-default-date-format) (nth 2 xact)) + (if (nth 3 xact) + (nth 3 xact) + "") + (nth 4 xact) (nth 1 posting) (nth 2 posting))) + (if (nth 3 posting) + (if (eq (nth 3 posting) 'pending) + (set-text-properties beg (1- (point)) + (list 'face 'ledger-font-reconciler-pending-face + 'where where)) + (set-text-properties beg (1- (point)) + (list 'face 'ledger-font-reconciler-cleared-face + 'where where))) + (set-text-properties beg (1- (point)) + (list 'face 'ledger-font-reconciler-uncleared-face + 'where where)))) )) + (goto-char (point-max)) + (delete-char -1)) ;gets rid of the extra line feed at the bottom of the list + (if ledger-success + (insert (concat "There are no uncleared entries for " account)) + (insert "Ledger has reported a problem. Check *Ledger Error* buffer."))) + (goto-char (point-min)) + (set-buffer-modified-p nil) + (toggle-read-only t) + + (ledger-reconcile-ensure-xacts-visible) + (length xacts))) + +(defun ledger-reconcile-ensure-xacts-visible () + "Ensures that the last of the visible transactions in the +ledger buffer is at the bottom of the main window. The key to +this is to ensure the window is selected when the buffer point is +moved and recentered. If they aren't strange things happen." + + (let ((recon-window (get-buffer-window (get-buffer ledger-recon-buffer-name)))) + (when recon-window + (fit-window-to-buffer recon-window) + (with-current-buffer buf + (add-hook 'kill-buffer-hook 'ledger-reconcile-quit nil t) + (if (get-buffer-window buf) + (select-window (get-buffer-window buf))) + (goto-char (point-max)) + (recenter -1)) + (select-window recon-window) + (ledger-reconcile-visit t)) + (add-hook 'post-command-hook 'ledger-reconcile-track-xact nil t))) + +(defun ledger-reconcile-track-xact () + "Force the ledger buffer to recenter on the transaction at point in the reconcile buffer." + (if (and ledger-buffer-tracks-reconcile-buffer + (member this-command (list 'next-line + 'previous-line + 'mouse-set-point + 'ledger-reconcile-toggle + 'end-of-buffer + 'beginning-of-buffer))) + (save-excursion + (ledger-reconcile-visit t)))) + +(defun ledger-reconcile-open-windows (buf rbuf) + "Ensure that the ledger buffer BUF is split by RBUF." + (if ledger-reconcile-force-window-bottom + ;;create the *Reconcile* window directly below the ledger buffer. + (set-window-buffer (split-window (get-buffer-window buf) nil nil) rbuf) + (pop-to-buffer rbuf))) + +(defun ledger-reconcile () + "Start reconciling, prompt for account." + (interactive) + (let ((account (ledger-read-account-with-prompt "Account to reconcile")) + (buf (current-buffer)) + (rbuf (get-buffer ledger-recon-buffer-name))) + + (add-hook 'after-save-hook 'ledger-reconcile-refresh-after-save nil t) + + (if rbuf ;; *Reconcile* already exists + (with-current-buffer rbuf + (set 'ledger-acct account) ;; already buffer local + (when (not (eq buf rbuf)) + ;; called from some other ledger-mode buffer + (ledger-reconcile-quit-cleanup) + (set 'ledger-buf buf)) ;; should already be buffer-local + + (unless (get-buffer-window rbuf) + (ledger-reconcile-open-windows buf rbuf))) + + ;; no recon-buffer, starting from scratch. + + (with-current-buffer (setq rbuf + (get-buffer-create ledger-recon-buffer-name)) + (ledger-reconcile-open-windows buf rbuf) + (ledger-reconcile-mode) + (make-local-variable 'ledger-target) + (set (make-local-variable 'ledger-buf) buf) + (set (make-local-variable 'ledger-acct) account))) + + ;; Narrow the ledger buffer + (with-current-buffer rbuf + (save-excursion + (if ledger-narrow-on-reconcile + (ledger-occur-mode account ledger-buf))) + (if (> (ledger-reconcile-refresh) 0) + (ledger-reconcile-change-target)) + (ledger-display-balance)))) + +(defvar ledger-reconcile-mode-abbrev-table) + +(defun ledger-reconcile-change-target () + "Change the target amount for the reconciliation process." + (interactive) + (setq ledger-target (ledger-read-commodity-string ledger-reconcile-target-prompt-string))) + +(defmacro ledger-reconcile-change-sort-key-and-refresh (sort-by) + `(lambda () + (interactive) + + (setq ledger-reconcile-sort-key ,sort-by) + (ledger-reconcile-refresh))) + +(define-derived-mode ledger-reconcile-mode text-mode "Reconcile" + "A mode for reconciling ledger entries." + (let ((map (make-sparse-keymap))) + (define-key map [(control ?m)] 'ledger-reconcile-visit) + (define-key map [return] 'ledger-reconcile-visit) + (define-key map [(control ?l)] 'ledger-reconcile-refresh) + (define-key map [(control ?c) (control ?c)] 'ledger-reconcile-finish) + (define-key map [? ] 'ledger-reconcile-toggle) + (define-key map [?a] 'ledger-reconcile-add) + (define-key map [?d] 'ledger-reconcile-delete) + (define-key map [?g] 'ledger-reconcile); + (define-key map [?n] 'next-line) + (define-key map [?p] 'previous-line) + (define-key map [?t] 'ledger-reconcile-change-target) + (define-key map [?s] 'ledger-reconcile-save) + (define-key map [?q] 'ledger-reconcile-quit) + (define-key map [?b] 'ledger-display-balance) + + (define-key map [(control ?c) (control ?a)] (ledger-reconcile-change-sort-key-and-refresh "(amount)")) + + (define-key map [(control ?c) (control ?d)] (ledger-reconcile-change-sort-key-and-refresh "(date)")) + + (define-key map [(control ?c) (control ?p)] (ledger-reconcile-change-sort-key-and-refresh "(payee)")) + + (define-key map [menu-bar] (make-sparse-keymap "ledger-recon-menu")) + (define-key map [menu-bar ledger-recon-menu] (cons "Reconcile" map)) + (define-key map [menu-bar ledger-recon-menu qui] '("Quit" . ledger-reconcile-quit)) + (define-key map [menu-bar ledger-recon-menu sep1] '("--")) + (define-key map [menu-bar ledger-recon-menu pre] '("Previous Entry" . previous-line)) + (define-key map [menu-bar ledger-recon-menu vis] '("Visit Source" . ledger-reconcile-visit)) + (define-key map [menu-bar ledger-recon-menu nex] '("Next Entry" . next-line)) + (define-key map [menu-bar ledger-recon-menu sep2] '("--")) + (define-key map [menu-bar ledger-recon-menu del] '("Delete Entry" . ledger-reconcile-delete)) + (define-key map [menu-bar ledger-recon-menu add] '("Add Entry" . ledger-reconcile-add)) + (define-key map [menu-bar ledger-recon-menu tog] '("Toggle Entry" . ledger-reconcile-toggle)) + (define-key map [menu-bar ledger-recon-menu sep3] '("--")) + (define-key map [menu-bar ledger-recon-menu sort-amt] `("Sort by amount" . ,(ledger-reconcile-change-sort-key-and-refresh "(amount)"))) + (define-key map [menu-bar ledger-recon-menu sort-pay] `("Sort by date" . ,(ledger-reconcile-change-sort-key-and-refresh "(date)"))) + (define-key map [menu-bar ledger-recon-menu sort-dat] `("Sort by payee" . ,(ledger-reconcile-change-sort-key-and-refresh "(payee)"))) + (define-key map [menu-bar ledger-recon-menu sep4] '("--")) + (define-key map [menu-bar ledger-recon-menu bal] '("Show Cleared Balance" . ledger-display-balance)) + (define-key map [menu-bar ledger-recon-menu tgt] '("Change Target Balance" . ledger-reconcile-change-target)) + (define-key map [menu-bar ledger-recon-menu sep5] '("--")) + (define-key map [menu-bar ledger-recon-menu rna] '("Reconcile New Account" . ledger-reconcile)) + (define-key map [menu-bar ledger-recon-menu sep6] '("--")) + (define-key map [menu-bar ledger-recon-menu fin] '("Finish" . ledger-reconcile-finish)) + (define-key map [menu-bar ledger-recon-menu ref] '("Refresh" . ledger-reconcile-refresh)) + (define-key map [menu-bar ledger-recon-menu sav] '("Save" . ledger-reconcile-save)) + + (use-local-map map))) + +(provide 'ledger-reconcile) + +;;; ledger-reconcile.el ends here diff --git a/lisp/ledger-regex.el b/lisp/ledger-regex.el new file mode 100644 index 00000000..77ce38c6 --- /dev/null +++ b/lisp/ledger-regex.el @@ -0,0 +1,335 @@ +;;; ledger-regex.el --- Helper code for use with the "ledger" command-line tool + +;; Copyright (C) 2003-2013 John Wiegley (johnw AT gnu DOT org) + +;; 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. + +(require 'rx) + +(eval-when-compile + (require 'cl)) + +(defconst ledger-amount-regex + (concat "\\( \\|\t\\| \t\\)[ \t]*-?" + "\\([A-Z$€£_]+ *\\)?" + "\\(-?[0-9,]+?\\)" + "\\(.[0-9]+\\)?" + "\\( *[[:word:]€£_\"]+\\)?" + "\\([ \t]*[@={]@?[^\n;]+?\\)?" + "\\([ \t]+;.+?\\|[ \t]*\\)?$")) + +(defconst ledger-amount-decimal-comma-regex + "-?[1-9][0-9.]*[,]?[0-9]*") + +(defconst ledger-amount-decimal-period-regex + "-?[1-9][0-9,]*[.]?[0-9]*") + +(defconst ledger-other-entries-regex + "\\(^[~=A-Za-z].+\\)+") + +(defconst ledger-comment-regex + "^[;#|\\*%].*\\|[ \t]+;.*") + +(defconst ledger-multiline-comment-start-regex + "^!comment$") +(defconst ledger-multiline-comment-end-regex + "^!end_comment$") +(defconst ledger-multiline-comment-regex + "^!comment\n\\(.*\n\\)*?!end_comment$") + +(defconst ledger-payee-any-status-regex + "^[0-9]+[-/][-/.=0-9]+\\(\\s-+\\*\\)?\\(\\s-+(.*?)\\)?\\s-+\\(.+?\\)\\s-*\\(;\\|$\\)") + +(defconst ledger-payee-pending-regex + "^[0-9]+[-/][-/.=0-9]+\\s-\\!\\s-+\\(([^)]+)\\s-+\\)?\\([^*].+?\\)\\s-*\\(;\\|$\\)") + +(defconst ledger-payee-cleared-regex + "^[0-9]+[-/][-/.=0-9]+\\s-\\*\\s-+\\(([^)]+)\\s-+\\)?\\([^*].+?\\)\\s-*\\(;\\|$\\)") + +(defconst ledger-payee-uncleared-regex + "^[0-9]+[-/][-/.=0-9]+\\s-+\\(([^)]+)\\s-+\\)?\\([^*].+?\\)\\s-*\\(;\\|$\\)") + +(defconst ledger-init-string-regex + "^--.+?\\($\\|[ ]\\)") + +(defconst ledger-account-any-status-regex + "^[ \t]+\\([*!]\\s-+\\)?\\([[(]?.+?\\)\\(\t\\|\n\\| [ \t]\\)") + +(defun ledger-account-any-status-with-seed-regex (seed) + (concat "^[ \t]+\\([*!]\\s-+\\)?\\([[(]?" seed ".+?\\)\\(\t\\|\n\\| [ \t]\\)")) + +(defconst ledger-account-pending-regex + "\\(^[ \t]+\\)\\(!\\s-*.*?\\)\\( \\|\t\\|$\\)") + +(defconst ledger-account-cleared-regex + "\\(^[ \t]+\\)\\(*\\s-*.*?\\)\\( \\|\t\\|$\\)") + + +(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 iso-date + ( let ((sep '(or ?- ?/))) + (rx (group + (and (group (? (= 4 num))) + (eval sep) + (group (and num (? num))) + (eval sep) + (group (and num (? num))))))) + "Match a single date, in its 'written' form.") + +(ledger-define-regexp full-date + (macroexpand + `(rx (and (regexp ,ledger-iso-date-regexp) + (? (and ?= (regexp ,ledger-iso-date-regexp)))))) + "Match a compound date, of the form ACTUAL=EFFECTIVE" + (actual iso-date) + (effective iso-date)) + +(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)))) + "") + +(ledger-define-regexp full-note + (macroexpand + `(rx (and line-start (+ blank) + ?\; (regexp ,ledger-note-regexp)))) + "") + +(ledger-define-regexp xact-line + (macroexpand + `(rx (and line-start + (regexp ,ledger-full-date-regexp) + (? (and (+ blank) (regexp ,ledger-state-regexp))) + (? (and (+ blank) (regexp ,ledger-code-regexp))) + (+ blank) (+? nonl) + (? (regexp ,ledger-end-note-regexp)) + line-end))) + "Match a transaction's first line (and optional notes)." + (actual-date full-date actual) + (effective-date full-date effective) + state + code + (note end-note)) + +(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 (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 (group + (or (and (regexp ,ledger-commodity-regexp) + (*? blank) + (regexp ,ledger-amount-regexp)) + (and (regexp ,ledger-amount-regexp) + (*? blank) + (regexp ,ledger-commodity-regexp)))))) + "") + +(ledger-define-regexp commodity-annotations + (macroexpand + `(rx (* (+ blank) + (or (and ?\{ (regexp ,ledger-commoditized-amount-regexp) ?\}) + (and ?\[ (regexp ,ledger-iso-date-regexp) ?\]) + (and ?\( (not (any ?\))) ?\)))))) + "") + +(ledger-define-regexp cost + (macroexpand + `(rx (and (or "@" "@@") (+ blank) + (regexp ,ledger-commoditized-amount-regexp)))) + "") + +(ledger-define-regexp balance-assertion + (macroexpand + `(rx (and ?= (+ blank) + (regexp ,ledger-commoditized-amount-regexp)))) + "") + +(ledger-define-regexp full-amount + (macroexpand `(rx (group (+? (not (any ?\;)))))) + "") + +(ledger-define-regexp post-line + (macroexpand + `(rx (and line-start (+ blank) + (? (and (regexp ,ledger-state-regexp) (* blank))) + (regexp ,ledger-full-account-regexp) + (? (and (regexp ,ledger-long-space-regexp) + (regexp ,ledger-full-amount-regexp))) + (? (regexp ,ledger-end-note-regexp)) + line-end))) + "" + state + (account-kind full-account kind) + (account full-account name) + (amount full-amount) + (note end-note)) + +(defconst ledger-iterate-regex + (concat "\\(Y\\s-+\\([0-9]+\\)\\|" ;; Catches a Y directive + ledger-iso-date-regexp + "\\([ *!]+\\)" ;; mark + "\\((.*)\\)?" ;; code + "\\(.*\\)" ;; desc + "\\)")) + +(provide 'ledger-regex) diff --git a/lisp/ledger-report.el b/lisp/ledger-report.el new file mode 100644 index 00000000..e785bc1b --- /dev/null +++ b/lisp/ledger-report.el @@ -0,0 +1,419 @@ +;;; ledger-report.el --- Helper code for use with the "ledger" command-line tool + +;; Copyright (C) 2003-2013 John Wiegley (johnw AT gnu DOT org) + +;; 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: +;; Provide facilities for running and saving reports in emacs + +;;; Code: + +(eval-when-compile + (require 'cl)) + +(defgroup ledger-report nil + "Customization option for the Report buffer" + :group 'ledger) + +(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 '%()' where + 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-report) + +(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) + ("value" . ledger-report-value-format-specifier)) + "An 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-report) + +(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-saved nil) +(defvar ledger-minibuffer-history nil) +(defvar ledger-report-mode-abbrev-table) + +(defun ledger-report-reverse-lines () + (interactive) + (goto-char (point-min)) + (forward-paragraph) + (forward-line) + (save-excursion + (setq inhibit-read-only t) + (reverse-region (point) (point-max)))) + +(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 [(shift ?r)] 'ledger-report-reverse-lines) + (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) + (define-key map [return] 'ledger-report-visit-source) + + + (define-key map [menu-bar] (make-sparse-keymap "ledger-rep")) + (define-key map [menu-bar ledger-rep] (cons "Reports" map)) + + (define-key map [menu-bar ledger-rep lrq] '("Quit" . ledger-report-quit)) + (define-key map [menu-bar ledger-rep s2] '("--")) + (define-key map [menu-bar ledger-rep lrd] '("Scroll Down" . scroll-down)) + (define-key map [menu-bar ledger-rep vis] '("Visit Source" . ledger-report-visit-source)) + (define-key map [menu-bar ledger-rep lru] '("Scroll Up" . scroll-up)) + (define-key map [menu-bar ledger-rep s1] '("--")) + (define-key map [menu-bar ledger-rep rev] '("Reverse report order" . ledger-report-reverse-lines)) + (define-key map [menu-bar ledger-rep s0] '("--")) + (define-key map [menu-bar ledger-rep lrk] '("Kill Report" . ledger-report-kill)) + (define-key map [menu-bar ledger-rep lrr] '("Re-run Report" . ledger-report-redo)) + (define-key map [menu-bar ledger-rep lre] '("Edit Report" . ledger-report-edit)) + (define-key map [menu-bar ledger-rep lrs] '("Save Report" . ledger-report-save)) + + (use-local-map map))) + +(defun ledger-report-value-format-specifier () + "Return a valid meta-data tag name" + ;; It is intended completion should be available on existing account + ;; names, but it remains to be implemented. + (ledger-read-string-with-default "Value: " nil)) + +(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 REPORT-NAME of the report to run or +EDIT. 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-report-saved) nil) + (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 S 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 NAME and CMD 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 from REPORT-CMD." + (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 variable `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-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 xact, the payee for that xact is used as the + default." + ;; It is intended completion 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-xact-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 + posting line for an xact, 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. + (ledger-read-account-with-prompt "Account")) + +(defun ledger-report-expand-format-specifiers (report-cmd) + "Expand %(account) and %(payee) appearing in REPORT-CMD with thing under point." + (save-match-data + (let ((expanded-cmd report-cmd)) + (set-match-data (list 0 0)) + (while (string-match "%(\\([^)]*\\))" expanded-cmd (if (> (length expanded-cmd) (match-end 0)) + (match-end 0) + (1- (length expanded-cmd)))) + (let* ((specifier (match-string 1 expanded-cmd)) + (f (cdr (assoc specifier ledger-report-format-specifiers)))) + (if f + (setq expanded-cmd (replace-match + (save-match-data + (with-current-buffer ledger-buf + (shell-quote-argument (funcall f)))) + t t expanded-cmd))))) + expanded-cmd))) + +(defun ledger-report-cmd (report-name edit) + "Get the command line to run the report name REPORT-NAME. +Optional EDIT the command." + (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 ledger-report-saved nil)) ;; this is a new report, or edited report + (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) + (progn + (ledger-reports-add report-name report-cmd) + (ledger-reports-custom-save))) + report-cmd)) + +(defun ledger-do-report (cmd) + "Run a report command line CMD." + (goto-char (point-min)) + (insert (format "Report: %s\n" ledger-report-name) + (format "Command: %s\n" cmd) + (make-string (- (window-width) 1) ?=) + "\n\n") + (let ((data-pos (point)) + (register-report (string-match " reg\\(ister\\)? " cmd)) + files-in-report) + (shell-command + ;; --subtotal does not produce identifiable transactions, so don't + ;; prepend location information for them + (if (and register-report + (not (string-match "--subtotal" cmd))) + (concat cmd " --prepend-format='%(filename):%(beg_line):'") + cmd) + t nil) + (when register-report + (goto-char data-pos) + (while (re-search-forward "^\\(/[^:]+\\)?:\\([0-9]+\\)?:" nil t) + (let ((file (match-string 1)) + (line (string-to-number (match-string 2)))) + (delete-region (match-beginning 0) (match-end 0)) + (when file + (set-text-properties (line-beginning-position) (line-end-position) + (list 'ledger-source (cons file (save-window-excursion + (save-excursion + (find-file file) + (widen) + (ledger-goto-line line) + (point-marker)))))) + (add-text-properties (line-beginning-position) (line-end-position) + (list 'face 'ledger-font-report-clickable-face)) + (end-of-line))))) + (goto-char data-pos))) + + +(defun ledger-report-visit-source () + "Visit the transaction under point in the report window." + (interactive) + (let* ((prop (get-text-property (point) 'ledger-source)) + (file (if prop (car prop))) + (line-or-marker (if prop (cdr prop)))) + (when (and file line-or-marker) + (find-file-other-window file) + (widen) + (if (markerp line-or-marker) + (goto-char line-or-marker) + (goto-char (point-min)) + (forward-line (1- line-or-marker)) + (re-search-backward "^[0-9]+") + (beginning-of-line) + (let ((start-of-txn (point))) + (forward-paragraph) + (narrow-to-region start-of-txn (point)) + (backward-paragraph)))))) + +(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))) + + (if (setq existing-name (ledger-report-name-exists ledger-report-name)) + (cond ((y-or-n-p (format "Overwrite existing report named '%s'? " + ledger-report-name)) + (if (string-equal + ledger-report-cmd + (car (cdr (assq existing-name ledger-reports)))) + (message "Nothing to save. Current command is identical to existing saved one") + (progn + (setq ledger-reports + (assq-delete-all existing-name ledger-reports)) + (ledger-reports-add ledger-report-name ledger-report-cmd) + (ledger-reports-custom-save)))) + (t + (progn + (setq ledger-report-name (ledger-report-read-new-name)) + (ledger-reports-add ledger-report-name ledger-report-cmd) + (ledger-reports-custom-save))))))) + +(provide 'ledger-report) + +;;; ledger-report.el ends here diff --git a/lisp/ledger-schedule.el b/lisp/ledger-schedule.el new file mode 100644 index 00000000..7497c7d0 --- /dev/null +++ b/lisp/ledger-schedule.el @@ -0,0 +1,330 @@ +;;; ledger-schedule.el --- Helper code for use with the "ledger" command-line tool + +;; Copyright (C) 2013 Craig Earls (enderw88 at gmail dot com) + +;; This file is not part of GNU Emacs. + +;; This is free software; you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; This is distributed in the hope that it will be useful, but WITHOUT +;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY +;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public +;; License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: +;; +;; This module provides for automatically adding transactions to a +;; ledger buffer on a periodic basis. Recurrence expressions are +;; inspired by Martin Fowler's "Recurring Events for Calendars", +;; martinfowler.com/apsupp/recurring.pdf + +;; use (fset 'VARNAME (macro args)) to put the macro definition in the +;; function slot of the symbol VARNAME. Then use VARNAME as the +;; function without have to use funcall. + +(defgroup ledger-schedule nil + "Support for automatically recommendation transactions." + :group 'ledger) + +(defcustom ledger-schedule-buffer-name "*Ledger Schedule*" + "Name for the schedule buffer" + :type 'string + :group 'ledger-schedule) + +(defcustom ledger-schedule-look-backward 7 + "Number of days to look back in time for transactions." + :type 'integer + :group 'ledger-schedule) + +(defcustom ledger-schedule-look-forward 14 + "Number of days auto look forward to recommend transactions" + :type 'integer + :group 'ledger-schedule) + +(defcustom ledger-schedule-file "~/FinanceData/ledger-schedule.ledger" + "File to find scheduled transactions." + :type 'file + :group 'ledger-schedule) + +(defsubst between (val low high) + (and (>= val low) (<= val high))) + +(defun ledger-schedule-days-in-month (month year) + "Return number of days in the MONTH, MONTH is from 1 to 12. +If year is nil, assume it is not a leap year" + (if (between month 1 12) + (if (and year (date-leap-year-p year) (= 2 month)) + 29 + (nth (1- month) '(31 28 31 30 31 30 31 31 30 31 30 31))) + (error "Month out of range, MONTH=%S" month))) + +;; Macros to handle date expressions + +(defun ledger-schedule-constrain-day-in-month (count day-of-week) + "Return a form that evaluates DATE that returns true for the COUNT DAY-OF-WEEK. +For example, return true if date is the 3rd Thursday of the +month. Negative COUNT starts from the end of the month. (EQ +COUNT 0) means EVERY day-of-week (eg. every Saturday)" + (if (and (between count -6 6) (between day-of-week 0 6)) + (cond ((zerop count) ;; Return true if day-of-week matches + `(eq (nth 6 (decode-time date)) ,day-of-week)) + ((> count 0) ;; Positive count + (let ((decoded (gensym))) + `(let ((,decoded (decode-time date))) + (and (eq (nth 6 ,decoded) ,day-of-week) + (between (nth 3 ,decoded) + ,(* (1- count) 7) + ,(* count 7)))))) + ((< count 0) + (let ((days-in-month (gensym)) + (decoded (gensym))) + `(let* ((,decoded (decode-time date)) + (,days-in-month (ledger-schedule-days-in-month + (nth 4 ,decoded) + (nth 5 ,decoded)))) + (and (eq (nth 6 ,decoded) ,day-of-week) + (between (nth 3 ,decoded) + (+ ,days-in-month ,(* count 7)) + (+ ,days-in-month ,(* (1+ count) 7))))))) + (t + (error "COUNT out of range, COUNT=%S" count))) + (error "Invalid argument to ledger-schedule-day-in-month-macro %S %S" + count + day-of-week))) + +(defun ledger-schedule-constrain-every-count-day (day-of-week skip start-date) + "Return a form that is true for every DAY skipping SKIP, starting on START. +For example every second Friday, regardless of month." + (let ((start-day (nth 6 (decode-time (eval start-date))))) + (if (eq start-day day-of-week) ;; good, can proceed + `(zerop (mod (- (time-to-days date) ,(time-to-days (eval start-date))) ,(* skip 7))) + (error "START-DATE day of week doesn't match DAY-OF-WEEK")))) + +(defun ledger-schedule-constrain-date-range (month1 day1 month2 day2) + "Return a form of DATE that is true if DATE falls between MONTH1 DAY1 and MONTH2 DAY2." + (let ((decoded (gensym)) + (target-month (gensym)) + (target-day (gensym))) + `(let* ((,decoded (decode-time date)) + (,target-month (nth 4 decoded)) + (,target-day (nth 3 decoded))) + (and (and (> ,target-month ,month1) + (< ,target-month ,month2)) + (and (> ,target-day ,day1) + (< ,target-day ,day2)))))) + + +(defun ledger-schedule-is-holiday (date) + "Return true if DATE is a holiday.") + +(defun ledger-schedule-scan-transactions (schedule-file) + "Scans AUTO_FILE and returns a list of transactions with date predicates. +The car of each item is a fuction of date that returns true if +the transaction should be logged for that day." + (interactive "fFile name: ") + (let ((xact-list (list))) + (with-current-buffer + (find-file-noselect schedule-file) + (goto-char (point-min)) + (while (re-search-forward "^\\[\\(.*\\)\\] " nil t) + (let ((date-descriptor "") + (transaction nil) + (xact-start (match-end 0))) + (setq date-descriptors + (ledger-schedule-read-descriptor-tree + (buffer-substring-no-properties + (match-beginning 0) + (match-end 0)))) + (forward-paragraph) + (setq transaction (list date-descriptors + (buffer-substring-no-properties + xact-start + (point)))) + (setq xact-list (cons transaction xact-list)))) + xact-list))) + +(defun ledger-schedule-replace-brackets () + "Replace all brackets with parens" + (goto-char (point-min)) + (while (search-forward "]" nil t) + (replace-match ")" nil t)) + (goto-char (point-min)) + (while (search-forward "[" nil t) + (replace-match "(" nil t))) + +(defvar ledger-schedule-descriptor-regex + (concat "\\(20[0-9][0-9]\\|[\*]\\)[/\\-]" ;; Year slot + "\\([\*EO]\\|[01][0-9]\\)[/\\-]" ;; Month slot + "\\([\*]\\|\\([0-3][0-9]\\)\\|" + "\\([0-5]" + "\\(\\(Su\\)\\|" + "\\(Mo\\)\\|" + "\\(Tu\\)\\|" + "\\(We\\)\\|" + "\\(Th\\)\\|" + "\\(Fr\\)\\|" + "\\(Sa\\)\\)\\)\\)")) + +(defun ledger-schedule-read-descriptor-tree (descriptor-string) + "Take a date DESCRIPTOR-STRING and return a function of date that +returns true if the date meets the requirements" + (with-temp-buffer + ;; copy the descriptor string into a temp buffer for manipulation + (let (pos) + ;; Replace brackets with parens + (insert descriptor-string) + (ledger-schedule-replace-brackets) + + (goto-char (point-max)) + ;; double quote all the descriptors for string processing later + (while (re-search-backward ledger-schedule-descriptor-regex nil t) ;; Day slot + (goto-char + (match-end 0)) + (insert ?\") + (goto-char (match-beginning 0)) + (insert "\"" ))) + + ;; read the descriptor string into a lisp object the transform the + ;; string descriptor into useable things + (ledger-schedule-transform-auto-tree + (read (buffer-substring-no-properties (point-min) (point-max)))))) + +(defun ledger-schedule-transform-auto-tree (descriptor-string-list) +"Takes a lisp list of date descriptor strings, TREE, and returns a string with a lambda function of date." +;; use funcall to use the lambda function spit out here + (if (consp descriptor-string-list) + (let (result) + (while (consp descriptor-string-list) + (let ((newcar (car descriptor-string-list))) + (if (consp newcar) + (setq newcar (ledger-schedule-transform-auto-tree (car descriptor-string-list)))) + ;; newcar may be a cons now, after ledger-schedule-transfrom-auto-tree + (if (consp newcar) + (push newcar result) + ;; this is where we actually turn the string descriptor into useful lisp + (push (ledger-schedule-compile-constraints newcar) result)) ) + (setq descriptor-string-list (cdr descriptor-string-list))) + + ;; tie up all the clauses in a big or and lambda, and return + ;; the lambda function as list to be executed by funcall + `(lambda (date) + ,(nconc (list 'or) (nreverse result) descriptor-string-list))))) + +(defun ledger-schedule-compile-constraints (descriptor-string) + "Return a list with the year, month and day fields split" + (let ((fields (split-string descriptor-string "[/\\-]" t)) + constrain-year constrain-month constrain-day) + (setq constrain-year (ledger-schedule-constrain-year (nth 0 fields))) + (setq constrain-month (ledger-schedule-constrain-month (nth 1 fields))) + (setq constrain-day (ledger-schedule-constrain-day (nth 2 fields))) + + (list 'and constrain-year constrain-month constrain-day))) + +(defun ledger-schedule-constrain-year (str) + (let ((year-match t)) + (cond ((string= str "*") + year-match) + ((/= 0 (setq year-match (string-to-number str))) + `(eq (nth 5 (decode-time date)) ,year-match)) + (t + (error "Improperly specified year constraint: " str))))) + +(defun ledger-schedule-constrain-month (str) + + (let ((month-match t)) + (cond ((string= str "*") + month-match) ;; always match + ((/= 0 (setq month-match (string-to-number str))) + (if (between month-match 1 12) ;; no month specified, assume 31 days. + `(eq (nth 4 (decode-time date)) ,month-match) + (error "ledger-schedule-constrain-numerical-month: month out of range %S" month-match))) + (t + (error "Improperly specified month constraint: " str))))) + +(defun ledger-schedule-constrain-day (str) + (let ((day-match t)) + (cond ((string= str "*") + t) + ((/= 0 (setq day-match (string-to-number str))) + `(eq (nth 3 (decode-time date)) ,day-match)) + (t + (error "Improperly specified day constraint: " str))))) + +(defun ledger-schedule-parse-date-descriptor (descriptor) + "Parse the date descriptor, return the evaluator" + (ledger-schedule-compile-constraints descriptor)) + +(defun ledger-schedule-list-upcoming-xacts (candidate-items early horizon) + "Search CANDIDATE-ITEMS for xacts that occur within the period today - EARLY to today + HORIZON" + (let ((start-date (time-subtract (current-time) (days-to-time early))) + test-date items) + (loop for day from 0 to (+ early horizon) by 1 do + (setq test-date (time-add start-date (days-to-time day))) + (dolist (candidate candidate-items items) + (if (funcall (car candidate) test-date) + (setq items (append items (list (list test-date (cadr candidate)))))))) + items)) + +(defun ledger-schedule-already-entered (candidate buffer) + (let ((target-date (format-time-string date-format (car candidate))) + (target-payee (cadr candidate))) + nil)) + +(defun ledger-schedule-create-auto-buffer (candidate-items early horizon ledger-buf) + "Format CANDIDATE-ITEMS for display." + (let ((candidates (ledger-schedule-list-upcoming-xacts candidate-items early horizon)) + (schedule-buf (get-buffer-create ledger-schedule-buffer-name)) + (date-format (cdr (assoc "date-format" ledger-environment-alist)))) + (with-current-buffer schedule-buf + (erase-buffer) + (dolist (candidate candidates) + (if (not (ledger-schedule-already-entered candidate ledger-buf)) + (insert (format-time-string date-format (car candidate) ) " " (cadr candidate) "\n"))) + (ledger-mode)) + (length candidates))) + + +;; +;; Test harnesses for use in ielm +;; +(defvar auto-items) + +(defun ledger-schedule-test ( early horizon) + (ledger-schedule-create-auto-buffer + (ledger-schedule-scan-transactions ledger-schedule-file) + early + horizon + (get-buffer "2013.ledger"))) + + +(defun ledger-schedule-test-predict () + (let ((today (current-time)) + test-date items) + + (loop for day from 0 to ledger-schedule-look-forward by 1 do + (setq test-date (time-add today (days-to-time day))) + (dolist (item auto-items items) + (if (funcall (car item) test-date) + (setq items (append items (list (decode-time test-date) (cdr item))))))) + items)) + +(defun ledger-schedule-upcoming () + (interactive) + (ledger-schedule-create-auto-buffer + (ledger-schedule-scan-transactions ledger-schedule-file) + ledger-schedule-look-backward + ledger-schedule-look-forward + (current-buffer))) + + +(provide 'ledger-schedule) + +;;; ledger-schedule.el ends here diff --git a/lisp/ledger-sort.el b/lisp/ledger-sort.el new file mode 100644 index 00000000..c5a41952 --- /dev/null +++ b/lisp/ledger-sort.el @@ -0,0 +1,126 @@ +;;; ledger-xact.el --- Helper code for use with the "ledger" command-line tool + +;; Copyright (C) 2003-2013 John Wiegley (johnw AT gnu DOT org) + +;; 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: +;; + +;;; Code: + +(defun ledger-next-record-function () + "Move point to next transaction." + (if (re-search-forward ledger-payee-any-status-regex nil t) + (goto-char (match-beginning 0)) + (goto-char (point-max)))) + +(defun ledger-end-record-function () + "Move point to end of transaction." + (forward-paragraph)) + +(defun ledger-sort-find-start () + (if (re-search-forward ";.*Ledger-mode:.*Start sort" nil t) + (match-end 0))) + +(defun ledger-sort-find-end () + (if (re-search-forward ";.*Ledger-mode:.*End sort" nil t) + (match-end 0))) + +(defun ledger-sort-insert-start-mark () + (interactive) + (save-excursion + (goto-char (point-min)) + (if (ledger-sort-find-start) + (delete-region (match-beginning 0) (match-end 0)))) + (beginning-of-line) + (insert "\n; Ledger-mode: Start sort\n\n")) + +(defun ledger-sort-insert-end-mark () + (interactive) + (save-excursion + (goto-char (point-min)) + (if (ledger-sort-find-end) + (delete-region (match-beginning 0) (match-end 0)))) + (beginning-of-line) + (insert "\n; Ledger-mode: End sort\n\n")) + +(defun ledger-sort-startkey () + "Return the actual date so the sort-subr doesn't sort onthe entire first line." + (buffer-substring-no-properties (point) (+ 10 (point)))) + +(defun ledger-sort-region (beg end) + "Sort the region from BEG to END in chronological order." + (interactive "r") ;; load beg and end from point and mark + ;; automagically + (let ((new-beg beg) + (new-end end) + point-delta + (bounds (ledger-find-xact-extents (point))) + target-xact) + + (setq point-delta (- (point) (car bounds))) + (setq target-xact (buffer-substring (car bounds) (cadr bounds))) + (setq inhibit-modification-hooks t) + (save-excursion + (save-restriction + (goto-char beg) + (ledger-next-record-function) ;; make sure point is at the + ;; beginning of a xact + (setq new-beg (point)) + (goto-char end) + (ledger-next-record-function) ;; make sure end of region is at + ;; the beginning of next record + ;; after the region + (setq new-end (point)) + (narrow-to-region new-beg new-end) + (goto-char new-beg) + + (let ((inhibit-field-text-motion t)) + (sort-subr + nil + 'ledger-next-record-function + 'ledger-end-record-function + 'ledger-sort-startkey)))) + + (goto-char (point-min)) + (re-search-forward (regexp-quote target-xact)) + (goto-char (+ (match-beginning 0) point-delta)) + (setq inhibit-modification-hooks nil))) + +(defun ledger-sort-buffer () + "Sort the entire buffer." + (interactive) + (let (sort-start + sort-end) + (save-excursion + (goto-char (point-min)) + (setq sort-start (ledger-sort-find-start) + sort-end (ledger-sort-find-end))) + (ledger-sort-region (if sort-start + sort-start + (point-min)) + (if sort-end + sort-end + (point-max))))) + +(provide 'ledger-sort) + +;;; ledger-sort.el ends here diff --git a/lisp/ledger-state.el b/lisp/ledger-state.el new file mode 100644 index 00000000..121e97ca --- /dev/null +++ b/lisp/ledger-state.el @@ -0,0 +1,244 @@ +;;; ledger-state.el --- Helper code for use with the "ledger" command-line tool + +;; Copyright (C) 2003-2013 John Wiegley (johnw AT gnu DOT org) + +;; 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: +;; Utilities for dealing with transaction and posting status. + +;;; Code: + +(defcustom ledger-clear-whole-transactions nil + "If non-nil, clear whole transactions, not individual postings." + :type 'boolean + :group 'ledger) + +(defun ledger-transaction-state () + "Return the state of the transaction at point." + (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-posting-state () + "Return the state of the posting." + (save-excursion + (goto-char (line-beginning-position)) + (skip-syntax-forward " ") + (cond ((looking-at "!\\s-*") 'pending) + ((looking-at "\\*\\s-*") 'cleared) + (t (ledger-transaction-state))))) + +(defun ledger-char-from-state (state) + "Return the char representation of STATE." + (if state + (if (eq state 'pending) + "!" + "*") + "")) + +(defun ledger-state-from-char (state-char) + "Get state from STATE-CHAR." + (cond ((eql state-char ?\!) 'pending) + ((eql state-char ?\*) 'cleared) + ((eql state-char ?\;) 'comment) + (t nil))) + +(defun ledger-toggle-current-posting (&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'). Returns the new status as 'pending 'cleared or nil. +This function is rather complicated because it must preserve both +the overall formatting of the ledger xact, as well as ensuring +that the most minimal display format is used. This could be +achieved more certainly by passing the xact to ledger for +formatting, but doing so causes inline math expressions to be +dropped." + (interactive) + (let ((bounds (ledger-find-xact-extents (point))) + new-status cur-status) + ;; Uncompact the xact, to make it easier to toggle the + ;; transaction + (save-excursion ;; this excursion checks state of entire + ;; transaction and unclears if marked + (goto-char (car bounds)) ;; beginning of xact + (skip-chars-forward "0-9./=\\- \t") ;; skip the date + (setq cur-status (and (member (char-after) '(?\* ?\!)) + (ledger-state-from-char (char-after)))) + ;;if cur-status if !, or * then delete the marker + (when cur-status + (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) + ;; Shift the cleared/pending status to the postings + (while (looking-at "[ \t]") + (skip-chars-forward " \t") + (when (not (eq (ledger-state-from-char (char-after)) 'comment)) + (insert (ledger-char-from-state cur-status) " ") + (if (search-forward " " (line-end-position) t) + (delete-char 2))) + (forward-line)) + (setq new-status nil))) + + ;;this excursion toggles the posting status + (save-excursion + (setq inhibit-modification-hooks t) + + (goto-char (line-beginning-position)) + (when (looking-at "[ \t]") + (skip-chars-forward " \t") + (let ((here (point)) + (cur-status (ledger-state-from-char (char-after)))) + (skip-chars-forward "*! ") + (let ((width (- (point) here))) + (when (> width 0) + (delete-region here (point)) + (save-excursion + (if (search-forward " " (line-end-position) t) + (insert (make-string width ? )))))) + (let (inserted) + (if cur-status + (if (and style (eq style 'cleared)) + (progn + (insert "* ") + (setq inserted 'cleared))) + (if (and style (eq style 'pending)) + (progn + (insert "! ") + (setq inserted 'pending)) + (progn + (insert "* ") + (setq inserted 'cleared)))) + (if (and inserted + (re-search-forward "\\(\t\\| [ \t]\\)" + (line-end-position) t)) + (cond + ((looking-at "\t") + (delete-char 1)) + ((looking-at " [ \t]") + (delete-char 2)) + ((looking-at " ") + (delete-char 1)))) + (setq new-status inserted)))) + (setq inhibit-modification-hooks nil)) + + ;; This excursion cleans up the xact so that it displays + ;; minimally. This means that if all posts are cleared, remove + ;; the marks and clear the entire transaction. + (save-excursion + (goto-char (car bounds)) + (forward-line) + (let ((first t) + (state nil) + (hetero nil)) + (while (and (not hetero) (looking-at "[ \t]")) + (skip-chars-forward " \t") + (let ((cur-status (ledger-state-from-char (char-after)))) + (if (not (eq cur-status 'comment)) + (if first + (setq state cur-status + first nil) + (if (not (eq state cur-status)) + (setq hetero t))))) + (forward-line)) + (when (and (not hetero) (not (eq state nil))) + (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 (ledger-char-from-state state) " ") + (setq new-status state) + (if (re-search-forward "\\(\t\\| [ \t]\\)" + (line-end-position) t) + (cond + ((looking-at "\t") + (delete-char 1)) + ((looking-at " [ \t]") + (delete-char 2)) + ((looking-at " ") + (delete-char 1))))))) + new-status)) + +(defun ledger-toggle-current (&optional style) + "Toggle the current thing at point with optional STYLE." + (interactive) + (if (or ledger-clear-whole-transactions + (eq 'transaction (ledger-thing-at-point))) + (progn + (save-excursion + (forward-line) + (goto-char (line-beginning-position)) + (while (and (not (eolp)) + (save-excursion + (not (eq 'transaction (ledger-thing-at-point))))) + (if (looking-at "\\s-+[*!]") + (ledger-toggle-current-posting style)) + (forward-line) + (goto-char (line-beginning-position)))) + (ledger-toggle-current-transaction style)) + (ledger-toggle-current-posting style))) + +(defun ledger-toggle-current-transaction (&optional style) + "Toggle the transaction at point using optional STYLE." + (interactive) + (save-excursion + (when (or (looking-at "^[0-9]") + (re-search-backward "^[0-9]" nil t)) + (skip-chars-forward "0-9./=\\-") + (delete-horizontal-space) + (if (or (eq (ledger-state-from-char (char-after)) 'pending) + (eq (ledger-state-from-char (char-after)) 'cleared)) + (progn + (delete-char 1) + (when (and style (eq style 'cleared)) + (insert " *") + 'cleared)) + (if (and style (eq style 'pending)) + (progn + (insert " ! ") + 'pending) + (progn + (insert " * ") + 'cleared)))))) + +(provide 'ledger-state) + +;;; ledger-state.el ends here diff --git a/lisp/ledger-test.el b/lisp/ledger-test.el new file mode 100644 index 00000000..a275ae7f --- /dev/null +++ b/lisp/ledger-test.el @@ -0,0 +1,127 @@ +;;; ledger-test.el --- Helper code for use with the "ledger" command-line tool + +;; Copyright (C) 2003-2013 John Wiegley (johnw AT gnu DOT org) + +;; 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. + +(defgroup ledger-test nil + "Definitions for the Ledger testing framework" + :group 'ledger) + +(defcustom ledger-source-directory "~/ledger/" + "Directory where the Ledger sources are located." + :type 'directory + :group 'ledger-test) + +(defcustom ledger-test-binary "/Products/ledger/debug/ledger" + "Directory where the Ledger debug binary is located." + :type 'file + :group 'ledger-test) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun ledger-create-test () + "Create a regression test." + (interactive) + (save-restriction + (org-narrow-to-subtree) + (save-excursion + (let (text beg) + (goto-char (point-min)) + (forward-line 1) + (setq beg (point)) + (search-forward ":PROPERTIES:") + (goto-char (line-beginning-position)) + (setq text (buffer-substring-no-properties beg (point))) + (goto-char (point-min)) + (re-search-forward ":ID:\\s-+\\([^-]+\\)") + (find-file-other-window + (format "~/src/ledger/test/regress/%s.test" (match-string 1))) + (sit-for 0) + (insert text) + (goto-char (point-min)) + (while (not (eobp)) + (goto-char (line-beginning-position)) + (delete-char 3) + (forward-line 1)))))) + +(defun ledger-test-org-narrow-to-entry () + (outline-back-to-heading) + (narrow-to-region (point) (progn (outline-next-heading) (point))) + (goto-char (point-min))) + +(defun ledger-test-create () + (interactive) + (let ((uuid (org-entry-get (point) "ID"))) + (when (string-match "\\`\\([^-]+\\)-" uuid) + (let ((prefix (match-string 1 uuid)) + input output) + (save-restriction + (ledger-test-org-narrow-to-entry) + (goto-char (point-min)) + (while (re-search-forward "#\\+begin_src ledger" nil t) + (goto-char (match-end 0)) + (forward-line 1) + (let ((beg (point))) + (re-search-forward "#\\+end_src") + (setq input + (concat (or input "") + (buffer-substring beg (match-beginning 0)))))) + (goto-char (point-min)) + (while (re-search-forward ":OUTPUT:" nil t) + (goto-char (match-end 0)) + (forward-line 1) + (let ((beg (point))) + (re-search-forward ":END:") + (setq output + (concat (or output "") + (buffer-substring beg (match-beginning 0))))))) + (find-file-other-window + (expand-file-name (concat prefix ".test") + (expand-file-name "test/regress" + ledger-source-directory))) + (ledger-mode) + (if input + (insert input) + (insert "2012-03-17 Payee\n") + (insert " Expenses:Food $20\n") + (insert " Assets:Cash\n")) + (insert "\ntest reg\n") + (if output + (insert output)) + (insert "end test\n"))))) + +(defun ledger-test-run () + (interactive) + (save-excursion + (goto-char (point-min)) + (when (re-search-forward "^test \\(.+?\\)\\( ->.*\\)?$" nil t) + (let ((command (expand-file-name ledger-test-binary)) + (args (format "--args-only --columns=80 --no-color -f \"%s\" %s" + buffer-file-name (match-string 1)))) + (setq args (replace-regexp-in-string "\\$sourcepath" + ledger-source-directory args)) + (kill-new args) + (message "Testing: ledger %s" args) + (let ((prev-directory default-directory)) + (cd ledger-source-directory) + (unwind-protect + (async-shell-command (format "\"%s\" %s" command args)) + (cd prev-directory))))))) + +(provide 'ledger-test) diff --git a/lisp/ledger-texi.el b/lisp/ledger-texi.el new file mode 100644 index 00000000..68880550 --- /dev/null +++ b/lisp/ledger-texi.el @@ -0,0 +1,172 @@ +;;; ledger-texi.el --- Helper code for use with the "ledger" command-line tool + +;; Copyright (C) 2003-2013 John Wiegley (johnw AT gnu DOT org) + +;; 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. + +(defgroup ledger-texi nil +"Options for working on Ledger texi documentation" +:group 'ledger) + +(defcustom ledger-texi-sample-doc-path "~/ledger/doc/sample.dat" +"Location for sample data to be used in texi tests" +:type 'file +:group 'ledger-texi) + +(defcustom ledger-texi-normalization-args "--args-only --columns 80" +"texi normalization for producing ledger output" +:type 'string +:group 'ledger-texi) + +(defun ledger-update-test () + (interactive) + (goto-char (point-min)) + (let ((command (buffer-substring (point-min) (line-end-position))) + input) + (re-search-forward "^<<<\n") + (let ((beg (point)) end) + (re-search-forward "^>>>") + (setq end (match-beginning 0)) + (forward-line 1) + (let ((output-beg (point))) + (re-search-forward "^>>>") + (goto-char (match-beginning 0)) + (delete-region output-beg (point)) + (apply #'call-process-region + beg end (expand-file-name "~/Products/ledger/debug/ledger") + nil t nil + "-f" "-" "--args-only" "--columns=80" "--no-color" + (split-string command " ")))))) + +(defun ledger-texi-write-test (name command input output &optional category) + (let ((buf (current-buffer))) + (with-current-buffer (find-file-noselect + (expand-file-name (concat name ".test") category)) + (erase-buffer) + (let ((case-fold-search nil)) + (if (string-match "\\$LEDGER\\s-+" command) + (setq command (replace-match "" t t command))) + (if (string-match " -f \\$\\([-a-z]+\\)" command) + (setq command (replace-match "" t t command)))) + (insert command ?\n) + (insert "<<<" ?\n) + (insert input) + (insert ">>>1" ?\n) + (insert output) + (insert ">>>2" ?\n) + (insert "=== 0" ?\n) + (save-buffer) + (unless (eq buf (current-buffer)) + (kill-buffer (current-buffer)))))) + +(defun ledger-texi-update-test () + (interactive) + (let ((details (ledger-texi-test-details)) + (name (file-name-sans-extension + (file-name-nondirectory (buffer-file-name))))) + (ledger-texi-write-test + name (nth 0 details) + (nth 1 details) + (ledger-texi-invoke-command + (ledger-texi-expand-command + (nth 0 details) + (ledger-texi-write-test-data name (nth 1 details))))))) + +(defun ledger-texi-test-details () + (goto-char (point-min)) + (let ((command (buffer-substring (point) (line-end-position))) + input output) + (re-search-forward "^<<<") + (let ((input-beg (1+ (match-end 0)))) + (re-search-forward "^>>>1") + (let ((output-beg (1+ (match-end 0)))) + (setq input (buffer-substring input-beg (match-beginning 0))) + (re-search-forward "^>>>2") + (setq output (buffer-substring output-beg (match-beginning 0))) + (list command input output))))) + +(defun ledger-texi-expand-command (command data-file) + (if (string-match "\\$LEDGER" command) + (replace-match (format "%s -f \"%s\" %s" ledger-binary-path + data-file ledger-texi-normalization-args) t t command) + (concat (format "%s -f \"%s\" %s " ledger-binary-path + data-file ledger-texi-normalization-args) command))) + +(defun ledger-texi-invoke-command (command) + (with-temp-buffer (shell-command command t (current-buffer)) + (if (= (point-min) (point-max)) + (progn + (push-mark nil t) + (message "Command '%s' yielded no result at %d" command (point)) + (ding)) + (buffer-string)))) + +(defun ledger-texi-write-test-data (name input) + (let ((path (expand-file-name name temporary-file-directory))) + (with-current-buffer (find-file-noselect path) + (erase-buffer) + (insert input) + (save-buffer)) + path)) + +(defun ledger-texi-update-examples () + (interactive) + (save-excursion + (goto-char (point-min)) + (while (re-search-forward "^@c \\(\\(?:sm\\)?ex\\) \\(\\S-+\\): \\(.*\\)" nil t) + (let ((section (match-string 1)) + (example-name (match-string 2)) + (command (match-string 3)) expanded-command + (data-file ledger-texi-sample-doc-path) + input output) + (goto-char (match-end 0)) + (forward-line) + (when (looking-at "@\\(\\(?:small\\)?example\\)") + (let ((beg (point))) + (re-search-forward "^@end \\(\\(?:small\\)?example\\)") + (delete-region beg (1+ (point))))) + + (when (let ((case-fold-search nil)) + (string-match " -f \\$\\([-a-z]+\\)" command)) + (let ((label (match-string 1 command))) + (setq command (replace-match "" t t command)) + (save-excursion + (goto-char (point-min)) + (search-forward (format "@c data: %s" label)) + (re-search-forward "@\\(\\(?:small\\)?example\\)") + (forward-line) + (let ((beg (point))) + (re-search-forward "@end \\(\\(?:small\\)?example\\)") + (setq data-file (ledger-texi-write-test-data + (format "%s.dat" label) + (buffer-substring-no-properties + beg (match-beginning 0)))))))) + + (let ((section-name (if (string= section "smex") + "smallexample" + "example")) + (output (ledger-texi-invoke-command + (ledger-texi-expand-command command data-file)))) + (insert "@" section-name ?\n output + "@end " section-name ?\n)) + + ;; Update the regression test associated with this example + (ledger-texi-write-test example-name command input output + "../test/manual"))))) + +(provide 'ledger-texi) diff --git a/lisp/ledger-xact.el b/lisp/ledger-xact.el new file mode 100644 index 00000000..25413e43 --- /dev/null +++ b/lisp/ledger-xact.el @@ -0,0 +1,200 @@ +;;; ledger-xact.el --- Helper code for use with the "ledger" command-line tool + +;; Copyright (C) 2003-2013 John Wiegley (johnw AT gnu DOT org) + +;; 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: +;; Utilities for running ledger synchronously. + +;;; Code: + +(defcustom ledger-highlight-xact-under-point t + "If t highlight xact under point." + :type 'boolean + :group 'ledger) + +(defcustom ledger-use-iso-dates nil + "If non-nil, use the iso-8601 format for dates (YYYY-MM-DD)." + :type 'boolean + :group 'ledger + :safe t) + +(defvar highlight-overlay (list)) + +(defun ledger-find-xact-extents (pos) + "Return point for beginning of xact and and of xact containing position. +Requires empty line separating xacts. Argument POS is a location +within the transaction." + (interactive "d") + (save-excursion + (goto-char pos) + (list (progn + (backward-paragraph) + (if (/= (point) (point-min)) + (forward-line)) + (line-beginning-position)) + (progn + (forward-paragraph) + (line-beginning-position))))) + +(defun ledger-highlight-xact-under-point () + "Move the highlight overlay to the current transaction." + (if ledger-highlight-xact-under-point + (let ((exts (ledger-find-xact-extents (point))) + (ovl highlight-overlay)) + (if (not highlight-overlay) + (setq ovl + (setq highlight-overlay + (make-overlay (car exts) + (cadr exts) + (current-buffer) t nil))) + (move-overlay ovl (car exts) (cadr exts))) + (overlay-put ovl 'face 'ledger-font-xact-highlight-face) + (overlay-put ovl 'priority 100)))) + +(defun ledger-xact-payee () + "Return the payee of the transaction 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) 'xact) + (ledger-context-field-value context-info 'payee) + nil)))) + +(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-xact-find-slot (moment) + "Find the right place in the buffer for a transaction at MOMENT. +MOMENT is an encoded date" + (catch 'found + (ledger-xact-iterate-transactions + (function + (lambda (start date mark desc) + (if (ledger-time-less-p moment date) + (throw 'found t))))))) + +(defun ledger-xact-iterate-transactions (callback) + "Iterate through each transaction call CALLBACK for each." + (goto-char (point-min)) + (let* ((now (current-time)) + (current-year (nth 5 (decode-time now)))) + (while (not (eobp)) + (when (looking-at ledger-iterate-regex) + (let ((found-y-p (match-string 2))) + (if found-y-p + (setq current-year (string-to-number found-y-p)) ;; a Y directive was found + (let ((start (match-beginning 0)) + (year (match-string 4)) + (month (string-to-number (match-string 5))) + (day (string-to-number (match-string 6))) + (mark (match-string 7)) + (code (match-string 8)) + (desc (match-string 9))) + (if (and year (> (length year) 0)) + (setq year (string-to-number year))) + (funcall callback start + (encode-time 0 0 0 day month + (or year current-year)) + mark desc))))) + (forward-line)))) + +(defsubst ledger-goto-line (line-number) + "Rapidly move point to line LINE-NUMBER." + (goto-char (point-min)) + (forward-line (1- line-number))) + +(defun ledger-year-and-month () + (let ((sep (if ledger-use-iso-dates + "-" + "/"))) + (concat ledger-year sep ledger-month sep))) + +(defun ledger-copy-transaction-at-point (date) + "Ask for a new DATE and copy the transaction under point to that date. Leave point on the first amount." + (interactive (list + (read-string "Copy to date: " (ledger-year-and-month) + 'ledger-minibuffer-history))) + (let* ((here (point)) + (extents (ledger-find-xact-extents (point))) + (transaction (buffer-substring-no-properties (car extents) (cadr extents))) + encoded-date) + (if (string-match ledger-iso-date-regexp date) + (setq encoded-date + (encode-time 0 0 0 (string-to-number (match-string 4 date)) + (string-to-number (match-string 3 date)) + (string-to-number (match-string 2 date))))) + (ledger-xact-find-slot encoded-date) + (insert transaction "\n") + (backward-paragraph 2) + (re-search-forward ledger-iso-date-regexp) + (replace-match date) + (ledger-next-amount))) + +(defun ledger-delete-current-transaction (pos) + "Delete the transaction surrounging point." + (interactive "d") + (let ((bounds (ledger-find-xact-extents pos))) + (delete-region (car bounds) (cadr bounds)))) + +(defun ledger-add-transaction (transaction-text &optional insert-at-point) + "Use ledger xact TRANSACTION-TEXT to add a transaction to the buffer. +If INSERT-AT-POINT is non-nil insert the transaction +there, otherwise call `ledger-xact-find-slot' to insert it at the +correct chronological place in the buffer." + (interactive (list + (read-string "Transaction: " (ledger-year-and-month)))) + (let* ((args (with-temp-buffer + (insert transaction-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 ledger-iso-date-regexp date) + (setq date + (encode-time 0 0 0 (string-to-number (match-string 4 date)) + (string-to-number (match-string 3 date)) + (string-to-number (match-string 2 date))))) + (ledger-xact-find-slot date))) + (if (> (length args) 1) + (save-excursion + (insert + (with-temp-buffer + (setq exit-code + (apply #'ledger-exec-ledger ledger-buf (current-buffer) "xact" + (mapcar 'eval args))) + (goto-char (point-min)) + (if (looking-at "Error: ") + (error (concat "Error in ledger-add-transaction: " (buffer-string))) + (buffer-string))) + "\n")) + (progn + (insert (car args) " \n\n") + (end-of-line -1))))) + + +(provide 'ledger-xact) + +;;; ledger-xact.el ends here -- cgit v1.2.3