diff options
Diffstat (limited to 'lisp')
| -rw-r--r-- | lisp/ldg-complete.el | 190 | ||||
| -rw-r--r-- | lisp/ldg-exec.el | 16 | ||||
| -rw-r--r-- | lisp/ldg-mode.el | 62 | ||||
| -rw-r--r-- | lisp/ldg-post.el | 98 | ||||
| -rw-r--r-- | lisp/ldg-reconcile.el | 76 | ||||
| -rw-r--r-- | lisp/ldg-regex.el | 250 | ||||
| -rw-r--r-- | lisp/ldg-register.el | 54 | ||||
| -rw-r--r-- | lisp/ldg-report.el | 198 | ||||
| -rw-r--r-- | lisp/ldg-state.el | 240 | ||||
| -rw-r--r-- | lisp/ldg-texi.el | 108 | ||||
| -rw-r--r-- | lisp/ldg-xact.el | 12 | ||||
| -rw-r--r-- | lisp/ledger.el | 934 | ||||
| -rw-r--r-- | lisp/timeclock.el | 950 |
13 files changed, 1594 insertions, 1594 deletions
diff --git a/lisp/ldg-complete.el b/lisp/ldg-complete.el index 33a734b3..7b4b0471 100644 --- a/lisp/ldg-complete.el +++ b/lisp/ldg-complete.el @@ -8,46 +8,46 @@ (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)))))) + (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) + (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))) + (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) + 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))))) + (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) @@ -58,99 +58,99 @@ (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))))))))) + "^[ \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)) + (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))) + (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)))) + (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))))) + (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) + 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 (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)))) + (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)))))) + (goto-char (match-end 0)))))) (provide 'ldg-complete) diff --git a/lisp/ldg-exec.el b/lisp/ldg-exec.el index 3881f8e9..bf3565b4 100644 --- a/lisp/ldg-exec.el +++ b/lisp/ldg-exec.el @@ -12,15 +12,15 @@ (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*")))) + (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))) + (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) @@ -28,7 +28,7 @@ (apply #'ledger-exec-ledger input-buffer nil "emacs" args) (goto-char (point-min)) (prog1 - (read (current-buffer)) + (read (current-buffer)) (kill-buffer (current-buffer))))) (provide 'ldg-exec) diff --git a/lisp/ldg-mode.el b/lisp/ldg-mode.el index 973b891c..3e9a9106 100644 --- a/lisp/ldg-mode.el +++ b/lisp/ldg-mode.el @@ -5,13 +5,13 @@ (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-comment-face) + ("^[0-9]+[-/.=][-/.=0-9]+\\s-+\\(([^)]+)\\s-+\\)?\\([^*].+?\\)\\(\\( ;\\| ;\\|$\\)\\)" 2 bold) + ;;("^[0-9]+[-/.=][-/.=0-9]+\\s-+\\(([^)]+)\\s-+\\)?\\([*].+?\\)\\(\\( ;\\| ;\\|$\\)\\)" ;; 2 font-lock-type-face) ("^\\s-+\\([*]\\s-*\\)?\\(\\([[(]\\)?[^*: - ]+?:[^]); - ]+?\\([])]\\)?\\)\\( \\| \\|$\\)" + ]+?:[^]); + ]+?\\([])]\\)?\\)\\( \\| \\|$\\)" 2 font-lock-keyword-face) ("^\\([~=].+\\)" 1 font-lock-function-name-face) ("^\\([A-Za-z]+ .+\\)" 1 font-lock-function-name-face)) @@ -30,7 +30,7 @@ (if (boundp 'font-lock-defaults) (set (make-local-variable 'font-lock-defaults) - '(ledger-font-lock-keywords nil t))) + '(ledger-font-lock-keywords nil t))) (set (make-local-variable 'pcomplete-parse-arguments-function) 'ledger-parse-arguments) @@ -56,58 +56,58 @@ "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))))) + (< (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))))) + (- (+ (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))))))) + (if (ledger-time-less-p moment date) + (throw 'found t))))))) (defun ledger-add-entry (entry-text &optional insert-at-point) (interactive "sEntry: ") (let* ((args (with-temp-buffer - (insert entry-text) - (eshell-parse-arguments (point-min) (point-max)))) - (ledger-buf (current-buffer)) - exit-code) + (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))) + (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))) + (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)) + (re-search-backward "^[0-9]" nil t)) (let ((beg (point))) - (while (not (eolp)) - (forward-line)) - (cons (copy-marker beg) (point-marker)))))) + (while (not (eolp)) + (forward-line)) + (cons (copy-marker beg) (point-marker)))))) (defun ledger-delete-current-entry () (interactive) diff --git a/lisp/ldg-post.el b/lisp/ldg-post.el index 492f9467..da4a2806 100644 --- a/lisp/ldg-post.el +++ b/lisp/ldg-post.el @@ -26,14 +26,14 @@ (defun ledger-post-all-accounts () (let ((origin (point)) - (ledger-post-list nil) - account elements) + (ledger-post-list nil) + account elements) (save-excursion (goto-char (point-min)) (while (re-search-forward ledger-post-line-regexp nil t) - (unless (and (>= origin (match-beginning 0)) - (< origin (match-end 0))) - (add-to-list 'ledger-post-list (ledger-regex-post-line-account)))) + (unless (and (>= origin (match-beginning 0)) + (< origin (match-end 0))) + (add-to-list 'ledger-post-list (ledger-regex-post-line-account)))) (nreverse ledger-post-list)))) (declare-function iswitchb-read-buffer "iswitchb" @@ -47,9 +47,9 @@ to choose from." (cond (ledger-post-use-iswitchb (let* ((iswitchb-use-virtual-buffers nil) - (iswitchb-make-buflist-hook - (lambda () - (setq iswitchb-temp-buflist choices)))) + (iswitchb-make-buflist-hook + (lambda () + (setq iswitchb-temp-buflist choices)))) (iswitchb-read-buffer prompt))) (ledger-post-use-ido (ido-completing-read prompt choices)) @@ -61,26 +61,26 @@ to choose from." (defun ledger-post-pick-account () (interactive) (let* ((account - (ledger-post-completing-read - "Account: " (or ledger-post-current-list - (setq ledger-post-current-list - (ledger-post-all-accounts))))) - (account-len (length account)) - (pos (point))) + (ledger-post-completing-read + "Account: " (or ledger-post-current-list + (setq ledger-post-current-list + (ledger-post-all-accounts))))) + (account-len (length account)) + (pos (point))) (goto-char (line-beginning-position)) (when (re-search-forward ledger-post-line-regexp (line-end-position) t) (let ((existing-len (length (ledger-regex-post-line-account)))) - (goto-char (match-beginning ledger-regex-post-line-group-account)) - (delete-region (match-beginning ledger-regex-post-line-group-account) - (match-end ledger-regex-post-line-group-account)) - (insert account) - (cond - ((> existing-len account-len) - (insert (make-string (- existing-len account-len) ? ))) - ((< existing-len account-len) - (dotimes (n (- account-len existing-len)) - (if (looking-at "[ \t]\\( [ \t]\\|\t\\)") - (delete-char 1))))))) + (goto-char (match-beginning ledger-regex-post-line-group-account)) + (delete-region (match-beginning ledger-regex-post-line-group-account) + (match-end ledger-regex-post-line-group-account)) + (insert account) + (cond + ((> existing-len account-len) + (insert (make-string (- existing-len account-len) ? ))) + ((< existing-len account-len) + (dotimes (n (- account-len existing-len)) + (if (looking-at "[ \t]\\( [ \t]\\|\t\\)") + (delete-char 1))))))) (goto-char pos))) (defun ledger-next-amount (&optional end) @@ -88,7 +88,7 @@ to choose from." (goto-char (match-beginning 0)) (skip-syntax-forward " ") (- (or (match-end 4) - (match-end 3)) (point)))) + (match-end 3)) (point)))) (defun ledger-align-amounts (&optional column) "Align amounts in the current region. @@ -98,24 +98,24 @@ This is done so that the last digit falls in COLUMN, which defaults to 52." (setq column ledger-post-amount-alignment-column)) (save-excursion (let* ((mark-first (< (mark) (point))) - (begin (if mark-first (mark) (point))) - (end (if mark-first (point-marker) (mark-marker))) - offset) + (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)))))) + (let ((col (current-column)) + (target-col (- column offset)) + adjust) + (setq adjust (- target-col col)) + (if (< col target-col) + (insert (make-string (- target-col col) ? )) + (move-to-column target-col) + (if (looking-back " ") + (delete-char (- col target-col)) + (skip-chars-forward "^ \t") + (delete-horizontal-space) + (insert " "))) + (forward-line)))))) (defun ledger-post-align-amount () (interactive) @@ -130,7 +130,7 @@ This is done so that the last digit falls in COLUMN, which defaults to 52." (when (< end (line-end-position)) (goto-char (line-beginning-position)) (if (looking-at ledger-post-line-regexp) - (ledger-post-align-amount))))) + (ledger-post-align-amount))))) (defun ledger-post-edit-amount () (interactive) @@ -139,12 +139,12 @@ This is done so that the last digit falls in COLUMN, which defaults to 52." (goto-char (match-end ledger-regex-post-line-group-account)) (when (re-search-forward "[-.,0-9]+" (line-end-position) t) (let ((val (match-string 0))) - (goto-char (match-beginning 0)) - (delete-region (match-beginning 0) (match-end 0)) - (calc) - (while (string-match "," val) - (setq val (replace-match "" nil nil val))) - (calc-eval val 'push))))) + (goto-char (match-beginning 0)) + (delete-region (match-beginning 0) (match-end 0)) + (calc) + (while (string-match "," val) + (setq val (replace-match "" nil nil val))) + (calc-eval val 'push))))) (defun ledger-post-prev-xact () (interactive) diff --git a/lisp/ldg-reconcile.el b/lisp/ldg-reconcile.el index 3be882f4..baeadc33 100644 --- a/lisp/ldg-reconcile.el +++ b/lisp/ldg-reconcile.el @@ -5,41 +5,41 @@ (defun ledger-display-balance () (let ((buffer ledger-buf) - (account ledger-acct)) + (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)))))))) + (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) + (account ledger-acct) + (inhibit-read-only t) + cleared) (when (or (equal (car where) "<stdin>") (equal (car where) "/dev/stdin")) (with-current-buffer ledger-buf - (goto-char (cdr where)) - (setq cleared (ledger-toggle-current 'pending))) + (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)))) + (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)))) + (line (count-lines (point-min) (point)))) (erase-buffer) (ledger-do-reconcile) (set-buffer-modified-p t) @@ -49,9 +49,9 @@ (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))))) + (with-current-buffer buf + (ledger-reconcile-refresh) + (set-buffer-modified-p nil))))) (defun ledger-reconcile-add () (interactive) @@ -64,12 +64,12 @@ (let ((where (get-text-property (point) 'where))) (when (or (equal (car where) "<stdin>") (equal (car where) "/dev/stdin")) (with-current-buffer ledger-buf - (goto-char (cdr where)) - (ledger-delete-current-entry)) + (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))))) + (goto-char (line-beginning-position)) + (delete-region (point) (1+ (line-end-position))) + (set-buffer-modified-p t))))) (defun ledger-reconcile-visit () (interactive) @@ -95,12 +95,12 @@ (goto-char (point-min)) (while (not (eobp)) (let ((where (get-text-property (point) 'where)) - (face (get-text-property (point) 'face))) - (if (and (eq face 'bold) - (or (equal (car where) "<stdin>") (equal (car where) "/dev/stdin"))) - (with-current-buffer ledger-buf - (goto-char (cdr where)) - (ledger-toggle-current 'cleared)))) + (face (get-text-property (point) 'face))) + (if (and (eq face 'bold) + (or (equal (car where) "<stdin>") (equal (car where) "/dev/stdin"))) + (with-current-buffer ledger-buf + (goto-char (cdr where)) + (ledger-toggle-current 'cleared)))) (forward-line 1))) (ledger-reconcile-save)) @@ -110,12 +110,12 @@ (defun ledger-reconcile (account) (interactive "sAccount to reconcile: ") (let ((buf (current-buffer)) - (rbuf (get-buffer "*Reconcile*"))) + (rbuf (get-buffer "*Reconcile*"))) (if rbuf - (kill-buffer rbuf)) + (kill-buffer rbuf)) (add-hook 'after-save-hook 'ledger-reconcile-refresh-after-save) (with-current-buffer - (pop-to-buffer (get-buffer-create "*Reconcile*")) + (pop-to-buffer (get-buffer-create "*Reconcile*")) (ledger-reconcile-mode) (set (make-local-variable 'ledger-buf) buf) (set (make-local-variable 'ledger-acct) account) diff --git a/lisp/ldg-regex.el b/lisp/ldg-regex.el index 93ef6b09..1c6b8f06 100644 --- a/lisp/ldg-regex.el +++ b/lisp/ldg-regex.el @@ -6,112 +6,112 @@ (defmacro ledger-define-regexp (name regex docs &rest args) "Simplify the creation of a Ledger regex and helper functions." (let ((defs - (list - `(defconst - ,(intern (concat "ledger-" (symbol-name name) "-regexp")) - ,(eval regex)))) - (addend 0) last-group) + (list + `(defconst + ,(intern (concat "ledger-" (symbol-name name) "-regexp")) + ,(eval regex)))) + (addend 0) last-group) (if (null args) - (progn - (nconc - defs - (list - `(defconst - ,(intern - (concat "ledger-regex-" (symbol-name name) "-group")) - 1))) - (nconc - defs - (list - `(defconst - ,(intern (concat "ledger-regex-" (symbol-name name) - "-group--count")) - 1))) - (nconc - defs - (list - `(defmacro - ,(intern (concat "ledger-regex-" (symbol-name name))) - (&optional string) - ,(format "Return the match string for the %s" name) - (match-string - ,(intern (concat "ledger-regex-" (symbol-name name) - "-group")) - string))))) + (progn + (nconc + defs + (list + `(defconst + ,(intern + (concat "ledger-regex-" (symbol-name name) "-group")) + 1))) + (nconc + defs + (list + `(defconst + ,(intern (concat "ledger-regex-" (symbol-name name) + "-group--count")) + 1))) + (nconc + defs + (list + `(defmacro + ,(intern (concat "ledger-regex-" (symbol-name name))) + (&optional string) + ,(format "Return the match string for the %s" name) + (match-string + ,(intern (concat "ledger-regex-" (symbol-name name) + "-group")) + string))))) (dolist (arg args) - (let (var grouping target) - (if (symbolp arg) - (setq var arg target arg) - (assert (listp arg)) - (if (= 2 (length arg)) - (setq var (car arg) - target (cadr arg)) - (setq var (car arg) - grouping (cadr arg) - target (caddr arg)))) - - (if (and last-group - (not (eq last-group (or grouping target)))) - (incf addend - (symbol-value - (intern-soft (concat "ledger-regex-" - (symbol-name last-group) - "-group--count"))))) - (nconc - defs - (list - `(defconst - ,(intern (concat "ledger-regex-" (symbol-name name) - "-group-" (symbol-name var))) - ,(+ addend - (symbol-value - (intern-soft - (if grouping - (concat "ledger-regex-" (symbol-name grouping) - "-group-" (symbol-name target)) - (concat "ledger-regex-" (symbol-name target) - "-group")))))))) - (nconc - defs - (list - `(defmacro - ,(intern (concat "ledger-regex-" (symbol-name name) - "-" (symbol-name var))) - (&optional string) - ,(format "Return the sub-group match for the %s %s." - name var) - (match-string - ,(intern (concat "ledger-regex-" (symbol-name name) - "-group-" (symbol-name var))) - string)))) - - (setq last-group (or grouping target)))) + (let (var grouping target) + (if (symbolp arg) + (setq var arg target arg) + (assert (listp arg)) + (if (= 2 (length arg)) + (setq var (car arg) + target (cadr arg)) + (setq var (car arg) + grouping (cadr arg) + target (caddr arg)))) + + (if (and last-group + (not (eq last-group (or grouping target)))) + (incf addend + (symbol-value + (intern-soft (concat "ledger-regex-" + (symbol-name last-group) + "-group--count"))))) + (nconc + defs + (list + `(defconst + ,(intern (concat "ledger-regex-" (symbol-name name) + "-group-" (symbol-name var))) + ,(+ addend + (symbol-value + (intern-soft + (if grouping + (concat "ledger-regex-" (symbol-name grouping) + "-group-" (symbol-name target)) + (concat "ledger-regex-" (symbol-name target) + "-group")))))))) + (nconc + defs + (list + `(defmacro + ,(intern (concat "ledger-regex-" (symbol-name name) + "-" (symbol-name var))) + (&optional string) + ,(format "Return the sub-group match for the %s %s." + name var) + (match-string + ,(intern (concat "ledger-regex-" (symbol-name name) + "-group-" (symbol-name var))) + string)))) + + (setq last-group (or grouping target)))) (nconc defs - (list - `(defconst ,(intern (concat "ledger-regex-" (symbol-name name) - "-group--count")) - ,(length args))))) + (list + `(defconst ,(intern (concat "ledger-regex-" (symbol-name name) + "-group--count")) + ,(length args))))) (cons 'progn defs))) (put 'ledger-define-regexp 'lisp-indent-function 1) (ledger-define-regexp date - (let ((sep '(or ?- (any ?. ?/)))) ; can't do (any ?- ?. ?/) due to bug + (let ((sep '(or ?- (any ?. ?/)))) ; can't do (any ?- ?. ?/) due to bug (rx (group - (and (? (= 4 num) - (eval sep)) - (and num (? num)) - (eval sep) - (and num (? num)))))) + (and (? (= 4 num) + (eval sep)) + (and num (? num)) + (eval sep) + (and num (? num)))))) "Match a single date, in its 'written' form.") (ledger-define-regexp full-date (macroexpand `(rx (and (regexp ,ledger-date-regexp) - (? (and ?= (regexp ,ledger-date-regexp)))))) + (? (and ?= (regexp ,ledger-date-regexp)))))) "Match a compound date, of the form ACTUAL=EFFECTIVE" (actual date) (effective date)) @@ -126,7 +126,7 @@ (ledger-define-regexp long-space (rx (and (*? blank) - (or (and ? (or ? ?\t)) ?\t))) + (or (and ? (or ? ?\t)) ?\t))) "Match a \"long space\".") (ledger-define-regexp note @@ -136,24 +136,24 @@ (ledger-define-regexp end-note (macroexpand `(rx (and (regexp ,ledger-long-space-regexp) ?\; - (regexp ,ledger-note-regexp)))) + (regexp ,ledger-note-regexp)))) "") (ledger-define-regexp full-note (macroexpand `(rx (and line-start (+ blank) - ?\; (regexp ,ledger-note-regexp)))) + ?\; (regexp ,ledger-note-regexp)))) "") (ledger-define-regexp xact-line (macroexpand `(rx (and line-start - (regexp ,ledger-full-date-regexp) - (? (and (+ blank) (regexp ,ledger-state-regexp))) - (? (and (+ blank) (regexp ,ledger-code-regexp))) - (+ blank) (+? nonl) - (? (regexp ,ledger-end-note-regexp)) - line-end))) + (regexp ,ledger-full-date-regexp) + (? (and (+ blank) (regexp ,ledger-state-regexp))) + (? (and (+ blank) (regexp ,ledger-code-regexp))) + (+ blank) (+? nonl) + (? (regexp ,ledger-end-note-regexp)) + line-end))) "Match a transaction's first line (and optional notes)." (actual-date full-date actual) (effective-date full-date effective) @@ -172,8 +172,8 @@ (ledger-define-regexp full-account (macroexpand `(rx (and (regexp ,ledger-account-kind-regexp) - (regexp ,ledger-account-regexp) - (? (any ?\] ?\)))))) + (regexp ,ledger-account-regexp) + (? (any ?\] ?\)))))) "" (kind account-kind) (name account)) @@ -181,50 +181,50 @@ (ledger-define-regexp commodity (rx (group (or (and ?\" (+ (not (any ?\"))) ?\") - (not (any blank ?\n - digit - ?- ?\[ ?\] - ?. ?, ?\; ?+ ?* ?/ ?^ ?? ?: ?& ?| ?! ?= - ?\< ?\> ?\{ ?\} ?\( ?\) ?@))))) + (not (any blank ?\n + digit + ?- ?\[ ?\] + ?. ?, ?\; ?+ ?* ?/ ?^ ?? ?: ?& ?| ?! ?= + ?\< ?\> ?\{ ?\} ?\( ?\) ?@))))) "") (ledger-define-regexp amount (rx (group (and (? ?-) - (and (+ digit) - (*? (and (any ?. ?,) (+ digit)))) - (? (and (any ?. ?,) (+ digit)))))) + (and (+ digit) + (*? (and (any ?. ?,) (+ digit)))) + (? (and (any ?. ?,) (+ digit)))))) "") (ledger-define-regexp commoditized-amount (macroexpand `(rx (group - (or (and (regexp ,ledger-commodity-regexp) - (*? blank) - (regexp ,ledger-amount-regexp)) - (and (regexp ,ledger-amount-regexp) - (*? blank) - (regexp ,ledger-commodity-regexp)))))) + (or (and (regexp ,ledger-commodity-regexp) + (*? blank) + (regexp ,ledger-amount-regexp)) + (and (regexp ,ledger-amount-regexp) + (*? blank) + (regexp ,ledger-commodity-regexp)))))) "") (ledger-define-regexp commodity-annotations (macroexpand `(rx (* (+ blank) - (or (and ?\{ (regexp ,ledger-commoditized-amount-regexp) ?\}) - (and ?\[ (regexp ,ledger-date-regexp) ?\]) - (and ?\( (not (any ?\))) ?\)))))) + (or (and ?\{ (regexp ,ledger-commoditized-amount-regexp) ?\}) + (and ?\[ (regexp ,ledger-date-regexp) ?\]) + (and ?\( (not (any ?\))) ?\)))))) "") (ledger-define-regexp cost (macroexpand `(rx (and (or "@" "@@") (+ blank) - (regexp ,ledger-commoditized-amount-regexp)))) + (regexp ,ledger-commoditized-amount-regexp)))) "") (ledger-define-regexp balance-assertion (macroexpand `(rx (and ?= (+ blank) - (regexp ,ledger-commoditized-amount-regexp)))) + (regexp ,ledger-commoditized-amount-regexp)))) "") (ledger-define-regexp full-amount @@ -234,12 +234,12 @@ (ledger-define-regexp post-line (macroexpand `(rx (and line-start (+ blank) - (? (and (regexp ,ledger-state-regexp) (* blank))) - (regexp ,ledger-full-account-regexp) - (? (and (regexp ,ledger-long-space-regexp) - (regexp ,ledger-full-amount-regexp))) - (? (regexp ,ledger-end-note-regexp)) - line-end))) + (? (and (regexp ,ledger-state-regexp) (* blank))) + (regexp ,ledger-full-account-regexp) + (? (and (regexp ,ledger-long-space-regexp) + (regexp ,ledger-full-amount-regexp))) + (? (regexp ,ledger-end-note-regexp)) + line-end))) "" state (account-kind full-account kind) diff --git a/lisp/ldg-register.el b/lisp/ldg-register.el index 02e50de9..7b5c0d0a 100644 --- a/lisp/ldg-register.el +++ b/lisp/ldg-register.el @@ -25,29 +25,29 @@ (dolist (post posts) (let ((index 1)) (dolist (xact (nthcdr 5 post)) - (let ((beg (point)) - (where - (with-current-buffer data-buffer - (cons - (nth 0 post) - (if ledger-clear-whole-entries - (save-excursion - (goto-line (nth 1 post)) - (point-marker)) - (save-excursion - (goto-line (nth 0 xact)) - (point-marker))))))) - (insert (format ledger-register-line-format - (format-time-string ledger-register-date-format - (nth 2 post)) - (nth 4 post) (nth 1 xact) (nth 2 xact))) - (if (nth 3 xact) - (set-text-properties beg (1- (point)) - (list 'face 'ledger-register-pending-face - 'where where)) - (set-text-properties beg (1- (point)) - (list 'where where)))) - (setq index (1+ index))))) + (let ((beg (point)) + (where + (with-current-buffer data-buffer + (cons + (nth 0 post) + (if ledger-clear-whole-entries + (save-excursion + (goto-line (nth 1 post)) + (point-marker)) + (save-excursion + (goto-line (nth 0 xact)) + (point-marker))))))) + (insert (format ledger-register-line-format + (format-time-string ledger-register-date-format + (nth 2 post)) + (nth 4 post) (nth 1 xact) (nth 2 xact))) + (if (nth 3 xact) + (set-text-properties beg (1- (point)) + (list 'face 'ledger-register-pending-face + 'where where)) + (set-text-properties beg (1- (point)) + (list 'where where)))) + (setq index (1+ index))))) (goto-char (point-min)) ) @@ -55,10 +55,10 @@ (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)) + (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)))) diff --git a/lisp/ldg-report.el b/lisp/ldg-report.el index 6fc74f1d..5a668847 100644 --- a/lisp/ldg-report.el +++ b/lisp/ldg-report.el @@ -15,7 +15,7 @@ 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"))) + (string :tag "Command Line"))) :group 'ledger) (defcustom ledger-report-format-specifiers @@ -73,8 +73,8 @@ text that should replace the format specifier." The empty string and unknown names are allowed." (completing-read "Report name: " - ledger-reports nil nil nil - 'ledger-report-name-prompt-history nil)) + 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'. @@ -93,18 +93,18 @@ used to generate the buffer, navigating the buffer, etc." (interactive (progn (when (and (buffer-modified-p) - (y-or-n-p "Buffer modified, save it? ")) + (y-or-n-p "Buffer modified, save it? ")) (save-buffer)) (let ((rname (ledger-report-read-name)) - (edit (not (null current-prefix-arg)))) + (edit (not (null current-prefix-arg)))) (list rname edit)))) (let ((buf (current-buffer)) - (rbuf (get-buffer ledger-report-buffer-name)) - (wcfg (current-window-configuration))) + (rbuf (get-buffer ledger-report-buffer-name)) + (wcfg (current-window-configuration))) (if rbuf - (kill-buffer rbuf)) + (kill-buffer rbuf)) (with-current-buffer - (pop-to-buffer (get-buffer-create ledger-report-buffer-name)) + (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) @@ -137,8 +137,8 @@ If name exists, returns the object naming the report, otherwise returns nil." (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)) + (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 @@ -165,9 +165,9 @@ end of a ledger file which is included in some other file." (defun ledger-read-string-with-default (prompt default) (let ((default-prompt (concat prompt - (if default - (concat " (" default "): ") - ": ")))) + (if default + (concat " (" default "): ") + ": ")))) (read-string default-prompt nil nil default))) (defun ledger-report-payee-format-specifier () @@ -191,26 +191,26 @@ 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))) + (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))))) + (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) @@ -222,18 +222,18 @@ the default." (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)) + (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") + (format "Command: %s\n" cmd) + (make-string (- (window-width) 1) ?=) + "\n") (shell-command cmd t nil)) (defun ledger-report-goto () @@ -241,7 +241,7 @@ the default." (interactive) (let ((rbuf (get-buffer ledger-report-buffer-name))) (if (not rbuf) - (error "There is no ledger report buffer")) + (error "There is no ledger report buffer")) (pop-to-buffer rbuf) (shrink-window-if-larger-than-buffer))) @@ -277,7 +277,7 @@ the default." (let ((name "")) (while (string-empty-p name) (setq name (read-from-minibuffer "Report name: " nil nil nil - 'ledger-report-name-prompt-history))) + 'ledger-report-name-prompt-history))) name)) (defun ledger-report-save () @@ -290,15 +290,15 @@ the default." (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-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))) @@ -333,24 +333,24 @@ the default." 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) + 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)))))))) + (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 () @@ -363,40 +363,40 @@ the fields in the line in a association list." (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))))))) + (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. @@ -406,8 +406,8 @@ specified line, returns nil." (save-excursion (let ((left (forward-line offset))) (if (not (equal left 0)) - nil - (ledger-context-at-point))))) + nil + (ledger-context-at-point))))) (defun ledger-context-line-type (context-info) (nth 0 context-info)) @@ -444,5 +444,5 @@ specified line, returns nil." (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-context-field-value context-info 'payee) + nil)))) diff --git a/lisp/ldg-state.el b/lisp/ldg-state.el index 945d72fe..6a841621 100644 --- a/lisp/ldg-state.el +++ b/lisp/ldg-state.el @@ -6,28 +6,28 @@ (defun ledger-toggle-state (state &optional style) (if (not (null state)) (if (and style (eq style 'cleared)) - 'cleared) + 'cleared) (if (and style (eq style 'pending)) - 'pending + 'pending 'cleared))) (defun ledger-entry-state () (save-excursion (when (or (looking-at "^[0-9]") - (re-search-backward "^[0-9]" nil t)) + (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))))) + ((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))))) + ((looking-at "\\*\\s-*") 'cleared) + (t (ledger-entry-state))))) (defun ledger-toggle-current-transaction (&optional style) "Toggle the cleared status of the transaction under point. @@ -42,129 +42,129 @@ formatting, but doing so causes inline math expressions to be dropped." (interactive) (let ((bounds (ledger-current-entry-bounds)) - clear cleared) + 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))) + (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)))) + (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))))) + (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))))))) + (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))) + (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)) + (save-excursion + (forward-line) + (goto-char (line-beginning-position)) + (while (and (not (eolp)) + (save-excursion + (not (eq 'entry (ledger-thing-at-point))))) + (if (looking-at "\\s-+[*!]") + (ledger-toggle-current-transaction nil)) + (forward-line) + (goto-char (line-beginning-position)))) + (ledger-toggle-current-entry style)) (ledger-toggle-current-transaction style))) (defun ledger-toggle-current-entry (&optional style) @@ -172,18 +172,18 @@ dropped." (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)))) + (re-search-backward "^[0-9]" nil t)) + (skip-chars-forward "0-9./=") + (delete-horizontal-space) + (if (member (char-after) '(?\* ?\!)) + (progn + (delete-char 1) + (if (and style (eq style 'cleared)) + (insert " *"))) + (if (and style (eq style 'pending)) + (insert " ! ") + (insert " * ")) + (setq clear t)))) clear)) (provide 'ldg-state) diff --git a/lisp/ldg-texi.el b/lisp/ldg-texi.el index 982ea0ed..9d5383eb 100644 --- a/lisp/ldg-texi.el +++ b/lisp/ldg-texi.el @@ -5,13 +5,13 @@ (defun ledger-texi-write-test (name command input output &optional category) (let ((buf (current-buffer))) (with-current-buffer (find-file-noselect - (expand-file-name (concat name ".test") category)) + (expand-file-name (concat name ".test") category)) (erase-buffer) (let ((case-fold-search nil)) - (if (string-match "\\$LEDGER\\s-+" command) - (setq command (replace-match "" t t command))) - (if (string-match " -f \\$\\([-a-z]+\\)" command) - (setq command (replace-match "" t t command)))) + (if (string-match "\\$LEDGER\\s-+" command) + (setq command (replace-match "" t t command))) + (if (string-match " -f \\$\\([-a-z]+\\)" command) + (setq command (replace-match "" t t command)))) (insert command ?\n) (insert "<<<" ?\n) (insert input) @@ -21,13 +21,13 @@ (insert "=== 0" ?\n) (save-buffer) (unless (eq buf (current-buffer)) - (kill-buffer (current-buffer)))))) + (kill-buffer (current-buffer)))))) (defun ledger-texi-update-test () (interactive) (let ((details (ledger-texi-test-details)) - (name (file-name-sans-extension - (file-name-nondirectory (buffer-file-name))))) + (name (file-name-sans-extension + (file-name-nondirectory (buffer-file-name))))) (ledger-texi-write-test name (nth 0 details) (nth 1 details) @@ -39,30 +39,30 @@ (defun ledger-texi-test-details () (goto-char (point-min)) (let ((command (buffer-substring (point) (line-end-position))) - input output) + input output) (re-search-forward "^<<<") (let ((input-beg (1+ (match-end 0)))) (re-search-forward "^>>>1") (let ((output-beg (1+ (match-end 0)))) - (setq input (buffer-substring input-beg (match-beginning 0))) - (re-search-forward "^>>>2") - (setq output (buffer-substring output-beg (match-beginning 0))) - (list command input output))))) + (setq input (buffer-substring input-beg (match-beginning 0))) + (re-search-forward "^>>>2") + (setq output (buffer-substring output-beg (match-beginning 0))) + (list command input output))))) (defun ledger-texi-expand-command (command data-file) (if (string-match "\\$LEDGER" command) (replace-match (format "%s -f \"%s\" %s" ledger-path - data-file ledger-normalization-args) t t command) + data-file ledger-normalization-args) t t command) (concat (format "%s -f \"%s\" %s " ledger-path - data-file ledger-normalization-args) command))) + data-file ledger-normalization-args) command))) (defun ledger-texi-invoke-command (command) (with-temp-buffer (shell-command command t (current-buffer)) (if (= (point-min) (point-max)) - (progn - (push-mark nil t) - (message "Command '%s' yielded no result at %d" command (point)) - (ding)) + (progn + (push-mark nil t) + (message "Command '%s' yielded no result at %d" command (point)) + (ding)) (buffer-string)))) (defun ledger-texi-write-test-data (name input) @@ -79,43 +79,43 @@ (goto-char (point-min)) (while (re-search-forward "^@c \\(\\(?:sm\\)?ex\\) \\(\\S-+\\): \\(.*\\)" nil t) (let ((section (match-string 1)) - (example-name (match-string 2)) - (command (match-string 3)) expanded-command - (data-file ledger-sample-doc-path) - input output) - (goto-char (match-end 0)) - (forward-line) - (when (looking-at "@\\(\\(?:small\\)?example\\)") - (let ((beg (point))) - (re-search-forward "^@end \\(\\(?:small\\)?example\\)") - (delete-region beg (1+ (point))))) + (example-name (match-string 2)) + (command (match-string 3)) expanded-command + (data-file ledger-sample-doc-path) + input output) + (goto-char (match-end 0)) + (forward-line) + (when (looking-at "@\\(\\(?:small\\)?example\\)") + (let ((beg (point))) + (re-search-forward "^@end \\(\\(?:small\\)?example\\)") + (delete-region beg (1+ (point))))) - (when (let ((case-fold-search nil)) - (string-match " -f \\$\\([-a-z]+\\)" command)) - (let ((label (match-string 1 command))) - (setq command (replace-match "" t t command)) - (save-excursion - (goto-char (point-min)) - (search-forward (format "@c data: %s" label)) - (re-search-forward "@\\(\\(?:small\\)?example\\)") - (forward-line) - (let ((beg (point))) - (re-search-forward "@end \\(\\(?:small\\)?example\\)") - (setq data-file (ledger-texi-write-test-data - (format "%s.dat" label) - (buffer-substring-no-properties - beg (match-beginning 0)))))))) + (when (let ((case-fold-search nil)) + (string-match " -f \\$\\([-a-z]+\\)" command)) + (let ((label (match-string 1 command))) + (setq command (replace-match "" t t command)) + (save-excursion + (goto-char (point-min)) + (search-forward (format "@c data: %s" label)) + (re-search-forward "@\\(\\(?:small\\)?example\\)") + (forward-line) + (let ((beg (point))) + (re-search-forward "@end \\(\\(?:small\\)?example\\)") + (setq data-file (ledger-texi-write-test-data + (format "%s.dat" label) + (buffer-substring-no-properties + beg (match-beginning 0)))))))) - (let ((section-name (if (string= section "smex") - "smallexample" - "example")) - (output (ledger-texi-invoke-command - (ledger-texi-expand-command command data-file)))) - (insert "@" section-name ?\n output - "@end " section-name ?\n)) + (let ((section-name (if (string= section "smex") + "smallexample" + "example")) + (output (ledger-texi-invoke-command + (ledger-texi-expand-command command data-file)))) + (insert "@" section-name ?\n output + "@end " section-name ?\n)) - ;; Update the regression test associated with this example - (ledger-texi-write-test example-name command input output - "../test/manual"))))) + ;; Update the regression test associated with this example + (ledger-texi-write-test example-name command input output + "../test/manual"))))) (provide 'ldg-texi) diff --git a/lisp/ldg-xact.el b/lisp/ldg-xact.el index 5945632a..e1f165a7 100644 --- a/lisp/ldg-xact.el +++ b/lisp/ldg-xact.el @@ -9,12 +9,12 @@ 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))))) + (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)))))) + (forward-paragraph)))))) diff --git a/lisp/ledger.el b/lisp/ledger.el index 0e2f4b11..25bb485b 100644 --- a/lisp/ledger.el +++ b/lisp/ledger.el @@ -107,7 +107,7 @@ 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"))) + (string :tag "Command Line"))) :group 'ledger) (defcustom ledger-report-format-specifiers @@ -128,13 +128,13 @@ text that should replace the format specifier." (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-comment-face) + ("^[0-9]+[-/.=][-/.=0-9]+\\s-+\\(([^)]+)\\s-+\\)?\\([^*].+?\\)\\(\\( ;\\| ;\\|$\\)\\)" 2 bold) + ;;("^[0-9]+[-/.=][-/.=0-9]+\\s-+\\(([^)]+)\\s-+\\)?\\([*].+?\\)\\(\\( ;\\| ;\\|$\\)\\)" ;; 2 font-lock-type-face) ("^\\s-+\\([*]\\s-*\\)?\\(\\([[(]\\)?[^*: - ]+?:[^]); - ]+?\\([])]\\)?\\)\\( \\| \\|$\\)" + ]+?:[^]); + ]+?\\([])]\\)?\\)\\( \\| \\|$\\)" 2 font-lock-keyword-face) ("^\\([~=].+\\)" 1 font-lock-function-name-face) ("^\\([A-Za-z]+ .+\\)" 1 font-lock-function-name-face)) @@ -155,88 +155,88 @@ 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)))) + (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))))) + (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))))) + (< (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))))) + (- (+ (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))))))) + (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) + (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))) + (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))) + (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)) + (re-search-backward "^[0-9]" nil t)) (let ((beg (point))) - (while (not (eolp)) - (forward-line)) - (cons (copy-marker beg) (point-marker)))))) + (while (not (eolp)) + (forward-line)) + (cons (copy-marker beg) (point-marker)))))) (defun ledger-delete-current-entry () (interactive) @@ -248,18 +248,18 @@ Return the difference in the format of a time value." (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)))) + (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 () @@ -268,28 +268,28 @@ Return the difference in the format of a time value." (defun ledger-toggle-state (state &optional style) (if (not (null state)) (if (and style (eq style 'cleared)) - 'cleared) + 'cleared) (if (and style (eq style 'pending)) - 'pending + 'pending 'cleared))) (defun ledger-entry-state () (save-excursion (when (or (looking-at "^[0-9]") - (re-search-backward "^[0-9]" nil t)) + (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))))) + ((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))))) + ((looking-at "\\*\\s-*") 'cleared) + (t (ledger-entry-state))))) (defun ledger-toggle-current-transaction (&optional style) "Toggle the cleared status of the transaction under point. @@ -304,129 +304,129 @@ formatting, but doing so causes inline math expressions to be dropped." (interactive) (let ((bounds (ledger-current-entry-bounds)) - clear cleared) + 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))) + (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)))) + (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))))) + (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))))))) + (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))) + (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)) + (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) @@ -440,7 +440,7 @@ dropped." (if (boundp 'font-lock-defaults) (set (make-local-variable 'font-lock-defaults) - '(ledger-font-lock-keywords nil t))) + '(ledger-font-lock-keywords nil t))) (set (make-local-variable 'pcomplete-parse-arguments-function) 'ledger-parse-arguments) @@ -475,41 +475,41 @@ dropped." (defun ledger-display-balance () (let ((buffer ledger-buf) - (account ledger-acct)) + (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)))))))) + (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) + (account ledger-acct) + (inhibit-read-only t) + cleared) (when (or (equal (car where) "<stdin>") (equal (car where) "/dev/stdin")) (with-current-buffer ledger-buf - (goto-char (cdr where)) - (setq cleared (ledger-toggle-current 'pending))) + (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)))) + (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)))) + (line (count-lines (point-min) (point)))) (erase-buffer) (ledger-do-reconcile) (set-buffer-modified-p t) @@ -519,9 +519,9 @@ dropped." (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))))) + (with-current-buffer buf + (ledger-reconcile-refresh) + (set-buffer-modified-p nil))))) (defun ledger-reconcile-add () (interactive) @@ -534,12 +534,12 @@ dropped." (let ((where (get-text-property (point) 'where))) (when (or (equal (car where) "<stdin>") (equal (car where) "/dev/stdin")) (with-current-buffer ledger-buf - (goto-char (cdr where)) - (ledger-delete-current-entry)) + (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))))) + (goto-char (line-beginning-position)) + (delete-region (point) (1+ (line-end-position))) + (set-buffer-modified-p t))))) (defun ledger-reconcile-visit () (interactive) @@ -565,53 +565,53 @@ dropped." (goto-char (point-min)) (while (not (eobp)) (let ((where (get-text-property (point) 'where)) - (face (get-text-property (point) 'face))) - (if (and (eq face 'bold) - (or (equal (car where) "<stdin>") (equal (car where) "/dev/stdin"))) - (with-current-buffer ledger-buf - (goto-char (cdr where)) - (ledger-toggle-current 'cleared)))) + (face (get-text-property (point) 'face))) + (if (and (eq face 'bold) + (or (equal (car where) "<stdin>") (equal (car where) "/dev/stdin"))) + (with-current-buffer ledger-buf + (goto-char (cdr where)) + (ledger-toggle-current 'cleared)))) (forward-line 1))) (ledger-reconcile-save)) (defun ledger-do-reconcile () (let* ((buf ledger-buf) - (account ledger-acct) - (items - (with-temp-buffer - (let ((exit-code - (ledger-run-ledger buf "--uncleared" "emacs" account))) - (when (= 0 exit-code) - (goto-char (point-min)) - (unless (eobp) - (unless (looking-at "(") - (error (buffer-string))) - (read (current-buffer)))))))) + (account ledger-acct) + (items + (with-temp-buffer + (let ((exit-code + (ledger-run-ledger buf "--uncleared" "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))))) + (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))) @@ -619,12 +619,12 @@ dropped." (defun ledger-reconcile (account) (interactive "sAccount to reconcile: ") (let ((buf (current-buffer)) - (rbuf (get-buffer "*Reconcile*"))) + (rbuf (get-buffer "*Reconcile*"))) (if rbuf - (kill-buffer rbuf)) + (kill-buffer rbuf)) (add-hook 'after-save-hook 'ledger-reconcile-refresh-after-save) (with-current-buffer - (pop-to-buffer (get-buffer-create "*Reconcile*")) + (pop-to-buffer (get-buffer-create "*Reconcile*")) (ledger-reconcile-mode) (set (make-local-variable 'ledger-buf) buf) (set (make-local-variable 'ledger-acct) account) @@ -681,24 +681,24 @@ dropped." 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) + 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)))))))) + (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 () @@ -711,40 +711,40 @@ the fields in the line in a association list." (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))))))) + (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. @@ -754,8 +754,8 @@ specified line, returns nil." (save-excursion (let ((left (forward-line offset))) (if (not (equal left 0)) - nil - (ledger-context-at-point))))) + nil + (ledger-context-at-point))))) (defun ledger-context-line-type (context-info) (nth 0 context-info)) @@ -792,8 +792,8 @@ specified line, returns nil." (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-context-field-value context-info 'payee) + nil)))) ;; Ledger report mode @@ -832,8 +832,8 @@ specified line, returns nil." The empty string and unknown names are allowed." (completing-read "Report name: " - ledger-reports nil nil nil - 'ledger-report-name-prompt-history nil)) + 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'. @@ -852,18 +852,18 @@ used to generate the buffer, navigating the buffer, etc." (interactive (progn (when (and (buffer-modified-p) - (y-or-n-p "Buffer modified, save it? ")) + (y-or-n-p "Buffer modified, save it? ")) (save-buffer)) (let ((rname (ledger-report-read-name)) - (edit (not (null current-prefix-arg)))) + (edit (not (null current-prefix-arg)))) (list rname edit)))) (let ((buf (current-buffer)) - (rbuf (get-buffer ledger-report-buffer-name)) - (wcfg (current-window-configuration))) + (rbuf (get-buffer ledger-report-buffer-name)) + (wcfg (current-window-configuration))) (if rbuf - (kill-buffer rbuf)) + (kill-buffer rbuf)) (with-current-buffer - (pop-to-buffer (get-buffer-create ledger-report-buffer-name)) + (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) @@ -896,8 +896,8 @@ If name exists, returns the object naming the report, otherwise returns nil." (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)) + (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 @@ -909,9 +909,9 @@ otherwise the current buffer file is used." (defun ledger-read-string-with-default (prompt default) (let ((default-prompt (concat prompt - (if default - (concat " (" default "): ") - ": ")))) + (if default + (concat " (" default "): ") + ": ")))) (read-string default-prompt nil nil default))) (defun ledger-report-payee-format-specifier () @@ -935,26 +935,26 @@ 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))) + (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))))) + (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) @@ -966,18 +966,18 @@ the default." (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)) + (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") + (format "Command: %s\n" cmd) + (make-string (- (window-width) 1) ?=) + "\n") (shell-command cmd t nil)) (defun ledger-report-goto () @@ -985,7 +985,7 @@ the default." (interactive) (let ((rbuf (get-buffer ledger-report-buffer-name))) (if (not rbuf) - (error "There is no ledger report buffer")) + (error "There is no ledger report buffer")) (pop-to-buffer rbuf) (shrink-window-if-larger-than-buffer))) @@ -1021,7 +1021,7 @@ the default." (let ((name "")) (while (string-empty-p name) (setq name (read-from-minibuffer "Report name: " nil nil nil - 'ledger-report-name-prompt-history))) + 'ledger-report-name-prompt-history))) name)) (defun ledger-report-save () @@ -1034,15 +1034,15 @@ the default." (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-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))) @@ -1053,46 +1053,46 @@ the default." (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)))))) + (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) + (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))) + (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) + 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))))) + (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) @@ -1103,100 +1103,100 @@ the default." (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))))))))) + "^[ \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)) + (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))) + (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)))) + (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))))) + (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) + 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 (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)))) + (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)))))) + (goto-char (match-end 0)))))) ;; A sample function for $ users @@ -1205,7 +1205,7 @@ the default." (goto-char (match-beginning 0)) (skip-syntax-forward " ") (- (or (match-end 4) - (match-end 3)) (point)))) + (match-end 3)) (point)))) (defun ledger-align-amounts (&optional column) "Align amounts in the current region. @@ -1215,24 +1215,24 @@ This is done so that the last digit falls in COLUMN, which defaults to 52." (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) + (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)))))) + (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) @@ -1247,14 +1247,14 @@ This is done so that the last digit falls in COLUMN, which defaults to 52." 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))))) + (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)))))) + (forward-paragraph)))))) ;; General helper functions @@ -1269,13 +1269,13 @@ This is done so that the last digit falls in COLUMN, which defaults to 52." (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)))))))) + (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)) diff --git a/lisp/timeclock.el b/lisp/timeclock.el index 03159e94..2cafa8eb 100644 --- a/lisp/timeclock.el +++ b/lisp/timeclock.el @@ -135,10 +135,10 @@ that day has a length that is different from the norm." "*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)) + (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) @@ -160,27 +160,27 @@ 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)) + (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) @@ -281,39 +281,39 @@ display (non-nil means on)." (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)))) + (> (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 \ + (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)))) + (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)) + (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)) + (remove-hook 'display-time-hook + 'timeclock-update-modeline)) (when timeclock-update-timer - (cancel-timer timeclock-update-timer) - (setq timeclock-update-timer nil))) + (cancel-timer timeclock-update-timer) + (setq timeclock-update-timer nil))) (force-mode-line-update) (setq timeclock-modeline-display on-p))) @@ -323,8 +323,8 @@ timeclock information")) "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)))) + (setq timeclock-modeline-display + (timeclock-modeline-display (or value 0)))) :type 'boolean :group 'timeclock :require 'timeclock) @@ -349,34 +349,34 @@ 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 (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)))) + (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)))))) + (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)))) + (and timeclock-get-project-function + (or find-project (interactive-p)) + (funcall timeclock-get-project-function)))) (run-hooks 'timeclock-in-hook))) ;;;###autoload @@ -397,12 +397,12 @@ discover the reason." (timeclock-log (if arg "O" "o") (or reason - (and timeclock-get-reason-function - (or find-reason (interactive-p)) - (funcall timeclock-get-reason-function)))) + (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)))) + (run-hooks 'timeclock-done-hook)))) ;; Should today-only be removed in favour of timeclock-relative? - gm (defsubst timeclock-workday-remaining (&optional today-only) @@ -412,8 +412,8 @@ 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))) + (- (if today-only (cadr discrep) + (car discrep))) 0.0))) ;;;###autoload @@ -424,24 +424,24 @@ 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) + (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))) + (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) + (message status) status))) ;;;###autoload @@ -477,7 +477,7 @@ Returns the new value of `timeclock-discrepancy'." timeclock-discrepancy) (defun timeclock-seconds-to-string (seconds &optional show-seconds - reverse-leader) + 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 @@ -486,14 +486,14 @@ 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)) + (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)))) + (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." @@ -501,7 +501,7 @@ as with time remaining, where negative time really means overtime)." ;;;###autoload (defun timeclock-workday-remaining-string (&optional show-seconds - today-only) + 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. @@ -509,10 +509,10 @@ 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))) + (timeclock-workday-remaining today-only) + show-seconds t))) (if (interactive-p) - (message string) + (message string) string))) (defsubst timeclock-workday-elapsed () @@ -522,7 +522,7 @@ 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) + (nth 2 discrep) 0.0))) ;;;###autoload @@ -532,9 +532,9 @@ 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))) + show-seconds))) (if (interactive-p) - (message string) + (message string) string))) (defsubst timeclock-time-to-seconds (time) @@ -546,8 +546,8 @@ non-nil, the amount returned will be relative to past time worked." (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)))) + (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) @@ -557,15 +557,15 @@ 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))))) + (if discrep + (if today-only + (cadr discrep) + (car discrep)) + 0.0))))) ;;;###autoload (defun timeclock-when-to-leave-string (&optional show-seconds - today-only) + 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 @@ -574,12 +574,12 @@ 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)))) + (string + (if show-seconds + (format-time-string "%-I:%M:%S %p" then) + (format-time-string "%-I:%M %p" then)))) (if (interactive-p) - (message string) + (message string) string))) ;;; Internal Functions: @@ -591,17 +591,17 @@ relative only to the time worked today, and not to past time." "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)) + (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))) + (or timeclock-last-project + (car timeclock-project-list))) (mapcar 'list timeclock-project-list) (or timeclock-last-project (car timeclock-project-list)))) @@ -611,7 +611,7 @@ relative only to the time worked today, and not to past time." (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))) + (mapcar 'list timeclock-reason-list))) (defun timeclock-update-modeline () "Update the `timeclock-mode-string' displayed in the modeline. @@ -619,22 +619,22 @@ 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"))) + (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)))))) + (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))) + (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")))) + (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) @@ -645,24 +645,24 @@ 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")) + (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") + (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-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) @@ -670,21 +670,21 @@ being logged for. Normally only \"in\" events specify a project." (defvar timeclock-moment-regexp (concat "\\([bhioO]\\)\\s-+" - "\\([0-9]+\\)/\\([0-9]+\\)/\\([0-9]+\\)\\s-+" - "\\([0-9]+\\):\\([0-9]+\\):\\([0-9]+\\)[ \t]*" "\\([^\n]*\\)")) + "\\([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)))) + (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. @@ -695,8 +695,8 @@ 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-time-to-seconds + (cadr timeclock-last-event))) timeclock-last-period)) (defsubst timeclock-entry-length (entry) @@ -741,9 +741,9 @@ This is only provided for coherency when used by (let (projects) (while entry-list (let ((project (timeclock-entry-project (car entry-list)))) - (if projects - (add-to-list 'projects project) - (setq projects (list project)))) + (if projects + (add-to-list 'projects project) + (setq projects (list project)))) (setq entry-list (cdr entry-list))) projects)) @@ -805,11 +805,11 @@ This is only provided for coherency when used by (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)))) + (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)) @@ -822,10 +822,10 @@ This is only provided for coherency when used by (defun timeclock-day-list (&optional log-data) (let ((alist (timeclock-day-alist log-data)) - day-list) + day-list) (while alist (setq day-list (cons (cdar alist) day-list) - alist (cdr alist))) + alist (cdr alist))) day-list)) (defsubst timeclock-project-alist (&optional log-data) @@ -963,73 +963,73 @@ lists: 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) + (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)))) + (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)) + (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)))) + (setcar (cdr log-data) + (cons (cons last-date day) + (cadr log-data)))) log-data))) (defun timeclock-find-discrep () @@ -1050,82 +1050,82 @@ discrepancy, today's discrepancy, and the time worked today." ;; 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) + (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)))) + (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)) + 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))))) + (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))) + elapsed))) ;;; A reporting function that uses timeclock-log-data @@ -1141,13 +1141,13 @@ If optional argument TIME is non-nil, use that instead of the current time." (defun timeclock-geometric-mean (l) "Compute the geometric mean of the values in the list L." (let ((total 0) - (count 0)) + (count 0)) (while l (setq total (+ total (car l)) - count (1+ count) - l (cdr l))) + count (1+ count) + l (cdr l))) (if (> count 0) - (/ total count) + (/ total count) 0))) (defun timeclock-generate-report (&optional html-p) @@ -1156,71 +1156,71 @@ 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))) + (today (timeclock-day-base))) (if html-p (insert "<p>")) (insert "Currently ") (let ((project (nth 2 timeclock-last-event)) - (begin (nth 1 timeclock-last-event)) - done) + (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"))) + (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 "<br>\n<b>") - (insert "\n*")) - (if (timeclock-currently-in-p) - (insert "Working on ")) - (if html-p - (insert project "</b><br>\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 "<p>")) - (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 "<br>")) - (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"))) + (insert " since " (format-time-string "%Y/%m/%d %-I:%M %p" begin)) + (if html-p + (insert "<br>\n<b>") + (insert "\n*")) + (if (timeclock-currently-in-p) + (insert "Working on ")) + (if html-p + (insert project "</b><br>\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 "<p>")) + (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 "<br>")) + (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 "<p>")) (insert "\nThere have been " - (number-to-string - (length (timeclock-day-alist log))) - " days of activity, starting " - (caar (last (timeclock-day-alist log)))) + (number-to-string + (length (timeclock-day-alist log))) + " days of activity, starting " + (caar (last (timeclock-day-alist log)))) (if html-p (insert "</p>")) (when html-p - (insert "<p> + (insert "<p> <table> <td width=\"25\"><br></td><td> <table border=1 cellpadding=3> @@ -1231,111 +1231,111 @@ HTML-P is non-nil, HTML markup is added." <th>-6 mons</th> <th>-1 year</th> </tr>") - (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 "<tr>\n") - (insert "<td align=\"center\">Time in</td>\n") - (let ((i 0) (l 5)) - (while (< i l) - (insert "<td align=\"right\">" - (timeclock-seconds-to-string (aref time-in i)) - "</td>\n") - (setq i (1+ i)))) - (insert "</tr>\n") - - (insert "<tr>\n") - (insert "<td align=\"center\">Time out</td>\n") - (let ((i 0) (l 5)) - (while (< i l) - (insert "<td align=\"right\">" - (timeclock-seconds-to-string (aref time-out i)) - "</td>\n") - (setq i (1+ i)))) - (insert "</tr>\n") - - (insert "<tr>\n") - (insert "<td align=\"center\">Break</td>\n") - (let ((i 0) (l 5)) - (while (< i l) - (insert "<td align=\"right\">" - (timeclock-seconds-to-string (aref breaks i)) - "</td>\n") - (setq i (1+ i)))) - (insert "</tr>\n") - - (insert "<tr>\n") - (insert "<td align=\"center\">Workday</td>\n") - (let ((i 0) (l 5)) - (while (< i l) - (insert "<td align=\"right\">" - (timeclock-seconds-to-string (aref workday i)) - "</td>\n") - (setq i (1+ i)))) - (insert "</tr>\n")) - (insert "<tfoot> + (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 "<tr>\n") + (insert "<td align=\"center\">Time in</td>\n") + (let ((i 0) (l 5)) + (while (< i l) + (insert "<td align=\"right\">" + (timeclock-seconds-to-string (aref time-in i)) + "</td>\n") + (setq i (1+ i)))) + (insert "</tr>\n") + + (insert "<tr>\n") + (insert "<td align=\"center\">Time out</td>\n") + (let ((i 0) (l 5)) + (while (< i l) + (insert "<td align=\"right\">" + (timeclock-seconds-to-string (aref time-out i)) + "</td>\n") + (setq i (1+ i)))) + (insert "</tr>\n") + + (insert "<tr>\n") + (insert "<td align=\"center\">Break</td>\n") + (let ((i 0) (l 5)) + (while (< i l) + (insert "<td align=\"right\">" + (timeclock-seconds-to-string (aref breaks i)) + "</td>\n") + (setq i (1+ i)))) + (insert "</tr>\n") + + (insert "<tr>\n") + (insert "<td align=\"center\">Workday</td>\n") + (let ((i 0) (l 5)) + (while (< i l) + (insert "<td align=\"right\">" + (timeclock-seconds-to-string (aref workday i)) + "</td>\n") + (setq i (1+ i)))) + (insert "</tr>\n")) + (insert "<tfoot> <td colspan=\"6\" align=\"center\"> <i>These are approximate figures</i></td> </tfoot> |