summaryrefslogtreecommitdiff
path: root/lisp
diff options
context:
space:
mode:
Diffstat (limited to 'lisp')
-rw-r--r--lisp/CMakeLists.txt10
-rw-r--r--lisp/ldg-commodities.el46
-rw-r--r--lisp/ldg-complete.el11
-rw-r--r--lisp/ldg-exec.el83
-rw-r--r--lisp/ldg-mode.el2
-rw-r--r--lisp/ldg-new.el6
-rw-r--r--lisp/ldg-occur.el4
-rw-r--r--lisp/ldg-post.el71
-rw-r--r--lisp/ldg-reconcile.el85
-rw-r--r--lisp/ldg-regex.el3
-rw-r--r--lisp/ldg-register.el86
-rw-r--r--lisp/ldg-report.el25
-rw-r--r--lisp/ldg-sort.el47
-rw-r--r--lisp/ldg-state.el80
-rw-r--r--lisp/ldg-xact.el3
-rw-r--r--lisp/ledger.el1340
-rw-r--r--lisp/timeclock.el1362
17 files changed, 277 insertions, 2987 deletions
diff --git a/lisp/CMakeLists.txt b/lisp/CMakeLists.txt
index 949171b3..876b3548 100644
--- a/lisp/CMakeLists.txt
+++ b/lisp/CMakeLists.txt
@@ -1,19 +1,21 @@
set(EMACS_LISP_SOURCES
+ ldg-commodities.el
ldg-complete.el
ldg-exec.el
+ ldg-fonts.el
+ ldg-init.el
ldg-mode.el
ldg-new.el
+ ldg-occur.el
ldg-post.el
ldg-reconcile.el
ldg-regex.el
- ldg-register.el
ldg-report.el
+ ldg-sort.el
ldg-state.el
ldg-test.el
ldg-texi.el
- ldg-xact.el
- ledger.el
- timeclock.el)
+ ldg-xact.el)
# find emacs and complain if not found
find_program(EMACS_EXECUTABLE emacs)
diff --git a/lisp/ldg-commodities.el b/lisp/ldg-commodities.el
index a3cc8951..9291136f 100644
--- a/lisp/ldg-commodities.el
+++ b/lisp/ldg-commodities.el
@@ -33,28 +33,30 @@
(defun ledger-split-commodity-string (str)
"Split a commoditized amount into two parts"
- (let (val
- comm)
- (with-temp-buffer
- (insert str)
- (goto-char (point-min))
- (cond ((re-search-forward "-?[1-9][0-9]*[.,][0-9]*" nil t)
- ;; found a decimal number
- (setq val
- (string-to-number
- (ledger-commodity-string-number-decimalize
- (delete-and-extract-region (match-beginning 0) (match-end 0)) :from-user)))
- (goto-char (point-min))
- (re-search-forward "[^[:space:]]" nil t)
- (setq comm
- (delete-and-extract-region (match-beginning 0) (match-end 0)))
- (list val comm))
- ((re-search-forward "0" nil t)
- ;; couldn't find a decimal number, look for a single 0,
- ;; indicating account with zero balance
- (list 0 ledger-reconcile-default-commodity))
- (t
- (error "split-commodity-string: cannot parse commodity string: %S" str))))))
+ (if (> (length str) 0)
+ (let (val
+ comm)
+ (with-temp-buffer
+ (insert str)
+ (goto-char (point-min))
+ (cond ((re-search-forward "-?[1-9][0-9]*[.,][0-9]*" nil t)
+ ;; found a decimal number
+ (setq val
+ (string-to-number
+ (ledger-commodity-string-number-decimalize
+ (delete-and-extract-region (match-beginning 0) (match-end 0)) :from-user)))
+ (goto-char (point-min))
+ (re-search-forward "[^[:space:]]" nil t)
+ (setq comm
+ (delete-and-extract-region (match-beginning 0) (match-end 0)))
+ (list val comm))
+ ((re-search-forward "0" nil t)
+ ;; couldn't find a decimal number, look for a single 0,
+ ;; indicating account with zero balance
+ (list 0 ledger-reconcile-default-commodity))
+ (t
+ (error "split-commodity-string: cannot parse commodity string: %S" str)))))
+ (list 0 ledger-reconcile-default-commodity)))
(defun ledger-string-balance-to-commoditized-amount (str)
diff --git a/lisp/ldg-complete.el b/lisp/ldg-complete.el
index 3686d0fd..6607d372 100644
--- a/lisp/ldg-complete.el
+++ b/lisp/ldg-complete.el
@@ -145,16 +145,17 @@ Return tree structure"
"Completes a transaction if there is another matching payee in the buffer.
Does not use ledger xact"
(interactive)
- (let ((name (caar (ledger-parse-arguments)))
- rest-of-name
+ (let* ((name (caar (ledger-parse-arguments)))
+ (rest-of-name name)
xacts)
(save-excursion
(when (eq 'transaction (ledger-thing-at-point))
+ (delete-region (point) (+ (length name) (point)))
;; Search backward for a matching payee
(when (re-search-backward
- (concat "^[0-9/.=-]+\\(\\s-+\\*\\)?\\(\\s-+(.*?)\\)?\\s-+"
- (regexp-quote name) ) nil t) ;; "\\(\t\\|\n\\| [ \t]\\)"
- (setq rest-of-name (buffer-substring-no-properties (match-end 0) (line-end-position)))
+ (concat "^[0-9/.=-]+\\(\\s-+\\*\\)?\\(\\s-+(.*?)\\)?\\s-+\\(.*"
+ (regexp-quote name) ".*\\)" ) nil t) ;; "\\(\t\\|\n\\| [ \t]\\)"
+ (setq rest-of-name (match-string 3))
;; Start copying the postings
(forward-line)
(while (looking-at "^\\s-+")
diff --git a/lisp/ldg-exec.el b/lisp/ldg-exec.el
index d62fd419..46775914 100644
--- a/lisp/ldg-exec.el
+++ b/lisp/ldg-exec.el
@@ -40,30 +40,48 @@
:type 'file
:group 'ledger-exec)
+(defun ledger-exec-handle-error (ledger-output)
+ "Deal with ledger errors contained in LEDGER-OUTPUT."
+ (with-current-buffer (get-buffer-create "*Ledger Error*")
+ (insert-buffer-substring ledger-output)
+ (make-frame)
+ (fit-frame)
+ (view-mode)
+ (toggle-read-only)))
+
+(defun ledger-exec-success-p (ledger-output-buffer)
+ (with-current-buffer ledger-output-buffer
+ (goto-char (point-min))
+ (if (and (> (buffer-size) 1) (looking-at (regexp-quote "While")))
+ nil
+ ledger-output-buffer)))
+
(defun ledger-exec-ledger (input-buffer &optional output-buffer &rest args)
"Run Ledger using INPUT-BUFFER and optionally capturing output in OUTPUT-BUFFER with ARGS."
(if (null ledger-binary-path)
- (error "The variable `ledger-binary-path' has not been set"))
- (let ((buf (or input-buffer (current-buffer)))
- (outbuf (or output-buffer
- (generate-new-buffer " *ledger-tmp*"))))
- (with-current-buffer buf
- (let ((coding-system-for-write 'utf-8)
- (coding-system-for-read 'utf-8))
- (apply #'call-process-region
- (append (list (point-min) (point-max)
- ledger-binary-path nil outbuf nil "-f" "-")
- args)))
- outbuf)))
-
-(defun ledger-exec-read (&optional input-buffer &rest args)
- "Run ledger from option INPUT-BUFFER using ARGS, return a list structure of the ledger Emacs output."
- (with-current-buffer
- (apply #'ledger-exec-ledger input-buffer nil "emacs" args)
- (goto-char (point-min))
- (prog1
- (read (current-buffer))
- (kill-buffer (current-buffer)))))
+ (error "The variable `ledger-binary-path' has not been set")
+ (let ((buf (or input-buffer (current-buffer)))
+ (outbuf (or output-buffer
+ (generate-new-buffer " *ledger-tmp*"))))
+ (with-current-buffer buf
+ (let ((coding-system-for-write 'utf-8)
+ (coding-system-for-read 'utf-8))
+ (apply #'call-process-region
+ (append (list (point-min) (point-max)
+ ledger-binary-path nil outbuf nil "-f" "-")
+ args)))
+ (if (ledger-exec-success-p outbuf)
+ outbuf
+ (ledger-exec-handle-error outbuf))))))
+
+;; (defun ledger-exec-read (&optional input-buffer &rest args)
+;; "Run ledger from option INPUT-BUFFER using ARGS, return a list structure of the ledger Emacs output."
+;; (with-current-buffer
+;; (apply #'ledger-exec-ledger input-buffer nil "emacs" args)
+;; (goto-char (point-min))
+;; (prog1
+;; (read (current-buffer))
+;; (kill-buffer (current-buffer)))))
(defun ledger-version-greater-p (needed)
"Verify the ledger binary is usable for `ledger-mode' (version greater than NEEDED)."
@@ -71,17 +89,18 @@
(version-strings '())
(version-number))
(with-temp-buffer
- (ledger-exec-ledger buffer (current-buffer) "--version")
- (goto-char (point-min))
- (delete-horizontal-space)
- (setq version-strings (split-string
- (buffer-substring-no-properties (point)
- (+ (point) 12))))
- (if (and (string-match (regexp-quote "Ledger") (car version-strings))
- (or (string= needed (car (cdr version-strings)))
- (string< needed (car (cdr version-strings)))))
- t
- nil))))
+ (if (ledger-exec-ledger (current-buffer) (current-buffer) "--version")
+ (progn
+ (goto-char (point-min))
+ (delete-horizontal-space)
+ (setq version-strings (split-string
+ (buffer-substring-no-properties (point)
+ (point-max))))
+ (if (and (string-match (regexp-quote "Ledger") (car version-strings))
+ (or (string= needed (car (cdr version-strings)))
+ (string< needed (car (cdr version-strings)))))
+ t
+ nil))))))
(defun ledger-check-version ()
"Verify that ledger works and is modern enough."
diff --git a/lisp/ldg-mode.el b/lisp/ldg-mode.el
index 00df0e67..84ccf62b 100644
--- a/lisp/ldg-mode.el
+++ b/lisp/ldg-mode.el
@@ -116,6 +116,8 @@
(interactive)
(customize-group 'ledger))))
(define-key map [sep1] '("--"))
+ (define-key map [sort-end] '(menu-item "Mark Sort End" ledger-sort-insert-end-mark))
+ (define-key map [sort-start] '(menu-item "Mark Sort Beginning" ledger-sort-insert-start-mark))
(define-key map [sort-buff] '(menu-item "Sort Buffer" ledger-sort-buffer))
(define-key map [sort-reg] '(menu-item "Sort Region" ledger-sort-region :enable mark-active))
(define-key map [sep2] '(menu-item "--"))
diff --git a/lisp/ldg-new.el b/lisp/ldg-new.el
index 7a2961f7..a9c70ff4 100644
--- a/lisp/ldg-new.el
+++ b/lisp/ldg-new.el
@@ -32,6 +32,7 @@
;;; Commentary:
;; Load up the ledger mode
+(require 'esh-util)
(require 'esh-arg)
(require 'ldg-commodities)
(require 'ldg-complete)
@@ -42,7 +43,7 @@
(require 'ldg-occur)
(require 'ldg-post)
(require 'ldg-reconcile)
-(require 'ldg-register)
+(require 'ldg-regex)
(require 'ldg-report)
(require 'ldg-sort)
(require 'ldg-state)
@@ -123,9 +124,6 @@
(ledger-dump-variable 'ledger-buffer-tracks-reconcile-buffer)
(ledger-dump-variable 'ledger-reconcile-force-window-bottom)
(ledger-dump-variable 'ledger-reconcile-toggle-to-pending)
- (insert "ldg-register:\n")
- (ledger-dump-variable 'ledger-register-date-format)
- (ledger-dump-variable 'ledger-register-line-format)
(insert "ldg-reports:\n")
(ledger-dump-variable 'ledger-reports)
(ledger-dump-variable 'ledger-report-format-specifiers)
diff --git a/lisp/ldg-occur.el b/lisp/ldg-occur.el
index 1561d6f8..f14aeeda 100644
--- a/lisp/ldg-occur.el
+++ b/lisp/ldg-occur.el
@@ -41,7 +41,9 @@
(make-variable-buffer-local 'ledger-occur-use-face-unfolded)
-(defvar ledger-occur-mode nil) ;; name of the minor mode, shown in the mode-line
+(defvar ledger-occur-mode nil
+"name of the minor mode, shown in the mode-line")
+
(make-variable-buffer-local 'ledger-occur-mode)
(or (assq 'ledger-occur-mode minor-mode-alist)
diff --git a/lisp/ldg-post.el b/lisp/ldg-post.el
index 7105ef7a..46acad1a 100644
--- a/lisp/ldg-post.el
+++ b/lisp/ldg-post.el
@@ -31,16 +31,20 @@
"Default indentation for account transactions in an entry."
:type 'string
:group 'ledger-post)
-
(defgroup ledger-post nil
"Options for controlling how Ledger-mode deals with postings and completion"
:group 'ledger)
-(defcustom ledger-post-auto-adjust-amounts nil
- "If non-nil, ."
+(defcustom ledger-post-auto-adjust-postings t
+ "If non-nil, adjust account and amount to columns set below"
:type 'boolean
:group 'ledger-post)
+(defcustom ledger-post-account-alignment-column 4
+ "The column Ledger-mode attempts to align accounts to."
+ :type 'integer
+ :group 'ledger-post)
+
(defcustom ledger-post-amount-alignment-column 52
"The column Ledger-mode attempts to align amounts to."
:type 'integer
@@ -123,20 +127,26 @@ PROMPT is a string to prompt with. CHOICES is a list of
(- (or (match-end 4)
(match-end 3)) (point))))
-(defun ledger-align-amounts (&optional column)
+(defun ledger-post-align-postings (&optional column)
"Align amounts and accounts in the current region.
This is done so that the last digit falls in COLUMN, which
-defaults to 52. ledger-default-acct-transaction-indent positions
+defaults to 52. ledger-post-account-column positions
the account"
(interactive "p")
(if (or (null column) (= column 1))
(setq column ledger-post-amount-alignment-column))
(save-excursion
;; Position the account
- ;; (beginning-of-line)
+ (if (not (or (looking-at "[ \t]*[1-9]")
+ (and (looking-at "[ \t]+\n")
+ (looking-back "[ \n]" (- (point) 2)))))
+ (save-excursion
+ (beginning-of-line)
+ (set-mark (point))
+ (delete-horizontal-space)
+ (insert (make-string ledger-post-account-alignment-column ? )))
+ (set-mark (point)))
(set-mark (point))
- ;; (delete-horizontal-space)
- ;; (insert ledger-default-acct-transaction-indent)
(goto-char (1+ (line-end-position)))
(let* ((mark-first (< (mark) (point)))
(begin (if mark-first (mark) (point)))
@@ -148,7 +158,7 @@ the account"
(let ((col (current-column))
(target-col (- column offset))
adjust)
- (setq adjust (- target-col col))
+ (setq adjust (- target-col col))
(if (< col target-col)
(insert (make-string (- target-col col) ? ))
(move-to-column target-col)
@@ -159,23 +169,24 @@ the account"
(insert " ")))
(forward-line))))))
-(defun ledger-post-align-amount ()
+(defun ledger-post-align-posting ()
"Align the amounts in this posting."
(interactive)
(save-excursion
(set-mark (line-beginning-position))
(goto-char (1+ (line-end-position)))
- (ledger-align-amounts)))
+ (ledger-post-align-postings)))
(defun ledger-post-maybe-align (beg end len)
"Align amounts only if point is in a posting.
BEG, END, and LEN control how far it can align."
- (save-excursion
- (goto-char beg)
- (when (<= end (line-end-position))
- (goto-char (line-beginning-position))
- (if (looking-at ledger-post-line-regexp)
- (ledger-align-amounts)))))
+ (if ledger-post-auto-adjust-postings
+ (save-excursion
+ (goto-char beg)
+ (when (<= end (line-end-position))
+ (goto-char (line-beginning-position))
+ (if (looking-at ledger-post-line-regexp)
+ (ledger-post-align-postings))))))
(defun ledger-post-edit-amount ()
"Call 'calc-mode' and push the amount in the posting to the top of stack."
@@ -186,19 +197,10 @@ BEG, END, and LEN control how far it can align."
(let ((end-of-amount (re-search-forward "[-.,0-9]+" (line-end-position) t)))
;; determine if there is an amount to edit
(if end-of-amount
- (let ((val (match-string 0)))
+ (let ((val (ledger-commodity-string-number-decimalize (match-string 0) :from-user)))
(goto-char (match-beginning 0))
(delete-region (match-beginning 0) (match-end 0))
(calc)
- (if ledger-use-decimal-comma
- (progn
- (while (string-match "\\." val)
- (setq val (replace-match "" nil nil val))) ;; gets rid of periods
- (while (string-match "," val)
- (setq val (replace-match "." nil nil val)))) ;; switch to period separator
- (progn
- (while (string-match "," val)
- (setq val (replace-match "" nil nil val))))) ;; gets rid of commas
(calc-eval val 'push)) ;; edit the amount
(progn ;;make sure there are two spaces after the account name and go to calc
(if (search-backward " " (- (point) 3) t)
@@ -225,10 +227,21 @@ BEG, END, and LEN control how far it can align."
(defun ledger-post-setup ()
"Configure `ledger-mode' to auto-align postings."
- (if ledger-post-auto-adjust-amounts
- (add-hook 'after-change-functions 'ledger-post-maybe-align t t))
+ (add-hook 'after-change-functions 'ledger-post-maybe-align t t)
(add-hook 'after-save-hook #'(lambda () (setq ledger-post-current-list nil))))
+
+(defun ledger-post-read-account-with-prompt (prompt)
+ (let* ((context (ledger-context-at-point))
+ (default
+ (if (eq (ledger-context-line-type context) 'acct-transaction)
+ (regexp-quote (ledger-context-field-value context 'account))
+ nil)))
+ (ledger-read-string-with-default prompt default)))
+
+
(provide 'ldg-post)
+
+
;;; ldg-post.el ends here
diff --git a/lisp/ldg-reconcile.el b/lisp/ldg-reconcile.el
index 33c9f06f..802cb3b4 100644
--- a/lisp/ldg-reconcile.el
+++ b/lisp/ldg-reconcile.el
@@ -70,32 +70,29 @@ reconcile-finish will mark all pending posting cleared."
(account ledger-acct)
(val nil))
(with-temp-buffer
- (ledger-exec-ledger buffer (current-buffer)
- ; note that in the line below, the --format option is
- ; separated from the actual format string. emacs does not
- ; split arguments like the shell does, so you need to
- ; specify the individual fields in the command line.
- "balance" "--limit" "cleared or pending" "--empty"
- "--format" "%(display_total)" account)
- (setq val
- (ledger-split-commodity-string
- (buffer-substring-no-properties (point-min) (point-max)))))))
+ ;; note that in the line below, the --format option is
+ ;; separated from the actual format string. emacs does not
+ ;; split arguments like the shell does, so you need to
+ ;; specify the individual fields in the command line.
+ (if (ledger-exec-ledger buffer (current-buffer)
+ "balance" "--limit" "cleared or pending" "--empty"
+ "--format" "%(display_total)" account)
+ (setq val
+ (ledger-split-commodity-string
+ (buffer-substring-no-properties (point-min) (point-max))))))))
(defun ledger-display-balance ()
- "Display the cleared-or-pending balnce and calculate the
-target-delta of the account being reconciled."
+ "Display the cleared-or-pending balance.
+And calculate the target-delta of the account being reconciled."
(interactive)
- (let* ((pending (ledger-reconcile-get-cleared-or-pending-balance))
- (target-delta (if ledger-target
- (-commodity ledger-target pending)
- nil)))
-
- (if target-delta
- (message "Pending balance: %s, Difference from target: %s"
- (ledger-commodity-to-string pending)
- (ledger-commodity-to-string target-delta))
- (message "Pending balance: %s"
- (ledger-commodity-to-string pending)))))
+ (let* ((pending (ledger-reconcile-get-cleared-or-pending-balance)))
+ (if pending
+ (if ledger-target
+ (message "Pending balance: %s, Difference from target: %s"
+ (ledger-commodity-to-string pending)
+ (ledger-commodity-to-string (-commodity ledger-target pending)))
+ (message "Pending balance: %s"
+ (ledger-commodity-to-string pending))))))
@@ -111,7 +108,7 @@ target-delta of the account being reconciled."
"Return a buffer from WHERE the transaction is."
(if (bufferp (car where))
(car where)
- (error "ledger-reconcile-get-buffer: Buffer not set")))
+ (error "Function ledger-reconcile-get-buffer: Buffer not set")))
(defun ledger-reconcile-toggle ()
"Toggle the current transaction, and mark the recon window."
@@ -276,23 +273,27 @@ POSTING is used in `ledger-clear-whole-transactions' is nil."
"Get the uncleared transactions in the account and display them in the *Reconcile* buffer."
(let* ((buf ledger-buf)
(account ledger-acct)
+ (ledger-success nil)
(xacts
(with-temp-buffer
- (ledger-exec-ledger buf (current-buffer)
- "--uncleared" "--real" "emacs" account)
- (goto-char (point-min))
- (unless (eobp)
- (unless (looking-at "(")
- (error (concat "ledger-do-reconcile: " (buffer-string))))
- (read (current-buffer)))))) ;current-buffer is the *temp* created above
- (if (> (length xacts) 0)
- (progn
+ (if (ledger-exec-ledger buf (current-buffer)
+ "--uncleared" "--real" "emacs" account)
+ (progn
+ (setq ledger-success t)
+ (goto-char (point-min))
+ (unless (eobp)
+ (if (looking-at "(")
+ (read (current-buffer))))))))) ;current-buffer is the *temp* created above
+ (if (and ledger-success (> (length xacts) 0))
+ (let ((date-format (cdr (assoc "date-format" ledger-environment-alist))))
(dolist (xact xacts)
(dolist (posting (nthcdr 5 xact))
(let ((beg (point))
(where (ledger-marker-where-xact-is xact posting)))
(insert (format "%s %-4s %-30s %-30s %15s\n"
- (format-time-string "%Y/%m/%d" (nth 2 xact))
+ (format-time-string (if date-format
+ date-format
+ "%Y/%m/%d") (nth 2 xact))
(if (nth 3 xact)
(nth 3 xact)
"")
@@ -310,7 +311,9 @@ POSTING is used in `ledger-clear-whole-transactions' is nil."
'where where)))) ))
(goto-char (point-max))
(delete-char -1)) ;gets rid of the extra line feed at the bottom of the list
- (insert (concat "There are no uncleared entries for " account)))
+ (if ledger-success
+ (insert (concat "There are no uncleared entries for " account))
+ (insert "Ledger has reported a problem. Check *Ledger Error* buffer.")))
(goto-char (point-min))
(set-buffer-modified-p nil)
(toggle-read-only t)
@@ -351,10 +354,11 @@ POSTING is used in `ledger-clear-whole-transactions' is nil."
(set-window-buffer (split-window (get-buffer-window buf) nil nil) rbuf)
(pop-to-buffer rbuf)))
-(defun ledger-reconcile (account)
- "Start reconciling ACCOUNT."
- (interactive "sAccount to reconcile: ")
- (let ((buf (current-buffer))
+(defun ledger-reconcile ()
+ "Start reconciling, prompt for account."
+ (interactive)
+ (let ((account (ledger-post-read-account-with-prompt "Account to reconcile"))
+ (buf (current-buffer))
(rbuf (get-buffer ledger-recon-buffer-name))) ;; this means
;; only one
;; *Reconcile*
@@ -396,7 +400,7 @@ POSTING is used in `ledger-clear-whole-transactions' is nil."
(defvar ledger-reconcile-mode-abbrev-table)
(defun ledger-reconcile-change-target ()
- "Change the traget amount for the reconciliation process."
+ "Change the target amount for the reconciliation process."
(interactive)
(setq ledger-target (ledger-read-commodity-string "Set reconciliation target")))
@@ -442,6 +446,5 @@ POSTING is used in `ledger-clear-whole-transactions' is nil."
(use-local-map map)))
(provide 'ldg-reconcile)
-(provide 'ldg-reconcile)
;;; ldg-reconcile.el ends here
diff --git a/lisp/ldg-regex.el b/lisp/ldg-regex.el
index e81394ef..97fd6e2c 100644
--- a/lisp/ldg-regex.el
+++ b/lisp/ldg-regex.el
@@ -24,7 +24,8 @@
(eval-when-compile
(require 'cl))
-(defvar ledger-date-regex "\\([0-9]+\\)[/-]\\([0-9]+\\)[/-]\\([0-9]+\\)")
+(defvar ledger-date-regex
+ "\\([0-9]+\\)[/-]\\([0-9]+\\)[/-]\\([0-9]+\\)")
(defmacro ledger-define-regexp (name regex docs &rest args)
"Simplify the creation of a Ledger regex and helper functions."
diff --git a/lisp/ldg-register.el b/lisp/ldg-register.el
deleted file mode 100644
index bfd8d360..00000000
--- a/lisp/ldg-register.el
+++ /dev/null
@@ -1,86 +0,0 @@
-;;; ldg-register.el --- Helper code for use with the "ledger" command-line tool
-
-;; Copyright (C) 2003-2013 John Wiegley (johnw AT gnu DOT org)
-
-;; This file is not part of GNU Emacs.
-
-;; This is free software; you can redistribute it and/or modify it under
-;; the terms of the GNU General Public License as published by the Free
-;; Software Foundation; either version 2, or (at your option) any later
-;; version.
-;;
-;; This is distributed in the hope that it will be useful, but WITHOUT
-;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
-;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
-;; for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
-;; MA 02111-1307, USA.
-
-(require 'ldg-post)
-(require 'ldg-state)
-
-(defgroup ledger-register nil
- ""
- :group 'ledger)
-
-(defcustom ledger-register-date-format "%m/%d/%y"
- "*The date format used for ledger register reports."
- :type 'string
- :group 'ledger-register)
-
-(defcustom ledger-register-line-format "%s %-30.30s %-25.25s %15s\n"
- "*The date format used for ledger register reports."
- :type 'string
- :group 'ledger-register)
-
-(defface ledger-register-pending-face
- '((((background light)) (:weight bold))
- (((background dark)) (:weight bold)))
- "Face used to highlight pending entries in a register report."
- :group 'ledger-register)
-
-(defun ledger-register-render (data-buffer posts)
- (dolist (post posts)
- (let ((index 1))
- (dolist (xact (nthcdr 5 post))
- (let ((beg (point))
- (where
- (with-current-buffer data-buffer
- (cons
- (nth 0 post)
- (if ledger-clear-whole-transactions
- (save-excursion
- (goto-line (nth 1 post))
- (point-marker))
- (save-excursion
- (goto-line (nth 0 xact))
- (point-marker)))))))
- (insert (format ledger-register-line-format
- (format-time-string ledger-register-date-format
- (nth 2 post))
- (nth 4 post) (nth 1 xact) (nth 2 xact)))
- (if (nth 3 xact)
- (set-text-properties beg (1- (point))
- (list 'face 'ledger-register-pending-face
- 'where where))
- (set-text-properties beg (1- (point))
- (list 'where where))))
- (setq index (1+ index)))))
- (goto-char (point-min)))
-
-(defun ledger-register-generate (&optional data-buffer &rest args)
- (let ((buf (or data-buffer (current-buffer))))
- (with-current-buffer (get-buffer-create "*ledger-register*")
- (let ((pos (point))
- (inhibit-read-only t))
- (erase-buffer)
- (ledger-register-render buf (apply #'ledger-exec-read buf args))
- (goto-char pos))
- (set-buffer-modified-p nil)
- (toggle-read-only t)
- (display-buffer (current-buffer) t))))
-
-(provide 'ldg-register)
diff --git a/lisp/ldg-report.el b/lisp/ldg-report.el
index 0728495e..8d91d9d4 100644
--- a/lisp/ldg-report.el
+++ b/lisp/ldg-report.el
@@ -258,12 +258,7 @@ used to generate the buffer, navigating the buffer, etc."
the default."
;; It is intended completion should be available on existing account
;; names, but it remains to be implemented.
- (let* ((context (ledger-context-at-point))
- (default
- (if (eq (ledger-context-line-type context) 'acct-transaction)
- (regexp-quote (ledger-context-field-value context 'account))
- nil)))
- (ledger-read-string-with-default "Account" default)))
+ (ledger-post-read-account-with-prompt "Account"))
(defun ledger-report-expand-format-specifiers (report-cmd)
"Expand %(account) and %(payee) appearing in REPORT-CMD with thing under point."
@@ -437,11 +432,13 @@ Optional EDIT the command."
("^\\(\\([0-9][0-9][0-9][0-9]/\\)?[01]?[0-9]/[0123]?[0-9]\\)[ \t]+\\(\\([!*]\\)[ \t]\\)?[ \t]*\\((\\(.*\\))\\)?[ \t]*\\(.*\\)[ \t]*$"
(date nil status nil nil code payee))))
(acct-transaction
- (("\\(^[ \t]+\\)\\(.*?\\)[ \t]+\\([$]\\)\\(-?[0-9]*\\(\\.[0-9]*\\)?\\)[ \t]*;[ \t]*\\(.*?\\)[ \t]*$"
+ (("^\\([ \t]+;\\|;\\)\\s-?\\(.*\\)"
+ (indent comment))
+ ("\\(^[ \t]+\\)\\([:A-Za-z0-9]+?\\)\\s-\\s-+\\([$€£]\\s-?\\)\\(-?[0-9]*\\(\\.[0-9]*\\)?\\)$"
+ (indent account commodity amount))
+ ("\\(^[ \t]+\\)\\(.*?\\)[ \t]+\\([$€£]\\s-?\\)\\(-?[0-9]*\\(\\.[0-9]*\\)?\\)[ \t]*;[ \t]*\\(.*?\\)[ \t]*$"
(indent account commodity amount nil comment))
- ("\\(^[ \t]+\\)\\(.*?\\)[ \t]+\\([$]\\)\\(-?[0-9]*\\(\\.[0-9]*\\)?\\)[ \t]*$"
- (indent account commodity amount nil))
- ("\\(^[ \t]+\\)\\(.*?\\)[ \t]+\\(-?[0-9]+\\(\\.[0-9]*\\)?\\)[ \t]+\\(.*?\\)[ \t]*;[ \t]*\\(.*?\\)[ \t]*$"
+ ("\\(^[ \t]+\\)\\(.*?\\)[ \t]+\\(-?[0-9]+\\(\\.[0-9]*\\)?\\)[ \t]+\\(.*?\\)[ \t]*\\(;[ \t]*\\(.*?\\)[ \t]*$\\|@+\\)"
(indent account amount nil commodity comment))
("\\(^[ \t]+\\)\\(.*?\\)[ \t]+\\(-?[0-9]+\\(\\.[0-9]*\\)?\\)[ \t]+\\(.*?\\)[ \t]*$"
(indent account amount nil commodity))
@@ -452,7 +449,13 @@ Optional EDIT the command."
("\\(^[ \t]+\\)\\(.*?\\)[ \t]*;[ \t]*\\(.*?\\)[ \t]*$"
(indent account comment))
("\\(^[ \t]+\\)\\(.*?\\)[ \t]*$"
- (indent account))))))
+ (indent account))
+
+;; Bad regexes
+ ("\\(^[ \t]+\\)\\(.*?\\)[ \t]+\\([$€£]\\s-?\\)\\(-?[0-9]*\\(\\.[0-9]*\\)?\\)[ \t]*$"
+ (indent account commodity amount nil))
+
+ ))))
(defun ledger-extract-context-info (line-type pos)
"Get context info for current line with LINE-TYPE.
diff --git a/lisp/ldg-sort.el b/lisp/ldg-sort.el
index cc036492..33ae2a98 100644
--- a/lisp/ldg-sort.el
+++ b/lisp/ldg-sort.el
@@ -38,6 +38,36 @@
"Move point to end of transaction."
(forward-paragraph))
+(defun ledger-sort-find-start ()
+ (if (re-search-forward ";.*Ledger-mode:.*Start sort" nil t)
+ (match-end 0)))
+
+(defun ledger-sort-find-end ()
+ (if (re-search-forward ";.*Ledger-mode:.*End sort" nil t)
+ (match-end 0)))
+
+(defun ledger-sort-insert-start-mark ()
+ (interactive)
+ (let (has-old-marker)
+ (save-excursion
+ (goto-char (point-min))
+ (setq has-old-marker (ledger-sort-find-start))
+ (if has-old-marker
+ (delete-region (match-beginning 0) (match-end 0))))
+ (beginning-of-line)
+ (insert "\n; Ledger-mode: Start sort\n\n")))
+
+(defun ledger-sort-insert-end-mark ()
+ (interactive)
+ (let (has-old-marker)
+ (save-excursion
+ (goto-char (point-min))
+ (setq has-old-marker (ledger-sort-find-end))
+ (if has-old-marker
+ (delete-region (match-beginning 0) (match-end 0))))
+ (beginning-of-line)
+ (insert "\n; Ledger-mode: End sort\n\n")))
+
(defun ledger-sort-region (beg end)
"Sort the region from BEG to END in chronological order."
(interactive "r") ;; load beg and end from point and mark
@@ -66,14 +96,15 @@
(defun ledger-sort-buffer ()
"Sort the entire buffer."
(interactive)
- (let ((sort-start (point-min))
- (sort-end (point-max)))
- (goto-char (point-min))
- (if (re-search-forward ";.*Ledger-mode:.*Start sort" nil t)
- (set 'sort-start (match-end 0)))
- (if (re-search-forward ";.*Ledger-mode:.*End sort" nil t)
- (set 'sort-end (match-end 0)))
- (ledger-sort-region sort-start sort-end)))
+ (goto-char (point-min))
+ (let ((sort-start (ledger-sort-find-start))
+ (sort-end (ledger-sort-find-end)))
+ (ledger-sort-region (if sort-start
+ sort-start
+ (point-min))
+ (if sort-end
+ sort-end
+ (point-max)))))
(provide 'ldg-sort)
diff --git a/lisp/ldg-state.el b/lisp/ldg-state.el
index b2247afe..dd5e42ad 100644
--- a/lisp/ldg-state.el
+++ b/lisp/ldg-state.el
@@ -122,42 +122,48 @@ dropped."
;;this excursion toggles the posting status
(save-excursion
- (goto-char (line-beginning-position))
- (when (looking-at "[ \t]")
- (skip-chars-forward " \t")
- (let ((here (point))
- (cur-status (ledger-state-from-char (char-after))))
- (skip-chars-forward "*! ")
- (let ((width (- (point) here)))
- (when (> width 0)
- (delete-region here (point))
- (save-excursion
- (if (search-forward " " (line-end-position) t)
- (insert (make-string width ? ))))))
- (let (inserted)
- (if cur-status
- (if (and style (eq style 'cleared))
- (progn
- (insert "* ")
- (setq inserted 'cleared)))
- (if (and style (eq style 'pending))
- (progn
- (insert "! ")
- (setq inserted 'pending))
- (progn
- (insert "* ")
- (setq inserted 'cleared))))
- (if (and inserted
- (re-search-forward "\\(\t\\| [ \t]\\)"
- (line-end-position) t))
- (cond
- ((looking-at "\t")
- (delete-char 1))
- ((looking-at " [ \t]")
- (delete-char 2))
- ((looking-at " ")
- (delete-char 1))))
- (setq new-status inserted)))))
+ (let ((has-align-hook (remove-hook
+ 'after-change-functions
+ 'ledger-post-maybe-align t)))
+
+ (goto-char (line-beginning-position))
+ (when (looking-at "[ \t]")
+ (skip-chars-forward " \t")
+ (let ((here (point))
+ (cur-status (ledger-state-from-char (char-after))))
+ (skip-chars-forward "*! ")
+ (let ((width (- (point) here)))
+ (when (> width 0)
+ (delete-region here (point))
+ (save-excursion
+ (if (search-forward " " (line-end-position) t)
+ (insert (make-string width ? ))))))
+ (let (inserted)
+ (if cur-status
+ (if (and style (eq style 'cleared))
+ (progn
+ (insert "* ")
+ (setq inserted 'cleared)))
+ (if (and style (eq style 'pending))
+ (progn
+ (insert "! ")
+ (setq inserted 'pending))
+ (progn
+ (insert "* ")
+ (setq inserted 'cleared))))
+ (if (and inserted
+ (re-search-forward "\\(\t\\| [ \t]\\)"
+ (line-end-position) t))
+ (cond
+ ((looking-at "\t")
+ (delete-char 1))
+ ((looking-at " [ \t]")
+ (delete-char 2))
+ ((looking-at " ")
+ (delete-char 1))))
+ (setq new-status inserted))))
+ (if has-align-hook
+ (add-hook 'after-change-functions 'ledger-post-maybe-align t t))))
;; This excursion cleans up the entry so that it displays
;; minimally. This means that if all posts are cleared, remove
@@ -254,6 +260,4 @@ dropped."
(provide 'ldg-state)
-(provide 'ldg-state)
-
;;; ldg-state.el ends here
diff --git a/lisp/ldg-xact.el b/lisp/ldg-xact.el
index 8db50df2..ecd87127 100644
--- a/lisp/ldg-xact.el
+++ b/lisp/ldg-xact.el
@@ -118,9 +118,6 @@ within the transaction."
(replace-match date)
(re-search-forward "[1-9][0-9]+\.[0-9]+")))
-
-
-(provide 'ldg-xact)
(provide 'ldg-xact)
;;; ldg-xact.el ends here
diff --git a/lisp/ledger.el b/lisp/ledger.el
deleted file mode 100644
index 4fc21d6a..00000000
--- a/lisp/ledger.el
+++ /dev/null
@@ -1,1340 +0,0 @@
-;;; ledger.el --- Helper code for use with the "ledger" command-line tool
-
-;; Copyright (C) 2003-2009 John Wiegley (johnw AT gnu DOT org)
-
-;; Emacs Lisp Archive Entry
-;; Filename: ledger.el
-;; Version: 2.6.3
-;; Date: Fri 18-Jul-2008
-;; Keywords: data
-;; Author: John Wiegley (johnw AT gnu DOT org)
-;; Maintainer: John Wiegley (johnw AT gnu DOT org)
-;; Description: Helper code for using my "ledger" command-line tool
-;; URL: http://www.newartisans.com/johnw/emacs.html
-;; Compatibility: Emacs22
-
-;; This file is not part of GNU Emacs.
-
-;; This is free software; you can redistribute it and/or modify it under
-;; the terms of the GNU General Public License as published by the Free
-;; Software Foundation; either version 2, or (at your option) any later
-;; version.
-;;
-;; This is distributed in the hope that it will be useful, but WITHOUT
-;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
-;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
-;; for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
-;; MA 02111-1307, USA.
-
-;;; Commentary:
-
-;; To use this module: Load this file, open a ledger data file, and
-;; type M-x ledger-mode. Once this is done, you can type:
-;;
-;; C-c C-a add a new entry, based on previous entries
-;; C-c C-e toggle cleared status of an entry
-;; C-c C-y set default year for entry mode
-;; C-c C-m set default month for entry mode
-;; C-c C-r reconcile uncleared entries related to an account
-;; C-c C-o C-r run a ledger report
-;; C-C C-o C-g goto the ledger report buffer
-;; C-c C-o C-e edit the defined ledger reports
-;; C-c C-o C-s save a report definition based on the current report
-;; C-c C-o C-a rerun a ledger report
-;; C-c C-o C-k kill the ledger report buffer
-;;
-;; In the reconcile buffer, use SPACE to toggle the cleared status of
-;; a transaction, C-x C-s to save changes (to the ledger file as
-;; well).
-;;
-;; The ledger reports command asks the user to select a report to run
-;; then creates a report buffer containing the results of running the
-;; associated command line. Its' behavior is modified by a prefix
-;; argument which, when given, causes the generated command line that
-;; will be used to create the report to be presented for editing
-;; before the report is actually run. Arbitrary unnamed command lines
-;; can be run by specifying an empty name for the report. The command
-;; line used can later be named and saved for future use as a named
-;; report from the generated reports buffer.
-;;
-;; In a report buffer, the following keys are available:
-;; (space) scroll up
-;; e edit the defined ledger reports
-;; s save a report definition based on the current report
-;; q quit the report (return to ledger buffer)
-;; r redo the report
-;; k kill the report buffer
-
-(require 'esh-util)
-(require 'esh-arg)
-(require 'pcomplete)
-
-(defvar ledger-version "1.3"
- "The version of ledger.el currently loaded")
-
-(defgroup ledger nil
- "Interface to the Ledger command-line accounting program."
- :group 'data)
-
-(defcustom ledger-binary-path "ledger"
- "Path to the ledger executable."
- :type 'file
- :group 'ledger)
-
-(defcustom ledger-clear-whole-entries nil
- "If non-nil, clear whole entries, not individual transactions."
- :type 'boolean
- :group 'ledger)
-
-(defcustom ledger-reports
- '(("bal" "ledger -f %(ledger-file) bal")
- ("reg" "ledger -f %(ledger-file) reg")
- ("payee" "ledger -f %(ledger-file) reg -- %(payee)")
- ("account" "ledger -f %(ledger-file) reg %(account)"))
- "Definition of reports to run.
-
-Each element has the form (NAME CMDLINE). The command line can
-contain format specifiers that are replaced with context sensitive
-information. Format specifiers have the format '%(<name>)' where
-<name> is an identifier for the information to be replaced. The
-`ledger-report-format-specifiers' alist variable contains a mapping
-from format specifier identifier to a lisp function that implements
-the substitution. See the documentation of the individual functions
-in that variable for more information on the behavior of each
-specifier."
- :type '(repeat (list (string :tag "Report Name")
- (string :tag "Command Line")))
- :group 'ledger)
-
-(defcustom ledger-report-format-specifiers
- '(("ledger-file" . ledger-report-ledger-file-format-specifier)
- ("payee" . ledger-report-payee-format-specifier)
- ("account" . ledger-report-account-format-specifier))
- "Alist mapping ledger report format specifiers to implementing functions
-
-The function is called with no parameters and expected to return the
-text that should replace the format specifier."
- :type 'alist
- :group 'ledger)
-
-(defcustom ledger-default-acct-transaction-indent " "
- "Default indentation for account transactions in an entry."
- :type 'string
- :group 'ledger)
-
-(defvar bold 'bold)
-(defvar ledger-font-lock-keywords
- '(("\\( \\| \\|^\\)\\(;.*\\)" 2 font-lock-comment-face)
- ("^[0-9]+[-/.=][-/.=0-9]+\\s-+\\(([^)]+)\\s-+\\)?\\([^*].+?\\)\\(\\( ;\\| ;\\|$\\)\\)" 2 bold)
- ;;("^[0-9]+[-/.=][-/.=0-9]+\\s-+\\(([^)]+)\\s-+\\)?\\([*].+?\\)\\(\\( ;\\| ;\\|$\\)\\)"
- ;; 2 font-lock-type-face)
- ("^\\s-+\\([*]\\s-*\\)?\\(\\([[(]\\)?\\([^*;]\\)+?\\(:\\|\\s-\\)[^]);
- ]+?\\([])]\\)?\\)\\( \\| \\|$\\)"
- 2 font-lock-keyword-face)
- ("^\\([~=].+\\)" 1 font-lock-function-name-face)
- ("^\\([A-Za-z]+ .+\\)" 1 font-lock-function-name-face))
- "Expressions to highlight in Ledger mode.")
-
-(defsubst ledger-current-year ()
- (format-time-string "%Y"))
-(defsubst ledger-current-month ()
- (format-time-string "%m"))
-
-(defvar ledger-year (ledger-current-year)
- "Start a ledger session with the current year, but make it
-customizable to ease retro-entry.")
-(defvar ledger-month (ledger-current-month)
- "Start a ledger session with the current month, but make it
-customizable to ease retro-entry.")
-
-(defun ledger-iterate-entries (callback)
- (goto-char (point-min))
- (let* ((now (current-time))
- (current-year (nth 5 (decode-time now))))
- (while (not (eobp))
- (when (looking-at
- (concat "\\(Y\\s-+\\([0-9]+\\)\\|"
- "\\([0-9]\\{4\\}+\\)?[./]?"
- "\\([0-9]+\\)[./]\\([0-9]+\\)\\s-+"
- "\\(\\*\\s-+\\)?\\(.+\\)\\)"))
- (let ((found (match-string 2)))
- (if found
- (setq current-year (string-to-number found))
- (let ((start (match-beginning 0))
- (year (match-string 3))
- (month (string-to-number (match-string 4)))
- (day (string-to-number (match-string 5)))
- (mark (match-string 6))
- (desc (match-string 7)))
- (if (and year (> (length year) 0))
- (setq year (string-to-number year)))
- (funcall callback start
- (encode-time 0 0 0 day month
- (or year current-year))
- mark desc)))))
- (forward-line))))
-
-(defun ledger-time-less-p (t1 t2)
- "Say whether time value T1 is less than time value T2."
- (or (< (car t1) (car t2))
- (and (= (car t1) (car t2))
- (< (nth 1 t1) (nth 1 t2)))))
-
-(defun ledger-time-subtract (t1 t2)
- "Subtract two time values.
-Return the difference in the format of a time value."
- (let ((borrow (< (cadr t1) (cadr t2))))
- (list (- (car t1) (car t2) (if borrow 1 0))
- (- (+ (if borrow 65536 0) (cadr t1)) (cadr t2)))))
-
-(defun ledger-find-slot (moment)
- (catch 'found
- (ledger-iterate-entries
- (function
- (lambda (start date mark desc)
- (if (ledger-time-less-p moment date)
- (throw 'found t)))))))
-
-(defun ledger-add-entry (entry-text &optional insert-at-point)
- (interactive
- (list
- (read-string "Entry: " (concat ledger-year "/" ledger-month "/"))))
- (let* ((args (with-temp-buffer
- (insert entry-text)
- (eshell-parse-arguments (point-min) (point-max))))
- (ledger-buf (current-buffer))
- exit-code)
- (unless insert-at-point
- (let ((date (car args)))
- (if (string-match "\\([0-9]+\\)/\\([0-9]+\\)/\\([0-9]+\\)" date)
- (setq date
- (encode-time 0 0 0 (string-to-number (match-string 3 date))
- (string-to-number (match-string 2 date))
- (string-to-number (match-string 1 date)))))
- (ledger-find-slot date)))
- (save-excursion
- (insert
- (with-temp-buffer
- (setq exit-code
- (apply #'ledger-run-ledger ledger-buf "entry"
- (mapcar 'eval args)))
- (goto-char (point-min))
- (if (looking-at "Error: ")
- (error (buffer-string))
- (buffer-string)))
- "\n"))))
-
-(defun ledger-current-entry-bounds ()
- (save-excursion
- (when (or (looking-at "^[0-9]")
- (re-search-backward "^[0-9]" nil t))
- (let ((beg (point)))
- (while (not (eolp))
- (forward-line))
- (cons (copy-marker beg) (point-marker))))))
-
-(defun ledger-delete-current-entry ()
- (interactive)
- (let ((bounds (ledger-current-entry-bounds)))
- (delete-region (car bounds) (cdr bounds))))
-
-(defun ledger-toggle-current-entry (&optional style)
- (interactive)
- (let (clear)
- (save-excursion
- (when (or (looking-at "^[0-9]")
- (re-search-backward "^[0-9]" nil t))
- (skip-chars-forward "0-9./=")
- (delete-horizontal-space)
- (if (member (char-after) '(?\* ?\!))
- (progn
- (delete-char 1)
- (if (and style (eq style 'cleared))
- (insert " *")))
- (if (and style (eq style 'pending))
- (insert " ! ")
- (insert " * "))
- (setq clear t))))
- clear))
-
-(defun ledger-move-to-next-field ()
- (re-search-forward "\\( \\|\t\\)" (line-end-position) t))
-
-(defun ledger-toggle-state (state &optional style)
- (if (not (null state))
- (if (and style (eq style 'cleared))
- 'cleared)
- (if (and style (eq style 'pending))
- 'pending
- 'cleared)))
-
-(defun ledger-entry-state ()
- (save-excursion
- (when (or (looking-at "^[0-9]")
- (re-search-backward "^[0-9]" nil t))
- (skip-chars-forward "0-9./=")
- (skip-syntax-forward " ")
- (cond ((looking-at "!\\s-*") 'pending)
- ((looking-at "\\*\\s-*") 'cleared)
- (t nil)))))
-
-(defun ledger-transaction-state ()
- (save-excursion
- (goto-char (line-beginning-position))
- (skip-syntax-forward " ")
- (cond ((looking-at "!\\s-*") 'pending)
- ((looking-at "\\*\\s-*") 'cleared)
- (t (ledger-entry-state)))))
-
-(defun ledger-toggle-current-transaction (&optional style)
- "Toggle the cleared status of the transaction under point.
-Optional argument STYLE may be `pending' or `cleared', depending
-on which type of status the caller wishes to indicate (default is
-`cleared').
-This function is rather complicated because it must preserve both
-the overall formatting of the ledger entry, as well as ensuring
-that the most minimal display format is used. This could be
-achieved more certainly by passing the entry to ledger for
-formatting, but doing so causes inline math expressions to be
-dropped."
- (interactive)
- (let ((bounds (ledger-current-entry-bounds))
- clear cleared)
- ;; Uncompact the entry, to make it easier to toggle the
- ;; transaction
- (save-excursion
- (goto-char (car bounds))
- (skip-chars-forward "0-9./= \t")
- (setq cleared (and (member (char-after) '(?\* ?\!))
- (char-after)))
- (when cleared
- (let ((here (point)))
- (skip-chars-forward "*! ")
- (let ((width (- (point) here)))
- (when (> width 0)
- (delete-region here (point))
- (if (search-forward " " (line-end-position) t)
- (insert (make-string width ? ))))))
- (forward-line)
- (while (looking-at "[ \t]")
- (skip-chars-forward " \t")
- (insert cleared " ")
- (if (search-forward " " (line-end-position) t)
- (delete-char 2))
- (forward-line))))
- ;; Toggle the individual transaction
- (save-excursion
- (goto-char (line-beginning-position))
- (when (looking-at "[ \t]")
- (skip-chars-forward " \t")
- (let ((here (point))
- (cleared (member (char-after) '(?\* ?\!))))
- (skip-chars-forward "*! ")
- (let ((width (- (point) here)))
- (when (> width 0)
- (delete-region here (point))
- (save-excursion
- (if (search-forward " " (line-end-position) t)
- (insert (make-string width ? ))))))
- (let (inserted)
- (if cleared
- (if (and style (eq style 'cleared))
- (progn
- (insert "* ")
- (setq inserted t)))
- (if (and style (eq style 'pending))
- (progn
- (insert "! ")
- (setq inserted t))
- (progn
- (insert "* ")
- (setq inserted t))))
- (if (and inserted
- (re-search-forward "\\(\t\\| [ \t]\\)"
- (line-end-position) t))
- (cond
- ((looking-at "\t")
- (delete-char 1))
- ((looking-at " [ \t]")
- (delete-char 2))
- ((looking-at " ")
- (delete-char 1))))
- (setq clear inserted)))))
- ;; Clean up the entry so that it displays minimally
- (save-excursion
- (goto-char (car bounds))
- (forward-line)
- (let ((first t)
- (state ? )
- (hetero nil))
- (while (and (not hetero) (looking-at "[ \t]"))
- (skip-chars-forward " \t")
- (let ((cleared (if (member (char-after) '(?\* ?\!))
- (char-after)
- ? )))
- (if first
- (setq state cleared
- first nil)
- (if (/= state cleared)
- (setq hetero t))))
- (forward-line))
- (when (and (not hetero) (/= state ? ))
- (goto-char (car bounds))
- (forward-line)
- (while (looking-at "[ \t]")
- (skip-chars-forward " \t")
- (let ((here (point)))
- (skip-chars-forward "*! ")
- (let ((width (- (point) here)))
- (when (> width 0)
- (delete-region here (point))
- (if (re-search-forward "\\(\t\\| [ \t]\\)"
- (line-end-position) t)
- (insert (make-string width ? ))))))
- (forward-line))
- (goto-char (car bounds))
- (skip-chars-forward "0-9./= \t")
- (insert state " ")
- (if (re-search-forward "\\(\t\\| [ \t]\\)"
- (line-end-position) t)
- (cond
- ((looking-at "\t")
- (delete-char 1))
- ((looking-at " [ \t]")
- (delete-char 2))
- ((looking-at " ")
- (delete-char 1)))))))
- clear))
-
-(defun ledger-toggle-current (&optional style)
- (interactive)
- (if (or ledger-clear-whole-entries
- (eq 'entry (ledger-thing-at-point)))
- (progn
- (save-excursion
- (forward-line)
- (goto-char (line-beginning-position))
- (while (and (not (eolp))
- (save-excursion
- (not (eq 'entry (ledger-thing-at-point)))))
- (if (looking-at "\\s-+[*!]")
- (ledger-toggle-current-transaction nil))
- (forward-line)
- (goto-char (line-beginning-position))))
- (ledger-toggle-current-entry style))
- (ledger-toggle-current-transaction style)))
-
-(defvar ledger-mode-abbrev-table)
-
-;;;###autoload
-(define-derived-mode ledger-mode text-mode "Ledger"
- "A mode for editing ledger data files.
-
-\\{ledger-mode-map}"
- (set (make-local-variable 'comment-start) " ; ")
- (set (make-local-variable 'comment-end) "")
- (set (make-local-variable 'indent-tabs-mode) nil)
-
- (if (boundp 'font-lock-defaults)
- (set (make-local-variable 'font-lock-defaults)
- '(ledger-font-lock-keywords nil t)))
-
- (set (make-local-variable 'pcomplete-parse-arguments-function)
- 'ledger-parse-arguments)
- (set (make-local-variable 'pcomplete-command-completion-function)
- 'ledger-complete-at-point)
- (set (make-local-variable 'pcomplete-termination-string) "")
-
- (let ((map (current-local-map)))
- (define-key map [(control ?c) (control ?a)] 'ledger-add-entry)
- (define-key map [(control ?c) (control ?d)] 'ledger-delete-current-entry)
- (define-key map [(control ?c) (control ?y)] 'ledger-set-year)
- (define-key map [(control ?c) (control ?m)] 'ledger-set-month)
- (define-key map [(control ?c) (control ?c)] 'ledger-toggle-current)
- (define-key map [(control ?c) (control ?e)] 'ledger-toggle-current-entry)
- (define-key map [(control ?c) (control ?r)] 'ledger-reconcile)
- (define-key map [(control ?c) (control ?s)] 'ledger-sort)
- (define-key map [tab] 'pcomplete)
- (define-key map [(control ?i)] 'pcomplete)
- (define-key map [(control ?c) tab] 'ledger-fully-complete-entry)
- (define-key map [(control ?c) (control ?i)] 'ledger-fully-complete-entry)
- (define-key map [(control ?c) (control ?o) (control ?r)] 'ledger-report)
- (define-key map [(control ?c) (control ?o) (control ?g)] 'ledger-report-goto)
- (define-key map [(control ?c) (control ?o) (control ?a)] 'ledger-report-redo)
- (define-key map [(control ?c) (control ?o) (control ?s)] 'ledger-report-save)
- (define-key map [(control ?c) (control ?o) (control ?e)] 'ledger-report-edit)
- (define-key map [(control ?c) (control ?o) (control ?k)] 'ledger-report-kill)))
-
-;; Reconcile mode
-
-(defvar ledger-buf nil)
-(defvar ledger-acct nil)
-
-(defun ledger-display-balance ()
- (let ((buffer ledger-buf)
- (account ledger-acct))
- (with-temp-buffer
- (let ((exit-code (ledger-run-ledger buffer "-C" "balance" account)))
- (if (/= 0 exit-code)
- (message "Error determining cleared balance")
- (goto-char (1- (point-max)))
- (goto-char (line-beginning-position))
- (delete-horizontal-space)
- (message "Cleared balance = %s"
- (buffer-substring-no-properties (point)
- (line-end-position))))))))
-
-(defun ledger-reconcile-toggle ()
- (interactive)
- (let ((where (get-text-property (point) 'where))
- (account ledger-acct)
- (inhibit-read-only t)
- cleared)
- (when (or (equal (car where) "<stdin>") (equal (car where) "/dev/stdin"))
- (with-current-buffer ledger-buf
- (goto-char (cdr where))
- (setq cleared (ledger-toggle-current 'pending)))
- (if cleared
- (add-text-properties (line-beginning-position)
- (line-end-position)
- (list 'face 'bold))
- (remove-text-properties (line-beginning-position)
- (line-end-position)
- (list 'face))))
- (forward-line)))
-
-(defun ledger-reconcile-refresh ()
- (interactive)
- (let ((inhibit-read-only t)
- (line (count-lines (point-min) (point))))
- (erase-buffer)
- (ledger-do-reconcile)
- (set-buffer-modified-p t)
- (goto-char (point-min))
- (forward-line line)))
-
-(defun ledger-reconcile-refresh-after-save ()
- (let ((buf (get-buffer "*Reconcile*")))
- (if buf
- (with-current-buffer buf
- (ledger-reconcile-refresh)
- (set-buffer-modified-p nil)))))
-
-(defun ledger-reconcile-add ()
- (interactive)
- (with-current-buffer ledger-buf
- (call-interactively #'ledger-add-entry))
- (ledger-reconcile-refresh))
-
-(defun ledger-reconcile-delete ()
- (interactive)
- (let ((where (get-text-property (point) 'where)))
- (when (or (equal (car where) "<stdin>") (equal (car where) "/dev/stdin"))
- (with-current-buffer ledger-buf
- (goto-char (cdr where))
- (ledger-delete-current-entry))
- (let ((inhibit-read-only t))
- (goto-char (line-beginning-position))
- (delete-region (point) (1+ (line-end-position)))
- (set-buffer-modified-p t)))))
-
-(defun ledger-reconcile-visit ()
- (interactive)
- (let ((where (get-text-property (point) 'where)))
- (when (markerp (cdr where))
- (switch-to-buffer-other-window ledger-buf)
- (goto-char (cdr where)))))
-
-(defun ledger-reconcile-save ()
- (interactive)
- (with-current-buffer ledger-buf
- (save-buffer))
- (set-buffer-modified-p nil)
- (ledger-display-balance))
-
-(defun ledger-reconcile-quit ()
- (interactive)
- (kill-buffer (current-buffer)))
-
-(defun ledger-reconcile-finish ()
- (interactive)
- (save-excursion
- (goto-char (point-min))
- (while (not (eobp))
- (let ((where (get-text-property (point) 'where))
- (face (get-text-property (point) 'face)))
- (if (and (eq face 'bold)
- (or (equal (car where) "<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" "--real"
- "emacs" account)))
- (when (= 0 exit-code)
- (goto-char (point-min))
- (unless (eobp)
- (unless (looking-at "(")
- (error (buffer-string)))
- (read (current-buffer))))))))
- (dolist (item items)
- (let ((index 1))
- (dolist (xact (nthcdr 5 item))
- (let ((beg (point))
- (where
- (with-current-buffer buf
- (cons
- (nth 0 item)
- (if ledger-clear-whole-entries
- (save-excursion
- (goto-line (nth 1 item))
- (point-marker))
- (save-excursion
- (goto-line (nth 0 xact))
- (point-marker)))))))
- (insert (format "%s %-30s %-25s %15s\n"
- (format-time-string "%m/%d" (nth 2 item))
- (nth 4 item) (nth 1 xact) (nth 2 xact)))
- (if (nth 3 xact)
- (set-text-properties beg (1- (point))
- (list 'face 'bold
- 'where where))
- (set-text-properties beg (1- (point))
- (list 'where where))))
- (setq index (1+ index)))))
- (goto-char (point-min))
- (set-buffer-modified-p nil)
- (toggle-read-only t)))
-
-(defun ledger-reconcile (account)
- (interactive "sAccount to reconcile: ")
- (let ((buf (current-buffer))
- (rbuf (get-buffer "*Reconcile*")))
- (if rbuf
- (kill-buffer rbuf))
- (add-hook 'after-save-hook 'ledger-reconcile-refresh-after-save)
- (with-current-buffer
- (pop-to-buffer (get-buffer-create "*Reconcile*"))
- (ledger-reconcile-mode)
- (set (make-local-variable 'ledger-buf) buf)
- (set (make-local-variable 'ledger-acct) account)
- (ledger-do-reconcile))))
-
-(defvar ledger-reconcile-mode-abbrev-table)
-
-(defvar ledger-reconcile-mode-map
- (let ((map (make-sparse-keymap)))
- (define-key map [(control ?m)] 'ledger-reconcile-visit)
- (define-key map [return] 'ledger-reconcile-visit)
- (define-key map [(control ?c) (control ?c)] 'ledger-reconcile-finish)
- (define-key map [(control ?x) (control ?s)] 'ledger-reconcile-save)
- (define-key map [(control ?l)] 'ledger-reconcile-refresh)
- (define-key map [? ] 'ledger-reconcile-toggle)
- (define-key map [?a] 'ledger-reconcile-add)
- (define-key map [?d] 'ledger-reconcile-delete)
- (define-key map [?n] 'next-line)
- (define-key map [?p] 'previous-line)
- (define-key map [?s] 'ledger-reconcile-save)
- (define-key map [?q] 'ledger-reconcile-quit)
- map))
-
-(define-derived-mode ledger-reconcile-mode text-mode "Reconcile"
- "A mode for reconciling ledger entries.
-
-\\{ledger-reconcile-mode-map}")
-
-;; Context sensitivity
-
-(defconst ledger-line-config
- '((entry
- (("^\\(\\([0-9][0-9][0-9][0-9]/\\)?[01]?[0-9]/[0123]?[0-9]\\)[ \t]+\\(\\([!*]\\)[ \t]\\)?[ \t]*\\((\\(.*\\))\\)?[ \t]*\\(.*?\\)[ \t]*;\\(.*\\)[ \t]*$"
- (date nil status nil nil code payee comment))
- ("^\\(\\([0-9][0-9][0-9][0-9]/\\)?[01]?[0-9]/[0123]?[0-9]\\)[ \t]+\\(\\([!*]\\)[ \t]\\)?[ \t]*\\((\\(.*\\))\\)?[ \t]*\\(.*\\)[ \t]*$"
- (date nil status nil nil code payee))))
- (acct-transaction
- (("\\(^[ \t]+\\)\\(.*?\\)[ \t]+\\([$]\\)\\(-?[0-9]*\\(\\.[0-9]*\\)?\\)[ \t]*;[ \t]*\\(.*?\\)[ \t]*$"
- (indent account commodity amount nil comment))
- ("\\(^[ \t]+\\)\\(.*?\\)[ \t]+\\([$]\\)\\(-?[0-9]*\\(\\.[0-9]*\\)?\\)[ \t]*$"
- (indent account commodity amount nil))
- ("\\(^[ \t]+\\)\\(.*?\\)[ \t]+\\(-?[0-9]+\\(\\.[0-9]*\\)?\\)[ \t]+\\(.*?\\)[ \t]*;[ \t]*\\(.*?\\)[ \t]*$"
- (indent account amount nil commodity comment))
- ("\\(^[ \t]+\\)\\(.*?\\)[ \t]+\\(-?[0-9]+\\(\\.[0-9]*\\)?\\)[ \t]+\\(.*?\\)[ \t]*$"
- (indent account amount nil commodity))
- ("\\(^[ \t]+\\)\\(.*?\\)[ \t]+\\(-?\\(\\.[0-9]*\\)\\)[ \t]+\\(.*?\\)[ \t]*;[ \t]*\\(.*?\\)[ \t]*$"
- (indent account amount nil commodity comment))
- ("\\(^[ \t]+\\)\\(.*?\\)[ \t]+\\(-?\\(\\.[0-9]*\\)\\)[ \t]+\\(.*?\\)[ \t]*$"
- (indent account amount nil commodity))
- ("\\(^[ \t]+\\)\\(.*?\\)[ \t]*;[ \t]*\\(.*?\\)[ \t]*$"
- (indent account comment))
- ("\\(^[ \t]+\\)\\(.*?\\)[ \t]*$"
- (indent account))))))
-
-(defun ledger-extract-context-info (line-type pos)
- "Get context info for current line.
-
-Assumes point is at beginning of line, and the pos argument specifies
-where the \"users\" point was."
- (let ((linfo (assoc line-type ledger-line-config))
- found field fields)
- (dolist (re-info (nth 1 linfo))
- (let ((re (nth 0 re-info))
- (names (nth 1 re-info)))
- (unless found
- (when (looking-at re)
- (setq found t)
- (dotimes (i (length names))
- (when (nth i names)
- (setq fields (append fields
- (list
- (list (nth i names)
- (match-string-no-properties (1+ i))
- (match-beginning (1+ i))))))))
- (dolist (f fields)
- (and (nth 1 f)
- (>= pos (nth 2 f))
- (setq field (nth 0 f))))))))
- (list line-type field fields)))
-
-(defun ledger-context-at-point ()
- "Return a list describing the context around point.
-
-The contents of the list are the line type, the name of the field
-point containing point, and for selected line types, the content of
-the fields in the line in a association list."
- (let ((pos (point)))
- (save-excursion
- (beginning-of-line)
- (let ((first-char (char-after)))
- (cond ((equal (point) (line-end-position))
- '(empty-line nil nil))
- ((memq first-char '(?\ ?\t))
- (ledger-extract-context-info 'acct-transaction pos))
- ((memq first-char '(?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9))
- (ledger-extract-context-info 'entry pos))
- ((equal first-char ?\=)
- '(automated-entry nil nil))
- ((equal first-char ?\~)
- '(period-entry nil nil))
- ((equal first-char ?\!)
- '(command-directive))
- ((equal first-char ?\;)
- '(comment nil nil))
- ((equal first-char ?Y)
- '(default-year nil nil))
- ((equal first-char ?P)
- '(commodity-price nil nil))
- ((equal first-char ?N)
- '(price-ignored-commodity nil nil))
- ((equal first-char ?D)
- '(default-commodity nil nil))
- ((equal first-char ?C)
- '(commodity-conversion nil nil))
- ((equal first-char ?i)
- '(timeclock-i nil nil))
- ((equal first-char ?o)
- '(timeclock-o nil nil))
- ((equal first-char ?b)
- '(timeclock-b nil nil))
- ((equal first-char ?h)
- '(timeclock-h nil nil))
- (t
- '(unknown nil nil)))))))
-
-(defun ledger-context-other-line (offset)
- "Return a list describing context of line offset for existing position.
-
-Offset can be positive or negative. If run out of buffer before reaching
-specified line, returns nil."
- (save-excursion
- (let ((left (forward-line offset)))
- (if (not (equal left 0))
- nil
- (ledger-context-at-point)))))
-
-(defun ledger-context-line-type (context-info)
- (nth 0 context-info))
-
-(defun ledger-context-current-field (context-info)
- (nth 1 context-info))
-
-(defun ledger-context-field-info (context-info field-name)
- (assoc field-name (nth 2 context-info)))
-
-(defun ledger-context-field-present-p (context-info field-name)
- (not (null (ledger-context-field-info context-info field-name))))
-
-(defun ledger-context-field-value (context-info field-name)
- (nth 1 (ledger-context-field-info context-info field-name)))
-
-(defun ledger-context-field-position (context-info field-name)
- (nth 2 (ledger-context-field-info context-info field-name)))
-
-(defun ledger-context-field-end-position (context-info field-name)
- (+ (ledger-context-field-position context-info field-name)
- (length (ledger-context-field-value context-info field-name))))
-
-(defun ledger-context-goto-field-start (context-info field-name)
- (goto-char (ledger-context-field-position context-info field-name)))
-
-(defun ledger-context-goto-field-end (context-info field-name)
- (goto-char (ledger-context-field-end-position context-info field-name)))
-
-(defun ledger-entry-payee ()
- "Returns the payee of the entry containing point or nil."
- (let ((i 0))
- (while (eq (ledger-context-line-type (ledger-context-other-line i)) 'acct-transaction)
- (setq i (- i 1)))
- (let ((context-info (ledger-context-other-line i)))
- (if (eq (ledger-context-line-type context-info) 'entry)
- (ledger-context-field-value context-info 'payee)
- nil))))
-
-;; Ledger report mode
-
-(defvar ledger-report-buffer-name "*Ledger Report*")
-
-(defvar ledger-report-name nil)
-(defvar ledger-report-cmd nil)
-(defvar ledger-report-name-prompt-history nil)
-(defvar ledger-report-cmd-prompt-history nil)
-(defvar ledger-original-window-cfg nil)
-
-(defvar ledger-report-mode-abbrev-table)
-
-(defvar ledger-report-mode-map
- (let ((map (make-sparse-keymap)))
- (define-key map [? ] 'scroll-up)
- (define-key map [backspace] 'scroll-down)
- (define-key map [?r] 'ledger-report-redo)
- (define-key map [?s] 'ledger-report-save)
- (define-key map [?k] 'ledger-report-kill)
- (define-key map [?e] 'ledger-report-edit)
- (define-key map [?q] 'ledger-report-quit)
- (define-key map [(control ?c) (control ?l) (control ?r)]
- 'ledger-report-redo)
- (define-key map [(control ?c) (control ?l) (control ?S)]
- 'ledger-report-save)
- (define-key map [(control ?c) (control ?l) (control ?k)]
- 'ledger-report-kill)
- (define-key map [(control ?c) (control ?l) (control ?e)]
- 'ledger-report-edit)
- map))
-
-(define-derived-mode ledger-report-mode text-mode "Ledger-Report"
- "A mode for viewing ledger reports.")
-
-(defun ledger-report-read-name ()
- "Read the name of a ledger report to use, with completion.
-
-The empty string and unknown names are allowed."
- (completing-read "Report name: "
- ledger-reports nil nil nil
- 'ledger-report-name-prompt-history nil))
-
-(defun ledger-report (report-name edit)
- "Run a user-specified report from `ledger-reports'.
-
-Prompts the user for the name of the report to run. If no name is
-entered, the user will be prompted for a command line to run. The
-command line specified or associated with the selected report name
-is run and the output is made available in another buffer for viewing.
-If a prefix argument is given and the user selects a valid report
-name, the user is prompted with the corresponding command line for
-editing before the command is run.
-
-The output buffer will be in `ledger-report-mode', which defines
-commands for saving a new named report based on the command line
-used to generate the buffer, navigating the buffer, etc."
- (interactive
- (progn
- (when (and (buffer-modified-p)
- (y-or-n-p "Buffer modified, save it? "))
- (save-buffer))
- (let ((rname (ledger-report-read-name))
- (edit (not (null current-prefix-arg))))
- (list rname edit))))
- (let ((buf (current-buffer))
- (rbuf (get-buffer ledger-report-buffer-name))
- (wcfg (current-window-configuration)))
- (if rbuf
- (kill-buffer rbuf))
- (with-current-buffer
- (pop-to-buffer (get-buffer-create ledger-report-buffer-name))
- (ledger-report-mode)
- (set (make-local-variable 'ledger-buf) buf)
- (set (make-local-variable 'ledger-report-name) report-name)
- (set (make-local-variable 'ledger-original-window-cfg) wcfg)
- (ledger-do-report (ledger-report-cmd report-name edit))
- (shrink-window-if-larger-than-buffer)
- (set-buffer-modified-p nil)
- (setq buffer-read-only t)
- (message "q to quit; r to redo; e to edit; k to kill; s to save; SPC and DEL to scroll"))))
-
-(defun string-empty-p (s)
- "Check for the empty string."
- (string-equal "" s))
-
-(defun ledger-report-name-exists (name)
- "Check to see if the given report name exists.
-
-If name exists, returns the object naming the report, otherwise returns nil."
- (unless (string-empty-p name)
- (car (assoc name ledger-reports))))
-
-(defun ledger-reports-add (name cmd)
- "Add a new report to `ledger-reports'."
- (setq ledger-reports (cons (list name cmd) ledger-reports)))
-
-(defun ledger-reports-custom-save ()
- "Save the `ledger-reports' variable using the customize framework."
- (customize-save-variable 'ledger-reports ledger-reports))
-
-(defun ledger-report-read-command (report-cmd)
- "Read the command line to create a report."
- (read-from-minibuffer "Report command line: "
- (if (null report-cmd) "ledger " report-cmd)
- nil nil 'ledger-report-cmd-prompt-history))
-
-(defun ledger-report-ledger-file-format-specifier ()
- "Substitute the full path to master or current ledger file
-
-The master file name is determined by the ledger-master-file buffer-local
-variable which can be set using file variables. If it is set, it is used,
-otherwise the current buffer file is used."
- (ledger-master-file))
-
-(defun ledger-read-string-with-default (prompt default)
- (let ((default-prompt (concat prompt
- (if default
- (concat " (" default "): ")
- ": "))))
- (read-string default-prompt nil nil default)))
-
-(defun ledger-report-payee-format-specifier ()
- "Substitute a payee name
-
-The user is prompted to enter a payee and that is substitued. If
-point is in an entry, the payee for that entry is used as the
-default."
- ;; It is intended copmletion should be available on existing
- ;; payees, but the list of possible completions needs to be
- ;; developed to allow this.
- (ledger-read-string-with-default "Payee" (regexp-quote (ledger-entry-payee))))
-
-(defun ledger-report-account-format-specifier ()
- "Substitute an account name
-
-The user is prompted to enter an account name, which can be any
-regular expression identifying an account. If point is on an account
-transaction line for an entry, the full account name on that line is
-the default."
- ;; It is intended completion should be available on existing account
- ;; names, but it remains to be implemented.
- (let* ((context (ledger-context-at-point))
- (default
- (if (eq (ledger-context-line-type context) 'acct-transaction)
- (regexp-quote (ledger-context-field-value context 'account))
- nil)))
- (ledger-read-string-with-default "Account" default)))
-
-(defun ledger-report-expand-format-specifiers (report-cmd)
- (let ((expanded-cmd report-cmd))
- (while (string-match "%(\\([^)]*\\))" expanded-cmd)
- (let* ((specifier (match-string 1 expanded-cmd))
- (f (cdr (assoc specifier ledger-report-format-specifiers))))
- (if f
- (setq expanded-cmd (replace-match
- (save-match-data
- (with-current-buffer ledger-buf
- (shell-quote-argument (funcall f))))
- t t expanded-cmd))
- (progn
- (set-window-configuration ledger-original-window-cfg)
- (error "Invalid ledger report format specifier '%s'" specifier)))))
- expanded-cmd))
-
-(defun ledger-report-cmd (report-name edit)
- "Get the command line to run the report."
- (let ((report-cmd (car (cdr (assoc report-name ledger-reports)))))
- ;; logic for substitution goes here
- (when (or (null report-cmd) edit)
- (setq report-cmd (ledger-report-read-command report-cmd)))
- (setq report-cmd (ledger-report-expand-format-specifiers report-cmd))
- (set (make-local-variable 'ledger-report-cmd) report-cmd)
- (or (string-empty-p report-name)
- (ledger-report-name-exists report-name)
- (ledger-reports-add report-name report-cmd)
- (ledger-reports-custom-save))
- report-cmd))
-
-(defun ledger-do-report (cmd)
- "Run a report command line."
- (goto-char (point-min))
- (insert (format "Report: %s\n" ledger-report-name)
- (format "Command: %s\n" cmd)
- (make-string (- (window-width) 1) ?=)
- "\n")
- (shell-command cmd t nil))
-
-(defun ledger-report-goto ()
- "Goto the ledger report buffer."
- (interactive)
- (let ((rbuf (get-buffer ledger-report-buffer-name)))
- (if (not rbuf)
- (error "There is no ledger report buffer"))
- (pop-to-buffer rbuf)
- (shrink-window-if-larger-than-buffer)))
-
-(defun ledger-report-redo ()
- "Redo the report in the current ledger report buffer."
- (interactive)
- (ledger-report-goto)
- (setq buffer-read-only nil)
- (erase-buffer)
- (ledger-do-report ledger-report-cmd)
- (setq buffer-read-only nil))
-
-(defun ledger-report-quit ()
- "Quit the ledger report buffer by burying it."
- (interactive)
- (ledger-report-goto)
- (set-window-configuration ledger-original-window-cfg)
- (bury-buffer (get-buffer ledger-report-buffer-name)))
-
-(defun ledger-report-kill ()
- "Kill the ledger report buffer."
- (interactive)
- (ledger-report-quit)
- (kill-buffer (get-buffer ledger-report-buffer-name)))
-
-(defun ledger-report-edit ()
- "Edit the defined ledger reports."
- (interactive)
- (customize-variable 'ledger-reports))
-
-(defun ledger-report-read-new-name ()
- "Read the name for a new report from the minibuffer."
- (let ((name ""))
- (while (string-empty-p name)
- (setq name (read-from-minibuffer "Report name: " nil nil nil
- 'ledger-report-name-prompt-history)))
- name))
-
-(defun ledger-report-save ()
- "Save the current report command line as a named report."
- (interactive)
- (ledger-report-goto)
- (let (existing-name)
- (when (string-empty-p ledger-report-name)
- (setq ledger-report-name (ledger-report-read-new-name)))
-
- (while (setq existing-name (ledger-report-name-exists ledger-report-name))
- (cond ((y-or-n-p (format "Overwrite existing report named '%s' "
- ledger-report-name))
- (when (string-equal
- ledger-report-cmd
- (car (cdr (assq existing-name ledger-reports))))
- (error "Current command is identical to existing saved one"))
- (setq ledger-reports
- (assq-delete-all existing-name ledger-reports)))
- (t
- (setq ledger-report-name (ledger-report-read-new-name)))))
-
- (ledger-reports-add ledger-report-name ledger-report-cmd)
- (ledger-reports-custom-save)))
-
-;; In-place completion support
-
-(defun ledger-thing-at-point ()
- (let ((here (point)))
- (goto-char (line-beginning-position))
- (cond ((looking-at "^[0-9/.=-]+\\(\\s-+\\*\\)?\\(\\s-+(.+?)\\)?\\s-+")
- (goto-char (match-end 0))
- 'entry)
- ((looking-at "^\\s-+\\([*!]\\s-+\\)?[[(]?\\(.\\)")
- (goto-char (match-beginning 2))
- 'transaction)
- ((looking-at "^\\(sun\\|mon\\|tue\\|wed\\|thu\\|fri\\|sat\\)\\s-+")
- (goto-char (match-end 0))
- 'entry)
- (t
- (ignore (goto-char here))))))
-
-(defun ledger-parse-arguments ()
- "Parse whitespace separated arguments in the current region."
- (let* ((info (save-excursion
- (cons (ledger-thing-at-point) (point))))
- (begin (cdr info))
- (end (point))
- begins args)
- (save-excursion
- (goto-char begin)
- (when (< (point) end)
- (skip-chars-forward " \t\n")
- (setq begins (cons (point) begins))
- (setq args (cons (buffer-substring-no-properties
- (car begins) end)
- args)))
- (cons (reverse args) (reverse begins)))))
-
-(defun ledger-entries ()
- (let ((origin (point))
- entries-list)
- (save-excursion
- (goto-char (point-min))
- (while (re-search-forward
- (concat "^[0-9/.=-]+\\(\\s-+\\*\\)?\\(\\s-+(.*?)\\)?\\s-+"
- "\\(.+?\\)\\(\t\\|\n\\| [ \t]\\)") nil t)
- (unless (and (>= origin (match-beginning 0))
- (< origin (match-end 0)))
- (setq entries-list (cons (match-string-no-properties 3)
- entries-list)))))
- (pcomplete-uniqify-list (nreverse entries-list))))
-
-(defvar ledger-account-tree nil)
-
-(defun ledger-find-accounts ()
- (let ((origin (point)) account-path elements)
- (save-excursion
- (setq ledger-account-tree (list t))
- (goto-char (point-min))
- (while (re-search-forward
- "^[ \t]+\\([*!]\\s-+\\)?[[(]?\\(.+?\\)\\(\t\\|\n\\| [ \t]\\)" nil t)
- (unless (and (>= origin (match-beginning 0))
- (< origin (match-end 0)))
- (setq account-path (match-string-no-properties 2))
- (setq elements (split-string account-path ":"))
- (let ((root ledger-account-tree))
- (while elements
- (let ((entry (assoc (car elements) root)))
- (if entry
- (setq root (cdr entry))
- (setq entry (cons (car elements) (list t)))
- (nconc root (list entry))
- (setq root (cdr entry))))
- (setq elements (cdr elements)))))))))
-
-(defun ledger-accounts ()
- (ledger-find-accounts)
- (let* ((current (caar (ledger-parse-arguments)))
- (elements (and current (split-string current ":")))
- (root ledger-account-tree)
- (prefix nil))
- (while (cdr elements)
- (let ((entry (assoc (car elements) root)))
- (if entry
- (setq prefix (concat prefix (and prefix ":")
- (car elements))
- root (cdr entry))
- (setq root nil elements nil)))
- (setq elements (cdr elements)))
- (and root
- (sort
- (mapcar (function
- (lambda (x)
- (let ((term (if prefix
- (concat prefix ":" (car x))
- (car x))))
- (if (> (length (cdr x)) 1)
- (concat term ":")
- term))))
- (cdr root))
- 'string-lessp))))
-
-(defun ledger-complete-at-point ()
- "Do appropriate completion for the thing at point"
- (interactive)
- (while (pcomplete-here
- (if (eq (save-excursion
- (ledger-thing-at-point)) 'entry)
- (if (null current-prefix-arg)
- (ledger-entries) ; this completes against entry names
- (progn
- (let ((text (buffer-substring (line-beginning-position)
- (line-end-position))))
- (delete-region (line-beginning-position)
- (line-end-position))
- (condition-case err
- (ledger-add-entry text t)
- ((error)
- (insert text))))
- (forward-line)
- (goto-char (line-end-position))
- (search-backward ";" (line-beginning-position) t)
- (skip-chars-backward " \t0123456789.,")
- (throw 'pcompleted t)))
- (ledger-accounts)))))
-
-(defun ledger-fully-complete-entry ()
- "Do appropriate completion for the thing at point"
- (interactive)
- (let ((name (caar (ledger-parse-arguments)))
- xacts)
- (save-excursion
- (when (eq 'entry (ledger-thing-at-point))
- (when (re-search-backward
- (concat "^[0-9/.=-]+\\(\\s-+\\*\\)?\\(\\s-+(.*?)\\)?\\s-+"
- (regexp-quote name) "\\(\t\\|\n\\| [ \t]\\)") nil t)
- (forward-line)
- (while (looking-at "^\\s-+")
- (setq xacts (cons (buffer-substring-no-properties
- (line-beginning-position)
- (line-end-position))
- xacts))
- (forward-line))
- (setq xacts (nreverse xacts)))))
- (when xacts
- (save-excursion
- (insert ?\n)
- (while xacts
- (insert (car xacts) ?\n)
- (setq xacts (cdr xacts))))
- (forward-line)
- (goto-char (line-end-position))
- (if (re-search-backward "\\(\t\\| [ \t]\\)" nil t)
- (goto-char (match-end 0))))))
-
-;; A sample function for $ users
-
-(defun ledger-next-amount (&optional end)
- (when (re-search-forward "\\( \\|\t\\| \t\\)[ \t]*-?\\([A-Z$€£]+ *\\)?\\(-?[0-9,]+?\\)\\(.[0-9]+\\)?\\( *[A-Z$€£]+\\)?\\([ \t]*@@?[^\n;]+?\\)?\\([ \t]+;.+?\\)?$" (marker-position end) t)
- (goto-char (match-beginning 0))
- (skip-syntax-forward " ")
- (- (or (match-end 4)
- (match-end 3)) (point))))
-
-(defun ledger-align-amounts (&optional column)
- "Align amounts in the current region.
-This is done so that the last digit falls in COLUMN, which defaults to 52."
- (interactive "p")
- (if (or (null column) (= column 1))
- (setq column 52))
- (save-excursion
- (let* ((mark-first (< (mark) (point)))
- (begin (if mark-first (mark) (point)))
- (end (if mark-first (point-marker) (mark-marker)))
- offset)
- (goto-char begin)
- (while (setq offset (ledger-next-amount end))
- (let ((col (current-column))
- (target-col (- column offset))
- adjust)
- (setq adjust (- target-col col))
- (if (< col target-col)
- (insert (make-string (- target-col col) ? ))
- (move-to-column target-col)
- (if (looking-back " ")
- (delete-char (- col target-col))
- (skip-chars-forward "^ \t")
- (delete-horizontal-space)
- (insert " ")))
- (forward-line))))))
-
-(defalias 'ledger-align-dollars 'ledger-align-amounts)
-
-;; A sample entry sorting function, which works if entry dates are of
-;; the form YYYY/mm/dd.
-
-(defun ledger-sort ()
- (interactive)
- (save-excursion
- (goto-char (point-min))
- (sort-subr
- nil
- (function
- (lambda ()
- (if (re-search-forward
- (concat "^[0-9/.=-]+\\(\\s-+\\*\\)?\\(\\s-+(.*?)\\)?\\s-+"
- "\\(.+?\\)\\(\t\\|\n\\| [ \t]\\)") nil t)
- (goto-char (match-beginning 0))
- (goto-char (point-max)))))
- (function
- (lambda ()
- (forward-paragraph))))))
-
-;; General helper functions
-
-(defvar ledger-delete-after nil)
-
-(defun ledger-run-ledger (buffer &rest args)
- "run ledger with supplied arguments"
- ;; Let's try again, just in case they moved it while we were sleeping.
- (cond
- ((null ledger-binary-path)
- (error "The variable `ledger-binary-path' has not been set"))
- (t
- (let ((buf (current-buffer)))
- (with-current-buffer buffer
- (let ((coding-system-for-write 'utf-8)
- (coding-system-for-read 'utf-8))
- (apply #'call-process-region
- (append (list (point-min) (point-max)
- ledger-binary-path ledger-delete-after
- buf nil "-f" "-")
- args))))))))
-
-(defun ledger-run-ledger-and-delete (buffer &rest args)
- (let ((ledger-delete-after t))
- (apply #'ledger-run-ledger buffer args)))
-
-(defun ledger-set-year (newyear)
- "Set ledger's idea of the current year to the prefix argument."
- (interactive "p")
- (if (= newyear 1)
- (setq ledger-year (read-string "Year: " (ledger-current-year)))
- (setq ledger-year (number-to-string newyear))))
-
-(defun ledger-set-month (newmonth)
- "Set ledger's idea of the current month to the prefix argument."
- (interactive "p")
- (if (= newmonth 1)
- (setq ledger-month (read-string "Month: " (ledger-current-month)))
- (setq ledger-month (format "%02d" newmonth))))
-
-(defvar ledger-master-file nil)
-
-(defun ledger-master-file ()
- "Return the master file for a ledger file.
-
-The master file is either the file for the current ledger buffer or the
-file specified by the buffer-local variable ledger-master-file. Typically
-this variable would be set in a file local variable comment block at the
-end of a ledger file which is included in some other file."
- (if ledger-master-file
- (expand-file-name ledger-master-file)
- (buffer-file-name)))
-
-(easy-menu-define ledger-menu ledger-mode-map
- "Ledger menu"
- '("Ledger"
- ["New entry" ledger-add-entry t]
- ["Toggle cleared status of current entry" ledger-toggle-current-entry t]
- ["Set default year for entry" ledger-set-year t]
- ["Set default month for entry" ledger-set-month t]
- "--"
- ["Reconcile uncleared entries for account" ledger-reconcile t]
- "--"
- "Reports"
- ["Run a report" ledger-report t]
- ["Go to report buffer" ledger-report-goto t]
- ["Edit defined reports" ledger-report-edit t]
- ["Save report definition" ledger-report-save t]
- ["Re-run ledger report" ledger-report-redo t]
- ["Kill report buffer" ledger-report-kill t]))
-
-(provide 'ledger)
-
-;;; ledger.el ends here
diff --git a/lisp/timeclock.el b/lisp/timeclock.el
deleted file mode 100644
index 2cafa8eb..00000000
--- a/lisp/timeclock.el
+++ /dev/null
@@ -1,1362 +0,0 @@
-;;; timeclock.el --- mode for keeping track of how much you work
-
-;; Copyright (C) 1999, 2000, 2001, 2003, 2004 Free Software Foundation, Inc.
-
-;; Author: John Wiegley <johnw@gnu.org>
-;; Created: 25 Mar 1999
-;; Version: 2.6
-;; Keywords: calendar data
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
-
-;;; Commentary:
-
-;; This mode is for keeping track of time intervals. You can use it
-;; for whatever purpose you like, but the typical scenario is to keep
-;; track of how much time you spend working on certain projects.
-;;
-;; Use `timeclock-in' when you start on a project, and `timeclock-out'
-;; when you're done. Once you've collected some data, you can use
-;; `timeclock-workday-remaining' to see how much time is left to be
-;; worked today (where `timeclock-workday' specifies the length of the
-;; working day), and `timeclock-when-to-leave' to calculate when you're free.
-
-;; You'll probably want to bind the timeclock commands to some handy
-;; keystrokes. At the moment, C-x t is unused:
-;;
-;; (require 'timeclock)
-;;
-;; (define-key ctl-x-map "ti" 'timeclock-in)
-;; (define-key ctl-x-map "to" 'timeclock-out)
-;; (define-key ctl-x-map "tc" 'timeclock-change)
-;; (define-key ctl-x-map "tr" 'timeclock-reread-log)
-;; (define-key ctl-x-map "tu" 'timeclock-update-modeline)
-;; (define-key ctl-x-map "tw" 'timeclock-when-to-leave-string)
-
-;; If you want Emacs to display the amount of time "left" to your
-;; workday in the modeline, you can either set the value of
-;; `timeclock-modeline-display' to t using M-x customize, or you
-;; can add this code to your .emacs file:
-;;
-;; (require 'timeclock)
-;; (timeclock-modeline-display)
-;;
-;; To cancel this modeline display at any time, just call
-;; `timeclock-modeline-display' again.
-
-;; You may also want Emacs to ask you before exiting, if you are
-;; currently working on a project. This can be done either by setting
-;; `timeclock-ask-before-exiting' to t using M-x customize (this is
-;; the default), or by adding the following to your .emacs file:
-;;
-;; (add-hook 'kill-emacs-query-functions 'timeclock-query-out)
-
-;; NOTE: If you change your .timelog file without using timeclock's
-;; functions, or if you change the value of any of timeclock's
-;; customizable variables, you should run the command
-;; `timeclock-reread-log'. This will recompute any discrepancies in
-;; your average working time, and will make sure that the various
-;; display functions return the correct value.
-
-;;; History:
-
-;;; Code:
-
-(defgroup timeclock nil
- "Keeping track time of the time that gets spent."
- :group 'data)
-
-;;; User Variables:
-
-(defcustom timeclock-file (convert-standard-filename "~/.timelog")
- "*The file used to store timeclock data in."
- :type 'file
- :group 'timeclock)
-
-(defcustom timeclock-workday (* 8 60 60)
- "*The length of a work period."
- :type 'integer
- :group 'timeclock)
-
-(defcustom timeclock-relative t
- "*Whether to maken reported time relative to `timeclock-workday'.
-For example, if the length of a normal workday is eight hours, and you
-work four hours on Monday, then the amount of time \"remaining\" on
-Tuesday is twelve hours -- relative to an averaged work period of
-eight hours -- or eight hours, non-relative. So relative time takes
-into account any discrepancy of time under-worked or over-worked on
-previous days. This only affects the timeclock modeline display."
- :type 'boolean
- :group 'timeclock)
-
-(defcustom timeclock-get-project-function 'timeclock-ask-for-project
- "*The function used to determine the name of the current project.
-When clocking in, and no project is specified, this function will be
-called to determine what is the current project to be worked on.
-If this variable is nil, no questions will be asked."
- :type 'function
- :group 'timeclock)
-
-(defcustom timeclock-get-reason-function 'timeclock-ask-for-reason
- "*A function used to determine the reason for clocking out.
-When clocking out, and no reason is specified, this function will be
-called to determine what is the reason.
-If this variable is nil, no questions will be asked."
- :type 'function
- :group 'timeclock)
-
-(defcustom timeclock-get-workday-function nil
- "*A function used to determine the length of today's workday.
-The first time that a user clocks in each day, this function will be
-called to determine what is the length of the current workday. If
-the return value is nil, or equal to `timeclock-workday', nothing special
-will be done. If it is a quantity different from `timeclock-workday',
-however, a record will be output to the timelog file to note the fact that
-that day has a length that is different from the norm."
- :type '(choice (const nil) function)
- :group 'timeclock)
-
-(defcustom timeclock-ask-before-exiting t
- "*If non-nil, ask if the user wants to clock out before exiting Emacs.
-This variable only has effect if set with \\[customize]."
- :set (lambda (symbol value)
- (if value
- (add-hook 'kill-emacs-query-functions 'timeclock-query-out)
- (remove-hook 'kill-emacs-query-functions 'timeclock-query-out))
- (setq timeclock-ask-before-exiting value))
- :type 'boolean
- :group 'timeclock)
-
-(defvar timeclock-update-timer nil
- "The timer used to update `timeclock-mode-string'.")
-
-;; For byte-compiler.
-(defvar display-time-hook)
-(defvar timeclock-modeline-display)
-
-(defcustom timeclock-use-display-time t
- "*If non-nil, use `display-time-hook' for doing modeline updates.
-The advantage of this is that one less timer has to be set running
-amok in Emacs' process space. The disadvantage is that it requires
-you to have `display-time' running. If you don't want to use
-`display-time', but still want the modeline to show how much time is
-left, set this variable to nil. Changing the value of this variable
-while timeclock information is being displayed in the modeline has no
-effect. You should call the function `timeclock-modeline-display' with
-a positive argument to force an update."
- :set (lambda (symbol value)
- (let ((currently-displaying
- (and (boundp 'timeclock-modeline-display)
- timeclock-modeline-display)))
- ;; if we're changing to the state that
- ;; `timeclock-modeline-display' is already using, don't
- ;; bother toggling it. This happens on the initial loading
- ;; of timeclock.el.
- (if (and currently-displaying
- (or (and value
- (boundp 'display-time-hook)
- (memq 'timeclock-update-modeline
- display-time-hook))
- (and (not value)
- timeclock-update-timer)))
- (setq currently-displaying nil))
- (and currently-displaying
- (set-variable 'timeclock-modeline-display nil))
- (setq timeclock-use-display-time value)
- (and currently-displaying
- (set-variable 'timeclock-modeline-display t))
- timeclock-use-display-time))
- :type 'boolean
- :group 'timeclock
- :require 'time)
-
-(defcustom timeclock-first-in-hook nil
- "*A hook run for the first \"in\" event each day.
-Note that this hook is run before recording any events. Thus the
-value of `timeclock-hours-today', `timeclock-last-event' and the
-return value of function `timeclock-last-period' are relative previous
-to today."
- :type 'hook
- :group 'timeclock)
-
-(defcustom timeclock-load-hook nil
- "*Hook that gets run after timeclock has been loaded."
- :type 'hook
- :group 'timeclock)
-
-(defcustom timeclock-in-hook nil
- "*A hook run every time an \"in\" event is recorded."
- :type 'hook
- :group 'timeclock)
-
-(defcustom timeclock-day-over-hook nil
- "*A hook that is run when the workday has been completed.
-This hook is only run if the current time remaining is being displayed
-in the modeline. See the variable `timeclock-modeline-display'."
- :type 'hook
- :group 'timeclock)
-
-(defcustom timeclock-out-hook nil
- "*A hook run every time an \"out\" event is recorded."
- :type 'hook
- :group 'timeclock)
-
-(defcustom timeclock-done-hook nil
- "*A hook run every time a project is marked as completed."
- :type 'hook
- :group 'timeclock)
-
-(defcustom timeclock-event-hook nil
- "*A hook run every time any event is recorded."
- :type 'hook
- :group 'timeclock)
-
-(defvar timeclock-last-event nil
- "A list containing the last event that was recorded.
-The format of this list is (CODE TIME PROJECT).")
-
-(defvar timeclock-last-event-workday nil
- "The number of seconds in the workday of `timeclock-last-event'.")
-
-;;; Internal Variables:
-
-(defvar timeclock-discrepancy nil
- "A variable containing the time discrepancy before the last event.
-Normally, timeclock assumes that you intend to work for
-`timeclock-workday' seconds every day. Any days in which you work
-more or less than this amount is considered either a positive or
-a negative discrepancy. If you work in such a manner that the
-discrepancy is always brought back to zero, then you will by
-definition have worked an average amount equal to `timeclock-workday'
-each day.")
-
-(defvar timeclock-elapsed nil
- "A variable containing the time elapsed for complete periods today.
-This value is not accurate enough to be useful by itself. Rather,
-call `timeclock-workday-elapsed', to determine how much time has been
-worked so far today. Also, if `timeclock-relative' is nil, this value
-will be the same as `timeclock-discrepancy'.") ; ? gm
-
-(defvar timeclock-last-period nil
- "Integer representing the number of seconds in the last period.
-Note that you shouldn't access this value, but instead should use the
-function `timeclock-last-period'.")
-
-(defvar timeclock-mode-string nil
- "The timeclock string (optionally) displayed in the modeline.
-The time is bracketed by <> if you are clocked in, otherwise by [].")
-
-(defvar timeclock-day-over nil
- "The date of the last day when notified \"day over\" for.")
-
-;;; User Functions:
-
-;;;###autoload
-(defun timeclock-modeline-display (&optional arg)
- "Toggle display of the amount of time left today in the modeline.
-If `timeclock-use-display-time' is non-nil (the default), then
-the function `display-time-mode' must be active, and the modeline
-will be updated whenever the time display is updated. Otherwise,
-the timeclock will use its own sixty second timer to do its
-updating. With prefix ARG, turn modeline display on if and only
-if ARG is positive. Returns the new status of timeclock modeline
-display (non-nil means on)."
- (interactive "P")
- ;; cf display-time-mode.
- (setq timeclock-mode-string "")
- (or global-mode-string (setq global-mode-string '("")))
- (let ((on-p (if arg
- (> (prefix-numeric-value arg) 0)
- (not timeclock-modeline-display))))
- (if on-p
- (progn
- (or (memq 'timeclock-mode-string global-mode-string)
- (setq global-mode-string
- (append global-mode-string '(timeclock-mode-string))))
- (unless (memq 'timeclock-update-modeline timeclock-event-hook)
- (add-hook 'timeclock-event-hook 'timeclock-update-modeline))
- (when timeclock-update-timer
- (cancel-timer timeclock-update-timer)
- (setq timeclock-update-timer nil))
- (if (boundp 'display-time-hook)
- (remove-hook 'display-time-hook 'timeclock-update-modeline))
- (if timeclock-use-display-time
- (progn
- ;; Update immediately so there is a visible change
- ;; on calling this function.
- (if display-time-mode (timeclock-update-modeline)
- (message "Activate `display-time-mode' to see \
-timeclock information"))
- (add-hook 'display-time-hook 'timeclock-update-modeline))
- (setq timeclock-update-timer
- (run-at-time nil 60 'timeclock-update-modeline))))
- (setq global-mode-string
- (delq 'timeclock-mode-string global-mode-string))
- (remove-hook 'timeclock-event-hook 'timeclock-update-modeline)
- (if (boundp 'display-time-hook)
- (remove-hook 'display-time-hook
- 'timeclock-update-modeline))
- (when timeclock-update-timer
- (cancel-timer timeclock-update-timer)
- (setq timeclock-update-timer nil)))
- (force-mode-line-update)
- (setq timeclock-modeline-display on-p)))
-
-;; This has to be here so that the function definition of
-;; `timeclock-modeline-display' is known to the "set" function.
-(defcustom timeclock-modeline-display nil
- "Toggle modeline display of time remaining.
-You must modify via \\[customize] for this variable to have an effect."
- :set (lambda (symbol value)
- (setq timeclock-modeline-display
- (timeclock-modeline-display (or value 0))))
- :type 'boolean
- :group 'timeclock
- :require 'timeclock)
-
-(defsubst timeclock-time-to-date (time)
- "Convert the TIME value to a textual date string."
- (format-time-string "%Y/%m/%d" time))
-
-;;;###autoload
-(defun timeclock-in (&optional arg project find-project)
- "Clock in, recording the current time moment in the timelog.
-With a numeric prefix ARG, record the fact that today has only that
-many hours in it to be worked. If arg is a non-numeric prefix arg
-\(non-nil, but not a number), 0 is assumed (working on a holiday or
-weekend). *If not called interactively, ARG should be the number of
-_seconds_ worked today*. This feature only has effect the first time
-this function is called within a day.
-
-PROJECT is the project being clocked into. If PROJECT is nil, and
-FIND-PROJECT is non-nil -- or the user calls `timeclock-in'
-interactively -- call the function `timeclock-get-project-function' to
-discover the name of the project."
- (interactive
- (list (and current-prefix-arg
- (if (numberp current-prefix-arg)
- (* current-prefix-arg 60 60)
- 0))))
- (if (equal (car timeclock-last-event) "i")
- (error "You've already clocked in!")
- (unless timeclock-last-event
- (timeclock-reread-log))
- ;; Either no log file, or day has rolled over.
- (unless (and timeclock-last-event
- (equal (timeclock-time-to-date
- (cadr timeclock-last-event))
- (timeclock-time-to-date (current-time))))
- (let ((workday (or (and (numberp arg) arg)
- (and arg 0)
- (and timeclock-get-workday-function
- (funcall timeclock-get-workday-function))
- timeclock-workday)))
- (run-hooks 'timeclock-first-in-hook)
- ;; settle the discrepancy for the new day
- (setq timeclock-discrepancy
- (- (or timeclock-discrepancy 0) workday))
- (if (not (= workday timeclock-workday))
- (timeclock-log "h" (and (numberp arg)
- (number-to-string arg))))))
- (timeclock-log "i" (or project
- (and timeclock-get-project-function
- (or find-project (interactive-p))
- (funcall timeclock-get-project-function))))
- (run-hooks 'timeclock-in-hook)))
-
-;;;###autoload
-(defun timeclock-out (&optional arg reason find-reason)
- "Clock out, recording the current time moment in the timelog.
-If a prefix ARG is given, the user has completed the project that was
-begun during the last time segment.
-
-REASON is the user's reason for clocking out. If REASON is nil, and
-FIND-REASON is non-nil -- or the user calls `timeclock-out'
-interactively -- call the function `timeclock-get-reason-function' to
-discover the reason."
- (interactive "P")
- (or timeclock-last-event
- (error "You haven't clocked in!"))
- (if (equal (downcase (car timeclock-last-event)) "o")
- (error "You've already clocked out!")
- (timeclock-log
- (if arg "O" "o")
- (or reason
- (and timeclock-get-reason-function
- (or find-reason (interactive-p))
- (funcall timeclock-get-reason-function))))
- (run-hooks 'timeclock-out-hook)
- (if arg
- (run-hooks 'timeclock-done-hook))))
-
-;; Should today-only be removed in favour of timeclock-relative? - gm
-(defsubst timeclock-workday-remaining (&optional today-only)
- "Return the number of seconds until the workday is complete.
-The amount returned is relative to the value of `timeclock-workday'.
-If TODAY-ONLY is non-nil, the value returned will be relative only to
-the time worked today, and not to past time."
- (let ((discrep (timeclock-find-discrep)))
- (if discrep
- (- (if today-only (cadr discrep)
- (car discrep)))
- 0.0)))
-
-;;;###autoload
-(defun timeclock-status-string (&optional show-seconds today-only)
- "Report the overall timeclock status at the present moment.
-If SHOW-SECONDS is non-nil, display second resolution.
-If TODAY-ONLY is non-nil, the display will be relative only to time
-worked today, ignoring the time worked on previous days."
- (interactive "P")
- (let ((remainder (timeclock-workday-remaining)) ; today-only?
- (last-in (equal (car timeclock-last-event) "i"))
- status)
- (setq status
- (format "Currently %s since %s (%s), %s %s, leave at %s"
- (if last-in "IN" "OUT")
- (if show-seconds
- (format-time-string "%-I:%M:%S %p"
- (nth 1 timeclock-last-event))
- (format-time-string "%-I:%M %p"
- (nth 1 timeclock-last-event)))
- (or (nth 2 timeclock-last-event)
- (if last-in "**UNKNOWN**" "workday over"))
- (timeclock-seconds-to-string remainder show-seconds t)
- (if (> remainder 0)
- "remaining" "over")
- (timeclock-when-to-leave-string show-seconds today-only)))
- (if (interactive-p)
- (message status)
- status)))
-
-;;;###autoload
-(defun timeclock-change (&optional arg project)
- "Change to working on a different project.
-This clocks out of the current project, then clocks in on a new one.
-With a prefix ARG, consider the previous project as finished at the
-time of changeover. PROJECT is the name of the last project you were
-working on."
- (interactive "P")
- (timeclock-out arg)
- (timeclock-in nil project (interactive-p)))
-
-;;;###autoload
-(defun timeclock-query-out ()
- "Ask the user whether to clock out.
-This is a useful function for adding to `kill-emacs-query-functions'."
- (and (equal (car timeclock-last-event) "i")
- (y-or-n-p "You're currently clocking time, clock out? ")
- (timeclock-out))
- ;; Unconditionally return t for `kill-emacs-query-functions'.
- t)
-
-;;;###autoload
-(defun timeclock-reread-log ()
- "Re-read the timeclock, to account for external changes.
-Returns the new value of `timeclock-discrepancy'."
- (interactive)
- (setq timeclock-discrepancy nil)
- (timeclock-find-discrep)
- (if (and timeclock-discrepancy timeclock-modeline-display)
- (timeclock-update-modeline))
- timeclock-discrepancy)
-
-(defun timeclock-seconds-to-string (seconds &optional show-seconds
- reverse-leader)
- "Convert SECONDS into a compact time string.
-If SHOW-SECONDS is non-nil, make the resolution of the return string
-include the second count. If REVERSE-LEADER is non-nil, it means to
-output a \"+\" if the time value is negative, rather than a \"-\".
-This is used when negative time values have an inverted meaning (such
-as with time remaining, where negative time really means overtime)."
- (if show-seconds
- (format "%s%d:%02d:%02d"
- (if (< seconds 0) (if reverse-leader "+" "-") "")
- (truncate (/ (abs seconds) 60 60))
- (% (truncate (/ (abs seconds) 60)) 60)
- (% (truncate (abs seconds)) 60))
- (format "%s%d:%02d"
- (if (< seconds 0) (if reverse-leader "+" "-") "")
- (truncate (/ (abs seconds) 60 60))
- (% (truncate (/ (abs seconds) 60)) 60))))
-
-(defsubst timeclock-currently-in-p ()
- "Return non-nil if the user is currently clocked in."
- (equal (car timeclock-last-event) "i"))
-
-;;;###autoload
-(defun timeclock-workday-remaining-string (&optional show-seconds
- today-only)
- "Return a string representing the amount of time left today.
-Display second resolution if SHOW-SECONDS is non-nil. If TODAY-ONLY
-is non-nil, the display will be relative only to time worked today.
-See `timeclock-relative' for more information about the meaning of
-\"relative to today\"."
- (interactive)
- (let ((string (timeclock-seconds-to-string
- (timeclock-workday-remaining today-only)
- show-seconds t)))
- (if (interactive-p)
- (message string)
- string)))
-
-(defsubst timeclock-workday-elapsed ()
- "Return the number of seconds worked so far today.
-If RELATIVE is non-nil, the amount returned will be relative to past
-time worked. The default is to return only the time that has elapsed
-so far today."
- (let ((discrep (timeclock-find-discrep)))
- (if discrep
- (nth 2 discrep)
- 0.0)))
-
-;;;###autoload
-(defun timeclock-workday-elapsed-string (&optional show-seconds)
- "Return a string representing the amount of time worked today.
-Display seconds resolution if SHOW-SECONDS is non-nil. If RELATIVE is
-non-nil, the amount returned will be relative to past time worked."
- (interactive)
- (let ((string (timeclock-seconds-to-string (timeclock-workday-elapsed)
- show-seconds)))
- (if (interactive-p)
- (message string)
- string)))
-
-(defsubst timeclock-time-to-seconds (time)
- "Convert TIME to a floating point number."
- (+ (* (car time) 65536.0)
- (cadr time)
- (/ (or (car (cdr (cdr time))) 0) 1000000.0)))
-
-(defsubst timeclock-seconds-to-time (seconds)
- "Convert SECONDS (a floating point number) to an Emacs time structure."
- (list (floor seconds 65536)
- (floor (mod seconds 65536))
- (floor (* (- seconds (ffloor seconds)) 1000000))))
-
-;; Should today-only be removed in favour of timeclock-relative? - gm
-(defsubst timeclock-when-to-leave (&optional today-only)
- "Return a time value representing the end of today's workday.
-If TODAY-ONLY is non-nil, the value returned will be relative only to
-the time worked today, and not to past time."
- (timeclock-seconds-to-time
- (- (timeclock-time-to-seconds (current-time))
- (let ((discrep (timeclock-find-discrep)))
- (if discrep
- (if today-only
- (cadr discrep)
- (car discrep))
- 0.0)))))
-
-;;;###autoload
-(defun timeclock-when-to-leave-string (&optional show-seconds
- today-only)
- "Return a string representing the end of today's workday.
-This string is relative to the value of `timeclock-workday'. If
-SHOW-SECONDS is non-nil, the value printed/returned will include
-seconds. If TODAY-ONLY is non-nil, the value returned will be
-relative only to the time worked today, and not to past time."
- ;; Should today-only be removed in favour of timeclock-relative? - gm
- (interactive)
- (let* ((then (timeclock-when-to-leave today-only))
- (string
- (if show-seconds
- (format-time-string "%-I:%M:%S %p" then)
- (format-time-string "%-I:%M %p" then))))
- (if (interactive-p)
- (message string)
- string)))
-
-;;; Internal Functions:
-
-(defvar timeclock-project-list nil)
-(defvar timeclock-last-project nil)
-
-(defun timeclock-completing-read (prompt alist &optional default)
- "A version of `completing-read' that works on both Emacs and XEmacs."
- (if (featurep 'xemacs)
- (let ((str (completing-read prompt alist)))
- (if (or (null str) (= (length str) 0))
- default
- str))
- (completing-read prompt alist nil nil nil nil default)))
-
-(defun timeclock-ask-for-project ()
- "Ask the user for the project they are clocking into."
- (timeclock-completing-read
- (format "Clock into which project (default \"%s\"): "
- (or timeclock-last-project
- (car timeclock-project-list)))
- (mapcar 'list timeclock-project-list)
- (or timeclock-last-project
- (car timeclock-project-list))))
-
-(defvar timeclock-reason-list nil)
-
-(defun timeclock-ask-for-reason ()
- "Ask the user for the reason they are clocking out."
- (timeclock-completing-read "Reason for clocking out: "
- (mapcar 'list timeclock-reason-list)))
-
-(defun timeclock-update-modeline ()
- "Update the `timeclock-mode-string' displayed in the modeline.
-The value of `timeclock-relative' affects the display as described in
-that variable's documentation."
- (interactive)
- (let ((remainder (timeclock-workday-remaining (not timeclock-relative)))
- (last-in (equal (car timeclock-last-event) "i")))
- (when (and (< remainder 0)
- (not (and timeclock-day-over
- (equal timeclock-day-over
- (timeclock-time-to-date
- (current-time))))))
- (setq timeclock-day-over
- (timeclock-time-to-date (current-time)))
- (run-hooks 'timeclock-day-over-hook))
- (setq timeclock-mode-string
- (propertize
- (format " %c%s%c "
- (if last-in ?< ?[)
- (timeclock-seconds-to-string remainder nil t)
- (if last-in ?> ?]))
- 'help-echo "timeclock: time remaining"))))
-
-(put 'timeclock-mode-string 'risky-local-variable t)
-
-(defun timeclock-log (code &optional project)
- "Log the event CODE to the timeclock log, at the time of call.
-If PROJECT is a string, it represents the project which the event is
-being logged for. Normally only \"in\" events specify a project."
- (with-current-buffer (find-file-noselect timeclock-file)
- (goto-char (point-max))
- (if (not (bolp))
- (insert "\n"))
- (let ((now (current-time)))
- (insert code " "
- (format-time-string "%Y/%m/%d %H:%M:%S" now)
- (or (and project
- (stringp project)
- (> (length project) 0)
- (concat " " project))
- "")
- "\n")
- (if (equal (downcase code) "o")
- (setq timeclock-last-period
- (- (timeclock-time-to-seconds now)
- (timeclock-time-to-seconds
- (cadr timeclock-last-event)))
- timeclock-discrepancy
- (+ timeclock-discrepancy
- timeclock-last-period)))
- (setq timeclock-last-event (list code now project)))
- (save-buffer)
- (run-hooks 'timeclock-event-hook)
- (kill-buffer (current-buffer))))
-
-(defvar timeclock-moment-regexp
- (concat "\\([bhioO]\\)\\s-+"
- "\\([0-9]+\\)/\\([0-9]+\\)/\\([0-9]+\\)\\s-+"
- "\\([0-9]+\\):\\([0-9]+\\):\\([0-9]+\\)[ \t]*" "\\([^\n]*\\)"))
-
-(defsubst timeclock-read-moment ()
- "Read the moment under point from the timelog."
- (if (looking-at timeclock-moment-regexp)
- (let ((code (match-string 1))
- (year (string-to-number (match-string 2)))
- (mon (string-to-number (match-string 3)))
- (mday (string-to-number (match-string 4)))
- (hour (string-to-number (match-string 5)))
- (min (string-to-number (match-string 6)))
- (sec (string-to-number (match-string 7)))
- (project (match-string 8)))
- (list code (encode-time sec min hour mday mon year) project))))
-
-(defun timeclock-last-period (&optional moment)
- "Return the value of the last event period.
-If the last event was a clock-in, the period will be open ended, and
-growing every second. Otherwise, it is a fixed amount which has been
-recorded to disk. If MOMENT is non-nil, use that as the current time.
-This is only provided for coherency when used by
-`timeclock-discrepancy'."
- (if (equal (car timeclock-last-event) "i")
- (- (timeclock-time-to-seconds (or moment (current-time)))
- (timeclock-time-to-seconds
- (cadr timeclock-last-event)))
- timeclock-last-period))
-
-(defsubst timeclock-entry-length (entry)
- (- (timeclock-time-to-seconds (cadr entry))
- (timeclock-time-to-seconds (car entry))))
-
-(defsubst timeclock-entry-begin (entry)
- (car entry))
-
-(defsubst timeclock-entry-end (entry)
- (cadr entry))
-
-(defsubst timeclock-entry-project (entry)
- (nth 2 entry))
-
-(defsubst timeclock-entry-comment (entry)
- (nth 3 entry))
-
-
-(defsubst timeclock-entry-list-length (entry-list)
- (let ((length 0))
- (while entry-list
- (setq length (+ length (timeclock-entry-length (car entry-list))))
- (setq entry-list (cdr entry-list)))
- length))
-
-(defsubst timeclock-entry-list-begin (entry-list)
- (timeclock-entry-begin (car entry-list)))
-
-(defsubst timeclock-entry-list-end (entry-list)
- (timeclock-entry-end (car (last entry-list))))
-
-(defsubst timeclock-entry-list-span (entry-list)
- (- (timeclock-time-to-seconds (timeclock-entry-list-end entry-list))
- (timeclock-time-to-seconds (timeclock-entry-list-begin entry-list))))
-
-(defsubst timeclock-entry-list-break (entry-list)
- (- (timeclock-entry-list-span entry-list)
- (timeclock-entry-list-length entry-list)))
-
-(defsubst timeclock-entry-list-projects (entry-list)
- (let (projects)
- (while entry-list
- (let ((project (timeclock-entry-project (car entry-list))))
- (if projects
- (add-to-list 'projects project)
- (setq projects (list project))))
- (setq entry-list (cdr entry-list)))
- projects))
-
-
-(defsubst timeclock-day-required (day)
- (or (car day) timeclock-workday))
-
-(defsubst timeclock-day-length (day)
- (timeclock-entry-list-length (cdr day)))
-
-(defsubst timeclock-day-debt (day)
- (- (timeclock-day-required day)
- (timeclock-day-length day)))
-
-(defsubst timeclock-day-begin (day)
- (timeclock-entry-list-begin (cdr day)))
-
-(defsubst timeclock-day-end (day)
- (timeclock-entry-list-end (cdr day)))
-
-(defsubst timeclock-day-span (day)
- (timeclock-entry-list-span (cdr day)))
-
-(defsubst timeclock-day-break (day)
- (timeclock-entry-list-break (cdr day)))
-
-(defsubst timeclock-day-projects (day)
- (timeclock-entry-list-projects (cdr day)))
-
-(defmacro timeclock-day-list-template (func)
- `(let ((length 0))
- (while day-list
- (setq length (+ length (,(eval func) (car day-list))))
- (setq day-list (cdr day-list)))
- length))
-
-(defun timeclock-day-list-required (day-list)
- (timeclock-day-list-template 'timeclock-day-required))
-
-(defun timeclock-day-list-length (day-list)
- (timeclock-day-list-template 'timeclock-day-length))
-
-(defun timeclock-day-list-debt (day-list)
- (timeclock-day-list-template 'timeclock-day-debt))
-
-(defsubst timeclock-day-list-begin (day-list)
- (timeclock-day-begin (car day-list)))
-
-(defsubst timeclock-day-list-end (day-list)
- (timeclock-day-end (car (last day-list))))
-
-(defun timeclock-day-list-span (day-list)
- (timeclock-day-list-template 'timeclock-day-span))
-
-(defun timeclock-day-list-break (day-list)
- (timeclock-day-list-template 'timeclock-day-break))
-
-(defun timeclock-day-list-projects (day-list)
- (let (projects)
- (while day-list
- (let ((projs (timeclock-day-projects (car day-list))))
- (while projs
- (if projects
- (add-to-list 'projects (car projs))
- (setq projects (list (car projs))))
- (setq projs (cdr projs))))
- (setq day-list (cdr day-list)))
- projects))
-
-
-(defsubst timeclock-current-debt (&optional log-data)
- (nth 0 (or log-data (timeclock-log-data))))
-
-(defsubst timeclock-day-alist (&optional log-data)
- (nth 1 (or log-data (timeclock-log-data))))
-
-(defun timeclock-day-list (&optional log-data)
- (let ((alist (timeclock-day-alist log-data))
- day-list)
- (while alist
- (setq day-list (cons (cdar alist) day-list)
- alist (cdr alist)))
- day-list))
-
-(defsubst timeclock-project-alist (&optional log-data)
- (nth 2 (or log-data (timeclock-log-data))))
-
-
-(defun timeclock-log-data (&optional recent-only filename)
- "Return the contents of the timelog file, in a useful format.
-If the optional argument RECENT-ONLY is non-nil, only show the contents
-from the last point where the time debt (see below) was set.
-If the optional argument FILENAME is non-nil, it is used instead of
-the file specified by `timeclock-file.'
-
-A timelog contains data in the form of a single entry per line.
-Each entry has the form:
-
- CODE YYYY/MM/DD HH:MM:SS [COMMENT]
-
-CODE is one of: b, h, i, o or O. COMMENT is optional when the code is
-i, o or O. The meanings of the codes are:
-
- b Set the current time balance, or \"time debt\". Useful when
- archiving old log data, when a debt must be carried forward.
- The COMMENT here is the number of seconds of debt.
-
- h Set the required working time for the given day. This must
- be the first entry for that day. The COMMENT in this case is
- the number of hours in this workday. Floating point amounts
- are allowed.
-
- i Clock in. The COMMENT in this case should be the name of the
- project worked on.
-
- o Clock out. COMMENT is unnecessary, but can be used to provide
- a description of how the period went, for example.
-
- O Final clock out. Whatever project was being worked on, it is
- now finished. Useful for creating summary reports.
-
-When this function is called, it will return a data structure with the
-following format:
-
- (DEBT ENTRIES-BY-DAY ENTRIES-BY-PROJECT)
-
-DEBT is a floating point number representing the number of seconds
-\"owed\" before any work was done. For a new file (one without a 'b'
-entry), this is always zero.
-
-The two entries lists have similar formats. They are both alists,
-where the CAR is the index, and the CDR is a list of time entries.
-For ENTRIES-BY-DAY, the CAR is a textual date string, of the form
-YYYY/MM/DD. For ENTRIES-BY-PROJECT, it is the name of the project
-worked on, or t for the default project.
-
-The CDR for ENTRIES-BY-DAY is slightly different than for
-ENTRIES-BY-PROJECT. It has the following form:
-
- (DAY-LENGTH TIME-ENTRIES...)
-
-For ENTRIES-BY-PROJECT, there is no DAY-LENGTH member. It is simply a
-list of TIME-ENTRIES. Note that if DAY-LENGTH is nil, it means
-whatever is the default should be used.
-
-A TIME-ENTRY is a recorded time interval. It has the following format
-\(although generally one does not have to manipulate these entries
-directly; see below):
-
- (BEGIN-TIME END-TIME PROJECT [COMMENT] [FINAL-P])
-
-Anyway, suffice it to say there are a lot of structures. Typically
-the user is expected to manipulate to the day(s) or project(s) that he
-or she wants, at which point the following helper functions may be
-used:
-
- timeclock-day-required
- timeclock-day-length
- timeclock-day-debt
- timeclock-day-begin
- timeclock-day-end
- timeclock-day-span
- timeclock-day-break
- timeclock-day-projects
-
- timeclock-day-list-required
- timeclock-day-list-length
- timeclock-day-list-debt
- timeclock-day-list-begin
- timeclock-day-list-end
- timeclock-day-list-span
- timeclock-day-list-break
- timeclock-day-list-projects
-
- timeclock-entry-length
- timeclock-entry-begin
- timeclock-entry-end
- timeclock-entry-project
- timeclock-entry-comment
-
- timeclock-entry-list-length
- timeclock-entry-list-begin
- timeclock-entry-list-end
- timeclock-entry-list-span
- timeclock-entry-list-break
- timeclock-entry-list-projects
-
-A few comments should make the use of the above functions obvious:
-
- `required' is the amount of time that must be spent during a day, or
- sequence of days, in order to have no debt.
-
- `length' is the actual amount of time that was spent.
-
- `debt' is the difference between required time and length. A
- negative debt signifies overtime.
-
- `begin' is the earliest moment at which work began.
-
- `end' is the final moment work was done.
-
- `span' is the difference between begin and end.
-
- `break' is the difference between span and length.
-
- `project' is the project that was worked on, and `projects' is a
- list of all the projects that were worked on during a given period.
-
- `comment', where it applies, could mean anything.
-
-There are a few more functions available, for locating day and entry
-lists:
-
- timeclock-day-alist LOG-DATA
- timeclock-project-alist LOG-DATA
- timeclock-current-debt LOG-DATA
-
-See the documentation for the given function if more info is needed."
- (let* ((log-data (list 0.0 nil nil))
- (now (current-time))
- (todays-date (timeclock-time-to-date now))
- last-date-limited last-date-seconds last-date
- (line 0) last beg day entry event)
- (with-temp-buffer
- (insert-file-contents (or filename timeclock-file))
- (when recent-only
- (goto-char (point-max))
- (unless (re-search-backward "^b\\s-+" nil t)
- (goto-char (point-min))))
- (while (or (setq event (timeclock-read-moment))
- (and beg (not last)
- (setq last t event (list "o" now))))
- (setq line (1+ line))
- (cond ((equal (car event) "b")
- (setcar log-data (string-to-number (nth 2 event))))
- ((equal (car event) "h")
- (setq last-date-limited (timeclock-time-to-date (cadr event))
- last-date-seconds (* (string-to-number (nth 2 event))
- 3600.0)))
- ((equal (car event) "i")
- (if beg
- (error "Error in format of timelog file, line %d" line)
- (setq beg t))
- (setq entry (list (cadr event) nil
- (and (> (length (nth 2 event)) 0)
- (nth 2 event))))
- (let ((date (timeclock-time-to-date (cadr event))))
- (if (and last-date
- (not (equal date last-date)))
- (progn
- (setcar (cdr log-data)
- (cons (cons last-date day)
- (cadr log-data)))
- (setq day (list (and last-date-limited
- last-date-seconds))))
- (unless day
- (setq day (list (and last-date-limited
- last-date-seconds)))))
- (setq last-date date
- last-date-limited nil)))
- ((equal (downcase (car event)) "o")
- (if (not beg)
- (error "Error in format of timelog file, line %d" line)
- (setq beg nil))
- (setcar (cdr entry) (cadr event))
- (let ((desc (and (> (length (nth 2 event)) 0)
- (nth 2 event))))
- (if desc
- (nconc entry (list (nth 2 event))))
- (if (equal (car event) "O")
- (nconc entry (if desc
- (list t)
- (list nil t))))
- (nconc day (list entry))
- (setq desc (nth 2 entry))
- (let ((proj (assoc desc (nth 2 log-data))))
- (if (null proj)
- (setcar (cddr log-data)
- (cons (cons desc (list entry))
- (car (cddr log-data))))
- (nconc (cdr proj) (list entry)))))))
- (forward-line))
- (if day
- (setcar (cdr log-data)
- (cons (cons last-date day)
- (cadr log-data))))
- log-data)))
-
-(defun timeclock-find-discrep ()
- "Calculate time discrepancies, in seconds.
-The result is a three element list, containing the total time
-discrepancy, today's discrepancy, and the time worked today."
- ;; This is not implemented in terms of the functions above, because
- ;; it's a bit wasteful to read all of that data in, just to throw
- ;; away more than 90% of the information afterwards.
- ;;
- ;; If it were implemented using those functions, it would look
- ;; something like this:
- ;; (let ((days (timeclock-day-alist (timeclock-log-data)))
- ;; (total 0.0))
- ;; (while days
- ;; (setq total (+ total (- (timeclock-day-length (cdar days))
- ;; (timeclock-day-required (cdar days))))
- ;; days (cdr days)))
- ;; total)
- (let* ((now (current-time))
- (todays-date (timeclock-time-to-date now))
- (first t) (accum 0) (elapsed 0)
- event beg last-date avg
- last-date-limited last-date-seconds)
- (unless timeclock-discrepancy
- (when (file-readable-p timeclock-file)
- (setq timeclock-project-list nil
- timeclock-last-project nil
- timeclock-reason-list nil
- timeclock-elapsed 0)
- (with-temp-buffer
- (insert-file-contents timeclock-file)
- (goto-char (point-max))
- (unless (re-search-backward "^b\\s-+" nil t)
- (goto-char (point-min)))
- (while (setq event (timeclock-read-moment))
- (cond ((equal (car event) "b")
- (setq accum (string-to-number (nth 2 event))))
- ((equal (car event) "h")
- (setq last-date-limited
- (timeclock-time-to-date (cadr event))
- last-date-seconds
- (* (string-to-number (nth 2 event)) 3600.0)))
- ((equal (car event) "i")
- (when (and (nth 2 event)
- (> (length (nth 2 event)) 0))
- (add-to-list 'timeclock-project-list (nth 2 event))
- (setq timeclock-last-project (nth 2 event)))
- (let ((date (timeclock-time-to-date (cadr event))))
- (if (if last-date
- (not (equal date last-date))
- first)
- (setq first nil
- accum (- accum (if last-date-limited
- last-date-seconds
- timeclock-workday))))
- (setq last-date date
- last-date-limited nil)
- (if beg
- (error "Error in format of timelog file!")
- (setq beg (timeclock-time-to-seconds (cadr event))))))
- ((equal (downcase (car event)) "o")
- (if (and (nth 2 event)
- (> (length (nth 2 event)) 0))
- (add-to-list 'timeclock-reason-list (nth 2 event)))
- (if (not beg)
- (error "Error in format of timelog file!")
- (setq timeclock-last-period
- (- (timeclock-time-to-seconds (cadr event)) beg)
- accum (+ timeclock-last-period accum)
- beg nil))
- (if (equal last-date todays-date)
- (setq timeclock-elapsed
- (+ timeclock-last-period timeclock-elapsed)))))
- (setq timeclock-last-event event
- timeclock-last-event-workday
- (if (equal (timeclock-time-to-date now) last-date-limited)
- last-date-seconds
- timeclock-workday))
- (forward-line))
- (setq timeclock-discrepancy accum))))
- (unless timeclock-last-event-workday
- (setq timeclock-last-event-workday timeclock-workday))
- (setq accum (or timeclock-discrepancy 0)
- elapsed (or timeclock-elapsed elapsed))
- (if timeclock-last-event
- (if (equal (car timeclock-last-event) "i")
- (let ((last-period (timeclock-last-period now)))
- (setq accum (+ accum last-period)
- elapsed (+ elapsed last-period)))
- (if (not (equal (timeclock-time-to-date
- (cadr timeclock-last-event))
- (timeclock-time-to-date now)))
- (setq accum (- accum timeclock-last-event-workday)))))
- (list accum (- elapsed timeclock-last-event-workday)
- elapsed)))
-
-;;; A reporting function that uses timeclock-log-data
-
-(defun timeclock-day-base (&optional time)
- "Given a time within a day, return 0:0:0 within that day.
-If optional argument TIME is non-nil, use that instead of the current time."
- (let ((decoded (decode-time (or time (current-time)))))
- (setcar (nthcdr 0 decoded) 0)
- (setcar (nthcdr 1 decoded) 0)
- (setcar (nthcdr 2 decoded) 0)
- (apply 'encode-time decoded)))
-
-(defun timeclock-geometric-mean (l)
- "Compute the geometric mean of the values in the list L."
- (let ((total 0)
- (count 0))
- (while l
- (setq total (+ total (car l))
- count (1+ count)
- l (cdr l)))
- (if (> count 0)
- (/ total count)
- 0)))
-
-(defun timeclock-generate-report (&optional html-p)
- "Generate a summary report based on the current timelog file.
-By default, the report is in plain text, but if the optional argument
-HTML-P is non-nil, HTML markup is added."
- (interactive)
- (let ((log (timeclock-log-data))
- (today (timeclock-day-base)))
- (if html-p (insert "<p>"))
- (insert "Currently ")
- (let ((project (nth 2 timeclock-last-event))
- (begin (nth 1 timeclock-last-event))
- done)
- (if (timeclock-currently-in-p)
- (insert "IN")
- (if (or (null project) (= (length project) 0))
- (progn (insert "Done Working Today")
- (setq done t))
- (insert "OUT")))
- (unless done
- (insert " since " (format-time-string "%Y/%m/%d %-I:%M %p" begin))
- (if html-p
- (insert "<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))))
- (if html-p (insert "</p>"))
- (when html-p
- (insert "<p>
-<table>
-<td width=\"25\"><br></td><td>
-<table border=1 cellpadding=3>
-<tr><th><i>Statistics</i></th>
- <th>Entire</th>
- <th>-30 days</th>
- <th>-3 mons</th>
- <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>
-<td colspan=\"6\" align=\"center\">
- <i>These are approximate figures</i></td>
-</tfoot>
-</table>
-</td></table>")))))
-
-;;; A helpful little function
-
-(defun timeclock-visit-timelog ()
- "Open the file named by `timeclock-file' in another window."
- (interactive)
- (find-file-other-window timeclock-file))
-
-(provide 'timeclock)
-
-(run-hooks 'timeclock-load-hook)
-
-;; make sure we know the list of reasons, projects, and have computed
-;; the last event and current discrepancy.
-(if (file-readable-p timeclock-file)
- (timeclock-reread-log))
-
-;;; arch-tag: a0be3377-deb6-44ec-b9a2-a7be28436a40
-;;; timeclock.el ends here
generated by cgit v1.2.3 (git 2.39.1) at 2025-01-24 11:07:56 +0000