From efce6c89362abed1276cd060cec8077777a038e4 Mon Sep 17 00:00:00 2001 From: Craig Earls Date: Mon, 4 Mar 2013 09:36:34 -0700 Subject: Add acct under point to reconcile prompt. Fix reconcile balance display of empty accounts --- lisp/ldg-commodities.el | 46 ++++++++++++++++++++++++---------------------- lisp/ldg-post.el | 12 ++++++++++++ lisp/ldg-reconcile.el | 9 +++++---- lisp/ldg-report.el | 11 +++-------- 4 files changed, 44 insertions(+), 34 deletions(-) diff --git a/lisp/ldg-commodities.el b/lisp/ldg-commodities.el index a3cc8951..9291136f 100644 --- a/lisp/ldg-commodities.el +++ b/lisp/ldg-commodities.el @@ -33,28 +33,30 @@ (defun ledger-split-commodity-string (str) "Split a commoditized amount into two parts" - (let (val - comm) - (with-temp-buffer - (insert str) - (goto-char (point-min)) - (cond ((re-search-forward "-?[1-9][0-9]*[.,][0-9]*" nil t) - ;; found a decimal number - (setq val - (string-to-number - (ledger-commodity-string-number-decimalize - (delete-and-extract-region (match-beginning 0) (match-end 0)) :from-user))) - (goto-char (point-min)) - (re-search-forward "[^[:space:]]" nil t) - (setq comm - (delete-and-extract-region (match-beginning 0) (match-end 0))) - (list val comm)) - ((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)) - (t - (error "split-commodity-string: cannot parse commodity string: %S" str)))))) + (if (> (length str) 0) + (let (val + comm) + (with-temp-buffer + (insert str) + (goto-char (point-min)) + (cond ((re-search-forward "-?[1-9][0-9]*[.,][0-9]*" nil t) + ;; found a decimal number + (setq val + (string-to-number + (ledger-commodity-string-number-decimalize + (delete-and-extract-region (match-beginning 0) (match-end 0)) :from-user))) + (goto-char (point-min)) + (re-search-forward "[^[:space:]]" nil t) + (setq comm + (delete-and-extract-region (match-beginning 0) (match-end 0))) + (list val comm)) + ((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)) + (t + (error "split-commodity-string: cannot parse commodity string: %S" str))))) + (list 0 ledger-reconcile-default-commodity))) (defun ledger-string-balance-to-commoditized-amount (str) diff --git a/lisp/ldg-post.el b/lisp/ldg-post.el index 7105ef7a..6cba305b 100644 --- a/lisp/ldg-post.el +++ b/lisp/ldg-post.el @@ -229,6 +229,18 @@ BEG, END, and LEN control how far it can align." (add-hook 'after-change-functions 'ledger-post-maybe-align t t)) (add-hook 'after-save-hook #'(lambda () (setq ledger-post-current-list nil)))) + +(defun ledger-post-read-account-with-prompt (prompt) + (let* ((context (ledger-context-at-point)) + (default + (if (eq (ledger-context-line-type context) 'acct-transaction) + (regexp-quote (ledger-context-field-value context 'account)) + nil))) + (ledger-read-string-with-default prompt default))) + + (provide 'ldg-post) + + ;;; ldg-post.el ends here diff --git a/lisp/ldg-reconcile.el b/lisp/ldg-reconcile.el index 33c9f06f..e45ab7c3 100644 --- a/lisp/ldg-reconcile.el +++ b/lisp/ldg-reconcile.el @@ -351,10 +351,11 @@ POSTING is used in `ledger-clear-whole-transactions' is nil." (set-window-buffer (split-window (get-buffer-window buf) nil nil) rbuf) (pop-to-buffer rbuf))) -(defun ledger-reconcile (account) - "Start reconciling ACCOUNT." - (interactive "sAccount to reconcile: ") - (let ((buf (current-buffer)) +(defun ledger-reconcile () + "Start reconciling, prompt for account." + (interactive) + (let ((account (ledger-post-read-account-with-prompt "Account to reconcile")) + (buf (current-buffer)) (rbuf (get-buffer ledger-recon-buffer-name))) ;; this means ;; only one ;; *Reconcile* diff --git a/lisp/ldg-report.el b/lisp/ldg-report.el index 0728495e..ef088f17 100644 --- a/lisp/ldg-report.el +++ b/lisp/ldg-report.el @@ -258,12 +258,7 @@ used to generate the buffer, navigating the buffer, etc." the default." ;; It is intended completion should be available on existing account ;; names, but it remains to be implemented. - (let* ((context (ledger-context-at-point)) - (default - (if (eq (ledger-context-line-type context) 'acct-transaction) - (regexp-quote (ledger-context-field-value context 'account)) - nil))) - (ledger-read-string-with-default "Account" default))) + (ledger-post-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." @@ -437,9 +432,9 @@ Optional EDIT the command." ("^\\(\\([0-9][0-9][0-9][0-9]/\\)?[01]?[0-9]/[0123]?[0-9]\\)[ \t]+\\(\\([!*]\\)[ \t]\\)?[ \t]*\\((\\(.*\\))\\)?[ \t]*\\(.*\\)[ \t]*$" (date nil status nil nil code payee)))) (acct-transaction - (("\\(^[ \t]+\\)\\(.*?\\)[ \t]+\\([$]\\)\\(-?[0-9]*\\(\\.[0-9]*\\)?\\)[ \t]*;[ \t]*\\(.*?\\)[ \t]*$" + (("\\(^[ \t]+\\)\\(.*?\\)[ \t]+\\([$€£]\\s-?\\)\\(-?[0-9]*\\(\\.[0-9]*\\)?\\)[ \t]*;[ \t]*\\(.*?\\)[ \t]*$" (indent account commodity amount nil comment)) - ("\\(^[ \t]+\\)\\(.*?\\)[ \t]+\\([$]\\)\\(-?[0-9]*\\(\\.[0-9]*\\)?\\)[ \t]*$" + ("\\(^[ \t]+\\)\\(.*?\\)[ \t]+\\([$€£]\\s-?\\)\\(-?[0-9]*\\(\\.[0-9]*\\)?\\)[ \t]*$" (indent account commodity amount nil)) ("\\(^[ \t]+\\)\\(.*?\\)[ \t]+\\(-?[0-9]+\\(\\.[0-9]*\\)?\\)[ \t]+\\(.*?\\)[ \t]*;[ \t]*\\(.*?\\)[ \t]*$" (indent account amount nil commodity comment)) -- cgit v1.2.3 From 5a48bc39356d98abe1b1afdcdc42f382755f6929 Mon Sep 17 00:00:00 2001 From: Craig Earls Date: Tue, 5 Mar 2013 21:30:05 -0500 Subject: Removed timeclock.el. This has been parts of the standard Emacs installation for a very long time. No need to repeat it here. --- lisp/timeclock.el | 1362 ----------------------------------------------------- 1 file changed, 1362 deletions(-) delete mode 100644 lisp/timeclock.el diff --git a/lisp/timeclock.el b/lisp/timeclock.el deleted file mode 100644 index 2cafa8eb..00000000 --- a/lisp/timeclock.el +++ /dev/null @@ -1,1362 +0,0 @@ -;;; timeclock.el --- mode for keeping track of how much you work - -;; Copyright (C) 1999, 2000, 2001, 2003, 2004 Free Software Foundation, Inc. - -;; Author: John Wiegley -;; Created: 25 Mar 1999 -;; Version: 2.6 -;; Keywords: calendar data - -;; This file is part of GNU Emacs. - -;; GNU Emacs 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. - -;; GNU Emacs 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 mode is for keeping track of time intervals. You can use it -;; for whatever purpose you like, but the typical scenario is to keep -;; track of how much time you spend working on certain projects. -;; -;; Use `timeclock-in' when you start on a project, and `timeclock-out' -;; when you're done. Once you've collected some data, you can use -;; `timeclock-workday-remaining' to see how much time is left to be -;; worked today (where `timeclock-workday' specifies the length of the -;; working day), and `timeclock-when-to-leave' to calculate when you're free. - -;; You'll probably want to bind the timeclock commands to some handy -;; keystrokes. At the moment, C-x t is unused: -;; -;; (require 'timeclock) -;; -;; (define-key ctl-x-map "ti" 'timeclock-in) -;; (define-key ctl-x-map "to" 'timeclock-out) -;; (define-key ctl-x-map "tc" 'timeclock-change) -;; (define-key ctl-x-map "tr" 'timeclock-reread-log) -;; (define-key ctl-x-map "tu" 'timeclock-update-modeline) -;; (define-key ctl-x-map "tw" 'timeclock-when-to-leave-string) - -;; If you want Emacs to display the amount of time "left" to your -;; workday in the modeline, you can either set the value of -;; `timeclock-modeline-display' to t using M-x customize, or you -;; can add this code to your .emacs file: -;; -;; (require 'timeclock) -;; (timeclock-modeline-display) -;; -;; To cancel this modeline display at any time, just call -;; `timeclock-modeline-display' again. - -;; You may also want Emacs to ask you before exiting, if you are -;; currently working on a project. This can be done either by setting -;; `timeclock-ask-before-exiting' to t using M-x customize (this is -;; the default), or by adding the following to your .emacs file: -;; -;; (add-hook 'kill-emacs-query-functions 'timeclock-query-out) - -;; NOTE: If you change your .timelog file without using timeclock's -;; functions, or if you change the value of any of timeclock's -;; customizable variables, you should run the command -;; `timeclock-reread-log'. This will recompute any discrepancies in -;; your average working time, and will make sure that the various -;; display functions return the correct value. - -;;; History: - -;;; Code: - -(defgroup timeclock nil - "Keeping track time of the time that gets spent." - :group 'data) - -;;; User Variables: - -(defcustom timeclock-file (convert-standard-filename "~/.timelog") - "*The file used to store timeclock data in." - :type 'file - :group 'timeclock) - -(defcustom timeclock-workday (* 8 60 60) - "*The length of a work period." - :type 'integer - :group 'timeclock) - -(defcustom timeclock-relative t - "*Whether to maken reported time relative to `timeclock-workday'. -For example, if the length of a normal workday is eight hours, and you -work four hours on Monday, then the amount of time \"remaining\" on -Tuesday is twelve hours -- relative to an averaged work period of -eight hours -- or eight hours, non-relative. So relative time takes -into account any discrepancy of time under-worked or over-worked on -previous days. This only affects the timeclock modeline display." - :type 'boolean - :group 'timeclock) - -(defcustom timeclock-get-project-function 'timeclock-ask-for-project - "*The function used to determine the name of the current project. -When clocking in, and no project is specified, this function will be -called to determine what is the current project to be worked on. -If this variable is nil, no questions will be asked." - :type 'function - :group 'timeclock) - -(defcustom timeclock-get-reason-function 'timeclock-ask-for-reason - "*A function used to determine the reason for clocking out. -When clocking out, and no reason is specified, this function will be -called to determine what is the reason. -If this variable is nil, no questions will be asked." - :type 'function - :group 'timeclock) - -(defcustom timeclock-get-workday-function nil - "*A function used to determine the length of today's workday. -The first time that a user clocks in each day, this function will be -called to determine what is the length of the current workday. If -the return value is nil, or equal to `timeclock-workday', nothing special -will be done. If it is a quantity different from `timeclock-workday', -however, a record will be output to the timelog file to note the fact that -that day has a length that is different from the norm." - :type '(choice (const nil) function) - :group 'timeclock) - -(defcustom timeclock-ask-before-exiting t - "*If non-nil, ask if the user wants to clock out before exiting Emacs. -This variable only has effect if set with \\[customize]." - :set (lambda (symbol value) - (if value - (add-hook 'kill-emacs-query-functions 'timeclock-query-out) - (remove-hook 'kill-emacs-query-functions 'timeclock-query-out)) - (setq timeclock-ask-before-exiting value)) - :type 'boolean - :group 'timeclock) - -(defvar timeclock-update-timer nil - "The timer used to update `timeclock-mode-string'.") - -;; For byte-compiler. -(defvar display-time-hook) -(defvar timeclock-modeline-display) - -(defcustom timeclock-use-display-time t - "*If non-nil, use `display-time-hook' for doing modeline updates. -The advantage of this is that one less timer has to be set running -amok in Emacs' process space. The disadvantage is that it requires -you to have `display-time' running. If you don't want to use -`display-time', but still want the modeline to show how much time is -left, set this variable to nil. Changing the value of this variable -while timeclock information is being displayed in the modeline has no -effect. You should call the function `timeclock-modeline-display' with -a positive argument to force an update." - :set (lambda (symbol value) - (let ((currently-displaying - (and (boundp 'timeclock-modeline-display) - timeclock-modeline-display))) - ;; if we're changing to the state that - ;; `timeclock-modeline-display' is already using, don't - ;; bother toggling it. This happens on the initial loading - ;; of timeclock.el. - (if (and currently-displaying - (or (and value - (boundp 'display-time-hook) - (memq 'timeclock-update-modeline - display-time-hook)) - (and (not value) - timeclock-update-timer))) - (setq currently-displaying nil)) - (and currently-displaying - (set-variable 'timeclock-modeline-display nil)) - (setq timeclock-use-display-time value) - (and currently-displaying - (set-variable 'timeclock-modeline-display t)) - timeclock-use-display-time)) - :type 'boolean - :group 'timeclock - :require 'time) - -(defcustom timeclock-first-in-hook nil - "*A hook run for the first \"in\" event each day. -Note that this hook is run before recording any events. Thus the -value of `timeclock-hours-today', `timeclock-last-event' and the -return value of function `timeclock-last-period' are relative previous -to today." - :type 'hook - :group 'timeclock) - -(defcustom timeclock-load-hook nil - "*Hook that gets run after timeclock has been loaded." - :type 'hook - :group 'timeclock) - -(defcustom timeclock-in-hook nil - "*A hook run every time an \"in\" event is recorded." - :type 'hook - :group 'timeclock) - -(defcustom timeclock-day-over-hook nil - "*A hook that is run when the workday has been completed. -This hook is only run if the current time remaining is being displayed -in the modeline. See the variable `timeclock-modeline-display'." - :type 'hook - :group 'timeclock) - -(defcustom timeclock-out-hook nil - "*A hook run every time an \"out\" event is recorded." - :type 'hook - :group 'timeclock) - -(defcustom timeclock-done-hook nil - "*A hook run every time a project is marked as completed." - :type 'hook - :group 'timeclock) - -(defcustom timeclock-event-hook nil - "*A hook run every time any event is recorded." - :type 'hook - :group 'timeclock) - -(defvar timeclock-last-event nil - "A list containing the last event that was recorded. -The format of this list is (CODE TIME PROJECT).") - -(defvar timeclock-last-event-workday nil - "The number of seconds in the workday of `timeclock-last-event'.") - -;;; Internal Variables: - -(defvar timeclock-discrepancy nil - "A variable containing the time discrepancy before the last event. -Normally, timeclock assumes that you intend to work for -`timeclock-workday' seconds every day. Any days in which you work -more or less than this amount is considered either a positive or -a negative discrepancy. If you work in such a manner that the -discrepancy is always brought back to zero, then you will by -definition have worked an average amount equal to `timeclock-workday' -each day.") - -(defvar timeclock-elapsed nil - "A variable containing the time elapsed for complete periods today. -This value is not accurate enough to be useful by itself. Rather, -call `timeclock-workday-elapsed', to determine how much time has been -worked so far today. Also, if `timeclock-relative' is nil, this value -will be the same as `timeclock-discrepancy'.") ; ? gm - -(defvar timeclock-last-period nil - "Integer representing the number of seconds in the last period. -Note that you shouldn't access this value, but instead should use the -function `timeclock-last-period'.") - -(defvar timeclock-mode-string nil - "The timeclock string (optionally) displayed in the modeline. -The time is bracketed by <> if you are clocked in, otherwise by [].") - -(defvar timeclock-day-over nil - "The date of the last day when notified \"day over\" for.") - -;;; User Functions: - -;;;###autoload -(defun timeclock-modeline-display (&optional arg) - "Toggle display of the amount of time left today in the modeline. -If `timeclock-use-display-time' is non-nil (the default), then -the function `display-time-mode' must be active, and the modeline -will be updated whenever the time display is updated. Otherwise, -the timeclock will use its own sixty second timer to do its -updating. With prefix ARG, turn modeline display on if and only -if ARG is positive. Returns the new status of timeclock modeline -display (non-nil means on)." - (interactive "P") - ;; cf display-time-mode. - (setq timeclock-mode-string "") - (or global-mode-string (setq global-mode-string '(""))) - (let ((on-p (if arg - (> (prefix-numeric-value arg) 0) - (not timeclock-modeline-display)))) - (if on-p - (progn - (or (memq 'timeclock-mode-string global-mode-string) - (setq global-mode-string - (append global-mode-string '(timeclock-mode-string)))) - (unless (memq 'timeclock-update-modeline timeclock-event-hook) - (add-hook 'timeclock-event-hook 'timeclock-update-modeline)) - (when timeclock-update-timer - (cancel-timer timeclock-update-timer) - (setq timeclock-update-timer nil)) - (if (boundp 'display-time-hook) - (remove-hook 'display-time-hook 'timeclock-update-modeline)) - (if timeclock-use-display-time - (progn - ;; Update immediately so there is a visible change - ;; on calling this function. - (if display-time-mode (timeclock-update-modeline) - (message "Activate `display-time-mode' to see \ -timeclock information")) - (add-hook 'display-time-hook 'timeclock-update-modeline)) - (setq timeclock-update-timer - (run-at-time nil 60 'timeclock-update-modeline)))) - (setq global-mode-string - (delq 'timeclock-mode-string global-mode-string)) - (remove-hook 'timeclock-event-hook 'timeclock-update-modeline) - (if (boundp 'display-time-hook) - (remove-hook 'display-time-hook - 'timeclock-update-modeline)) - (when timeclock-update-timer - (cancel-timer timeclock-update-timer) - (setq timeclock-update-timer nil))) - (force-mode-line-update) - (setq timeclock-modeline-display on-p))) - -;; This has to be here so that the function definition of -;; `timeclock-modeline-display' is known to the "set" function. -(defcustom timeclock-modeline-display nil - "Toggle modeline display of time remaining. -You must modify via \\[customize] for this variable to have an effect." - :set (lambda (symbol value) - (setq timeclock-modeline-display - (timeclock-modeline-display (or value 0)))) - :type 'boolean - :group 'timeclock - :require 'timeclock) - -(defsubst timeclock-time-to-date (time) - "Convert the TIME value to a textual date string." - (format-time-string "%Y/%m/%d" time)) - -;;;###autoload -(defun timeclock-in (&optional arg project find-project) - "Clock in, recording the current time moment in the timelog. -With a numeric prefix ARG, record the fact that today has only that -many hours in it to be worked. If arg is a non-numeric prefix arg -\(non-nil, but not a number), 0 is assumed (working on a holiday or -weekend). *If not called interactively, ARG should be the number of -_seconds_ worked today*. This feature only has effect the first time -this function is called within a day. - -PROJECT is the project being clocked into. If PROJECT is nil, and -FIND-PROJECT is non-nil -- or the user calls `timeclock-in' -interactively -- call the function `timeclock-get-project-function' to -discover the name of the project." - (interactive - (list (and current-prefix-arg - (if (numberp current-prefix-arg) - (* current-prefix-arg 60 60) - 0)))) - (if (equal (car timeclock-last-event) "i") - (error "You've already clocked in!") - (unless timeclock-last-event - (timeclock-reread-log)) - ;; Either no log file, or day has rolled over. - (unless (and timeclock-last-event - (equal (timeclock-time-to-date - (cadr timeclock-last-event)) - (timeclock-time-to-date (current-time)))) - (let ((workday (or (and (numberp arg) arg) - (and arg 0) - (and timeclock-get-workday-function - (funcall timeclock-get-workday-function)) - timeclock-workday))) - (run-hooks 'timeclock-first-in-hook) - ;; settle the discrepancy for the new day - (setq timeclock-discrepancy - (- (or timeclock-discrepancy 0) workday)) - (if (not (= workday timeclock-workday)) - (timeclock-log "h" (and (numberp arg) - (number-to-string arg)))))) - (timeclock-log "i" (or project - (and timeclock-get-project-function - (or find-project (interactive-p)) - (funcall timeclock-get-project-function)))) - (run-hooks 'timeclock-in-hook))) - -;;;###autoload -(defun timeclock-out (&optional arg reason find-reason) - "Clock out, recording the current time moment in the timelog. -If a prefix ARG is given, the user has completed the project that was -begun during the last time segment. - -REASON is the user's reason for clocking out. If REASON is nil, and -FIND-REASON is non-nil -- or the user calls `timeclock-out' -interactively -- call the function `timeclock-get-reason-function' to -discover the reason." - (interactive "P") - (or timeclock-last-event - (error "You haven't clocked in!")) - (if (equal (downcase (car timeclock-last-event)) "o") - (error "You've already clocked out!") - (timeclock-log - (if arg "O" "o") - (or reason - (and timeclock-get-reason-function - (or find-reason (interactive-p)) - (funcall timeclock-get-reason-function)))) - (run-hooks 'timeclock-out-hook) - (if arg - (run-hooks 'timeclock-done-hook)))) - -;; Should today-only be removed in favour of timeclock-relative? - gm -(defsubst timeclock-workday-remaining (&optional today-only) - "Return the number of seconds until the workday is complete. -The amount returned is relative to the value of `timeclock-workday'. -If TODAY-ONLY is non-nil, the value returned will be relative only to -the time worked today, and not to past time." - (let ((discrep (timeclock-find-discrep))) - (if discrep - (- (if today-only (cadr discrep) - (car discrep))) - 0.0))) - -;;;###autoload -(defun timeclock-status-string (&optional show-seconds today-only) - "Report the overall timeclock status at the present moment. -If SHOW-SECONDS is non-nil, display second resolution. -If TODAY-ONLY is non-nil, the display will be relative only to time -worked today, ignoring the time worked on previous days." - (interactive "P") - (let ((remainder (timeclock-workday-remaining)) ; today-only? - (last-in (equal (car timeclock-last-event) "i")) - status) - (setq status - (format "Currently %s since %s (%s), %s %s, leave at %s" - (if last-in "IN" "OUT") - (if show-seconds - (format-time-string "%-I:%M:%S %p" - (nth 1 timeclock-last-event)) - (format-time-string "%-I:%M %p" - (nth 1 timeclock-last-event))) - (or (nth 2 timeclock-last-event) - (if last-in "**UNKNOWN**" "workday over")) - (timeclock-seconds-to-string remainder show-seconds t) - (if (> remainder 0) - "remaining" "over") - (timeclock-when-to-leave-string show-seconds today-only))) - (if (interactive-p) - (message status) - status))) - -;;;###autoload -(defun timeclock-change (&optional arg project) - "Change to working on a different project. -This clocks out of the current project, then clocks in on a new one. -With a prefix ARG, consider the previous project as finished at the -time of changeover. PROJECT is the name of the last project you were -working on." - (interactive "P") - (timeclock-out arg) - (timeclock-in nil project (interactive-p))) - -;;;###autoload -(defun timeclock-query-out () - "Ask the user whether to clock out. -This is a useful function for adding to `kill-emacs-query-functions'." - (and (equal (car timeclock-last-event) "i") - (y-or-n-p "You're currently clocking time, clock out? ") - (timeclock-out)) - ;; Unconditionally return t for `kill-emacs-query-functions'. - t) - -;;;###autoload -(defun timeclock-reread-log () - "Re-read the timeclock, to account for external changes. -Returns the new value of `timeclock-discrepancy'." - (interactive) - (setq timeclock-discrepancy nil) - (timeclock-find-discrep) - (if (and timeclock-discrepancy timeclock-modeline-display) - (timeclock-update-modeline)) - timeclock-discrepancy) - -(defun timeclock-seconds-to-string (seconds &optional show-seconds - reverse-leader) - "Convert SECONDS into a compact time string. -If SHOW-SECONDS is non-nil, make the resolution of the return string -include the second count. If REVERSE-LEADER is non-nil, it means to -output a \"+\" if the time value is negative, rather than a \"-\". -This is used when negative time values have an inverted meaning (such -as with time remaining, where negative time really means overtime)." - (if show-seconds - (format "%s%d:%02d:%02d" - (if (< seconds 0) (if reverse-leader "+" "-") "") - (truncate (/ (abs seconds) 60 60)) - (% (truncate (/ (abs seconds) 60)) 60) - (% (truncate (abs seconds)) 60)) - (format "%s%d:%02d" - (if (< seconds 0) (if reverse-leader "+" "-") "") - (truncate (/ (abs seconds) 60 60)) - (% (truncate (/ (abs seconds) 60)) 60)))) - -(defsubst timeclock-currently-in-p () - "Return non-nil if the user is currently clocked in." - (equal (car timeclock-last-event) "i")) - -;;;###autoload -(defun timeclock-workday-remaining-string (&optional show-seconds - today-only) - "Return a string representing the amount of time left today. -Display second resolution if SHOW-SECONDS is non-nil. If TODAY-ONLY -is non-nil, the display will be relative only to time worked today. -See `timeclock-relative' for more information about the meaning of -\"relative to today\"." - (interactive) - (let ((string (timeclock-seconds-to-string - (timeclock-workday-remaining today-only) - show-seconds t))) - (if (interactive-p) - (message string) - string))) - -(defsubst timeclock-workday-elapsed () - "Return the number of seconds worked so far today. -If RELATIVE is non-nil, the amount returned will be relative to past -time worked. The default is to return only the time that has elapsed -so far today." - (let ((discrep (timeclock-find-discrep))) - (if discrep - (nth 2 discrep) - 0.0))) - -;;;###autoload -(defun timeclock-workday-elapsed-string (&optional show-seconds) - "Return a string representing the amount of time worked today. -Display seconds resolution if SHOW-SECONDS is non-nil. If RELATIVE is -non-nil, the amount returned will be relative to past time worked." - (interactive) - (let ((string (timeclock-seconds-to-string (timeclock-workday-elapsed) - show-seconds))) - (if (interactive-p) - (message string) - string))) - -(defsubst timeclock-time-to-seconds (time) - "Convert TIME to a floating point number." - (+ (* (car time) 65536.0) - (cadr time) - (/ (or (car (cdr (cdr time))) 0) 1000000.0))) - -(defsubst timeclock-seconds-to-time (seconds) - "Convert SECONDS (a floating point number) to an Emacs time structure." - (list (floor seconds 65536) - (floor (mod seconds 65536)) - (floor (* (- seconds (ffloor seconds)) 1000000)))) - -;; Should today-only be removed in favour of timeclock-relative? - gm -(defsubst timeclock-when-to-leave (&optional today-only) - "Return a time value representing the end of today's workday. -If TODAY-ONLY is non-nil, the value returned will be relative only to -the time worked today, and not to past time." - (timeclock-seconds-to-time - (- (timeclock-time-to-seconds (current-time)) - (let ((discrep (timeclock-find-discrep))) - (if discrep - (if today-only - (cadr discrep) - (car discrep)) - 0.0))))) - -;;;###autoload -(defun timeclock-when-to-leave-string (&optional show-seconds - today-only) - "Return a string representing the end of today's workday. -This string is relative to the value of `timeclock-workday'. If -SHOW-SECONDS is non-nil, the value printed/returned will include -seconds. If TODAY-ONLY is non-nil, the value returned will be -relative only to the time worked today, and not to past time." - ;; Should today-only be removed in favour of timeclock-relative? - gm - (interactive) - (let* ((then (timeclock-when-to-leave today-only)) - (string - (if show-seconds - (format-time-string "%-I:%M:%S %p" then) - (format-time-string "%-I:%M %p" then)))) - (if (interactive-p) - (message string) - string))) - -;;; Internal Functions: - -(defvar timeclock-project-list nil) -(defvar timeclock-last-project nil) - -(defun timeclock-completing-read (prompt alist &optional default) - "A version of `completing-read' that works on both Emacs and XEmacs." - (if (featurep 'xemacs) - (let ((str (completing-read prompt alist))) - (if (or (null str) (= (length str) 0)) - default - str)) - (completing-read prompt alist nil nil nil nil default))) - -(defun timeclock-ask-for-project () - "Ask the user for the project they are clocking into." - (timeclock-completing-read - (format "Clock into which project (default \"%s\"): " - (or timeclock-last-project - (car timeclock-project-list))) - (mapcar 'list timeclock-project-list) - (or timeclock-last-project - (car timeclock-project-list)))) - -(defvar timeclock-reason-list nil) - -(defun timeclock-ask-for-reason () - "Ask the user for the reason they are clocking out." - (timeclock-completing-read "Reason for clocking out: " - (mapcar 'list timeclock-reason-list))) - -(defun timeclock-update-modeline () - "Update the `timeclock-mode-string' displayed in the modeline. -The value of `timeclock-relative' affects the display as described in -that variable's documentation." - (interactive) - (let ((remainder (timeclock-workday-remaining (not timeclock-relative))) - (last-in (equal (car timeclock-last-event) "i"))) - (when (and (< remainder 0) - (not (and timeclock-day-over - (equal timeclock-day-over - (timeclock-time-to-date - (current-time)))))) - (setq timeclock-day-over - (timeclock-time-to-date (current-time))) - (run-hooks 'timeclock-day-over-hook)) - (setq timeclock-mode-string - (propertize - (format " %c%s%c " - (if last-in ?< ?[) - (timeclock-seconds-to-string remainder nil t) - (if last-in ?> ?])) - 'help-echo "timeclock: time remaining")))) - -(put 'timeclock-mode-string 'risky-local-variable t) - -(defun timeclock-log (code &optional project) - "Log the event CODE to the timeclock log, at the time of call. -If PROJECT is a string, it represents the project which the event is -being logged for. Normally only \"in\" events specify a project." - (with-current-buffer (find-file-noselect timeclock-file) - (goto-char (point-max)) - (if (not (bolp)) - (insert "\n")) - (let ((now (current-time))) - (insert code " " - (format-time-string "%Y/%m/%d %H:%M:%S" now) - (or (and project - (stringp project) - (> (length project) 0) - (concat " " project)) - "") - "\n") - (if (equal (downcase code) "o") - (setq timeclock-last-period - (- (timeclock-time-to-seconds now) - (timeclock-time-to-seconds - (cadr timeclock-last-event))) - timeclock-discrepancy - (+ timeclock-discrepancy - timeclock-last-period))) - (setq timeclock-last-event (list code now project))) - (save-buffer) - (run-hooks 'timeclock-event-hook) - (kill-buffer (current-buffer)))) - -(defvar timeclock-moment-regexp - (concat "\\([bhioO]\\)\\s-+" - "\\([0-9]+\\)/\\([0-9]+\\)/\\([0-9]+\\)\\s-+" - "\\([0-9]+\\):\\([0-9]+\\):\\([0-9]+\\)[ \t]*" "\\([^\n]*\\)")) - -(defsubst timeclock-read-moment () - "Read the moment under point from the timelog." - (if (looking-at timeclock-moment-regexp) - (let ((code (match-string 1)) - (year (string-to-number (match-string 2))) - (mon (string-to-number (match-string 3))) - (mday (string-to-number (match-string 4))) - (hour (string-to-number (match-string 5))) - (min (string-to-number (match-string 6))) - (sec (string-to-number (match-string 7))) - (project (match-string 8))) - (list code (encode-time sec min hour mday mon year) project)))) - -(defun timeclock-last-period (&optional moment) - "Return the value of the last event period. -If the last event was a clock-in, the period will be open ended, and -growing every second. Otherwise, it is a fixed amount which has been -recorded to disk. If MOMENT is non-nil, use that as the current time. -This is only provided for coherency when used by -`timeclock-discrepancy'." - (if (equal (car timeclock-last-event) "i") - (- (timeclock-time-to-seconds (or moment (current-time))) - (timeclock-time-to-seconds - (cadr timeclock-last-event))) - timeclock-last-period)) - -(defsubst timeclock-entry-length (entry) - (- (timeclock-time-to-seconds (cadr entry)) - (timeclock-time-to-seconds (car entry)))) - -(defsubst timeclock-entry-begin (entry) - (car entry)) - -(defsubst timeclock-entry-end (entry) - (cadr entry)) - -(defsubst timeclock-entry-project (entry) - (nth 2 entry)) - -(defsubst timeclock-entry-comment (entry) - (nth 3 entry)) - - -(defsubst timeclock-entry-list-length (entry-list) - (let ((length 0)) - (while entry-list - (setq length (+ length (timeclock-entry-length (car entry-list)))) - (setq entry-list (cdr entry-list))) - length)) - -(defsubst timeclock-entry-list-begin (entry-list) - (timeclock-entry-begin (car entry-list))) - -(defsubst timeclock-entry-list-end (entry-list) - (timeclock-entry-end (car (last entry-list)))) - -(defsubst timeclock-entry-list-span (entry-list) - (- (timeclock-time-to-seconds (timeclock-entry-list-end entry-list)) - (timeclock-time-to-seconds (timeclock-entry-list-begin entry-list)))) - -(defsubst timeclock-entry-list-break (entry-list) - (- (timeclock-entry-list-span entry-list) - (timeclock-entry-list-length entry-list))) - -(defsubst timeclock-entry-list-projects (entry-list) - (let (projects) - (while entry-list - (let ((project (timeclock-entry-project (car entry-list)))) - (if projects - (add-to-list 'projects project) - (setq projects (list project)))) - (setq entry-list (cdr entry-list))) - projects)) - - -(defsubst timeclock-day-required (day) - (or (car day) timeclock-workday)) - -(defsubst timeclock-day-length (day) - (timeclock-entry-list-length (cdr day))) - -(defsubst timeclock-day-debt (day) - (- (timeclock-day-required day) - (timeclock-day-length day))) - -(defsubst timeclock-day-begin (day) - (timeclock-entry-list-begin (cdr day))) - -(defsubst timeclock-day-end (day) - (timeclock-entry-list-end (cdr day))) - -(defsubst timeclock-day-span (day) - (timeclock-entry-list-span (cdr day))) - -(defsubst timeclock-day-break (day) - (timeclock-entry-list-break (cdr day))) - -(defsubst timeclock-day-projects (day) - (timeclock-entry-list-projects (cdr day))) - -(defmacro timeclock-day-list-template (func) - `(let ((length 0)) - (while day-list - (setq length (+ length (,(eval func) (car day-list)))) - (setq day-list (cdr day-list))) - length)) - -(defun timeclock-day-list-required (day-list) - (timeclock-day-list-template 'timeclock-day-required)) - -(defun timeclock-day-list-length (day-list) - (timeclock-day-list-template 'timeclock-day-length)) - -(defun timeclock-day-list-debt (day-list) - (timeclock-day-list-template 'timeclock-day-debt)) - -(defsubst timeclock-day-list-begin (day-list) - (timeclock-day-begin (car day-list))) - -(defsubst timeclock-day-list-end (day-list) - (timeclock-day-end (car (last day-list)))) - -(defun timeclock-day-list-span (day-list) - (timeclock-day-list-template 'timeclock-day-span)) - -(defun timeclock-day-list-break (day-list) - (timeclock-day-list-template 'timeclock-day-break)) - -(defun timeclock-day-list-projects (day-list) - (let (projects) - (while day-list - (let ((projs (timeclock-day-projects (car day-list)))) - (while projs - (if projects - (add-to-list 'projects (car projs)) - (setq projects (list (car projs)))) - (setq projs (cdr projs)))) - (setq day-list (cdr day-list))) - projects)) - - -(defsubst timeclock-current-debt (&optional log-data) - (nth 0 (or log-data (timeclock-log-data)))) - -(defsubst timeclock-day-alist (&optional log-data) - (nth 1 (or log-data (timeclock-log-data)))) - -(defun timeclock-day-list (&optional log-data) - (let ((alist (timeclock-day-alist log-data)) - day-list) - (while alist - (setq day-list (cons (cdar alist) day-list) - alist (cdr alist))) - day-list)) - -(defsubst timeclock-project-alist (&optional log-data) - (nth 2 (or log-data (timeclock-log-data)))) - - -(defun timeclock-log-data (&optional recent-only filename) - "Return the contents of the timelog file, in a useful format. -If the optional argument RECENT-ONLY is non-nil, only show the contents -from the last point where the time debt (see below) was set. -If the optional argument FILENAME is non-nil, it is used instead of -the file specified by `timeclock-file.' - -A timelog contains data in the form of a single entry per line. -Each entry has the form: - - CODE YYYY/MM/DD HH:MM:SS [COMMENT] - -CODE is one of: b, h, i, o or O. COMMENT is optional when the code is -i, o or O. The meanings of the codes are: - - b Set the current time balance, or \"time debt\". Useful when - archiving old log data, when a debt must be carried forward. - The COMMENT here is the number of seconds of debt. - - h Set the required working time for the given day. This must - be the first entry for that day. The COMMENT in this case is - the number of hours in this workday. Floating point amounts - are allowed. - - i Clock in. The COMMENT in this case should be the name of the - project worked on. - - o Clock out. COMMENT is unnecessary, but can be used to provide - a description of how the period went, for example. - - O Final clock out. Whatever project was being worked on, it is - now finished. Useful for creating summary reports. - -When this function is called, it will return a data structure with the -following format: - - (DEBT ENTRIES-BY-DAY ENTRIES-BY-PROJECT) - -DEBT is a floating point number representing the number of seconds -\"owed\" before any work was done. For a new file (one without a 'b' -entry), this is always zero. - -The two entries lists have similar formats. They are both alists, -where the CAR is the index, and the CDR is a list of time entries. -For ENTRIES-BY-DAY, the CAR is a textual date string, of the form -YYYY/MM/DD. For ENTRIES-BY-PROJECT, it is the name of the project -worked on, or t for the default project. - -The CDR for ENTRIES-BY-DAY is slightly different than for -ENTRIES-BY-PROJECT. It has the following form: - - (DAY-LENGTH TIME-ENTRIES...) - -For ENTRIES-BY-PROJECT, there is no DAY-LENGTH member. It is simply a -list of TIME-ENTRIES. Note that if DAY-LENGTH is nil, it means -whatever is the default should be used. - -A TIME-ENTRY is a recorded time interval. It has the following format -\(although generally one does not have to manipulate these entries -directly; see below): - - (BEGIN-TIME END-TIME PROJECT [COMMENT] [FINAL-P]) - -Anyway, suffice it to say there are a lot of structures. Typically -the user is expected to manipulate to the day(s) or project(s) that he -or she wants, at which point the following helper functions may be -used: - - timeclock-day-required - timeclock-day-length - timeclock-day-debt - timeclock-day-begin - timeclock-day-end - timeclock-day-span - timeclock-day-break - timeclock-day-projects - - timeclock-day-list-required - timeclock-day-list-length - timeclock-day-list-debt - timeclock-day-list-begin - timeclock-day-list-end - timeclock-day-list-span - timeclock-day-list-break - timeclock-day-list-projects - - timeclock-entry-length - timeclock-entry-begin - timeclock-entry-end - timeclock-entry-project - timeclock-entry-comment - - timeclock-entry-list-length - timeclock-entry-list-begin - timeclock-entry-list-end - timeclock-entry-list-span - timeclock-entry-list-break - timeclock-entry-list-projects - -A few comments should make the use of the above functions obvious: - - `required' is the amount of time that must be spent during a day, or - sequence of days, in order to have no debt. - - `length' is the actual amount of time that was spent. - - `debt' is the difference between required time and length. A - negative debt signifies overtime. - - `begin' is the earliest moment at which work began. - - `end' is the final moment work was done. - - `span' is the difference between begin and end. - - `break' is the difference between span and length. - - `project' is the project that was worked on, and `projects' is a - list of all the projects that were worked on during a given period. - - `comment', where it applies, could mean anything. - -There are a few more functions available, for locating day and entry -lists: - - timeclock-day-alist LOG-DATA - timeclock-project-alist LOG-DATA - timeclock-current-debt LOG-DATA - -See the documentation for the given function if more info is needed." - (let* ((log-data (list 0.0 nil nil)) - (now (current-time)) - (todays-date (timeclock-time-to-date now)) - last-date-limited last-date-seconds last-date - (line 0) last beg day entry event) - (with-temp-buffer - (insert-file-contents (or filename timeclock-file)) - (when recent-only - (goto-char (point-max)) - (unless (re-search-backward "^b\\s-+" nil t) - (goto-char (point-min)))) - (while (or (setq event (timeclock-read-moment)) - (and beg (not last) - (setq last t event (list "o" now)))) - (setq line (1+ line)) - (cond ((equal (car event) "b") - (setcar log-data (string-to-number (nth 2 event)))) - ((equal (car event) "h") - (setq last-date-limited (timeclock-time-to-date (cadr event)) - last-date-seconds (* (string-to-number (nth 2 event)) - 3600.0))) - ((equal (car event) "i") - (if beg - (error "Error in format of timelog file, line %d" line) - (setq beg t)) - (setq entry (list (cadr event) nil - (and (> (length (nth 2 event)) 0) - (nth 2 event)))) - (let ((date (timeclock-time-to-date (cadr event)))) - (if (and last-date - (not (equal date last-date))) - (progn - (setcar (cdr log-data) - (cons (cons last-date day) - (cadr log-data))) - (setq day (list (and last-date-limited - last-date-seconds)))) - (unless day - (setq day (list (and last-date-limited - last-date-seconds))))) - (setq last-date date - last-date-limited nil))) - ((equal (downcase (car event)) "o") - (if (not beg) - (error "Error in format of timelog file, line %d" line) - (setq beg nil)) - (setcar (cdr entry) (cadr event)) - (let ((desc (and (> (length (nth 2 event)) 0) - (nth 2 event)))) - (if desc - (nconc entry (list (nth 2 event)))) - (if (equal (car event) "O") - (nconc entry (if desc - (list t) - (list nil t)))) - (nconc day (list entry)) - (setq desc (nth 2 entry)) - (let ((proj (assoc desc (nth 2 log-data)))) - (if (null proj) - (setcar (cddr log-data) - (cons (cons desc (list entry)) - (car (cddr log-data)))) - (nconc (cdr proj) (list entry))))))) - (forward-line)) - (if day - (setcar (cdr log-data) - (cons (cons last-date day) - (cadr log-data)))) - log-data))) - -(defun timeclock-find-discrep () - "Calculate time discrepancies, in seconds. -The result is a three element list, containing the total time -discrepancy, today's discrepancy, and the time worked today." - ;; This is not implemented in terms of the functions above, because - ;; it's a bit wasteful to read all of that data in, just to throw - ;; away more than 90% of the information afterwards. - ;; - ;; If it were implemented using those functions, it would look - ;; something like this: - ;; (let ((days (timeclock-day-alist (timeclock-log-data))) - ;; (total 0.0)) - ;; (while days - ;; (setq total (+ total (- (timeclock-day-length (cdar days)) - ;; (timeclock-day-required (cdar days)))) - ;; days (cdr days))) - ;; total) - (let* ((now (current-time)) - (todays-date (timeclock-time-to-date now)) - (first t) (accum 0) (elapsed 0) - event beg last-date avg - last-date-limited last-date-seconds) - (unless timeclock-discrepancy - (when (file-readable-p timeclock-file) - (setq timeclock-project-list nil - timeclock-last-project nil - timeclock-reason-list nil - timeclock-elapsed 0) - (with-temp-buffer - (insert-file-contents timeclock-file) - (goto-char (point-max)) - (unless (re-search-backward "^b\\s-+" nil t) - (goto-char (point-min))) - (while (setq event (timeclock-read-moment)) - (cond ((equal (car event) "b") - (setq accum (string-to-number (nth 2 event)))) - ((equal (car event) "h") - (setq last-date-limited - (timeclock-time-to-date (cadr event)) - last-date-seconds - (* (string-to-number (nth 2 event)) 3600.0))) - ((equal (car event) "i") - (when (and (nth 2 event) - (> (length (nth 2 event)) 0)) - (add-to-list 'timeclock-project-list (nth 2 event)) - (setq timeclock-last-project (nth 2 event))) - (let ((date (timeclock-time-to-date (cadr event)))) - (if (if last-date - (not (equal date last-date)) - first) - (setq first nil - accum (- accum (if last-date-limited - last-date-seconds - timeclock-workday)))) - (setq last-date date - last-date-limited nil) - (if beg - (error "Error in format of timelog file!") - (setq beg (timeclock-time-to-seconds (cadr event)))))) - ((equal (downcase (car event)) "o") - (if (and (nth 2 event) - (> (length (nth 2 event)) 0)) - (add-to-list 'timeclock-reason-list (nth 2 event))) - (if (not beg) - (error "Error in format of timelog file!") - (setq timeclock-last-period - (- (timeclock-time-to-seconds (cadr event)) beg) - accum (+ timeclock-last-period accum) - beg nil)) - (if (equal last-date todays-date) - (setq timeclock-elapsed - (+ timeclock-last-period timeclock-elapsed))))) - (setq timeclock-last-event event - timeclock-last-event-workday - (if (equal (timeclock-time-to-date now) last-date-limited) - last-date-seconds - timeclock-workday)) - (forward-line)) - (setq timeclock-discrepancy accum)))) - (unless timeclock-last-event-workday - (setq timeclock-last-event-workday timeclock-workday)) - (setq accum (or timeclock-discrepancy 0) - elapsed (or timeclock-elapsed elapsed)) - (if timeclock-last-event - (if (equal (car timeclock-last-event) "i") - (let ((last-period (timeclock-last-period now))) - (setq accum (+ accum last-period) - elapsed (+ elapsed last-period))) - (if (not (equal (timeclock-time-to-date - (cadr timeclock-last-event)) - (timeclock-time-to-date now))) - (setq accum (- accum timeclock-last-event-workday))))) - (list accum (- elapsed timeclock-last-event-workday) - elapsed))) - -;;; A reporting function that uses timeclock-log-data - -(defun timeclock-day-base (&optional time) - "Given a time within a day, return 0:0:0 within that day. -If optional argument TIME is non-nil, use that instead of the current time." - (let ((decoded (decode-time (or time (current-time))))) - (setcar (nthcdr 0 decoded) 0) - (setcar (nthcdr 1 decoded) 0) - (setcar (nthcdr 2 decoded) 0) - (apply 'encode-time decoded))) - -(defun timeclock-geometric-mean (l) - "Compute the geometric mean of the values in the list L." - (let ((total 0) - (count 0)) - (while l - (setq total (+ total (car l)) - count (1+ count) - l (cdr l))) - (if (> count 0) - (/ total count) - 0))) - -(defun timeclock-generate-report (&optional html-p) - "Generate a summary report based on the current timelog file. -By default, the report is in plain text, but if the optional argument -HTML-P is non-nil, HTML markup is added." - (interactive) - (let ((log (timeclock-log-data)) - (today (timeclock-day-base))) - (if html-p (insert "

")) - (insert "Currently ") - (let ((project (nth 2 timeclock-last-event)) - (begin (nth 1 timeclock-last-event)) - done) - (if (timeclock-currently-in-p) - (insert "IN") - (if (or (null project) (= (length project) 0)) - (progn (insert "Done Working Today") - (setq done t)) - (insert "OUT"))) - (unless done - (insert " since " (format-time-string "%Y/%m/%d %-I:%M %p" begin)) - (if html-p - (insert "
\n") - (insert "\n*")) - (if (timeclock-currently-in-p) - (insert "Working on ")) - (if html-p - (insert project "
\n") - (insert project "*\n")) - (let ((proj-data (cdr (assoc project (timeclock-project-alist log)))) - (two-weeks-ago (timeclock-seconds-to-time - (- (timeclock-time-to-seconds today) - (* 2 7 24 60 60)))) - two-week-len today-len) - (while proj-data - (if (not (time-less-p - (timeclock-entry-begin (car proj-data)) today)) - (setq today-len (timeclock-entry-list-length proj-data) - proj-data nil) - (if (and (null two-week-len) - (not (time-less-p - (timeclock-entry-begin (car proj-data)) - two-weeks-ago))) - (setq two-week-len (timeclock-entry-list-length proj-data))) - (setq proj-data (cdr proj-data)))) - (if (null two-week-len) - (setq two-week-len today-len)) - (if html-p (insert "

")) - (if today-len - (insert "\nTime spent on this task today: " - (timeclock-seconds-to-string today-len) - ". In the last two weeks: " - (timeclock-seconds-to-string two-week-len)) - (if two-week-len - (insert "\nTime spent on this task in the last two weeks: " - (timeclock-seconds-to-string two-week-len)))) - (if html-p (insert "
")) - (insert "\n" - (timeclock-seconds-to-string (timeclock-workday-elapsed)) - " worked today, " - (timeclock-seconds-to-string (timeclock-workday-remaining)) - " remaining, done at " - (timeclock-when-to-leave-string) "\n"))) - (if html-p (insert "

")) - (insert "\nThere have been " - (number-to-string - (length (timeclock-day-alist log))) - " days of activity, starting " - (caar (last (timeclock-day-alist log)))) - (if html-p (insert "

")) - (when html-p - (insert "

- -

 - - - - - - - -") - (let* ((day-list (timeclock-day-list)) - (thirty-days-ago (timeclock-seconds-to-time - (- (timeclock-time-to-seconds today) - (* 30 24 60 60)))) - (three-months-ago (timeclock-seconds-to-time - (- (timeclock-time-to-seconds today) - (* 90 24 60 60)))) - (six-months-ago (timeclock-seconds-to-time - (- (timeclock-time-to-seconds today) - (* 180 24 60 60)))) - (one-year-ago (timeclock-seconds-to-time - (- (timeclock-time-to-seconds today) - (* 365 24 60 60)))) - (time-in (vector (list t) (list t) (list t) (list t) (list t))) - (time-out (vector (list t) (list t) (list t) (list t) (list t))) - (breaks (vector (list t) (list t) (list t) (list t) (list t))) - (workday (vector (list t) (list t) (list t) (list t) (list t))) - (lengths (vector '(0 0) thirty-days-ago three-months-ago - six-months-ago one-year-ago))) - ;; collect statistics from complete timelog - (while day-list - (let ((i 0) (l 5)) - (while (< i l) - (unless (time-less-p - (timeclock-day-begin (car day-list)) - (aref lengths i)) - (let ((base (timeclock-time-to-seconds - (timeclock-day-base - (timeclock-day-begin (car day-list)))))) - (nconc (aref time-in i) - (list (- (timeclock-time-to-seconds - (timeclock-day-begin (car day-list))) - base))) - (let ((span (timeclock-day-span (car day-list))) - (len (timeclock-day-length (car day-list))) - (req (timeclock-day-required (car day-list)))) - ;; If the day's actual work length is less than - ;; 70% of its span, then likely the exit time - ;; and break amount are not worthwhile adding to - ;; the statistic - (when (and (> span 0) - (> (/ (float len) (float span)) 0.70)) - (nconc (aref time-out i) - (list (- (timeclock-time-to-seconds - (timeclock-day-end (car day-list))) - base))) - (nconc (aref breaks i) (list (- span len)))) - (if req - (setq len (+ len (- timeclock-workday req)))) - (nconc (aref workday i) (list len))))) - (setq i (1+ i)))) - (setq day-list (cdr day-list))) - ;; average statistics - (let ((i 0) (l 5)) - (while (< i l) - (aset time-in i (timeclock-geometric-mean - (cdr (aref time-in i)))) - (aset time-out i (timeclock-geometric-mean - (cdr (aref time-out i)))) - (aset breaks i (timeclock-geometric-mean - (cdr (aref breaks i)))) - (aset workday i (timeclock-geometric-mean - (cdr (aref workday i)))) - (setq i (1+ i)))) - ;; Output the HTML table - (insert "\n") - (insert "\n") - (let ((i 0) (l 5)) - (while (< i l) - (insert "\n") - (setq i (1+ i)))) - (insert "\n") - - (insert "\n") - (insert "\n") - (let ((i 0) (l 5)) - (while (< i l) - (insert "\n") - (setq i (1+ i)))) - (insert "\n") - - (insert "\n") - (insert "\n") - (let ((i 0) (l 5)) - (while (< i l) - (insert "\n") - (setq i (1+ i)))) - (insert "\n") - - (insert "\n") - (insert "\n") - (let ((i 0) (l 5)) - (while (< i l) - (insert "\n") - (setq i (1+ i)))) - (insert "\n")) - (insert " - - -
StatisticsEntire-30 days-3 mons-6 mons-1 year
Time in" - (timeclock-seconds-to-string (aref time-in i)) - "
Time out" - (timeclock-seconds-to-string (aref time-out i)) - "
Break" - (timeclock-seconds-to-string (aref breaks i)) - "
Workday" - (timeclock-seconds-to-string (aref workday i)) - "
- These are approximate figures
-
"))))) - -;;; A helpful little function - -(defun timeclock-visit-timelog () - "Open the file named by `timeclock-file' in another window." - (interactive) - (find-file-other-window timeclock-file)) - -(provide 'timeclock) - -(run-hooks 'timeclock-load-hook) - -;; make sure we know the list of reasons, projects, and have computed -;; the last event and current discrepancy. -(if (file-readable-p timeclock-file) - (timeclock-reread-log)) - -;;; arch-tag: a0be3377-deb6-44ec-b9a2-a7be28436a40 -;;; timeclock.el ends here -- cgit v1.2.3 From 0744a0ac8fac128255a0baec0343d1092a998cee Mon Sep 17 00:00:00 2001 From: Craig Earls Date: Wed, 6 Mar 2013 14:35:34 -0500 Subject: Added menu entries to help set sort region --- doc/ledger-mode.texi | 4 +++- lisp/ldg-mode.el | 2 ++ lisp/ldg-sort.el | 47 +++++++++++++++++++++++++++++++++++++++-------- 3 files changed, 44 insertions(+), 9 deletions(-) diff --git a/doc/ledger-mode.texi b/doc/ledger-mode.texi index f530d587..e13610bc 100644 --- a/doc/ledger-mode.texi +++ b/doc/ledger-mode.texi @@ -316,7 +316,9 @@ markup within your ledger. For exmaple <<< information to not sort >>> @end smallexample - +You can use menu entries to insert start and end markers. These +functions will automatically delete old markers and put new new marker +at point. @node Hiding Transactions, , Sorting Transactions, The Ledger Buffer @section Hiding Transactions diff --git a/lisp/ldg-mode.el b/lisp/ldg-mode.el index 00df0e67..84ccf62b 100644 --- a/lisp/ldg-mode.el +++ b/lisp/ldg-mode.el @@ -116,6 +116,8 @@ (interactive) (customize-group 'ledger)))) (define-key map [sep1] '("--")) + (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 [sep2] '(menu-item "--")) diff --git a/lisp/ldg-sort.el b/lisp/ldg-sort.el index cc036492..33ae2a98 100644 --- a/lisp/ldg-sort.el +++ b/lisp/ldg-sort.el @@ -38,6 +38,36 @@ "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) + (let (has-old-marker) + (save-excursion + (goto-char (point-min)) + (setq has-old-marker (ledger-sort-find-start)) + (if has-old-marker + (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) + (let (has-old-marker) + (save-excursion + (goto-char (point-min)) + (setq has-old-marker (ledger-sort-find-end)) + (if has-old-marker + (delete-region (match-beginning 0) (match-end 0)))) + (beginning-of-line) + (insert "\n; Ledger-mode: End sort\n\n"))) + (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 @@ -66,14 +96,15 @@ (defun ledger-sort-buffer () "Sort the entire buffer." (interactive) - (let ((sort-start (point-min)) - (sort-end (point-max))) - (goto-char (point-min)) - (if (re-search-forward ";.*Ledger-mode:.*Start sort" nil t) - (set 'sort-start (match-end 0))) - (if (re-search-forward ";.*Ledger-mode:.*End sort" nil t) - (set 'sort-end (match-end 0))) - (ledger-sort-region sort-start sort-end))) + (goto-char (point-min)) + (let ((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) -- cgit v1.2.3 From 1eba7c6cdf4ac334a5b8580e4f18102db26b8c5f Mon Sep 17 00:00:00 2001 From: Craig Earls Date: Wed, 6 Mar 2013 14:36:31 -0500 Subject: Code formatting cleanup. --- lisp/ldg-occur.el | 4 +++- lisp/ldg-reconcile.el | 1 - lisp/ldg-regex.el | 3 ++- 3 files changed, 5 insertions(+), 3 deletions(-) diff --git a/lisp/ldg-occur.el b/lisp/ldg-occur.el index 1561d6f8..f14aeeda 100644 --- a/lisp/ldg-occur.el +++ b/lisp/ldg-occur.el @@ -41,7 +41,9 @@ (make-variable-buffer-local 'ledger-occur-use-face-unfolded) -(defvar ledger-occur-mode nil) ;; name of the minor mode, shown in the mode-line +(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) diff --git a/lisp/ldg-reconcile.el b/lisp/ldg-reconcile.el index e45ab7c3..fd452004 100644 --- a/lisp/ldg-reconcile.el +++ b/lisp/ldg-reconcile.el @@ -443,6 +443,5 @@ POSTING is used in `ledger-clear-whole-transactions' is nil." (use-local-map map))) (provide 'ldg-reconcile) -(provide 'ldg-reconcile) ;;; ldg-reconcile.el ends here diff --git a/lisp/ldg-regex.el b/lisp/ldg-regex.el index e81394ef..97fd6e2c 100644 --- a/lisp/ldg-regex.el +++ b/lisp/ldg-regex.el @@ -24,7 +24,8 @@ (eval-when-compile (require 'cl)) -(defvar ledger-date-regex "\\([0-9]+\\)[/-]\\([0-9]+\\)[/-]\\([0-9]+\\)") +(defvar ledger-date-regex + "\\([0-9]+\\)[/-]\\([0-9]+\\)[/-]\\([0-9]+\\)") (defmacro ledger-define-regexp (name regex docs &rest args) "Simplify the creation of a Ledger regex and helper functions." -- cgit v1.2.3 From 7579ebb34dbd53309b7069c23fc7812a261aea97 Mon Sep 17 00:00:00 2001 From: Craig Earls Date: Wed, 6 Mar 2013 14:44:22 -0500 Subject: Added missing lisp files to CMakeList.txt --- lisp/CMakeLists.txt | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/lisp/CMakeLists.txt b/lisp/CMakeLists.txt index 949171b3..5341f67a 100644 --- a/lisp/CMakeLists.txt +++ b/lisp/CMakeLists.txt @@ -1,19 +1,21 @@ set(EMACS_LISP_SOURCES + ldg-commodities.el ldg-complete.el ldg-exec.el + ldg-fonts.el ldg-mode.el ldg-new.el + ldg-occur.el ldg-post.el ldg-reconcile.el ldg-regex.el ldg-register.el ldg-report.el + ldg-sort.el ldg-state.el ldg-test.el ldg-texi.el - ldg-xact.el - ledger.el - timeclock.el) + ldg-xact.el) # find emacs and complain if not found find_program(EMACS_EXECUTABLE emacs) -- cgit v1.2.3 From 63653f50d5e05d07a65bb906d0afa77f22a6084e Mon Sep 17 00:00:00 2001 From: Craig Earls Date: Wed, 6 Mar 2013 15:23:46 -0500 Subject: Correct bug is edit amount. Edit-amount was still looking for decimal-comma --- doc/ledger-mode.texi | 2 +- lisp/ldg-post.el | 11 +---------- 2 files changed, 2 insertions(+), 11 deletions(-) diff --git a/doc/ledger-mode.texi b/doc/ledger-mode.texi index e13610bc..001eb054 100644 --- a/doc/ledger-mode.texi +++ b/doc/ledger-mode.texi @@ -323,7 +323,7 @@ at point. @node Hiding Transactions, , Sorting Transactions, The Ledger Buffer @section Hiding Transactions -Often you will want to run Ledger register reports just to look at a +Often you will want to run Ledger register reports just to look at ax specific set of transactions. If you don't need the running total calculation handled by Ledger, Ledger-mode provides a rapid way of narrowing what is displayed in the buffer in a way that is simpler than diff --git a/lisp/ldg-post.el b/lisp/ldg-post.el index 6cba305b..e794f071 100644 --- a/lisp/ldg-post.el +++ b/lisp/ldg-post.el @@ -186,19 +186,10 @@ BEG, END, and LEN control how far it can align." (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 (match-string 0))) + (let ((val (ledger-commodity-string-number-decimalize (match-string 0) :from-user))) (goto-char (match-beginning 0)) (delete-region (match-beginning 0) (match-end 0)) (calc) - (if ledger-use-decimal-comma - (progn - (while (string-match "\\." val) - (setq val (replace-match "" nil nil val))) ;; gets rid of periods - (while (string-match "," val) - (setq val (replace-match "." nil nil val)))) ;; switch to period separator - (progn - (while (string-match "," val) - (setq val (replace-match "" nil nil val))))) ;; gets rid of commas (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) -- cgit v1.2.3 From 81eeb210e8e2b33077624fd9d0fd3ef63837701a Mon Sep 17 00:00:00 2001 From: Craig Earls Date: Wed, 6 Mar 2013 16:57:07 -0500 Subject: Improved context regex to handles @ and @@ pricing --- lisp/ldg-report.el | 18 +++++++++++++----- 1 file changed, 13 insertions(+), 5 deletions(-) diff --git a/lisp/ldg-report.el b/lisp/ldg-report.el index ef088f17..8d91d9d4 100644 --- a/lisp/ldg-report.el +++ b/lisp/ldg-report.el @@ -432,11 +432,13 @@ Optional EDIT the command." ("^\\(\\([0-9][0-9][0-9][0-9]/\\)?[01]?[0-9]/[0123]?[0-9]\\)[ \t]+\\(\\([!*]\\)[ \t]\\)?[ \t]*\\((\\(.*\\))\\)?[ \t]*\\(.*\\)[ \t]*$" (date nil status nil nil code payee)))) (acct-transaction - (("\\(^[ \t]+\\)\\(.*?\\)[ \t]+\\([$€£]\\s-?\\)\\(-?[0-9]*\\(\\.[0-9]*\\)?\\)[ \t]*;[ \t]*\\(.*?\\)[ \t]*$" + (("^\\([ \t]+;\\|;\\)\\s-?\\(.*\\)" + (indent comment)) + ("\\(^[ \t]+\\)\\([:A-Za-z0-9]+?\\)\\s-\\s-+\\([$€£]\\s-?\\)\\(-?[0-9]*\\(\\.[0-9]*\\)?\\)$" + (indent account commodity amount)) + ("\\(^[ \t]+\\)\\(.*?\\)[ \t]+\\([$€£]\\s-?\\)\\(-?[0-9]*\\(\\.[0-9]*\\)?\\)[ \t]*;[ \t]*\\(.*?\\)[ \t]*$" (indent account commodity amount nil comment)) - ("\\(^[ \t]+\\)\\(.*?\\)[ \t]+\\([$€£]\\s-?\\)\\(-?[0-9]*\\(\\.[0-9]*\\)?\\)[ \t]*$" - (indent account commodity amount nil)) - ("\\(^[ \t]+\\)\\(.*?\\)[ \t]+\\(-?[0-9]+\\(\\.[0-9]*\\)?\\)[ \t]+\\(.*?\\)[ \t]*;[ \t]*\\(.*?\\)[ \t]*$" + ("\\(^[ \t]+\\)\\(.*?\\)[ \t]+\\(-?[0-9]+\\(\\.[0-9]*\\)?\\)[ \t]+\\(.*?\\)[ \t]*\\(;[ \t]*\\(.*?\\)[ \t]*$\\|@+\\)" (indent account amount nil commodity comment)) ("\\(^[ \t]+\\)\\(.*?\\)[ \t]+\\(-?[0-9]+\\(\\.[0-9]*\\)?\\)[ \t]+\\(.*?\\)[ \t]*$" (indent account amount nil commodity)) @@ -447,7 +449,13 @@ Optional EDIT the command." ("\\(^[ \t]+\\)\\(.*?\\)[ \t]*;[ \t]*\\(.*?\\)[ \t]*$" (indent account comment)) ("\\(^[ \t]+\\)\\(.*?\\)[ \t]*$" - (indent account)))))) + (indent account)) + +;; Bad regexes + ("\\(^[ \t]+\\)\\(.*?\\)[ \t]+\\([$€£]\\s-?\\)\\(-?[0-9]*\\(\\.[0-9]*\\)?\\)[ \t]*$" + (indent account commodity amount nil)) + + )))) (defun ledger-extract-context-info (line-type pos) "Get context info for current line with LINE-TYPE. -- cgit v1.2.3 From 27d27ecb6c5be3a9523fd4efc895b6d0b2a6cfb4 Mon Sep 17 00:00:00 2001 From: Craig Earls Date: Wed, 6 Mar 2013 21:13:06 -0500 Subject: Account auto formatting now works with tab completion --- lisp/ldg-complete.el | 11 ++++++----- lisp/ldg-post.el | 13 +++++++++---- lisp/ldg-reconcile.el | 2 +- lisp/ldg-xact.el | 3 --- 4 files changed, 16 insertions(+), 13 deletions(-) diff --git a/lisp/ldg-complete.el b/lisp/ldg-complete.el index 3686d0fd..6607d372 100644 --- a/lisp/ldg-complete.el +++ b/lisp/ldg-complete.el @@ -145,16 +145,17 @@ Return tree structure" "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 + (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) ;; "\\(\t\\|\n\\| [ \t]\\)" - (setq rest-of-name (buffer-substring-no-properties (match-end 0) (line-end-position))) + (concat "^[0-9/.=-]+\\(\\s-+\\*\\)?\\(\\s-+(.*?)\\)?\\s-+\\(.*" + (regexp-quote name) ".*\\)" ) nil t) ;; "\\(\t\\|\n\\| [ \t]\\)" + (setq rest-of-name (match-string 3)) ;; Start copying the postings (forward-line) (while (looking-at "^\\s-+") diff --git a/lisp/ldg-post.el b/lisp/ldg-post.el index e794f071..d68d7f16 100644 --- a/lisp/ldg-post.el +++ b/lisp/ldg-post.el @@ -133,10 +133,15 @@ the account" (setq column ledger-post-amount-alignment-column)) (save-excursion ;; Position the account - ;; (beginning-of-line) - (set-mark (point)) - ;; (delete-horizontal-space) - ;; (insert ledger-default-acct-transaction-indent) + (if (not + (and (looking-at "[ \t]+\n") + (looking-back "[ \n]" (- (point) 2)))) + (progn + (beginning-of-line) + (set-mark (point)) + (delete-horizontal-space) + (insert ledger-default-acct-transaction-indent)) + (set-mark (point))) (goto-char (1+ (line-end-position))) (let* ((mark-first (< (mark) (point))) (begin (if mark-first (mark) (point))) diff --git a/lisp/ldg-reconcile.el b/lisp/ldg-reconcile.el index fd452004..7b3df459 100644 --- a/lisp/ldg-reconcile.el +++ b/lisp/ldg-reconcile.el @@ -397,7 +397,7 @@ POSTING is used in `ledger-clear-whole-transactions' is nil." (defvar ledger-reconcile-mode-abbrev-table) (defun ledger-reconcile-change-target () - "Change the traget amount for the reconciliation process." + "Change the target amount for the reconciliation process." (interactive) (setq ledger-target (ledger-read-commodity-string "Set reconciliation target"))) diff --git a/lisp/ldg-xact.el b/lisp/ldg-xact.el index 8db50df2..ecd87127 100644 --- a/lisp/ldg-xact.el +++ b/lisp/ldg-xact.el @@ -118,9 +118,6 @@ within the transaction." (replace-match date) (re-search-forward "[1-9][0-9]+\.[0-9]+"))) - - -(provide 'ldg-xact) (provide 'ldg-xact) ;;; ldg-xact.el ends here -- cgit v1.2.3 From b475e569c4c4cb97d32e76de4d85d0810c9cc462 Mon Sep 17 00:00:00 2001 From: Craig Earls Date: Thu, 7 Mar 2013 15:28:09 -0500 Subject: Made account formatting and auto complete compatible. --- lisp/ldg-new.el | 1 + lisp/ldg-post.el | 38 +++++++++++++----------- lisp/ldg-reconcile.el | 16 +++++------ lisp/ldg-state.el | 80 +++++++++++++++++++++++++++------------------------ 4 files changed, 72 insertions(+), 63 deletions(-) diff --git a/lisp/ldg-new.el b/lisp/ldg-new.el index 7a2961f7..4cebbba7 100644 --- a/lisp/ldg-new.el +++ b/lisp/ldg-new.el @@ -32,6 +32,7 @@ ;;; Commentary: ;; Load up the ledger mode +(require 'esh-util) (require 'esh-arg) (require 'ldg-commodities) (require 'ldg-complete) diff --git a/lisp/ldg-post.el b/lisp/ldg-post.el index d68d7f16..87922dd1 100644 --- a/lisp/ldg-post.el +++ b/lisp/ldg-post.el @@ -36,11 +36,16 @@ "Options for controlling how Ledger-mode deals with postings and completion" :group 'ledger) -(defcustom ledger-post-auto-adjust-amounts nil - "If non-nil, ." +(defcustom ledger-post-auto-adjust-postings nil + "If non-nil, adjust account and amount to columns set below" :type 'boolean :group 'ledger-post) +(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 @@ -123,25 +128,25 @@ PROMPT is a string to prompt with. CHOICES is a list of (- (or (match-end 4) (match-end 3)) (point)))) -(defun ledger-align-amounts (&optional column) +(defun ledger-post-align-postings (&optional column) "Align amounts and accounts in the current region. This is done so that the last digit falls in COLUMN, which -defaults to 52. ledger-default-acct-transaction-indent positions +defaults to 52. ledger-post-account-column positions the account" (interactive "p") (if (or (null column) (= column 1)) (setq column ledger-post-amount-alignment-column)) (save-excursion ;; Position the account - (if (not - (and (looking-at "[ \t]+\n") - (looking-back "[ \n]" (- (point) 2)))) - (progn + (if (not (and (looking-at "[ \t]+\n") + (looking-back "[ \n]" (- (point) 2)))) + (save-excursion (beginning-of-line) - (set-mark (point)) - (delete-horizontal-space) - (insert ledger-default-acct-transaction-indent)) + (set-mark (point)) + (delete-horizontal-space) + (insert (make-string ledger-post-account-alignment-column ? ))) (set-mark (point))) + (set-mark (point)) (goto-char (1+ (line-end-position))) (let* ((mark-first (< (mark) (point))) (begin (if mark-first (mark) (point))) @@ -153,7 +158,7 @@ the account" (let ((col (current-column)) (target-col (- column offset)) adjust) - (setq adjust (- target-col col)) + (setq adjust (- target-col col)) (if (< col target-col) (insert (make-string (- target-col col) ? )) (move-to-column target-col) @@ -164,13 +169,13 @@ the account" (insert " "))) (forward-line)))))) -(defun ledger-post-align-amount () +(defun ledger-post-align-posting () "Align the amounts in this posting." (interactive) (save-excursion (set-mark (line-beginning-position)) (goto-char (1+ (line-end-position))) - (ledger-align-amounts))) + (ledger-post-align-postings))) (defun ledger-post-maybe-align (beg end len) "Align amounts only if point is in a posting. @@ -180,7 +185,7 @@ BEG, END, and LEN control how far it can align." (when (<= end (line-end-position)) (goto-char (line-beginning-position)) (if (looking-at ledger-post-line-regexp) - (ledger-align-amounts))))) + (ledger-post-align-postings))))) (defun ledger-post-edit-amount () "Call 'calc-mode' and push the amount in the posting to the top of stack." @@ -221,8 +226,7 @@ BEG, END, and LEN control how far it can align." (defun ledger-post-setup () "Configure `ledger-mode' to auto-align postings." - (if ledger-post-auto-adjust-amounts - (add-hook 'after-change-functions 'ledger-post-maybe-align t t)) + (add-hook 'after-change-functions 'ledger-post-maybe-align t t) (add-hook 'after-save-hook #'(lambda () (setq ledger-post-current-list nil)))) diff --git a/lisp/ldg-reconcile.el b/lisp/ldg-reconcile.el index 7b3df459..6ede6b51 100644 --- a/lisp/ldg-reconcile.el +++ b/lisp/ldg-reconcile.el @@ -70,20 +70,20 @@ reconcile-finish will mark all pending posting cleared." (account ledger-acct) (val nil)) (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. (ledger-exec-ledger buffer (current-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. "balance" "--limit" "cleared or pending" "--empty" "--format" "%(display_total)" account) - (setq val + (setq val (ledger-split-commodity-string (buffer-substring-no-properties (point-min) (point-max))))))) (defun ledger-display-balance () - "Display the cleared-or-pending balnce and calculate the -target-delta of the account being reconciled." + "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)) (target-delta (if ledger-target @@ -111,7 +111,7 @@ target-delta of the account being reconciled." "Return a buffer from WHERE the transaction is." (if (bufferp (car where)) (car where) - (error "ledger-reconcile-get-buffer: Buffer not set"))) + (error "Function ledger-reconcile-get-buffer: Buffer not set"))) (defun ledger-reconcile-toggle () "Toggle the current transaction, and mark the recon window." diff --git a/lisp/ldg-state.el b/lisp/ldg-state.el index b2247afe..dd5e42ad 100644 --- a/lisp/ldg-state.el +++ b/lisp/ldg-state.el @@ -122,42 +122,48 @@ dropped." ;;this excursion toggles the posting status (save-excursion - (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))))) + (let ((has-align-hook (remove-hook + 'after-change-functions + 'ledger-post-maybe-align 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)))) + (if has-align-hook + (add-hook 'after-change-functions 'ledger-post-maybe-align t t)))) ;; This excursion cleans up the entry so that it displays ;; minimally. This means that if all posts are cleared, remove @@ -254,6 +260,4 @@ dropped." (provide 'ldg-state) -(provide 'ldg-state) - ;;; ldg-state.el ends here -- cgit v1.2.3 From 7758100df9152bab243d9531518af76acdbc7287 Mon Sep 17 00:00:00 2001 From: Craig Earls Date: Thu, 7 Mar 2013 16:08:07 -0500 Subject: Caught another omission in the built list --- lisp/CMakeLists.txt | 1 + lisp/ldg-new.el | 1 + 2 files changed, 2 insertions(+) diff --git a/lisp/CMakeLists.txt b/lisp/CMakeLists.txt index 5341f67a..32a31001 100644 --- a/lisp/CMakeLists.txt +++ b/lisp/CMakeLists.txt @@ -3,6 +3,7 @@ set(EMACS_LISP_SOURCES ldg-complete.el ldg-exec.el ldg-fonts.el + ldg-init.el ldg-mode.el ldg-new.el ldg-occur.el diff --git a/lisp/ldg-new.el b/lisp/ldg-new.el index 4cebbba7..f888fd6c 100644 --- a/lisp/ldg-new.el +++ b/lisp/ldg-new.el @@ -43,6 +43,7 @@ (require 'ldg-occur) (require 'ldg-post) (require 'ldg-reconcile) +(require 'ldg-regex) (require 'ldg-register) (require 'ldg-report) (require 'ldg-sort) -- cgit v1.2.3 From 37ddc5f5888197782e7e3449b3e29a0285d9ad61 Mon Sep 17 00:00:00 2001 From: Craig Earls Date: Thu, 7 Mar 2013 16:11:55 -0500 Subject: Deprecated ledger.el --- lisp/ledger.el | 1340 -------------------------------------------------------- 1 file changed, 1340 deletions(-) delete mode 100644 lisp/ledger.el diff --git a/lisp/ledger.el b/lisp/ledger.el deleted file mode 100644 index 4fc21d6a..00000000 --- a/lisp/ledger.el +++ /dev/null @@ -1,1340 +0,0 @@ -;;; ledger.el --- Helper code for use with the "ledger" command-line tool - -;; Copyright (C) 2003-2009 John Wiegley (johnw AT gnu DOT org) - -;; Emacs Lisp Archive Entry -;; Filename: ledger.el -;; Version: 2.6.3 -;; Date: Fri 18-Jul-2008 -;; Keywords: data -;; Author: John Wiegley (johnw AT gnu DOT org) -;; Maintainer: John Wiegley (johnw AT gnu DOT org) -;; Description: Helper code for using my "ledger" command-line tool -;; URL: http://www.newartisans.com/johnw/emacs.html -;; Compatibility: Emacs22 - -;; 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: - -;; To use this module: Load this file, open a ledger data file, and -;; type M-x ledger-mode. Once this is done, you can type: -;; -;; C-c C-a add a new entry, based on previous entries -;; C-c C-e toggle cleared status of an entry -;; C-c C-y set default year for entry mode -;; C-c C-m set default month for entry mode -;; C-c C-r reconcile uncleared entries related to an account -;; C-c C-o C-r run a ledger report -;; C-C C-o C-g goto the ledger report buffer -;; C-c C-o C-e edit the defined ledger reports -;; C-c C-o C-s save a report definition based on the current report -;; C-c C-o C-a rerun a ledger report -;; C-c C-o C-k kill the ledger report buffer -;; -;; In the reconcile buffer, use SPACE to toggle the cleared status of -;; a transaction, C-x C-s to save changes (to the ledger file as -;; well). -;; -;; The ledger reports command asks the user to select a report to run -;; then creates a report buffer containing the results of running the -;; associated command line. Its' behavior is modified by a prefix -;; argument which, when given, causes the generated command line that -;; will be used to create the report to be presented for editing -;; before the report is actually run. Arbitrary unnamed command lines -;; can be run by specifying an empty name for the report. The command -;; line used can later be named and saved for future use as a named -;; report from the generated reports buffer. -;; -;; In a report buffer, the following keys are available: -;; (space) scroll up -;; e edit the defined ledger reports -;; s save a report definition based on the current report -;; q quit the report (return to ledger buffer) -;; r redo the report -;; k kill the report buffer - -(require 'esh-util) -(require 'esh-arg) -(require 'pcomplete) - -(defvar ledger-version "1.3" - "The version of ledger.el currently loaded") - -(defgroup ledger nil - "Interface to the Ledger command-line accounting program." - :group 'data) - -(defcustom ledger-binary-path "ledger" - "Path to the ledger executable." - :type 'file - :group 'ledger) - -(defcustom ledger-clear-whole-entries nil - "If non-nil, clear whole entries, not individual transactions." - :type 'boolean - :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) - -(defcustom ledger-report-format-specifiers - '(("ledger-file" . ledger-report-ledger-file-format-specifier) - ("payee" . ledger-report-payee-format-specifier) - ("account" . ledger-report-account-format-specifier)) - "Alist mapping ledger report format specifiers to implementing functions - -The function is called with no parameters and expected to return the -text that should replace the format specifier." - :type 'alist - :group 'ledger) - -(defcustom ledger-default-acct-transaction-indent " " - "Default indentation for account transactions in an entry." - :type 'string - :group 'ledger) - -(defvar bold 'bold) -(defvar ledger-font-lock-keywords - '(("\\( \\| \\|^\\)\\(;.*\\)" 2 font-lock-comment-face) - ("^[0-9]+[-/.=][-/.=0-9]+\\s-+\\(([^)]+)\\s-+\\)?\\([^*].+?\\)\\(\\( ;\\| ;\\|$\\)\\)" 2 bold) - ;;("^[0-9]+[-/.=][-/.=0-9]+\\s-+\\(([^)]+)\\s-+\\)?\\([*].+?\\)\\(\\( ;\\| ;\\|$\\)\\)" - ;; 2 font-lock-type-face) - ("^\\s-+\\([*]\\s-*\\)?\\(\\([[(]\\)?\\([^*;]\\)+?\\(:\\|\\s-\\)[^]); - ]+?\\([])]\\)?\\)\\( \\| \\|$\\)" - 2 font-lock-keyword-face) - ("^\\([~=].+\\)" 1 font-lock-function-name-face) - ("^\\([A-Za-z]+ .+\\)" 1 font-lock-function-name-face)) - "Expressions to highlight in Ledger mode.") - -(defsubst ledger-current-year () - (format-time-string "%Y")) -(defsubst ledger-current-month () - (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-iterate-entries (callback) - (goto-char (point-min)) - (let* ((now (current-time)) - (current-year (nth 5 (decode-time now)))) - (while (not (eobp)) - (when (looking-at - (concat "\\(Y\\s-+\\([0-9]+\\)\\|" - "\\([0-9]\\{4\\}+\\)?[./]?" - "\\([0-9]+\\)[./]\\([0-9]+\\)\\s-+" - "\\(\\*\\s-+\\)?\\(.+\\)\\)")) - (let ((found (match-string 2))) - (if found - (setq current-year (string-to-number found)) - (let ((start (match-beginning 0)) - (year (match-string 3)) - (month (string-to-number (match-string 4))) - (day (string-to-number (match-string 5))) - (mark (match-string 6)) - (desc (match-string 7))) - (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)))) - -(defun ledger-time-less-p (t1 t2) - "Say whether time value T1 is less than time value T2." - (or (< (car t1) (car t2)) - (and (= (car t1) (car t2)) - (< (nth 1 t1) (nth 1 t2))))) - -(defun ledger-time-subtract (t1 t2) - "Subtract two time values. -Return the difference in the format of a time value." - (let ((borrow (< (cadr t1) (cadr t2)))) - (list (- (car t1) (car t2) (if borrow 1 0)) - (- (+ (if borrow 65536 0) (cadr t1)) (cadr t2))))) - -(defun ledger-find-slot (moment) - (catch 'found - (ledger-iterate-entries - (function - (lambda (start date mark desc) - (if (ledger-time-less-p moment date) - (throw 'found t))))))) - -(defun ledger-add-entry (entry-text &optional insert-at-point) - (interactive - (list - (read-string "Entry: " (concat ledger-year "/" ledger-month "/")))) - (let* ((args (with-temp-buffer - (insert entry-text) - (eshell-parse-arguments (point-min) (point-max)))) - (ledger-buf (current-buffer)) - exit-code) - (unless insert-at-point - (let ((date (car args))) - (if (string-match "\\([0-9]+\\)/\\([0-9]+\\)/\\([0-9]+\\)" date) - (setq date - (encode-time 0 0 0 (string-to-number (match-string 3 date)) - (string-to-number (match-string 2 date)) - (string-to-number (match-string 1 date))))) - (ledger-find-slot date))) - (save-excursion - (insert - (with-temp-buffer - (setq exit-code - (apply #'ledger-run-ledger ledger-buf "entry" - (mapcar 'eval args))) - (goto-char (point-min)) - (if (looking-at "Error: ") - (error (buffer-string)) - (buffer-string))) - "\n")))) - -(defun ledger-current-entry-bounds () - (save-excursion - (when (or (looking-at "^[0-9]") - (re-search-backward "^[0-9]" nil t)) - (let ((beg (point))) - (while (not (eolp)) - (forward-line)) - (cons (copy-marker beg) (point-marker)))))) - -(defun ledger-delete-current-entry () - (interactive) - (let ((bounds (ledger-current-entry-bounds))) - (delete-region (car bounds) (cdr bounds)))) - -(defun ledger-toggle-current-entry (&optional style) - (interactive) - (let (clear) - (save-excursion - (when (or (looking-at "^[0-9]") - (re-search-backward "^[0-9]" nil t)) - (skip-chars-forward "0-9./=") - (delete-horizontal-space) - (if (member (char-after) '(?\* ?\!)) - (progn - (delete-char 1) - (if (and style (eq style 'cleared)) - (insert " *"))) - (if (and style (eq style 'pending)) - (insert " ! ") - (insert " * ")) - (setq clear t)))) - clear)) - -(defun ledger-move-to-next-field () - (re-search-forward "\\( \\|\t\\)" (line-end-position) t)) - -(defun ledger-toggle-state (state &optional style) - (if (not (null state)) - (if (and style (eq style 'cleared)) - 'cleared) - (if (and style (eq style 'pending)) - 'pending - 'cleared))) - -(defun ledger-entry-state () - (save-excursion - (when (or (looking-at "^[0-9]") - (re-search-backward "^[0-9]" nil t)) - (skip-chars-forward "0-9./=") - (skip-syntax-forward " ") - (cond ((looking-at "!\\s-*") 'pending) - ((looking-at "\\*\\s-*") 'cleared) - (t nil))))) - -(defun ledger-transaction-state () - (save-excursion - (goto-char (line-beginning-position)) - (skip-syntax-forward " ") - (cond ((looking-at "!\\s-*") 'pending) - ((looking-at "\\*\\s-*") 'cleared) - (t (ledger-entry-state))))) - -(defun ledger-toggle-current-transaction (&optional style) - "Toggle the cleared status of the transaction under point. -Optional argument STYLE may be `pending' or `cleared', depending -on which type of status the caller wishes to indicate (default is -`cleared'). -This function is rather complicated because it must preserve both -the overall formatting of the ledger entry, as well as ensuring -that the most minimal display format is used. This could be -achieved more certainly by passing the entry to ledger for -formatting, but doing so causes inline math expressions to be -dropped." - (interactive) - (let ((bounds (ledger-current-entry-bounds)) - clear cleared) - ;; Uncompact the entry, to make it easier to toggle the - ;; transaction - (save-excursion - (goto-char (car bounds)) - (skip-chars-forward "0-9./= \t") - (setq cleared (and (member (char-after) '(?\* ?\!)) - (char-after))) - (when cleared - (let ((here (point))) - (skip-chars-forward "*! ") - (let ((width (- (point) here))) - (when (> width 0) - (delete-region here (point)) - (if (search-forward " " (line-end-position) t) - (insert (make-string width ? )))))) - (forward-line) - (while (looking-at "[ \t]") - (skip-chars-forward " \t") - (insert cleared " ") - (if (search-forward " " (line-end-position) t) - (delete-char 2)) - (forward-line)))) - ;; Toggle the individual transaction - (save-excursion - (goto-char (line-beginning-position)) - (when (looking-at "[ \t]") - (skip-chars-forward " \t") - (let ((here (point)) - (cleared (member (char-after) '(?\* ?\!)))) - (skip-chars-forward "*! ") - (let ((width (- (point) here))) - (when (> width 0) - (delete-region here (point)) - (save-excursion - (if (search-forward " " (line-end-position) t) - (insert (make-string width ? )))))) - (let (inserted) - (if cleared - (if (and style (eq style 'cleared)) - (progn - (insert "* ") - (setq inserted t))) - (if (and style (eq style 'pending)) - (progn - (insert "! ") - (setq inserted t)) - (progn - (insert "* ") - (setq inserted t)))) - (if (and inserted - (re-search-forward "\\(\t\\| [ \t]\\)" - (line-end-position) t)) - (cond - ((looking-at "\t") - (delete-char 1)) - ((looking-at " [ \t]") - (delete-char 2)) - ((looking-at " ") - (delete-char 1)))) - (setq clear inserted))))) - ;; Clean up the entry so that it displays minimally - (save-excursion - (goto-char (car bounds)) - (forward-line) - (let ((first t) - (state ? ) - (hetero nil)) - (while (and (not hetero) (looking-at "[ \t]")) - (skip-chars-forward " \t") - (let ((cleared (if (member (char-after) '(?\* ?\!)) - (char-after) - ? ))) - (if first - (setq state cleared - first nil) - (if (/= state cleared) - (setq hetero t)))) - (forward-line)) - (when (and (not hetero) (/= state ? )) - (goto-char (car bounds)) - (forward-line) - (while (looking-at "[ \t]") - (skip-chars-forward " \t") - (let ((here (point))) - (skip-chars-forward "*! ") - (let ((width (- (point) here))) - (when (> width 0) - (delete-region here (point)) - (if (re-search-forward "\\(\t\\| [ \t]\\)" - (line-end-position) t) - (insert (make-string width ? )))))) - (forward-line)) - (goto-char (car bounds)) - (skip-chars-forward "0-9./= \t") - (insert state " ") - (if (re-search-forward "\\(\t\\| [ \t]\\)" - (line-end-position) t) - (cond - ((looking-at "\t") - (delete-char 1)) - ((looking-at " [ \t]") - (delete-char 2)) - ((looking-at " ") - (delete-char 1))))))) - clear)) - -(defun ledger-toggle-current (&optional style) - (interactive) - (if (or ledger-clear-whole-entries - (eq 'entry (ledger-thing-at-point))) - (progn - (save-excursion - (forward-line) - (goto-char (line-beginning-position)) - (while (and (not (eolp)) - (save-excursion - (not (eq 'entry (ledger-thing-at-point))))) - (if (looking-at "\\s-+[*!]") - (ledger-toggle-current-transaction nil)) - (forward-line) - (goto-char (line-beginning-position)))) - (ledger-toggle-current-entry style)) - (ledger-toggle-current-transaction style))) - -(defvar ledger-mode-abbrev-table) - -;;;###autoload -(define-derived-mode ledger-mode text-mode "Ledger" - "A mode for editing ledger data files. - -\\{ledger-mode-map}" - (set (make-local-variable 'comment-start) " ; ") - (set (make-local-variable 'comment-end) "") - (set (make-local-variable 'indent-tabs-mode) nil) - - (if (boundp 'font-lock-defaults) - (set (make-local-variable 'font-lock-defaults) - '(ledger-font-lock-keywords nil t))) - - (set (make-local-variable 'pcomplete-parse-arguments-function) - 'ledger-parse-arguments) - (set (make-local-variable 'pcomplete-command-completion-function) - 'ledger-complete-at-point) - (set (make-local-variable 'pcomplete-termination-string) "") - - (let ((map (current-local-map))) - (define-key map [(control ?c) (control ?a)] 'ledger-add-entry) - (define-key map [(control ?c) (control ?d)] 'ledger-delete-current-entry) - (define-key map [(control ?c) (control ?y)] 'ledger-set-year) - (define-key map [(control ?c) (control ?m)] 'ledger-set-month) - (define-key map [(control ?c) (control ?c)] 'ledger-toggle-current) - (define-key map [(control ?c) (control ?e)] 'ledger-toggle-current-entry) - (define-key map [(control ?c) (control ?r)] 'ledger-reconcile) - (define-key map [(control ?c) (control ?s)] 'ledger-sort) - (define-key map [tab] 'pcomplete) - (define-key map [(control ?i)] 'pcomplete) - (define-key map [(control ?c) tab] 'ledger-fully-complete-entry) - (define-key map [(control ?c) (control ?i)] 'ledger-fully-complete-entry) - (define-key map [(control ?c) (control ?o) (control ?r)] 'ledger-report) - (define-key map [(control ?c) (control ?o) (control ?g)] 'ledger-report-goto) - (define-key map [(control ?c) (control ?o) (control ?a)] 'ledger-report-redo) - (define-key map [(control ?c) (control ?o) (control ?s)] 'ledger-report-save) - (define-key map [(control ?c) (control ?o) (control ?e)] 'ledger-report-edit) - (define-key map [(control ?c) (control ?o) (control ?k)] 'ledger-report-kill))) - -;; Reconcile mode - -(defvar ledger-buf nil) -(defvar ledger-acct nil) - -(defun ledger-display-balance () - (let ((buffer ledger-buf) - (account ledger-acct)) - (with-temp-buffer - (let ((exit-code (ledger-run-ledger buffer "-C" "balance" account))) - (if (/= 0 exit-code) - (message "Error determining cleared balance") - (goto-char (1- (point-max))) - (goto-char (line-beginning-position)) - (delete-horizontal-space) - (message "Cleared balance = %s" - (buffer-substring-no-properties (point) - (line-end-position)))))))) - -(defun ledger-reconcile-toggle () - (interactive) - (let ((where (get-text-property (point) 'where)) - (account ledger-acct) - (inhibit-read-only t) - cleared) - (when (or (equal (car where) "") (equal (car where) "/dev/stdin")) - (with-current-buffer ledger-buf - (goto-char (cdr where)) - (setq cleared (ledger-toggle-current 'pending))) - (if cleared - (add-text-properties (line-beginning-position) - (line-end-position) - (list 'face 'bold)) - (remove-text-properties (line-beginning-position) - (line-end-position) - (list 'face)))) - (forward-line))) - -(defun ledger-reconcile-refresh () - (interactive) - (let ((inhibit-read-only t) - (line (count-lines (point-min) (point)))) - (erase-buffer) - (ledger-do-reconcile) - (set-buffer-modified-p t) - (goto-char (point-min)) - (forward-line line))) - -(defun ledger-reconcile-refresh-after-save () - (let ((buf (get-buffer "*Reconcile*"))) - (if buf - (with-current-buffer buf - (ledger-reconcile-refresh) - (set-buffer-modified-p nil))))) - -(defun ledger-reconcile-add () - (interactive) - (with-current-buffer ledger-buf - (call-interactively #'ledger-add-entry)) - (ledger-reconcile-refresh)) - -(defun ledger-reconcile-delete () - (interactive) - (let ((where (get-text-property (point) 'where))) - (when (or (equal (car where) "") (equal (car where) "/dev/stdin")) - (with-current-buffer ledger-buf - (goto-char (cdr where)) - (ledger-delete-current-entry)) - (let ((inhibit-read-only t)) - (goto-char (line-beginning-position)) - (delete-region (point) (1+ (line-end-position))) - (set-buffer-modified-p t))))) - -(defun ledger-reconcile-visit () - (interactive) - (let ((where (get-text-property (point) 'where))) - (when (markerp (cdr where)) - (switch-to-buffer-other-window ledger-buf) - (goto-char (cdr where))))) - -(defun ledger-reconcile-save () - (interactive) - (with-current-buffer ledger-buf - (save-buffer)) - (set-buffer-modified-p nil) - (ledger-display-balance)) - -(defun ledger-reconcile-quit () - (interactive) - (kill-buffer (current-buffer))) - -(defun ledger-reconcile-finish () - (interactive) - (save-excursion - (goto-char (point-min)) - (while (not (eobp)) - (let ((where (get-text-property (point) 'where)) - (face (get-text-property (point) 'face))) - (if (and (eq face 'bold) - (or (equal (car where) "") - (equal (car where) "/dev/stdin"))) - (with-current-buffer ledger-buf - (goto-char (cdr where)) - (ledger-toggle-current 'cleared)))) - (forward-line 1))) - (ledger-reconcile-save)) - -(defun ledger-do-reconcile () - (let* ((buf ledger-buf) - (account ledger-acct) - (items - (with-temp-buffer - (let ((exit-code - (ledger-run-ledger buf "--uncleared" "--real" - "emacs" account))) - (when (= 0 exit-code) - (goto-char (point-min)) - (unless (eobp) - (unless (looking-at "(") - (error (buffer-string))) - (read (current-buffer)))))))) - (dolist (item items) - (let ((index 1)) - (dolist (xact (nthcdr 5 item)) - (let ((beg (point)) - (where - (with-current-buffer buf - (cons - (nth 0 item) - (if ledger-clear-whole-entries - (save-excursion - (goto-line (nth 1 item)) - (point-marker)) - (save-excursion - (goto-line (nth 0 xact)) - (point-marker))))))) - (insert (format "%s %-30s %-25s %15s\n" - (format-time-string "%m/%d" (nth 2 item)) - (nth 4 item) (nth 1 xact) (nth 2 xact))) - (if (nth 3 xact) - (set-text-properties beg (1- (point)) - (list 'face 'bold - 'where where)) - (set-text-properties beg (1- (point)) - (list 'where where)))) - (setq index (1+ index))))) - (goto-char (point-min)) - (set-buffer-modified-p nil) - (toggle-read-only t))) - -(defun ledger-reconcile (account) - (interactive "sAccount to reconcile: ") - (let ((buf (current-buffer)) - (rbuf (get-buffer "*Reconcile*"))) - (if rbuf - (kill-buffer rbuf)) - (add-hook 'after-save-hook 'ledger-reconcile-refresh-after-save) - (with-current-buffer - (pop-to-buffer (get-buffer-create "*Reconcile*")) - (ledger-reconcile-mode) - (set (make-local-variable 'ledger-buf) buf) - (set (make-local-variable 'ledger-acct) account) - (ledger-do-reconcile)))) - -(defvar ledger-reconcile-mode-abbrev-table) - -(defvar ledger-reconcile-mode-map - (let ((map (make-sparse-keymap))) - (define-key map [(control ?m)] 'ledger-reconcile-visit) - (define-key map [return] 'ledger-reconcile-visit) - (define-key map [(control ?c) (control ?c)] 'ledger-reconcile-finish) - (define-key map [(control ?x) (control ?s)] 'ledger-reconcile-save) - (define-key map [(control ?l)] 'ledger-reconcile-refresh) - (define-key map [? ] 'ledger-reconcile-toggle) - (define-key map [?a] 'ledger-reconcile-add) - (define-key map [?d] 'ledger-reconcile-delete) - (define-key map [?n] 'next-line) - (define-key map [?p] 'previous-line) - (define-key map [?s] 'ledger-reconcile-save) - (define-key map [?q] 'ledger-reconcile-quit) - map)) - -(define-derived-mode ledger-reconcile-mode text-mode "Reconcile" - "A mode for reconciling ledger entries. - -\\{ledger-reconcile-mode-map}") - -;; Context sensitivity - -(defconst ledger-line-config - '((entry - (("^\\(\\([0-9][0-9][0-9][0-9]/\\)?[01]?[0-9]/[0123]?[0-9]\\)[ \t]+\\(\\([!*]\\)[ \t]\\)?[ \t]*\\((\\(.*\\))\\)?[ \t]*\\(.*?\\)[ \t]*;\\(.*\\)[ \t]*$" - (date nil status nil nil code payee comment)) - ("^\\(\\([0-9][0-9][0-9][0-9]/\\)?[01]?[0-9]/[0123]?[0-9]\\)[ \t]+\\(\\([!*]\\)[ \t]\\)?[ \t]*\\((\\(.*\\))\\)?[ \t]*\\(.*\\)[ \t]*$" - (date nil status nil nil code payee)))) - (acct-transaction - (("\\(^[ \t]+\\)\\(.*?\\)[ \t]+\\([$]\\)\\(-?[0-9]*\\(\\.[0-9]*\\)?\\)[ \t]*;[ \t]*\\(.*?\\)[ \t]*$" - (indent account commodity amount nil comment)) - ("\\(^[ \t]+\\)\\(.*?\\)[ \t]+\\([$]\\)\\(-?[0-9]*\\(\\.[0-9]*\\)?\\)[ \t]*$" - (indent account commodity amount nil)) - ("\\(^[ \t]+\\)\\(.*?\\)[ \t]+\\(-?[0-9]+\\(\\.[0-9]*\\)?\\)[ \t]+\\(.*?\\)[ \t]*;[ \t]*\\(.*?\\)[ \t]*$" - (indent account amount nil commodity comment)) - ("\\(^[ \t]+\\)\\(.*?\\)[ \t]+\\(-?[0-9]+\\(\\.[0-9]*\\)?\\)[ \t]+\\(.*?\\)[ \t]*$" - (indent account amount nil commodity)) - ("\\(^[ \t]+\\)\\(.*?\\)[ \t]+\\(-?\\(\\.[0-9]*\\)\\)[ \t]+\\(.*?\\)[ \t]*;[ \t]*\\(.*?\\)[ \t]*$" - (indent account amount nil commodity comment)) - ("\\(^[ \t]+\\)\\(.*?\\)[ \t]+\\(-?\\(\\.[0-9]*\\)\\)[ \t]+\\(.*?\\)[ \t]*$" - (indent account amount nil commodity)) - ("\\(^[ \t]+\\)\\(.*?\\)[ \t]*;[ \t]*\\(.*?\\)[ \t]*$" - (indent account comment)) - ("\\(^[ \t]+\\)\\(.*?\\)[ \t]*$" - (indent account)))))) - -(defun ledger-extract-context-info (line-type pos) - "Get context info for current line. - -Assumes point is at beginning of line, and the pos argument specifies -where the \"users\" point was." - (let ((linfo (assoc line-type ledger-line-config)) - found field fields) - (dolist (re-info (nth 1 linfo)) - (let ((re (nth 0 re-info)) - (names (nth 1 re-info))) - (unless found - (when (looking-at re) - (setq found t) - (dotimes (i (length names)) - (when (nth i names) - (setq fields (append fields - (list - (list (nth i names) - (match-string-no-properties (1+ i)) - (match-beginning (1+ i)))))))) - (dolist (f fields) - (and (nth 1 f) - (>= pos (nth 2 f)) - (setq field (nth 0 f)))))))) - (list line-type field fields))) - -(defun ledger-context-at-point () - "Return a list describing the context around point. - -The contents of the list are the line type, the name of the field -point containing point, and for selected line types, the content of -the fields in the line in a association list." - (let ((pos (point))) - (save-excursion - (beginning-of-line) - (let ((first-char (char-after))) - (cond ((equal (point) (line-end-position)) - '(empty-line nil nil)) - ((memq first-char '(?\ ?\t)) - (ledger-extract-context-info 'acct-transaction pos)) - ((memq first-char '(?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9)) - (ledger-extract-context-info 'entry pos)) - ((equal first-char ?\=) - '(automated-entry nil nil)) - ((equal first-char ?\~) - '(period-entry nil nil)) - ((equal first-char ?\!) - '(command-directive)) - ((equal first-char ?\;) - '(comment nil nil)) - ((equal first-char ?Y) - '(default-year nil nil)) - ((equal first-char ?P) - '(commodity-price nil nil)) - ((equal first-char ?N) - '(price-ignored-commodity nil nil)) - ((equal first-char ?D) - '(default-commodity nil nil)) - ((equal first-char ?C) - '(commodity-conversion nil nil)) - ((equal first-char ?i) - '(timeclock-i nil nil)) - ((equal first-char ?o) - '(timeclock-o nil nil)) - ((equal first-char ?b) - '(timeclock-b nil nil)) - ((equal first-char ?h) - '(timeclock-h nil nil)) - (t - '(unknown nil nil))))))) - -(defun ledger-context-other-line (offset) - "Return a list describing context of line offset for existing position. - -Offset can be positive or negative. If run out of buffer before reaching -specified line, returns nil." - (save-excursion - (let ((left (forward-line offset))) - (if (not (equal left 0)) - nil - (ledger-context-at-point))))) - -(defun ledger-context-line-type (context-info) - (nth 0 context-info)) - -(defun ledger-context-current-field (context-info) - (nth 1 context-info)) - -(defun ledger-context-field-info (context-info field-name) - (assoc field-name (nth 2 context-info))) - -(defun ledger-context-field-present-p (context-info field-name) - (not (null (ledger-context-field-info context-info field-name)))) - -(defun ledger-context-field-value (context-info field-name) - (nth 1 (ledger-context-field-info context-info field-name))) - -(defun ledger-context-field-position (context-info field-name) - (nth 2 (ledger-context-field-info context-info field-name))) - -(defun ledger-context-field-end-position (context-info field-name) - (+ (ledger-context-field-position context-info field-name) - (length (ledger-context-field-value context-info field-name)))) - -(defun ledger-context-goto-field-start (context-info field-name) - (goto-char (ledger-context-field-position context-info field-name))) - -(defun ledger-context-goto-field-end (context-info field-name) - (goto-char (ledger-context-field-end-position context-info field-name))) - -(defun ledger-entry-payee () - "Returns the payee of the entry containing point or nil." - (let ((i 0)) - (while (eq (ledger-context-line-type (ledger-context-other-line i)) 'acct-transaction) - (setq i (- i 1))) - (let ((context-info (ledger-context-other-line i))) - (if (eq (ledger-context-line-type context-info) 'entry) - (ledger-context-field-value context-info 'payee) - nil)))) - -;; Ledger report mode - -(defvar ledger-report-buffer-name "*Ledger Report*") - -(defvar ledger-report-name nil) -(defvar ledger-report-cmd nil) -(defvar ledger-report-name-prompt-history nil) -(defvar ledger-report-cmd-prompt-history nil) -(defvar ledger-original-window-cfg nil) - -(defvar ledger-report-mode-abbrev-table) - -(defvar ledger-report-mode-map - (let ((map (make-sparse-keymap))) - (define-key map [? ] 'scroll-up) - (define-key map [backspace] 'scroll-down) - (define-key map [?r] 'ledger-report-redo) - (define-key map [?s] 'ledger-report-save) - (define-key map [?k] 'ledger-report-kill) - (define-key map [?e] 'ledger-report-edit) - (define-key map [?q] 'ledger-report-quit) - (define-key map [(control ?c) (control ?l) (control ?r)] - 'ledger-report-redo) - (define-key map [(control ?c) (control ?l) (control ?S)] - 'ledger-report-save) - (define-key map [(control ?c) (control ?l) (control ?k)] - 'ledger-report-kill) - (define-key map [(control ?c) (control ?l) (control ?e)] - 'ledger-report-edit) - map)) - -(define-derived-mode ledger-report-mode text-mode "Ledger-Report" - "A mode for viewing ledger reports.") - -(defun ledger-report-read-name () - "Read the name of a ledger report to use, with completion. - -The empty string and unknown names are allowed." - (completing-read "Report name: " - ledger-reports nil nil nil - 'ledger-report-name-prompt-history nil)) - -(defun ledger-report (report-name edit) - "Run a user-specified report from `ledger-reports'. - -Prompts the user for the name of the report to run. If no name is -entered, the user will be prompted for a command line to run. The -command line specified or associated with the selected report name -is run and the output is made available in another buffer for viewing. -If a prefix argument is given and the user selects a valid report -name, the user is prompted with the corresponding command line for -editing before the command is run. - -The output buffer will be in `ledger-report-mode', which defines -commands for saving a new named report based on the command line -used to generate the buffer, navigating the buffer, etc." - (interactive - (progn - (when (and (buffer-modified-p) - (y-or-n-p "Buffer modified, save it? ")) - (save-buffer)) - (let ((rname (ledger-report-read-name)) - (edit (not (null current-prefix-arg)))) - (list rname edit)))) - (let ((buf (current-buffer)) - (rbuf (get-buffer ledger-report-buffer-name)) - (wcfg (current-window-configuration))) - (if rbuf - (kill-buffer rbuf)) - (with-current-buffer - (pop-to-buffer (get-buffer-create ledger-report-buffer-name)) - (ledger-report-mode) - (set (make-local-variable 'ledger-buf) buf) - (set (make-local-variable 'ledger-report-name) report-name) - (set (make-local-variable 'ledger-original-window-cfg) wcfg) - (ledger-do-report (ledger-report-cmd report-name edit)) - (shrink-window-if-larger-than-buffer) - (set-buffer-modified-p nil) - (setq buffer-read-only t) - (message "q to quit; r to redo; e to edit; k to kill; s to save; SPC and DEL to scroll")))) - -(defun string-empty-p (s) - "Check for the empty string." - (string-equal "" s)) - -(defun ledger-report-name-exists (name) - "Check to see if the given report name exists. - -If name exists, returns the object naming the report, otherwise returns nil." - (unless (string-empty-p name) - (car (assoc name ledger-reports)))) - -(defun ledger-reports-add (name cmd) - "Add a new report to `ledger-reports'." - (setq ledger-reports (cons (list name cmd) ledger-reports))) - -(defun ledger-reports-custom-save () - "Save the `ledger-reports' variable using the customize framework." - (customize-save-variable 'ledger-reports ledger-reports)) - -(defun ledger-report-read-command (report-cmd) - "Read the command line to create a report." - (read-from-minibuffer "Report command line: " - (if (null report-cmd) "ledger " report-cmd) - nil nil 'ledger-report-cmd-prompt-history)) - -(defun ledger-report-ledger-file-format-specifier () - "Substitute the full path to master or current ledger file - -The master file name is determined by the ledger-master-file buffer-local -variable which can be set using file variables. If it is set, it is used, -otherwise the current buffer file is used." - (ledger-master-file)) - -(defun ledger-read-string-with-default (prompt default) - (let ((default-prompt (concat prompt - (if default - (concat " (" default "): ") - ": ")))) - (read-string default-prompt nil nil default))) - -(defun ledger-report-payee-format-specifier () - "Substitute a payee name - -The user is prompted to enter a payee and that is substitued. If -point is in an entry, the payee for that entry is used as the -default." - ;; It is intended copmletion should be available on existing - ;; payees, but the list of possible completions needs to be - ;; developed to allow this. - (ledger-read-string-with-default "Payee" (regexp-quote (ledger-entry-payee)))) - -(defun ledger-report-account-format-specifier () - "Substitute an account name - -The user is prompted to enter an account name, which can be any -regular expression identifying an account. If point is on an account -transaction line for an entry, the full account name on that line is -the default." - ;; It is intended completion should be available on existing account - ;; names, but it remains to be implemented. - (let* ((context (ledger-context-at-point)) - (default - (if (eq (ledger-context-line-type context) 'acct-transaction) - (regexp-quote (ledger-context-field-value context 'account)) - nil))) - (ledger-read-string-with-default "Account" default))) - -(defun ledger-report-expand-format-specifiers (report-cmd) - (let ((expanded-cmd report-cmd)) - (while (string-match "%(\\([^)]*\\))" expanded-cmd) - (let* ((specifier (match-string 1 expanded-cmd)) - (f (cdr (assoc specifier ledger-report-format-specifiers)))) - (if f - (setq expanded-cmd (replace-match - (save-match-data - (with-current-buffer ledger-buf - (shell-quote-argument (funcall f)))) - t t expanded-cmd)) - (progn - (set-window-configuration ledger-original-window-cfg) - (error "Invalid ledger report format specifier '%s'" specifier))))) - expanded-cmd)) - -(defun ledger-report-cmd (report-name edit) - "Get the command line to run the report." - (let ((report-cmd (car (cdr (assoc report-name ledger-reports))))) - ;; logic for substitution goes here - (when (or (null report-cmd) edit) - (setq report-cmd (ledger-report-read-command report-cmd))) - (setq report-cmd (ledger-report-expand-format-specifiers report-cmd)) - (set (make-local-variable 'ledger-report-cmd) report-cmd) - (or (string-empty-p report-name) - (ledger-report-name-exists report-name) - (ledger-reports-add report-name report-cmd) - (ledger-reports-custom-save)) - report-cmd)) - -(defun ledger-do-report (cmd) - "Run a report command line." - (goto-char (point-min)) - (insert (format "Report: %s\n" ledger-report-name) - (format "Command: %s\n" cmd) - (make-string (- (window-width) 1) ?=) - "\n") - (shell-command cmd t nil)) - -(defun ledger-report-goto () - "Goto the ledger report buffer." - (interactive) - (let ((rbuf (get-buffer ledger-report-buffer-name))) - (if (not rbuf) - (error "There is no ledger report buffer")) - (pop-to-buffer rbuf) - (shrink-window-if-larger-than-buffer))) - -(defun ledger-report-redo () - "Redo the report in the current ledger report buffer." - (interactive) - (ledger-report-goto) - (setq buffer-read-only nil) - (erase-buffer) - (ledger-do-report ledger-report-cmd) - (setq buffer-read-only nil)) - -(defun ledger-report-quit () - "Quit the ledger report buffer by burying it." - (interactive) - (ledger-report-goto) - (set-window-configuration ledger-original-window-cfg) - (bury-buffer (get-buffer ledger-report-buffer-name))) - -(defun ledger-report-kill () - "Kill the ledger report buffer." - (interactive) - (ledger-report-quit) - (kill-buffer (get-buffer ledger-report-buffer-name))) - -(defun ledger-report-edit () - "Edit the defined ledger reports." - (interactive) - (customize-variable 'ledger-reports)) - -(defun ledger-report-read-new-name () - "Read the name for a new report from the minibuffer." - (let ((name "")) - (while (string-empty-p name) - (setq name (read-from-minibuffer "Report name: " nil nil nil - 'ledger-report-name-prompt-history))) - name)) - -(defun ledger-report-save () - "Save the current report command line as a named report." - (interactive) - (ledger-report-goto) - (let (existing-name) - (when (string-empty-p ledger-report-name) - (setq ledger-report-name (ledger-report-read-new-name))) - - (while (setq existing-name (ledger-report-name-exists ledger-report-name)) - (cond ((y-or-n-p (format "Overwrite existing report named '%s' " - ledger-report-name)) - (when (string-equal - ledger-report-cmd - (car (cdr (assq existing-name ledger-reports)))) - (error "Current command is identical to existing saved one")) - (setq ledger-reports - (assq-delete-all existing-name ledger-reports))) - (t - (setq ledger-report-name (ledger-report-read-new-name))))) - - (ledger-reports-add ledger-report-name ledger-report-cmd) - (ledger-reports-custom-save))) - -;; In-place completion support - -(defun ledger-thing-at-point () - (let ((here (point))) - (goto-char (line-beginning-position)) - (cond ((looking-at "^[0-9/.=-]+\\(\\s-+\\*\\)?\\(\\s-+(.+?)\\)?\\s-+") - (goto-char (match-end 0)) - 'entry) - ((looking-at "^\\s-+\\([*!]\\s-+\\)?[[(]?\\(.\\)") - (goto-char (match-beginning 2)) - 'transaction) - ((looking-at "^\\(sun\\|mon\\|tue\\|wed\\|thu\\|fri\\|sat\\)\\s-+") - (goto-char (match-end 0)) - 'entry) - (t - (ignore (goto-char here)))))) - -(defun ledger-parse-arguments () - "Parse whitespace separated arguments in the current region." - (let* ((info (save-excursion - (cons (ledger-thing-at-point) (point)))) - (begin (cdr info)) - (end (point)) - begins args) - (save-excursion - (goto-char begin) - (when (< (point) end) - (skip-chars-forward " \t\n") - (setq begins (cons (point) begins)) - (setq args (cons (buffer-substring-no-properties - (car begins) end) - args))) - (cons (reverse args) (reverse begins))))) - -(defun ledger-entries () - (let ((origin (point)) - entries-list) - (save-excursion - (goto-char (point-min)) - (while (re-search-forward - (concat "^[0-9/.=-]+\\(\\s-+\\*\\)?\\(\\s-+(.*?)\\)?\\s-+" - "\\(.+?\\)\\(\t\\|\n\\| [ \t]\\)") nil t) - (unless (and (>= origin (match-beginning 0)) - (< origin (match-end 0))) - (setq entries-list (cons (match-string-no-properties 3) - entries-list))))) - (pcomplete-uniqify-list (nreverse entries-list)))) - -(defvar ledger-account-tree nil) - -(defun ledger-find-accounts () - (let ((origin (point)) account-path elements) - (save-excursion - (setq ledger-account-tree (list t)) - (goto-char (point-min)) - (while (re-search-forward - "^[ \t]+\\([*!]\\s-+\\)?[[(]?\\(.+?\\)\\(\t\\|\n\\| [ \t]\\)" nil t) - (unless (and (>= origin (match-beginning 0)) - (< origin (match-end 0))) - (setq account-path (match-string-no-properties 2)) - (setq elements (split-string account-path ":")) - (let ((root ledger-account-tree)) - (while elements - (let ((entry (assoc (car elements) root))) - (if entry - (setq root (cdr entry)) - (setq entry (cons (car elements) (list t))) - (nconc root (list entry)) - (setq root (cdr entry)))) - (setq elements (cdr elements))))))))) - -(defun ledger-accounts () - (ledger-find-accounts) - (let* ((current (caar (ledger-parse-arguments))) - (elements (and current (split-string current ":"))) - (root ledger-account-tree) - (prefix nil)) - (while (cdr elements) - (let ((entry (assoc (car elements) root))) - (if entry - (setq prefix (concat prefix (and prefix ":") - (car elements)) - root (cdr entry)) - (setq root nil elements nil))) - (setq elements (cdr elements))) - (and root - (sort - (mapcar (function - (lambda (x) - (let ((term (if prefix - (concat prefix ":" (car x)) - (car x)))) - (if (> (length (cdr x)) 1) - (concat term ":") - term)))) - (cdr root)) - 'string-lessp)))) - -(defun ledger-complete-at-point () - "Do appropriate completion for the thing at point" - (interactive) - (while (pcomplete-here - (if (eq (save-excursion - (ledger-thing-at-point)) 'entry) - (if (null current-prefix-arg) - (ledger-entries) ; this completes against entry names - (progn - (let ((text (buffer-substring (line-beginning-position) - (line-end-position)))) - (delete-region (line-beginning-position) - (line-end-position)) - (condition-case err - (ledger-add-entry text t) - ((error) - (insert text)))) - (forward-line) - (goto-char (line-end-position)) - (search-backward ";" (line-beginning-position) t) - (skip-chars-backward " \t0123456789.,") - (throw 'pcompleted t))) - (ledger-accounts))))) - -(defun ledger-fully-complete-entry () - "Do appropriate completion for the thing at point" - (interactive) - (let ((name (caar (ledger-parse-arguments))) - xacts) - (save-excursion - (when (eq 'entry (ledger-thing-at-point)) - (when (re-search-backward - (concat "^[0-9/.=-]+\\(\\s-+\\*\\)?\\(\\s-+(.*?)\\)?\\s-+" - (regexp-quote name) "\\(\t\\|\n\\| [ \t]\\)") nil t) - (forward-line) - (while (looking-at "^\\s-+") - (setq xacts (cons (buffer-substring-no-properties - (line-beginning-position) - (line-end-position)) - xacts)) - (forward-line)) - (setq xacts (nreverse xacts))))) - (when xacts - (save-excursion - (insert ?\n) - (while xacts - (insert (car xacts) ?\n) - (setq xacts (cdr xacts)))) - (forward-line) - (goto-char (line-end-position)) - (if (re-search-backward "\\(\t\\| [ \t]\\)" nil t) - (goto-char (match-end 0)))))) - -;; A sample function for $ users - -(defun ledger-next-amount (&optional end) - (when (re-search-forward "\\( \\|\t\\| \t\\)[ \t]*-?\\([A-Z$€£]+ *\\)?\\(-?[0-9,]+?\\)\\(.[0-9]+\\)?\\( *[A-Z$€£]+\\)?\\([ \t]*@@?[^\n;]+?\\)?\\([ \t]+;.+?\\)?$" (marker-position end) t) - (goto-char (match-beginning 0)) - (skip-syntax-forward " ") - (- (or (match-end 4) - (match-end 3)) (point)))) - -(defun ledger-align-amounts (&optional column) - "Align amounts in the current region. -This is done so that the last digit falls in COLUMN, which defaults to 52." - (interactive "p") - (if (or (null column) (= column 1)) - (setq column 52)) - (save-excursion - (let* ((mark-first (< (mark) (point))) - (begin (if mark-first (mark) (point))) - (end (if mark-first (point-marker) (mark-marker))) - offset) - (goto-char begin) - (while (setq offset (ledger-next-amount end)) - (let ((col (current-column)) - (target-col (- column offset)) - adjust) - (setq adjust (- target-col col)) - (if (< col target-col) - (insert (make-string (- target-col col) ? )) - (move-to-column target-col) - (if (looking-back " ") - (delete-char (- col target-col)) - (skip-chars-forward "^ \t") - (delete-horizontal-space) - (insert " "))) - (forward-line)))))) - -(defalias 'ledger-align-dollars 'ledger-align-amounts) - -;; A sample entry sorting function, which works if entry dates are of -;; the form YYYY/mm/dd. - -(defun ledger-sort () - (interactive) - (save-excursion - (goto-char (point-min)) - (sort-subr - nil - (function - (lambda () - (if (re-search-forward - (concat "^[0-9/.=-]+\\(\\s-+\\*\\)?\\(\\s-+(.*?)\\)?\\s-+" - "\\(.+?\\)\\(\t\\|\n\\| [ \t]\\)") nil t) - (goto-char (match-beginning 0)) - (goto-char (point-max))))) - (function - (lambda () - (forward-paragraph)))))) - -;; General helper functions - -(defvar ledger-delete-after nil) - -(defun ledger-run-ledger (buffer &rest args) - "run ledger with supplied arguments" - ;; Let's try again, just in case they moved it while we were sleeping. - (cond - ((null ledger-binary-path) - (error "The variable `ledger-binary-path' has not been set")) - (t - (let ((buf (current-buffer))) - (with-current-buffer buffer - (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 ledger-delete-after - buf nil "-f" "-") - args)))))))) - -(defun ledger-run-ledger-and-delete (buffer &rest args) - (let ((ledger-delete-after t)) - (apply #'ledger-run-ledger buffer args))) - -(defun ledger-set-year (newyear) - "Set ledger's idea of the current year to the prefix argument." - (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." - (interactive "p") - (if (= newmonth 1) - (setq ledger-month (read-string "Month: " (ledger-current-month))) - (setq ledger-month (format "%02d" newmonth)))) - -(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))) - -(easy-menu-define ledger-menu ledger-mode-map - "Ledger menu" - '("Ledger" - ["New entry" ledger-add-entry t] - ["Toggle cleared status of current entry" ledger-toggle-current-entry t] - ["Set default year for entry" ledger-set-year t] - ["Set default month for entry" ledger-set-month t] - "--" - ["Reconcile uncleared entries for account" ledger-reconcile t] - "--" - "Reports" - ["Run a report" ledger-report t] - ["Go to report buffer" ledger-report-goto t] - ["Edit defined reports" ledger-report-edit t] - ["Save report definition" ledger-report-save t] - ["Re-run ledger report" ledger-report-redo t] - ["Kill report buffer" ledger-report-kill t])) - -(provide 'ledger) - -;;; ledger.el ends here -- cgit v1.2.3 From cdd7f0675c5906e6a70781a09f87dc4f459a518d Mon Sep 17 00:00:00 2001 From: Craig Earls Date: Thu, 7 Mar 2013 16:52:51 -0500 Subject: refactored the auto-adjust to make it default --- lisp/ldg-post.el | 21 +++++++++++---------- 1 file changed, 11 insertions(+), 10 deletions(-) diff --git a/lisp/ldg-post.el b/lisp/ldg-post.el index 87922dd1..46acad1a 100644 --- a/lisp/ldg-post.el +++ b/lisp/ldg-post.el @@ -31,12 +31,11 @@ "Default indentation for account transactions in an entry." :type 'string :group 'ledger-post) - (defgroup ledger-post nil "Options for controlling how Ledger-mode deals with postings and completion" :group 'ledger) -(defcustom ledger-post-auto-adjust-postings nil +(defcustom ledger-post-auto-adjust-postings t "If non-nil, adjust account and amount to columns set below" :type 'boolean :group 'ledger-post) @@ -138,8 +137,9 @@ the account" (setq column ledger-post-amount-alignment-column)) (save-excursion ;; Position the account - (if (not (and (looking-at "[ \t]+\n") - (looking-back "[ \n]" (- (point) 2)))) + (if (not (or (looking-at "[ \t]*[1-9]") + (and (looking-at "[ \t]+\n") + (looking-back "[ \n]" (- (point) 2))))) (save-excursion (beginning-of-line) (set-mark (point)) @@ -180,12 +180,13 @@ the account" (defun ledger-post-maybe-align (beg end len) "Align amounts only if point is in a posting. BEG, END, and LEN control how far it can align." - (save-excursion - (goto-char beg) - (when (<= end (line-end-position)) - (goto-char (line-beginning-position)) - (if (looking-at ledger-post-line-regexp) - (ledger-post-align-postings))))) + (if ledger-post-auto-adjust-postings + (save-excursion + (goto-char beg) + (when (<= end (line-end-position)) + (goto-char (line-beginning-position)) + (if (looking-at ledger-post-line-regexp) + (ledger-post-align-postings)))))) (defun ledger-post-edit-amount () "Call 'calc-mode' and push the amount in the posting to the top of stack." -- cgit v1.2.3 From 8f4b0e89627b082f9c5d4bd2b506661aab732b0b Mon Sep 17 00:00:00 2001 From: Craig Earls Date: Fri, 8 Mar 2013 00:08:25 -0500 Subject: Added Ledger error handling. No more lisp backtraces! --- lisp/ldg-exec.el | 83 +++++++++++++++++++++++++++++++-------------------- lisp/ldg-reconcile.el | 53 ++++++++++++++++---------------- 2 files changed, 78 insertions(+), 58 deletions(-) diff --git a/lisp/ldg-exec.el b/lisp/ldg-exec.el index d62fd419..46775914 100644 --- a/lisp/ldg-exec.el +++ b/lisp/ldg-exec.el @@ -40,30 +40,48 @@ :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) + (make-frame) + (fit-frame) + (view-mode) + (toggle-read-only))) + +(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 + 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))) - outbuf))) - -(defun ledger-exec-read (&optional input-buffer &rest args) - "Run ledger from option INPUT-BUFFER using ARGS, return a list structure of the ledger Emacs output." - (with-current-buffer - (apply #'ledger-exec-ledger input-buffer nil "emacs" args) - (goto-char (point-min)) - (prog1 - (read (current-buffer)) - (kill-buffer (current-buffer))))) + (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-exec-read (&optional input-buffer &rest args) +;; "Run ledger from option INPUT-BUFFER using ARGS, return a list structure of the ledger Emacs output." +;; (with-current-buffer +;; (apply #'ledger-exec-ledger input-buffer nil "emacs" args) +;; (goto-char (point-min)) +;; (prog1 +;; (read (current-buffer)) +;; (kill-buffer (current-buffer))))) (defun ledger-version-greater-p (needed) "Verify the ledger binary is usable for `ledger-mode' (version greater than NEEDED)." @@ -71,17 +89,18 @@ (version-strings '()) (version-number)) (with-temp-buffer - (ledger-exec-ledger buffer (current-buffer) "--version") - (goto-char (point-min)) - (delete-horizontal-space) - (setq version-strings (split-string - (buffer-substring-no-properties (point) - (+ (point) 12)))) - (if (and (string-match (regexp-quote "Ledger") (car version-strings)) - (or (string= needed (car (cdr version-strings))) - (string< needed (car (cdr version-strings))))) - t - nil)))) + (if (ledger-exec-ledger (current-buffer) (current-buffer) "--version") + (progn + (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 (car (cdr version-strings))) + (string< needed (car (cdr version-strings))))) + t + nil)))))) (defun ledger-check-version () "Verify that ledger works and is modern enough." diff --git a/lisp/ldg-reconcile.el b/lisp/ldg-reconcile.el index 6ede6b51..9f1a220c 100644 --- a/lisp/ldg-reconcile.el +++ b/lisp/ldg-reconcile.el @@ -74,28 +74,25 @@ reconcile-finish will mark all pending posting cleared." ;; 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. - (ledger-exec-ledger buffer (current-buffer) - "balance" "--limit" "cleared or pending" "--empty" - "--format" "%(display_total)" account) - (setq val - (ledger-split-commodity-string - (buffer-substring-no-properties (point-min) (point-max))))))) + (if (ledger-exec-ledger buffer (current-buffer) + "balance" "--limit" "cleared or pending" "--empty" + "--format" "%(display_total)" account) + (setq val + (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)) - (target-delta (if ledger-target - (-commodity ledger-target pending) - nil))) - - (if target-delta - (message "Pending balance: %s, Difference from target: %s" - (ledger-commodity-to-string pending) - (ledger-commodity-to-string target-delta)) - (message "Pending balance: %s" - (ledger-commodity-to-string pending))))) + (let* ((pending (ledger-reconcile-get-cleared-or-pending-balance))) + (if 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)))))) @@ -276,16 +273,18 @@ POSTING is used in `ledger-clear-whole-transactions' is nil." "Get the uncleared transactions in the account and display them in the *Reconcile* buffer." (let* ((buf ledger-buf) (account ledger-acct) + (ledger-success nil) (xacts (with-temp-buffer - (ledger-exec-ledger buf (current-buffer) - "--uncleared" "--real" "emacs" account) - (goto-char (point-min)) - (unless (eobp) - (unless (looking-at "(") - (error (concat "ledger-do-reconcile: " (buffer-string)))) - (read (current-buffer)))))) ;current-buffer is the *temp* created above - (if (> (length xacts) 0) + (if (ledger-exec-ledger buf (current-buffer) + "--uncleared" "--real" "emacs" account) + (progn + (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)) (progn (dolist (xact xacts) (dolist (posting (nthcdr 5 xact)) @@ -310,7 +309,9 @@ POSTING is used in `ledger-clear-whole-transactions' is nil." 'where where)))) )) (goto-char (point-max)) (delete-char -1)) ;gets rid of the extra line feed at the bottom of the list - (insert (concat "There are no uncleared entries for " account))) + (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) -- cgit v1.2.3 From a875940a93848d4b18b5bed45049edc901ad07a2 Mon Sep 17 00:00:00 2001 From: Johann Klähn Date: Fri, 8 Mar 2013 21:45:56 +0100 Subject: fix ledger xml output, remove ledger json command As the format used by property trees to represent valid JSON and that for valid XML is too different and given that there are more requests for valid XML output I decided to pursue a quick fix and remove the json command in favor of a working xml command. See bug #782, #909, recent discussion on mailing list. JSON support is postponed until I or someone else finds time to work on this or the python bindings are more stable. --- src/account.cc | 19 +++++++------------ src/amount.cc | 8 +++----- src/amount.h | 2 +- src/annotate.cc | 16 +++++----------- src/balance.cc | 6 ++---- src/commodity.cc | 6 ++---- src/item.cc | 9 ++++----- src/mask.h | 2 +- src/post.cc | 43 +++++++++++++++---------------------------- src/ptree.cc | 15 +++++++-------- src/ptree.h | 3 +-- src/report.cc | 5 ----- src/system.hh.in | 1 - src/times.h | 16 ++++------------ src/value.cc | 20 ++++++++++---------- src/xact.cc | 18 ++++++------------ 16 files changed, 68 insertions(+), 121 deletions(-) diff --git a/src/account.cc b/src/account.cc index 7dcd5faa..c3fc80f1 100644 --- a/src/account.cc +++ b/src/account.cc @@ -692,12 +692,10 @@ void account_t::xdata_t::details_t::update(post_t& post, } } -void put_account(property_tree::ptree& pt, const account_t& acct, +void put_account(property_tree::ptree& st, const account_t& acct, function pred) { if (pred(acct)) { - property_tree::ptree& st(pt.put("account", "")); - std::ostringstream buf; buf.width(sizeof(unsigned long) * 2); buf.fill('0'); @@ -709,18 +707,15 @@ void put_account(property_tree::ptree& pt, const account_t& acct, st.put("fullname", acct.fullname()); value_t total = acct.amount(); - if (! total.is_null()) { - property_tree::ptree& t(st.put("account-amount", "")); - put_value(t, total); - } + if (! total.is_null()) + put_value(st.put("account-amount", ""), total); + total = acct.total(); - if (! total.is_null()) { - property_tree::ptree& t(st.put("account-total", "")); - put_value(t, total); - } + if (! total.is_null()) + put_value(st.put("account-total", ""), total); foreach (const accounts_map::value_type& pair, acct.accounts) - put_account(st, *pair.second, pred); + put_account(st.add("account", ""), *pair.second, pred); } } diff --git a/src/amount.cc b/src/amount.cc index 88f2d124..55cbabeb 100644 --- a/src/amount.cc +++ b/src/amount.cc @@ -1320,13 +1320,11 @@ bool amount_t::valid() const return true; } -void put_amount(property_tree::ptree& pt, const amount_t& amt, - bool wrap, bool commodity_details) +void put_amount(property_tree::ptree& st, const amount_t& amt, + bool commodity_details) { - property_tree::ptree& st(wrap ? pt.put("amount", "") : pt); - if (amt.has_commodity()) - put_commodity(st, amt.commodity(), commodity_details); + put_commodity(st.put("commodity", ""), amt.commodity(), commodity_details); st.put("quantity", amt.quantity_string()); } diff --git a/src/amount.h b/src/amount.h index b70058ff..938d4b7b 100644 --- a/src/amount.h +++ b/src/amount.h @@ -793,7 +793,7 @@ inline std::istream& operator>>(std::istream& in, amount_t& amt) { } void put_amount(property_tree::ptree& pt, const amount_t& amt, - bool wrap = true, bool commodity_details = false); + bool commodity_details = false); } // namespace ledger diff --git a/src/annotate.cc b/src/annotate.cc index 12016868..8816a89c 100644 --- a/src/annotate.cc +++ b/src/annotate.cc @@ -216,19 +216,13 @@ void annotation_t::print(std::ostream& out, bool keep_base, out << " ((" << *value_expr << "))"; } -void put_annotation(property_tree::ptree& pt, const annotation_t& details) +void put_annotation(property_tree::ptree& st, const annotation_t& details) { - property_tree::ptree& st(pt.put("annotation", "")); + if (details.price) + put_amount(st.put("price", ""), *details.price); - if (details.price) { - property_tree::ptree& t(st.put("price", "")); - put_amount(t, *details.price, false); - } - - if (details.date) { - property_tree::ptree& t(st.put("date", "")); - put_date(t, *details.date, false); - } + if (details.date) + put_date(st.put("date", ""), *details.date); if (details.tag) st.put("tag", *details.tag); diff --git a/src/balance.cc b/src/balance.cc index f86d6561..b702cb7b 100644 --- a/src/balance.cc +++ b/src/balance.cc @@ -336,12 +336,10 @@ void balance_t::print(std::ostream& out, amount_printer.close(); } -void put_balance(property_tree::ptree& pt, const balance_t& bal) +void put_balance(property_tree::ptree& st, const balance_t& bal) { - property_tree::ptree& st(pt.put("balance", "")); - foreach (const balance_t::amounts_map::value_type& pair, bal.amounts) - put_amount(st, pair.second); + put_amount(st.add("amount", ""), pair.second); } } // namespace ledger diff --git a/src/commodity.cc b/src/commodity.cc index c7a893f1..535b31c9 100644 --- a/src/commodity.cc +++ b/src/commodity.cc @@ -497,11 +497,9 @@ bool commodity_t::compare_by_commodity::operator()(const amount_t * left, } } -void put_commodity(property_tree::ptree& pt, const commodity_t& comm, +void put_commodity(property_tree::ptree& st, const commodity_t& comm, bool commodity_details) { - property_tree::ptree& st(pt.put("commodity", "")); - std::string flags; if (! (comm.has_flags(COMMODITY_STYLE_SUFFIXED))) flags += 'P'; if (comm.has_flags(COMMODITY_STYLE_SEPARATED)) flags += 'S'; @@ -512,7 +510,7 @@ void put_commodity(property_tree::ptree& pt, const commodity_t& comm, st.put("symbol", comm.symbol()); if (commodity_details && comm.has_annotation()) - put_annotation(st, as_annotated_commodity(comm).details); + put_annotation(st.put("annotation", ""), as_annotated_commodity(comm).details); } } // namespace ledger diff --git a/src/item.cc b/src/item.cc index 896589e9..a29a3fd3 100644 --- a/src/item.cc +++ b/src/item.cc @@ -600,16 +600,15 @@ string item_context(const item_t& item, const string& desc) return out.str(); } -void put_metadata(property_tree::ptree& pt, const item_t::string_map& metadata) +void put_metadata(property_tree::ptree& st, const item_t::string_map& metadata) { - property_tree::ptree& st(pt.put("metadata", "")); foreach (const item_t::string_map::value_type& pair, metadata) { if (pair.second.first) { - property_tree::ptree& vt(st.put("pair", "")); - vt.put("key", pair.first); + property_tree::ptree& vt(st.add("value", "")); + vt.put(".key", pair.first); put_value(vt, *pair.second.first); } else { - st.put("tag", pair.first); + st.add("tag", pair.first); } } } diff --git a/src/mask.h b/src/mask.h index d46b3349..877a0011 100644 --- a/src/mask.h +++ b/src/mask.h @@ -151,7 +151,7 @@ inline std::ostream& operator<<(std::ostream& out, const mask_t& mask) { } inline void put_mask(property_tree::ptree& pt, const mask_t& mask) { - pt.put("mask", mask.str()); + pt.put_value(mask.str()); } } // namespace ledger diff --git a/src/post.cc b/src/post.cc index c7435aec..1a24429b 100644 --- a/src/post.cc +++ b/src/post.cc @@ -696,10 +696,8 @@ void extend_post(post_t& post, journal_t& journal) } } -void put_post(property_tree::ptree& pt, const post_t& post) +void put_post(property_tree::ptree& st, const post_t& post) { - property_tree::ptree& st(pt.put("posting", "")); - if (post.state() == item_t::CLEARED) st.put(".state", "cleared"); else if (post.state() == item_t::PENDING) @@ -710,14 +708,10 @@ void put_post(property_tree::ptree& pt, const post_t& post) if (post.has_flags(ITEM_GENERATED)) st.put(".generated", "true"); - if (post._date) { - property_tree::ptree& t(st.put("date", "")); - put_date(t, *post._date, false); - } - if (post._date_aux) { - property_tree::ptree& t(st.put("aux-date", "")); - put_date(t, *post._date_aux, false); - } + if (post._date) + put_date(st.put("date", ""), *post._date); + if (post._date_aux) + put_date(st.put("aux-date", ""), *post._date_aux); if (post.account) { property_tree::ptree& t(st.put("account", "")); @@ -736,34 +730,27 @@ void put_post(property_tree::ptree& pt, const post_t& post) if (post.has_xdata() && post.xdata().has_flags(POST_EXT_COMPOUND)) put_value(t, post.xdata().compound_value); else - put_amount(t, post.amount); + put_amount(t.put("amount", ""), post.amount); } - if (post.cost) { - property_tree::ptree& t(st.put("cost", "")); - put_amount(t, *post.cost, false); - } + if (post.cost) + put_amount(st.put("cost", ""), *post.cost); if (post.assigned_amount) { - if (post.has_flags(POST_CALCULATED)) { - property_tree::ptree& t(st.put("balance-assertion", "")); - put_amount(t, *post.assigned_amount, false); - } else { - property_tree::ptree& t(st.put("balance-assignment", "")); - put_amount(t, *post.assigned_amount, false); - } + if (post.has_flags(POST_CALCULATED)) + put_amount(st.put("balance-assertion", ""), *post.assigned_amount); + else + put_amount(st.put("balance-assignment", ""), *post.assigned_amount); } if (post.note) st.put("note", *post.note); if (post.metadata) - put_metadata(st, *post.metadata); + put_metadata(st.put("metadata", ""), *post.metadata); - if (post.xdata_ && ! post.xdata_->total.is_null()) { - property_tree::ptree& t(st.put("total", "")); - put_value(t, post.xdata_->total); - } + if (post.xdata_ && ! post.xdata_->total.is_null()) + put_value(st.put("total", ""), post.xdata_->total); } } // namespace ledger diff --git a/src/ptree.cc b/src/ptree.cc index 1e271465..1d2d4b26 100644 --- a/src/ptree.cc +++ b/src/ptree.cc @@ -61,28 +61,27 @@ void format_ptree::flush() property_tree::ptree& ct(pt.put("ledger.commodities", "")); foreach (const commodities_pair& pair, commodities) - put_commodity(ct, *pair.second, true); + put_commodity(ct.add("commodity", ""), *pair.second, true); property_tree::ptree& at(pt.put("ledger.accounts", "")); - put_account(at, *report.session.journal->master, account_visited_p); + put_account(at.add("account", ""), *report.session.journal->master, account_visited_p); property_tree::ptree& tt(pt.put("ledger.transactions", "")); foreach (const xact_t * xact, transactions) { - put_xact(tt, *xact); + property_tree::ptree& t(tt.add("transaction", "")); + put_xact(t, *xact); - property_tree::ptree& post_tree(tt.put("postings", "")); + property_tree::ptree& post_tree(t.put("postings", "")); foreach (const post_t * post, xact->posts) if (post->has_xdata() && post->xdata().has_flags(POST_EXT_VISITED)) - put_post(post_tree, *post); + put_post(post_tree.add("posting", ""), *post); } switch (format) { case FORMAT_XML: property_tree::write_xml(out, pt); - break; - case FORMAT_JSON: - property_tree::write_json(out, pt); + out << std::endl; break; } } diff --git a/src/ptree.h b/src/ptree.h index ac9e1060..154c8837 100644 --- a/src/ptree.h +++ b/src/ptree.h @@ -75,8 +75,7 @@ protected: public: enum format_t { - FORMAT_XML, - FORMAT_JSON + FORMAT_XML } format; format_ptree(report_t& _report, format_t _format = FORMAT_XML) diff --git a/src/report.cc b/src/report.cc index 8bb38fb6..29077f10 100644 --- a/src/report.cc +++ b/src/report.cc @@ -1628,11 +1628,6 @@ expr_t::ptr_op_t report_t::lookup(const symbol_t::kind_t kind, } break; - case 'j': - if (is_eq(p, "json")) - return POSTS_REPORTER(new format_ptree(*this, - format_ptree::FORMAT_JSON)); - break; case 'l': if (is_eq(p, "lisp")) return POSTS_REPORTER(new format_emacs_posts(output_stream)); diff --git a/src/system.hh.in b/src/system.hh.in index 08a45a15..ff7ea75b 100644 --- a/src/system.hh.in +++ b/src/system.hh.in @@ -204,7 +204,6 @@ typedef std::ostream::pos_type ostream_pos_type; #include #include -#include #include #include diff --git a/src/times.h b/src/times.h index ae4e4c75..4b89cc0c 100644 --- a/src/times.h +++ b/src/times.h @@ -111,20 +111,12 @@ std::string format_date(const date_t& when, void set_date_format(const char * format); void set_input_date_format(const char * format); -inline void put_datetime(property_tree::ptree& pt, const datetime_t& when, - bool wrap = true) { - if (wrap) - pt.put("datetime", format_datetime(when, FMT_WRITTEN)); - else - pt.put_value(format_datetime(when, FMT_WRITTEN)); +inline void put_datetime(property_tree::ptree& pt, const datetime_t& when) { + pt.put_value(format_datetime(when, FMT_WRITTEN)); } -inline void put_date(property_tree::ptree& pt, const date_t& when, - bool wrap = true) { - if (wrap) - pt.put("date", format_date(when, FMT_WRITTEN)); - else - pt.put_value(format_date(when, FMT_WRITTEN)); +inline void put_date(property_tree::ptree& pt, const date_t& when) { + pt.put_value(format_date(when, FMT_WRITTEN)); } struct date_traits_t diff --git a/src/value.cc b/src/value.cc index e8afac50..98e48c2f 100644 --- a/src/value.cc +++ b/src/value.cc @@ -2062,35 +2062,35 @@ void put_value(property_tree::ptree& pt, const value_t& value) { switch (value.type()) { case value_t::VOID: - pt.put("void", ""); + pt.add("void", ""); break; case value_t::BOOLEAN: - pt.put("bool", value.as_boolean() ? "true" : "false"); + pt.add("bool", value.as_boolean() ? "true" : "false"); break; case value_t::INTEGER: - pt.put("int", value.to_string()); + pt.add("int", value.to_string()); break; case value_t::AMOUNT: - put_amount(pt, value.as_amount()); + put_amount(pt.add("amount", ""), value.as_amount()); break; case value_t::BALANCE: - put_balance(pt, value.as_balance()); + put_balance(pt.add("balance", ""), value.as_balance()); break; case value_t::DATETIME: - put_datetime(pt, value.as_datetime()); + put_datetime(pt.add("datetime", ""), value.as_datetime()); break; case value_t::DATE: - put_date(pt, value.as_date()); + put_date(pt.add("date", ""), value.as_date()); break; case value_t::STRING: - pt.put("string", value.as_string()); + pt.add("string", value.as_string()); break; case value_t::MASK: - put_mask(pt, value.as_mask()); + put_mask(pt.add("mask", ""), value.as_mask()); break; case value_t::SEQUENCE: { - property_tree::ptree& st(pt.put("sequence", "")); + property_tree::ptree& st(pt.add("sequence", "")); foreach (const value_t& member, value.as_sequence()) put_value(st, member); break; diff --git a/src/xact.cc b/src/xact.cc index d33520b4..8aecf5d6 100644 --- a/src/xact.cc +++ b/src/xact.cc @@ -847,10 +847,8 @@ void auto_xact_t::extend_xact(xact_base_t& xact, parse_context_t& context) } } -void put_xact(property_tree::ptree& pt, const xact_t& xact) +void put_xact(property_tree::ptree& st, const xact_t& xact) { - property_tree::ptree& st(pt.put("transaction", "")); - if (xact.state() == item_t::CLEARED) st.put(".state", "cleared"); else if (xact.state() == item_t::PENDING) @@ -859,14 +857,10 @@ void put_xact(property_tree::ptree& pt, const xact_t& xact) if (xact.has_flags(ITEM_GENERATED)) st.put(".generated", "true"); - if (xact._date) { - property_tree::ptree& t(st.put("date", "")); - put_date(t, *xact._date, false); - } - if (xact._date_aux) { - property_tree::ptree& t(st.put("aux-date", "")); - put_date(t, *xact._date_aux, false); - } + if (xact._date) + put_date(st.put("date", ""), *xact._date); + if (xact._date_aux) + put_date(st.put("aux-date", ""), *xact._date_aux); if (xact.code) st.put("code", *xact.code); @@ -877,7 +871,7 @@ void put_xact(property_tree::ptree& pt, const xact_t& xact) st.put("note", *xact.note); if (xact.metadata) - put_metadata(st, *xact.metadata); + put_metadata(st.put("metadata", ""), *xact.metadata); } } // namespace ledger -- cgit v1.2.3 From 44823d241f01c9cb2b891283f9e110f15aeebf9a Mon Sep 17 00:00:00 2001 From: Johann Klähn Date: Fri, 8 Mar 2013 23:16:31 +0100 Subject: indent output of ledger xml --- src/ptree.cc | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/ptree.cc b/src/ptree.cc index 1d2d4b26..e7afdcd1 100644 --- a/src/ptree.cc +++ b/src/ptree.cc @@ -80,7 +80,8 @@ void format_ptree::flush() switch (format) { case FORMAT_XML: - property_tree::write_xml(out, pt); + property_tree::xml_writer_settings indented(' ', 2); + property_tree::write_xml(out, pt, indented); out << std::endl; break; } -- cgit v1.2.3 From 404e84cd445d41b3f2fc6cd775babf12864fcefc Mon Sep 17 00:00:00 2001 From: Craig Earls Date: Fri, 8 Mar 2013 18:53:02 -0500 Subject: Removed ldg-register.el functionality all contained in ldg-report --- lisp/CMakeLists.txt | 1 - lisp/ldg-new.el | 4 --- lisp/ldg-register.el | 86 ---------------------------------------------------- 3 files changed, 91 deletions(-) delete mode 100644 lisp/ldg-register.el diff --git a/lisp/CMakeLists.txt b/lisp/CMakeLists.txt index 32a31001..876b3548 100644 --- a/lisp/CMakeLists.txt +++ b/lisp/CMakeLists.txt @@ -10,7 +10,6 @@ set(EMACS_LISP_SOURCES ldg-post.el ldg-reconcile.el ldg-regex.el - ldg-register.el ldg-report.el ldg-sort.el ldg-state.el diff --git a/lisp/ldg-new.el b/lisp/ldg-new.el index f888fd6c..a9c70ff4 100644 --- a/lisp/ldg-new.el +++ b/lisp/ldg-new.el @@ -44,7 +44,6 @@ (require 'ldg-post) (require 'ldg-reconcile) (require 'ldg-regex) -(require 'ldg-register) (require 'ldg-report) (require 'ldg-sort) (require 'ldg-state) @@ -125,9 +124,6 @@ (ledger-dump-variable 'ledger-buffer-tracks-reconcile-buffer) (ledger-dump-variable 'ledger-reconcile-force-window-bottom) (ledger-dump-variable 'ledger-reconcile-toggle-to-pending) - (insert "ldg-register:\n") - (ledger-dump-variable 'ledger-register-date-format) - (ledger-dump-variable 'ledger-register-line-format) (insert "ldg-reports:\n") (ledger-dump-variable 'ledger-reports) (ledger-dump-variable 'ledger-report-format-specifiers) diff --git a/lisp/ldg-register.el b/lisp/ldg-register.el deleted file mode 100644 index bfd8d360..00000000 --- a/lisp/ldg-register.el +++ /dev/null @@ -1,86 +0,0 @@ -;;; ldg-register.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 'ldg-post) -(require 'ldg-state) - -(defgroup ledger-register nil - "" - :group 'ledger) - -(defcustom ledger-register-date-format "%m/%d/%y" - "*The date format used for ledger register reports." - :type 'string - :group 'ledger-register) - -(defcustom ledger-register-line-format "%s %-30.30s %-25.25s %15s\n" - "*The date format used for ledger register reports." - :type 'string - :group 'ledger-register) - -(defface ledger-register-pending-face - '((((background light)) (:weight bold)) - (((background dark)) (:weight bold))) - "Face used to highlight pending entries in a register report." - :group 'ledger-register) - -(defun ledger-register-render (data-buffer posts) - (dolist (post posts) - (let ((index 1)) - (dolist (xact (nthcdr 5 post)) - (let ((beg (point)) - (where - (with-current-buffer data-buffer - (cons - (nth 0 post) - (if ledger-clear-whole-transactions - (save-excursion - (goto-line (nth 1 post)) - (point-marker)) - (save-excursion - (goto-line (nth 0 xact)) - (point-marker))))))) - (insert (format ledger-register-line-format - (format-time-string ledger-register-date-format - (nth 2 post)) - (nth 4 post) (nth 1 xact) (nth 2 xact))) - (if (nth 3 xact) - (set-text-properties beg (1- (point)) - (list 'face 'ledger-register-pending-face - 'where where)) - (set-text-properties beg (1- (point)) - (list 'where where)))) - (setq index (1+ index))))) - (goto-char (point-min))) - -(defun ledger-register-generate (&optional data-buffer &rest args) - (let ((buf (or data-buffer (current-buffer)))) - (with-current-buffer (get-buffer-create "*ledger-register*") - (let ((pos (point)) - (inhibit-read-only t)) - (erase-buffer) - (ledger-register-render buf (apply #'ledger-exec-read buf args)) - (goto-char pos)) - (set-buffer-modified-p nil) - (toggle-read-only t) - (display-buffer (current-buffer) t)))) - -(provide 'ldg-register) -- cgit v1.2.3 From bfe360d4c992caf2e7da09ab058599c0404f1348 Mon Sep 17 00:00:00 2001 From: Craig Earls Date: Fri, 8 Mar 2013 19:33:16 -0500 Subject: Reconcile date configuration is pulled from ledgerrc --- lisp/ldg-reconcile.el | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/lisp/ldg-reconcile.el b/lisp/ldg-reconcile.el index 9f1a220c..802cb3b4 100644 --- a/lisp/ldg-reconcile.el +++ b/lisp/ldg-reconcile.el @@ -285,13 +285,15 @@ POSTING is used in `ledger-clear-whole-transactions' is nil." (if (looking-at "(") (read (current-buffer))))))))) ;current-buffer is the *temp* created above (if (and ledger-success (> (length xacts) 0)) - (progn + (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 "%Y/%m/%d" (nth 2 xact)) + (format-time-string (if date-format + date-format + "%Y/%m/%d") (nth 2 xact)) (if (nth 3 xact) (nth 3 xact) "") -- cgit v1.2.3