ledger-cli/lisp/ledger-xact.el

;;; ledger-xact.el --- Helper code for use with the "ledger" command-line tool

;; Copyright (C) 2003-2016 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., 51 Franklin Street, Fifth Floor, Boston,
;; MA 02110-1301 USA.


;;; Commentary:
;; Utilities for running ledger synchronously.

;;; Code:

(require 'eshell)
(require 'ledger-regex)
(require 'ledger-navigate)
;; TODO: This file depends on code in ledger-mode.el, which depends on this.

(defcustom ledger-highlight-xact-under-point t
  "If t highlight xact under point."
  :type 'boolean
  :group 'ledger)

(defcustom ledger-use-iso-dates nil
  "If non-nil, use the iso-8601 format for dates (YYYY-MM-DD)."
  :type 'boolean
  :group 'ledger
  :safe t)

(defvar ledger-xact-highlight-overlay (list))
(make-variable-buffer-local 'ledger-xact-highlight-overlay)

(defun ledger-highlight-xact-under-point ()
  "Move the highlight overlay to the current transaction."
  (if ledger-highlight-xact-under-point
      (let ((exts (ledger-navigate-find-element-extents (point)))
            (ovl ledger-xact-highlight-overlay))
        (if (not ledger-xact-highlight-overlay)
            (setq ovl
                  (setq ledger-xact-highlight-overlay
                        (make-overlay (car exts)
                                      (cadr exts)
                                      (current-buffer) t nil)))
          (move-overlay ovl (car exts) (cadr exts)))
        (overlay-put ovl 'face 'ledger-font-xact-highlight-face)
        (overlay-put ovl 'priority '(nil . 99)))))

(defun ledger-xact-payee ()
  "Return the payee of the transaction containing point or nil."
  (let ((i 0))
    (while (eq (ledger-context-line-type (ledger-context-other-line i)) 'acct-transaction)
      (setq i (- i 1)))
    (let ((context-info (ledger-context-other-line i)))
      (if (eq (ledger-context-line-type context-info) 'xact)
          (ledger-context-field-value context-info 'payee)
        nil))))

(defun ledger-time-less-p (t1 t2)
  "Say whether time value T1 is less than time value T2."
  (or (< (car t1) (car t2))
      (and (= (car t1) (car t2))
           (< (nth 1 t1) (nth 1 t2)))))

(defun ledger-xact-find-slot (moment)
  "Find the right place in the buffer for a transaction at MOMENT.
MOMENT is an encoded date"
  (let (last-xact-start)
    (catch 'found
      (ledger-xact-iterate-transactions
       (function
        (lambda (start date mark desc)
          (setq last-xact-start start)
          (if (ledger-time-less-p moment date)
              (throw 'found t))))))
    (when (and (eobp) last-xact-start)
      (let ((end (cadr (ledger-navigate-find-xact-extents last-xact-start))))
        (goto-char end)
        (insert "\n")
        (forward-line)))))

(defun ledger-xact-iterate-transactions (callback)
  "Iterate through each transaction call CALLBACK for each."
  (goto-char (point-min))
  (let* ((now (current-time))
         (current-year (nth 5 (decode-time now))))
    (while (not (eobp))
      (when (looking-at ledger-iterate-regex)
        (let ((found-y-p (match-string 2)))
          (if found-y-p
              (setq current-year (string-to-number found-y-p)) ;; a Y directive was found
            (let ((start (match-beginning 0))
                  (year (match-string 4))
                  (month (string-to-number (match-string 5)))
                  (day (string-to-number (match-string 6)))
                  (mark (match-string 7))
                  (code (match-string 8))
                  (desc (match-string 9)))
              (if (and year (> (length year) 0))
                  (setq year (string-to-number year)))
              (funcall callback start
                       (encode-time 0 0 0 day month
                                    (or year current-year))
                       mark desc)))))
      (forward-line))))

(defun ledger-year-and-month ()
  (let ((sep (if ledger-use-iso-dates
                 "-"
               "/")))
    (concat ledger-year sep ledger-month sep)))

(defun ledger-copy-transaction-at-point (date)
  "Ask for a new DATE and copy the transaction under point to that date.  Leave point on the first amount."
  (interactive  (list
                 (ledger-read-date "Copy to date: ")))
  (let* ((here (point))
         (extents (ledger-navigate-find-xact-extents (point)))
         (transaction (buffer-substring-no-properties (car extents) (cadr extents)))
         encoded-date)
    (if (string-match ledger-iso-date-regexp date)
        (setq encoded-date
              (encode-time 0 0 0 (string-to-number (match-string 4 date))
                           (string-to-number (match-string 3 date))
                           (string-to-number (match-string 2 date)))))
    (ledger-xact-find-slot encoded-date)
    (insert transaction "\n")
    (beginning-of-line -1)
    (ledger-navigate-beginning-of-xact)
    (re-search-forward ledger-iso-date-regexp)
    (replace-match date)
    (ledger-next-amount)
    (if (re-search-forward "[-0-9]")
        (goto-char (match-beginning 0)))))

(defun ledger-delete-current-transaction (pos)
  "Delete the transaction surrounging POS."
  (interactive "d")
  (let ((bounds (ledger-navigate-find-xact-extents pos)))
    (delete-region (car bounds) (cadr bounds))))

(defun ledger-add-transaction (transaction-text &optional insert-at-point)
  "Use ledger xact TRANSACTION-TEXT to add a transaction to the buffer.
If INSERT-AT-POINT is non-nil insert the transaction there,
otherwise call `ledger-xact-find-slot' to insert it at the
correct chronological place in the buffer."
  (interactive (list
                ;; Note: This isn't "just" the date - it can contain
                ;; other text too
                (ledger-read-date "Transaction: ")))
  (let* ((args (with-temp-buffer
                 (insert transaction-text)
                 (eshell-parse-arguments (point-min) (point-max))))
         (ledger-buf (current-buffer))
         exit-code)
    (unless insert-at-point
      (let ((date (car args)))
        (if (string-match ledger-iso-date-regexp date)
            (setq date
                  (encode-time 0 0 0 (string-to-number (match-string 4 date))
                               (string-to-number (match-string 3 date))
                               (string-to-number (match-string 2 date)))))
        (ledger-xact-find-slot date)))
    (if (> (length args) 1)
        (save-excursion
          (insert
           (with-temp-buffer
             (setq exit-code
                   (apply #'ledger-exec-ledger ledger-buf (current-buffer) "xact"
                          (mapcar 'eval args)))
             (goto-char (point-min))
             (if (looking-at "Error: ")
                 (error (concat "Error in ledger-add-transaction: " (buffer-string)))
               (ledger-post-align-postings (point-min) (point-max))
               (buffer-string)))
           "\n"))
      (progn
        (insert (car args) " \n\n")
        (end-of-line -1)))))

(provide 'ledger-xact)

;;; ledger-xact.el ends here