tarao/pit.el

## pit.el
;;; pit.el --- Manipulate pit data.

;; Copyright (C) 2008 Takeru Naito
;; Author: Takeru Naito <takeru.naito@gmail.com>
;; Original: cho45 http://lowreal.rubyforge.org/pit/

;; This file 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 file 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:

;; * Description
;;
;; pit.el manipulate Pit data.
;
;; See http://lowreal.rubyforge.org/pit/
;;
;; * Usage
;;
;; Just put the code like below into your .emacs:
;;
;; (require 'pit)
;;
;; (pit/get 'github.com)
;; (pit/get 'github.com '(require ((user . "Your github user name")
;;                                 (token . "Your github token"))))
;;
;; (pit/set 'github.com)
;; (pit/set 'github.com '(config ((user . "Your github user name")
;;                                (token . "Your github token"))))
;; (pit/set 'github.com '(data ((user . "Your github user name")
;;                              (token . "Your github token"))))

;;; Change Log:

;; 2008-12-19:
;;  * Initial import

(eval-when-compile (require 'cl))

(defun pit/x->bool (elt) (not (not elt)))

(defun pit/fold-left (proc init lis)
  (if lis (pit/fold-left proc (funcall proc init (car lis)) (cdr lis)) init))

(defvar pit/directory "~/.pit")
(defvar pit/config (expand-file-name
                    (format "%s/%s.yaml" pit/directory "pit")))

(defun pit/alist/update (base other)
  (mapcar (lambda (key)
            (or (assoc key other)
                (assoc key base)))
          (let ((hash (make-hash-table :test 'eql)))
            (loop for cons in (append base other)
                  for key = (car cons)
                  unless (gethash key hash)
                  do (puthash key key hash)
                  finally return
                  (loop for x being the hash-values in hash collect x)))))

(defvar pit/profile-regexp
  (rx bol
      (? (or "\"" "'"))
      "profile"
      (? (or "\"" "'"))
      ":"
      (* space)
      (? (or "\"" "'"))
      (group
       (+? nonl))
      (? (or "\"" "'"))
      (? "\r")
      eol))

(defun pit/profile ()
  (when (file-exists-p pit/config)
    (let* ((profile
            (with-temp-buffer
              (insert-file-contents pit/config)
              (when (re-search-forward pit/profile-regexp nil t)
                (match-string 1))))
           (profile/file
            (expand-file-name
             (format "%s/%s.yaml" pit/directory profile))))
      profile/file)))

(defun pit/keys/all-p (ret keys)
  (pit/x->bool
   (pit/fold-left (lambda (x y)
                (and x (assoc y ret) y))
              t keys)))

(defun pit/set (name &optional opts)
  (let ((profile (pit/load))
        (result
         (if (eq (car opts) 'data)
             (cadr opts)
           (mapcar
            (lambda (pair)
              (let ((key (car pair))
                    (value (cdr pair)))
                (cons key
                      (read-from-minibuffer
                       (format "\[%s\] %s: " name key)
                       value))))
            (or (cadr opts)
                (pit/get name))))))

    (when (eq (or (assoc 'config opts)
                  (assoc name profile))
              result)
      (message "No Changes"))

    (let*
        ((brand-new-profile
          (if (assoc name profile)
              (mapcar (lambda (prof)
                        (if (eq (car prof) name)
                            `(,name ,result)
                          prof))
                      profile)
            (append profile `((,name ,result)))))
         (names (mapcar (lambda (pair)
                          (car pair))
                        brand-new-profile)))

      (let ((profile/file (pit/profile)))
        (set-buffer (find-file-noselect profile/file))
        (unless (file-exists-p profile/file)
          (set-buffer-modified-p t)
          (save-buffer)
          (set-file-modes profile/file ?\600)))
      (erase-buffer)
      (insert "--- ")
      (mapc (lambda (name)
              (insert (format "\n%s: " (pit/yaml-quote (symbol-name name))))
              (mapcar (lambda (pair)
                        (insert
                         (format "\n  %s: %s "
                                 (pit/yaml-quote (symbol-name (car pair)))
                                 (pit/yaml-quote (cdr pair)))))
                      (cadr (assoc name brand-new-profile))))
            names)
      (insert "\n")
      (save-buffer)
      (kill-buffer))
    result))

(defun pit/get (name &optional opts)
  (let* ((profile (pit/load))
         (ret (cadr (assoc name profile))))

    (if (eq (car opts) 'require)
        (let*
            ((required (cadr opts))
             (keys (mapcar (lambda (cons)
                             (car cons))
                           required)))
          (when keys
            (if (pit/keys/all-p ret keys)
                ret
              (pit/set name `(config ,(pit/alist/update required ret))))))
      ret)))

(defun pit/load ()
  (let
      ((dirname (expand-file-name pit/directory)))
    (unless (file-accessible-directory-p dirname)
      (make-directory dirname)
      (set-file-modes dirname ?\700))
    (unless (file-exists-p pit/config)
       (set-buffer (find-file-noselect pit/config))
       (insert "--- \nprofile: default\n")
       (save-buffer)
       (kill-buffer)
       (set-file-modes pit/config ?\600)))
  (let ((profile/file (pit/profile))
        result)
    (when (and profile/file
               (file-exists-p profile/file))
      (with-temp-buffer
        (insert-file-contents profile/file)
        (let ((regexp1 "^\\([\"']?\\)\\(.+?\\)\\1 *: *$")
              (regexp2
               "^ +\\(\\([\"']?\\)\\(?:.+?\\)\\2\\) *: *\\(\\([\"']?\\)\\(?:.*?\\)\\4\\) *$"))
          (while (re-search-forward regexp1 nil t)
            (let ((name (intern (pit/yaml-unquote (match-string 2))))
                  (bound (save-excursion (re-search-forward regexp1 nil t)))
                  config)
              (while (re-search-forward regexp2 bound t)
                (let* ((raw-key (match-string 1))
                       (raw-value (match-string 3))
                       (key (intern (pit/yaml-unquote raw-key)))
                       (value (pit/yaml-unquote raw-value)))
                  (setq config (append config `((,key . ,value))))))
              (setq result (append result `((,name . (,config)))))))))
      result)))

(defun pit/yaml-quote (object)
  (cond
   ((null object)
    "~")
   ((stringp object)
    (cond
     ((equal object "")
      "''")
     ((string-match "[\"'\n]" object)
      (format
       "\"%s\""
       (replace-regexp-in-string
        "\n" "\\\\n"
        (replace-regexp-in-string "\"" "\\\\\"" object))))
     ((string-match "\\`[^0-9A-Za-z_]\\|[[:space:]]\\|:\\'" object)
      (format "'%s'" object))
     (t object)))))

(defun pit/yaml-unquote (string)
  (setq string (replace-regexp-in-string
                "\\`[[:space:]]+\\|[[:space:]]+\\'" "" string))
  (cond
   ((string-match "\\`'\\(.*\\)'\\'" string)
    (replace-regexp-in-string "''" "'" (match-string 1 string)))
   ((string-match "\\`\"\\(.*\\)\"\\'" string)
    (replace-regexp-in-string
     "\\\\\"" "\""
     (replace-regexp-in-string "\\\\n" "\n" (match-string 1 string))))
   (t
    (unless (or (equal string "~")
                (equal string ""))
      string))))

;;; Test
(defvar pit/test-profile-yaml
  "---
profile: default
")

(defvar pit/test-profile-yaml-quoted
  "---
\"profile\": 'default'"
)


(dont-compile
  (when (fboundp 'expectations)
    (expectations
      (desc "pit/profile")
      (expect "default"
        (with-temp-buffer
          (insert pit/test-profile-yaml)
          (goto-char (point-min))
          (when (re-search-forward pit/profile-regexp nil t)
            (match-string 1))))

      (expect "default"
        (with-temp-buffer
          (insert pit/test-profile-yaml-quoted)
          (goto-char (point-min))
          (when (re-search-forward pit/profile-regexp nil t)
            (match-string 1))))
      )))


(provide 'pit)

;;; pit.el ends here

;; Local Variables:
;; mode: emacs-lisp
;; coding: utf-8-unix
;; indent-tabs-mode: nil
;; End:
	;;; pit.el --- Manipulate pit data.

	;; Copyright (C) 2008 Takeru Naito
	;; Author: Takeru Naito <takeru.naito@gmail.com>
	;; Original: cho45 http://lowreal.rubyforge.org/pit/

	;; This file 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 file 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:

	;; * Description
	;;
	;; pit.el manipulate Pit data.
	;
	;; See http://lowreal.rubyforge.org/pit/
	;;
	;; * Usage
	;;
	;; Just put the code like below into your .emacs:
	;;
	;; (require 'pit)
	;;
	;; (pit/get 'github.com)
	;; (pit/get 'github.com '(require ((user . "Your github user name")
	;; (token . "Your github token"))))
	;;
	;; (pit/set 'github.com)
	;; (pit/set 'github.com '(config ((user . "Your github user name")
	;; (token . "Your github token"))))
	;; (pit/set 'github.com '(data ((user . "Your github user name")
	;; (token . "Your github token"))))

	;;; Change Log:

	;; 2008-12-19:
	;; * Initial import

	(eval-when-compile (require 'cl))

	(defun pit/x->bool (elt) (not (not elt)))

	(defun pit/fold-left (proc init lis)
	(if lis (pit/fold-left proc (funcall proc init (car lis)) (cdr lis)) init))

	(defvar pit/directory "~/.pit")
	(defvar pit/config (expand-file-name
	(format "%s/%s.yaml" pit/directory "pit")))

	(defun pit/alist/update (base other)
	(mapcar (lambda (key)
	(or (assoc key other)
	(assoc key base)))
	(let ((hash (make-hash-table :test 'eql)))
	(loop for cons in (append base other)
	for key = (car cons)
	unless (gethash key hash)
	do (puthash key key hash)
	finally return
	(loop for x being the hash-values in hash collect x)))))

	(defvar pit/profile-regexp
	(rx bol
	(? (or "\"" "'"))
	"profile"
	(? (or "\"" "'"))
	":"
	(* space)
	(? (or "\"" "'"))
	(group
	(+? nonl))
	(? (or "\"" "'"))
	(? "\r")
	eol))

	(defun pit/profile ()
	(when (file-exists-p pit/config)
	(let* ((profile
	(with-temp-buffer
	(insert-file-contents pit/config)
	(when (re-search-forward pit/profile-regexp nil t)
	(match-string 1))))
	(profile/file
	(expand-file-name
	(format "%s/%s.yaml" pit/directory profile))))
	profile/file)))

	(defun pit/keys/all-p (ret keys)
	(pit/x->bool
	(pit/fold-left (lambda (x y)
	(and x (assoc y ret) y))
	t keys)))

	(defun pit/set (name &optional opts)
	(let ((profile (pit/load))
	(result
	(if (eq (car opts) 'data)
	(cadr opts)
	(mapcar
	(lambda (pair)
	(let ((key (car pair))
	(value (cdr pair)))
	(cons key
	(read-from-minibuffer
	(format "\[%s\] %s: " name key)
	value))))
	(or (cadr opts)
	(pit/get name))))))

	(when (eq (or (assoc 'config opts)
	(assoc name profile))
	result)
	(message "No Changes"))

	(let*
	((brand-new-profile
	(if (assoc name profile)
	(mapcar (lambda (prof)
	(if (eq (car prof) name)
	`(,name ,result)
	prof))
	profile)
	(append profile `((,name ,result)))))
	(names (mapcar (lambda (pair)
	(car pair))
	brand-new-profile)))

	(let ((profile/file (pit/profile)))
	(set-buffer (find-file-noselect profile/file))
	(unless (file-exists-p profile/file)
	(set-buffer-modified-p t)
	(save-buffer)
	(set-file-modes profile/file ?\600)))
	(erase-buffer)
	(insert "--- ")
	(mapc (lambda (name)
	(insert (format "\n%s: " (pit/yaml-quote (symbol-name name))))
	(mapcar (lambda (pair)
	(insert
	(format "\n %s: %s "
	(pit/yaml-quote (symbol-name (car pair)))
	(pit/yaml-quote (cdr pair)))))
	(cadr (assoc name brand-new-profile))))
	names)
	(insert "\n")
	(save-buffer)
	(kill-buffer))
	result))

	(defun pit/get (name &optional opts)
	(let* ((profile (pit/load))
	(ret (cadr (assoc name profile))))

	(if (eq (car opts) 'require)
	(let*
	((required (cadr opts))
	(keys (mapcar (lambda (cons)
	(car cons))
	required)))
	(when keys
	(if (pit/keys/all-p ret keys)
	ret
	(pit/set name `(config ,(pit/alist/update required ret))))))
	ret)))

	(defun pit/load ()
	(let
	((dirname (expand-file-name pit/directory)))
	(unless (file-accessible-directory-p dirname)
	(make-directory dirname)
	(set-file-modes dirname ?\700))
	(unless (file-exists-p pit/config)
	(set-buffer (find-file-noselect pit/config))
	(insert "--- \nprofile: default\n")
	(save-buffer)
	(kill-buffer)
	(set-file-modes pit/config ?\600)))
	(let ((profile/file (pit/profile))
	result)
	(when (and profile/file
	(file-exists-p profile/file))
	(with-temp-buffer
	(insert-file-contents profile/file)
	(let ((regexp1 "^\\([\"']?\\)\\(.+?\\)\\1 : $")
	(regexp2
	"^ +\\(\\([\"']?\\)\\(?:.+?\\)\\2\\) : \\(\\([\"']?\\)\\(?:.?\\)\\4\\) $"))
	(while (re-search-forward regexp1 nil t)
	(let ((name (intern (pit/yaml-unquote (match-string 2))))
	(bound (save-excursion (re-search-forward regexp1 nil t)))
	config)
	(while (re-search-forward regexp2 bound t)
	(let* ((raw-key (match-string 1))
	(raw-value (match-string 3))
	(key (intern (pit/yaml-unquote raw-key)))
	(value (pit/yaml-unquote raw-value)))
	(setq config (append config `((,key . ,value))))))
	(setq result (append result `((,name . (,config)))))))))
	result)))

	(defun pit/yaml-quote (object)
	(cond
	((null object)
	"~")
	((stringp object)
	(cond
	((equal object "")
	"''")
	((string-match "[\"'\n]" object)
	(format
	"\"%s\""
	(replace-regexp-in-string
	"\n" "\\\\n"
	(replace-regexp-in-string "\"" "\\\\\"" object))))
	((string-match "\\`[^0-9A-Za-z_]\\\|[[:space:]]\\\|:\\'" object)
	(format "'%s'" object))
	(t object)))))

	(defun pit/yaml-unquote (string)
	(setq string (replace-regexp-in-string
	"\\`[[:space:]]+\\\|[[:space:]]+\\'" "" string))
	(cond
	((string-match "\\`'\\(.*\\)'\\'" string)
	(replace-regexp-in-string "''" "'" (match-string 1 string)))
	((string-match "\\`\"\\(.*\\)\"\\'" string)
	(replace-regexp-in-string
	"\\\\\"" "\""
	(replace-regexp-in-string "\\\\n" "\n" (match-string 1 string))))
	(t
	(unless (or (equal string "~")
	(equal string ""))
	string))))

	;;; Test
	(defvar pit/test-profile-yaml
	"---
	profile: default
	")

	(defvar pit/test-profile-yaml-quoted
	"---
	\"profile\": 'default'"
	)


	(dont-compile
	(when (fboundp 'expectations)
	(expectations
	(desc "pit/profile")
	(expect "default"
	(with-temp-buffer
	(insert pit/test-profile-yaml)
	(goto-char (point-min))
	(when (re-search-forward pit/profile-regexp nil t)
	(match-string 1))))

	(expect "default"
	(with-temp-buffer
	(insert pit/test-profile-yaml-quoted)
	(goto-char (point-min))
	(when (re-search-forward pit/profile-regexp nil t)
	(match-string 1))))
	)))


	(provide 'pit)

	;;; pit.el ends here

	;; Local Variables:
	;; mode: emacs-lisp
	;; coding: utf-8-unix
	;; indent-tabs-mode: nil
	;; End: