| << | < | 2005-08 | > | >> | ||
|---|---|---|---|---|---|---|
| Su | Mo | Tu | We | Th | Fr | Sa |
| 1 | 2 | 3 | 4 | 5 | 6 | |
| 7 | 8 | 9 | 10 | 11 | 12 | 13 |
| 14 | 15 | 16 | 17 | 18 | 19 | 20 |
| 21 | 22 | 23 | 24 | 25 | 26 | 27 |
| 28 | 29 | 30 | 31 | |||
;;; -*- MODE: Lisp; PACKAGE: EDITOR; -*-
;;;
;;; custom completion library
;;;
;;;
;;;
(provide "customcompletion")
(defvar *completion-exist-message* "Possible completions are:\n\n")
(defvar *completion-not-exist-message* "No possible completions.\n\n")
(defvar *completion-message-line-num* 2)
(defvar *completion-list-buffer* "*Completion List Items*")
(defvar *completion-completing-list* nil)
(defun index-generator (&optional index)
(let ((idx (or index *completion-message-line-num*)))
#'(lambda (&optional reset)
(if reset
(setq idx (1+ *completion-message-line-num*))
(setq idx (1+ idx))))))
(defun get-list-item (list-buffer index)
(let ((from nil) (to nil))
(set-buffer list-buffer)
(goto-line index)
(setq from (progn (goto-bol) (point)))
(setq to (progn (goto-eol) (point)))
(buffer-substring from to)))
(defun get-matched-list (regexp lst)
(remove-if
#'(lambda (x)
(eql nil x))
(mapcar
#'(lambda (x)
(if (eql nil
(string-match
(format nil "^~A" regexp) x))
nil
x)) lst)))
(defun clear-buffer (lst buf)
(set-buffer buf)
(delete-region (point-min) (point-max))
(if (< 0 (length lst))
(insert *completion-exist-message*)
(insert *completion-not-exist-message*))
(dolist (item lst)
(when (not (eql nil item))
(insert (format nil "~A\n" item)))))
(defun custom-completion (lst &optional str)
(interactive)
(let ((curbuf (selected-buffer))
(buf (get-buffer-create *completion-list-buffer*))
(items lst)
(ans (or str ""))
(myindex (index-generator)))
(save-window-excursion
(split-window)
(set-buffer buf)
(mapc 'make-local-variable '(auto-save need-not-save))
(setq auto-save nil)
(setq need-not-save t)
(if (string-equal "" ans)
(clear-buffer items buf)
(clear-buffer (get-matched-list ans items) buf))
(loop
(minibuffer-prompt "Completing : ~A" ans)
(let ((c (read-char *keyboard*)))
(case c
(#\RET (return ans))
(#\C-h #| 2005.08.09 修正しました |# (let ((len (length ans)))
(when (not (= 0 len))
(setq ans (substring ans 0 (1- len)))
(clear-buffer (get-matched-list ans items) buf))))
(#\Left )
(#\Right )
(#\TAB (let ((lines (funcall myindex)))
(if (< lines (buffer-lines buf))
(setq ans (get-list-item buf lines))
(setq ans (get-list-item buf (funcall myindex t))))))
(#\C-g (delete-buffer buf)
(quit))
(t (setq ans (format nil "~A~C" ans c))
(clear-buffer (get-matched-list ans items) buf))))))
(delete-buffer buf)
(insert (format nil "~A" (if str
(let ((start (mismatch str ans)))
(if (eql nil start)
ans
(substring ans start)))
ans)))))
(defun execute-custom-completion ()
(interactive)
(let ((str nil))
(setq str (or (selection-start-end (start end)
(buffer-substring start end))
(save-excursion
(buffer-substring (progn
(skip-syntax-spec-forward "w_")
(point))
(progn
(skip-syntax-spec-backward "w_")
(point))))))
(custom-completion *completion-completing-list* str)))
(defun for-lisp-interaction-mode ()
(setq *completion-completing-list*
(make-list-from-keyword-table
(load-keyword-file "lisp")))
(define-key ed::*lisp-interaction-mode-map* '(#\C-c #\;)
'execute-custom-completion))
(defun for-lisp-mode ()
(setq *completion-completing-list*
(make-list-from-keyword-table
(load-keyword-file "lisp")))
(define-key ed::*lisp-mode-map* '(#\C-c #\;)
'execute-custom-completion))
(add-hook 'ed::*lisp-interaction-mode-hook* 'for-lisp-interaction-mode)
(add-hook 'ed::*lisp-mode-hook* 'for-lisp-mode)(require "ccompletion.l");;; -*- MODE: LISP; PACKAGE: EDITOR; -*-
;;;
;;;
(defpackage "GPG"
(:use "lisp" "editor"))
(in-package "GPG")
(defvar *gpg-path* "X:/path/to/GnuPG")
(defvar *gpg* (merge-pathnames "gpg.exe" *gpg-path*))
(defvar *gpg-default-user* nil)
(defvar *gpg-signed-file-suffix* ".asc")
(defvar *gpg-encrypt-file-suffix* ".gpg")
(defvar *gpg-change-background-color-when-signed* nil)
(defvar *gpg-change-background-color-when-success-verify* nil)
(defvar *gpg-default-background-color* #(#xffffff #x000000))
(defvar *gpg-signed-mailpart-color* #(#x55ff00 #x330000))
(defvar *gpg-success-verify-color* #(#x99ff99 #x444444))
(defconstant *gpg-start-signed-message* "-----BEGIN PGP SIGNED MESSAGE-----")
(defconstant *gpg-end-pgp-message* "-----END PGP SIGNATURE-----")
(defconstant *gpg-comment-message* "Using GnuPG(gpg.l) with KaMail.")
(defun gpg-sign (str &optional user phrase)
(let ((gpg nil)
(tmpfile (make-temp-file-name))
(buf (get-buffer-create "*OUT*"))
(buffer-data nil)
(usr (or user *gpg-default-user* (read-string "GPG User : " :default *gpg-default-user*)))
(passphrase (or phrase (read-string "Passphrase: ")))
(fp nil))
(with-open-file (fp tmpfile :direction :output)
(princ str fp))
(setq gpg (make-process
(concat *gpg* " -u " usr " --comment \"" *gpg-comment-message* "\" --passphrase-fd 0 --clearsign " tmpfile)))
(sit-for 0.1)
(process-send-string gpg (concat passphrase "\n"))
(sit-for 0.1)
(set-buffer buf)
(let ((line nil))
(with-output-to-buffer (buf)
(with-open-file (fp (concat tmpfile ".asc") )
(while (setq line (read-line fp nil nil nil))
(format t "~A\n" line)))))
(setq buffer-data (buffer-substring (point-min) (point-max)))
(delete-file tmpfile :if-does-not-exist :skip :if-access-denied :skip)
(delete-file (concat tmpfile ".asc") :if-does-not-exist :skip :if-access-denied :skip)
(delete-buffer buf)
buffer-data))
(defun gpg-signed-mailpart (&optional user)
(interactive)
(goto-line (point-min))
(scan-buffer "^$" :regexp t :tail t)
(next-line)
(when (eql (point) (point-max))
(message "No messages.")
(return-from gpg-signed-mailpart))
(let* ((from nil)
(to nil)
(luser (or user *gpg-default-user* (read-string "GPG User : " :default *gpg-default-user*)))
(uid (gpg-get-user-id luser))
(mailpart nil))
(save-excursion
(previous-line)
(goto-bol)
(insert "OpenPGP: id=")
(insert uid)
(insert #\LFD))
(setq from (point))
(save-excursion (goto-eol) (setq to (point)))
(setq mailpart (buffer-substring from to))
(delete-region from to)
(insert (gpg-sign mailpart luser))
(when *gpg-change-background-color-when-signed*
(set-buffer-colors *gpg-signed-mailpart-color*))
))
(defun gpg-get-user-id (&optional user)
(interactive)
(let ((buf (get-buffer-create "*GPG list-keys*"))
(usr (or user (read-string "GPG User: " :default *gpg-default-user*)))
(id nil))
(save-window-excursion
(execute-shell-command
(format nil "\"~A\" --list-keys ~A" *gpg* usr)
:output buf)
(set-buffer buf)
(goto-char (point-min))
(when (scan-buffer "^pub[ ]+[^/]+/\\([A-Z0-9]+\\).+" :regexp t)
(setq id (match-string 1)))
(delete-buffer buf)
id)))
(defun gpg-get-pgp-message ()
(interactive)
(let ((from nil) (to nil))
(save-excursion
(goto-char (point-min))
(when (scan-buffer *gpg-start-signed-message*)
(setq from (point)))
(when (scan-buffer *gpg-end-pgp-message* :tail t)
(setq to (point)))
(if (and from to)
(buffer-substring from to)
nil))))
(defun gpg-verify-signed-mail ()
(interactive)
(let ((buf (get-buffer-create "*GPG OUT*"))
(tmpfile (make-temp-file-name))
(keyid nil)
(date nil)
(signed-user nil)
(sign nil))
(save-window-excursion
(with-open-file (fp tmpfile :direction :output)
(princ (gpg-get-pgp-message) fp))
(execute-shell-command
(format nil "\"~A\" --verify ~A" *gpg* tmpfile)
:output buf)
(set-buffer buf)
(goto-char (point-min))
(when (scan-buffer ".*\\([0-9]\\{2\\}/[0-9]\\{2\\}/[0-9]\\{2\\} [0-9]\\{2\\}:[0-9]\\{2\\}:[0-9]\\{2\\}\\).*ID \\([A-F0-9]\\{8\\}\\).*" :regexp t)
(setq date (match-string 1))
(setq keyid (match-string 2)))
(when (scan-buffer ".*“\\(.*\\)”からの\\(.*\\)$" :regexp t)
(setq signed-user (match-string 1))
(setq sign (match-string 2))))
(delete-buffer buf)
(delete-file tmpfile)
(if (string= "正しい署名" sign)
(progn
(message "~A: Signed-Date: ~A, KeyID: ~A, Signed-User: ~A"
sign date keyid signed-user)
(if *gpg-change-background-color-when-success-verify*
(set-buffer-colors *gpg-success-verify-color*)))
(message "~A: Signed-Date: ~A, KeyID: ~A, Signd-User: ~A"
sign date keyid signed-user))))(in-package "kamail")
(defun gpg-auto-sign-mail ()
(interactive)
(GPG::gpg-signed-mailpart)
(kamail-create-and-send-buffer-quit))
(when *kamail-use-auto-sign*
(define-key km::*kamail-draft-map* '(#\C-c #\C-c) 'gpg-auto-sign-mail))
(defun gpg-auto-verify-signed-mail ()
(interactive)
(let ((openpgp-id nil)
(header (header-to-alist)))
(setq openpgp-id (get-header-value "openpgp" header))
(set-buffer-colors GPG::*gpg-default-background-color*)
(when openpgp-id
(setq openpgp-id (string-match "id=\\(.*\\)" openpgp-id))
(GPG::gpg-verify-signed-mail))))
(add-hook 'km::*kamail-show-mail-hook* 'gpg-auto-verify-signed-mail)(require "gpg/gpg")
;;; GnuPG
(setq GPG::*gpg-default-user* "GPG-USER")
(setq GPG::*gpg-change-background-color-when-signed* t)
(setq GPG::*gpg-change-background-color-when-success-verify* t)
;;; 勝手に署名もーど
(setq *kamail-use-auto-sign* t)
(define-key *kamail-draft-map* '(#\C-c #\S) 'GPG::gpg-signed-mailpart)
(define-key *kamail-view-map* '(#\C-c #\V) 'GPG::gpg-verify-signed-mail)
(require "gpg/gpg-misc")