diff options
| -rw-r--r-- | lisp/ledger-check.el | 136 | ||||
| -rw-r--r-- | lisp/ledger-mode.el | 2 | ||||
| -rw-r--r-- | lisp/ledger-occur.el | 3 | ||||
| -rw-r--r-- | lisp/ledger-reconcile.el | 3 | ||||
| -rw-r--r-- | lisp/ledger-schedule.el | 47 |
5 files changed, 167 insertions, 24 deletions
diff --git a/lisp/ledger-check.el b/lisp/ledger-check.el new file mode 100644 index 00000000..8eed34ed --- /dev/null +++ b/lisp/ledger-check.el @@ -0,0 +1,136 @@ +;;; ledger-check.el --- Helper code for use with the "ledger" command-line tool + +;; Copyright (C) 2015 Craig Earls (enderw88 AT gmail DOT com) + +;; This file is not part of GNU Emacs. + +;; This is free software; you can redistribute it and/or modify it under +;; the terms of the GNU General Public License as published by the Free +;; Software Foundation; either version 2, or (at your option) any later +;; version. +;; +;; This is distributed in the hope that it will be useful, but WITHOUT +;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +;; for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, +;; MA 02110-1301 USA. + +;;; Commentary: +;; Provide secial mode to correct errors in ledger when running with --strict and --explicit +;; +;; Adapted to ledger mode by Craig Earls <enderw88 at gmail dot com> + +;;; Code: + +(require 'easymenu) +(eval-when-compile + (require 'cl)) + +(defvar ledger-check-buffer-name "*Ledger Check*") + + + + +(defvar ledger-check-mode-map + (let ((map (make-sparse-keymap))) + (define-key map [return] 'ledger-report-visit-source) + (define-key map [?q] 'ledger-check-quit) + map) + "Keymap for `ledger-check-mode'.") + +(easy-menu-define ledger-check-mode-menu ledger-check-mode-map + "Ledger check menu" + '("Check" +; ["Re-run Check" ledger-check-redo] + "---" + ["Visit Source" ledger-report-visit-source] + "---" + ["Quit" ledger-check-quit] + )) + +(define-derived-mode ledger-check-mode text-mode "Ledger-Check" + "A mode for viewing ledger errors and warnings.") + + +(defun ledger-do-check () + "Run a check command ." + (goto-char (point-min)) + (let ((data-pos (point)) + (have-warnings nil)) + (shell-command + ;; ledger balance command will just return empty if you give it + ;; an account name that doesn't exist. I will assume that no + ;; one will ever have an account named "e342asd2131". If + ;; someones does, this will probably still work for them. + ;; I should only highlight error and warning lines. + "ledger bal e342asd2131 --strict --explicit " + t nil) + (goto-char data-pos) + + ;; format check report to make it navigate the file + + (while (re-search-forward "^.*: \"\\(.*\\)\", line \\([0-9]+\\)" nil t) + (let ((file (match-string 1)) + (line (string-to-number (match-string 2)))) + (when file + (set-text-properties (line-beginning-position) (line-end-position) + (list 'ledger-source (cons file (save-window-excursion + (save-excursion + (find-file file) + (widen) + (ledger-navigate-to-line line) + (point-marker)))))) + (add-text-properties (line-beginning-position) (line-end-position) + (list 'face 'ledger-font-report-clickable-face)) + (setq have-warnings 'true) + (end-of-line)))) + (if (not have-warnings) + (insert "No errors or warnings reported.")))) + +(defun ledger-check-goto () + "Goto the ledger check buffer." + (interactive) + (let ((rbuf (get-buffer ledger-check-buffer-name))) + (if (not rbuf) + (error "There is no ledger check buffer")) + (pop-to-buffer rbuf) + (shrink-window-if-larger-than-buffer))) + +(defun ledger-check-quit () + "Quit the ledger check buffer." + (interactive) + (ledger-check-goto) + (set-window-configuration ledger-original-window-cfg) + (kill-buffer (get-buffer ledger-check-buffer-name))) + +(defun ledger-check-buffer () + "Run a ledge with --explicit and --strict report errors and assist with fixing them. + +The output buffer will be in `ledger-check-mode', which defines +commands for navigating the buffer to the errors found, etc." + (interactive + (progn + (when (and (buffer-modified-p) + (y-or-n-p "Buffer modified, save it? ")) + (save-buffer)))) + (let ((buf (current-buffer)) + (cbuf (get-buffer ledger-check-buffer-name)) + (wcfg (current-window-configuration))) + (if cbuf + (kill-buffer cbuf)) + (with-current-buffer + (pop-to-buffer (get-buffer-create ledger-check-buffer-name)) + (ledger-check-mode) + (set (make-local-variable 'ledger-original-window-cfg) wcfg) + (ledger-do-check) + (shrink-window-if-larger-than-buffer) + (set-buffer-modified-p nil) + (setq buffer-read-only t) + (message "q to quit; r to redo; k to kill")))) + + +(provide 'ledger-check) diff --git a/lisp/ledger-mode.el b/lisp/ledger-mode.el index 9eff6bc6..7e30c350 100644 --- a/lisp/ledger-mode.el +++ b/lisp/ledger-mode.el @@ -49,6 +49,7 @@ (require 'ledger-texi) (require 'ledger-xact) (require 'ledger-schedule) +(require 'ledger-check) ;;; Code: @@ -316,6 +317,7 @@ With a prefix argument, remove the effective date." ["Copy Trans at Point" ledger-copy-transaction-at-point] "---" ["Clean-up Buffer" ledger-mode-clean-buffer] + ["Check Buffer" ledger-check-buffer ledger-works] ["Align Region" ledger-post-align-postings mark-active] ["Align Xact" ledger-post-align-xact] ["Sort Region" ledger-sort-region mark-active] diff --git a/lisp/ledger-occur.el b/lisp/ledger-occur.el index 810657a3..efdb246a 100644 --- a/lisp/ledger-occur.el +++ b/lisp/ledger-occur.el @@ -29,7 +29,8 @@ ;;; Code: -(require 'cl) +(eval-when-compile + (require 'cl)) (require 'ledger-navigate) (defconst ledger-occur-overlay-property-name 'ledger-occur-custom-buffer-grep) diff --git a/lisp/ledger-reconcile.el b/lisp/ledger-reconcile.el index a6a7dd86..68019c13 100644 --- a/lisp/ledger-reconcile.el +++ b/lisp/ledger-reconcile.el @@ -446,7 +446,8 @@ Return a count of the uncleared transactions." (fmt (ledger-reconcile-compile-format-string ledger-reconcile-buffer-line-format))) (if (and ledger-success (> (length xacts) 0)) (progn - (insert (format ledger-reconcile-buffer-header account)) + (if ledger-reconcile-buffer-header + (insert (format ledger-reconcile-buffer-header account))) (dolist (xact xacts) (ledger-reconcile-format-xact xact fmt)) (goto-char (point-max)) diff --git a/lisp/ledger-schedule.el b/lisp/ledger-schedule.el index 1fbbcb59..723fa2b3 100644 --- a/lisp/ledger-schedule.el +++ b/lisp/ledger-schedule.el @@ -31,7 +31,8 @@ ;; function without have to use funcall. (require 'ledger-init) -(require 'cl) +(eval-when-compile + (require 'cl)) ;;; Code: @@ -202,39 +203,41 @@ the transaction should be logged for that day." (defun ledger-schedule-compile-constraints (descriptor-string) "Return a list with the year, month and day fields split." (let ((fields (split-string descriptor-string "[/\\-]" t))) - (if (string-match "[A-Za-z]" descriptor-string) - (ledger-schedule-constrain-day (nth 0 fields) (nth 1 fields) (nth 2 fields)) - (list 'and - (ledger-schedule-constrain-day (nth 0 fields) (nth 1 fields) (nth 2 fields)) - (ledger-schedule-constrain-year (nth 0 fields) (nth 1 fields) (nth 2 fields)) - (ledger-schedule-constrain-month (nth 0 fields) (nth 1 fields) (nth 2 fields)))))) + (list 'and + (ledger-schedule-constrain-day (nth 0 fields) (nth 1 fields) (nth 2 fields)) + (ledger-schedule-constrain-year (nth 0 fields) (nth 1 fields) (nth 2 fields)) + (ledger-schedule-constrain-month (nth 0 fields) (nth 1 fields) (nth 2 fields))))) (defun ledger-schedule-constrain-year (year-desc month-desc day-desc) "Return a form that constrains the year. YEAR-DESC, MONT-DESC, and DAY-DESC are the string portions of the date descriptor." - (cond ((string= year-desc "*") t) - ((/= 0 (string-to-number year-desc)) - `(memq (nth 5 (decode-time date)) ',(mapcar 'string-to-number (split-string year-desc ",")))) - (t - (error "Improperly specified year constraint: %s %s %s" year-desc month-desc day-desc)))) + (cond + ((string-match "[A-Za-z]" day-desc) t) ; there is an advanced day descriptor which overrides the year + ((string= year-desc "*") t) + ((/= 0 (string-to-number year-desc)) + `(memq (nth 5 (decode-time date)) ',(mapcar 'string-to-number (split-string year-desc ",")))) + (t + (error "Improperly specified year constraint: %s %s %s" year-desc month-desc day-desc)))) (defun ledger-schedule-constrain-month (year-desc month-desc day-desc) "Return a form that constrains the month. YEAR-DESC, MONT-DESC, and DAY-DESC are the string portions of the date descriptor." - (cond ((string= month-desc "*") - t) ;; always match - ((string= month-desc "E") ;; Even - `(evenp (nth 4 (decode-time date)))) - ((string= month-desc "O") ;; Odd - `(oddp (nth 4 (decode-time date)))) - ((/= 0 (string-to-number month-desc)) ;; Starts with number - `(memq (nth 4 (decode-time date)) ',(mapcar 'string-to-number (split-string month-desc ",")))) - (t - (error "Improperly specified month constraint: %s %s %s" year-desc month-desc day-desc)))) + (cond + ((string-match "[A-Za-z]" day-desc) t) ; there is an advanced day descriptor which overrides the month + ((string= month-desc "*") + t) ;; always match + ((string= month-desc "E") ;; Even + `(evenp (nth 4 (decode-time date)))) + ((string= month-desc "O") ;; Odd + `(oddp (nth 4 (decode-time date)))) + ((/= 0 (string-to-number month-desc)) ;; Starts with number + `(memq (nth 4 (decode-time date)) ',(mapcar 'string-to-number (split-string month-desc ",")))) + (t + (error "Improperly specified month constraint: %s %s %s" year-desc month-desc day-desc)))) (defun ledger-schedule-constrain-day (year-desc month-desc day-desc) "Return a form that constrains the day. |