;; mapae for xyzzy
;;   by S.Sugiyama
;;   Thu, 15 Mar 2007 23:48:12 +0900
;; == 設定例 ==
;; (require 'mapae)
;; (setq mapae-perl-command "perl")
;; (setq mapae-command "c:/program files/xyzzy/etc/mapae.pl")
;; (global-set-key '(#\C-c #\w #\n) 'mapae-new-post)
;; (global-set-key '(#\C-c #\w #\r) 'mapae-get-recent-post)
;; (global-set-key '(#\C-c #\w #\g) 'mapae-get-post)
;; (global-set-key '(#\C-c #\w #\l) 'mapae-get-recent-titles)
;; (setq mapae-favorite-mode 'xml-mode)
;; ;(setq mapae-browser-command  #'bx:navigate) ; browserex
;; (setq mapae-browser-command "c:/Program Files/Mozilla Firefox/firefox.exe")


(eval-when (:compile-toplevel :load-toplevel :execute)
  (defpackage mapae
    (:use "lisp" "editor"))
  (in-package 'mapae)
  (shadow '(define-key call-process erase-buffer re-search-forward 
	    forward-line interactive
	    set-process-sentinel read-file-name rename-buffer lambda 
	    buffer-name search-forward replace-match file-executable-p
	    format message assoc))
  )

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defmacro defgroup (&rest args))

  (defmacro defcustom (var val comment &rest args)
    `(progn
       (export (quote ,var))
       (defvar ,var ,val ,comment)))

  (defmacro save-current-buffer (&body body)
    `(block nil
       (let ((#1=#:buffer (selected-buffer))
	     (#2=#:res (progn ,@body)))
	 (set-buffer #1#)
	 #2#)))
  
  (defmacro current-buffer ()
    '(selected-buffer))
  
  (defmacro count-lines (&rest args)
    '(current-line-number))
  
  (defmacro with-current-buffer (buff &body body)
    `(block nil
       (let ((#3=#:buffer (selected-buffer))
	     (#4=#:res (progn (set-buffer ,buff) ,@body)))
	 (set-buffer #3#)
	 #4#)))

  (defun replace-cm-hyphen-something (str)
    (let ((start 0))
      (while (string-match "\\([CM]\\)-\\(.\\)" str start)
	(setq str (concatenate 'string (substring str 0 (match-beginning 0))
			       (string (code-char
					(if (string= (match-string 1) "C")
					    (logand (char-code (char (match-string 2) 0)) 31)
					  (logior (char-code (char (match-string 2) 0)) #x8000))))
			       (substring str (match-end 0))))
	(setq start (- (match-end 0) 2))))
    str)
  

  (defmacro define-key (keymap key func)
    (setq key (replace-cm-hyphen-something key))
    (let ((list  (coerce key 'list)))
      `(ed:define-key ,keymap (quote ,list) ,func)))
  
  (defmacro generate-new-buffer (name)
    `(create-new-buffer ,name))

  (defmacro set-process-sentinel(proc func)
    `(ed:set-process-sentinel ,proc #'(lisp:lambda (p) (funcall ,func p "finished\n"))))

  
  (defmacro accept-process-output (proc) t)


  (defmacro erase-buffer(&optional buffer)
    `(ed:erase-buffer (if ,buffer ,buffer (selected-buffer))))

  (defmacro read-from-minibuffer(prompt &optional initial)
    `(read-string ,prompt :default ,initial))
  
  (defmacro read-file-name (prompt &optional dir default-filename mustmatch
				   initial)
    `(ed:read-file-name ,prompt :default ,dir))
  
  (defmacro interrupt-process (proc)
    `(signal-process ,proc))
  
  (defmacro use-local-map (keymap)
    `(use-keymap ,keymap))
  
  (defmacro current-local-map ()
    `(local-keymap))
  
  (defmacro aset (array n elm)
    `(setf (aref ,array ,n) ,elm))

  (defmacro match-string-no-properties (n)
    `(match-string ,n))

  (defmacro buffer-substring-no-properties (start end)
    `(buffer-substring ,start ,end))
  
  (defmacro select-window(window)
    window)

  (defmacro file-name-directory (filename)
    `(directory-namestring ,filename))


  (defmacro file-name-nondirectory (filename)
    `(file-namestring ,filename))

  (defmacro kill-new (str)
    `(ed::kill-new ,str))

  (defmacro rename-buffer (name &optional unique)
    `(ed:rename-buffer ,name))

  (defmacro lambda (args &body body)
    `(function (lisp:lambda ,args ,@body)))

  (defmacro condition-case (var body &rest handlers)
    (list* 'handler-case body (mapcar #'(lisp:lambda (h) (list* (car h) '(c) 
								(cdr h))) handlers)))

  (defmacro set-keymap-parent (child parent)
    `(let ((#5=#:map1 (copy-keymap ,parent)))
       (dolist (l (cdr ,child))
	 (ed:define-key #5# (car l) (cdr l)))
       (setq ,child #5#)))

  (defmacro add-to-list (list-var element &optional append)
    (if append
	`(setq ,(eval list-var) (append ,(eval list-var) (list ,element)))
      `(setq ,(eval list-var) (append (list ,element) ,(eval list-var)))))

  (defmacro replace-match (newtext &optional fixedcase)
    `(ed:replace-match ,newtext))

  (defmacro interactive (&optional arg)
    `(ed:interactive ,(cond ((equal arg "P") "p")
			 (t arg))))

  )


(export '(mapae-new-post
          mapae-get-recent-post
          mapae-get-post
          mapae-get-recent-titles
	  mapae-hatena-keyword-hide
	  mapae-hatena-keyword-show
	  mapae-change-text-filter
	  ))

(defconstant emacs-xyzzy-encode-alist
  (list (cons 'sjis  *encoding-sjis*)
        (cons 'euc-jp  *encoding-euc-jp*)
        (cons 'junet  *encoding-jis*)
        (cons 'utf-8  *encoding-utf8*)))


(defvar highlight-attribute '(:bold t :foreground 3)
  "ハイライト表示の属性")

(defvar invisible-attribute '(:foreground 7)
  "非可視表示の属性")

(defvar underline-attribute '(:underline t)
  "アンダーライン表示の属性")

(defun assoc (key list)
  (lisp:assoc key list :test #'equal))

(defun buffer-name (&optional buffer)
  (ed:buffer-name (if buffer buffer (selected-buffer))))

(defun call-process (program &optional infile destination display &rest args)
  (let ((cmdline program)
	(outfile (make-temp-file-name))
	result)
    (dolist (arg args nil)
      (setq cmdline (concatenate 'string cmdline " \"" arg "\"")))
    (setq result (ed:call-process cmdline
				  :input infile
				  :output outfile
				  :show :minimize
				  :wait t))
    (cond ((eq destination t)
	   (insert-file-contents outfile))
	  ((not destination) nil)
	  (t
           (save-current-buffer
            (set-buffer destination)
            (insert-file-contents outfile))))
    (delete-file outfile)
    result
    ))

(defun call-process-region(start end program &optional delete destination display &rest args)
  (let ((infile (make-temp-file-name))
	result)
    (write-region start end infile nil (cdr (assoc mapae-default-process-coding-system emacs-xyzzy-encode-alist)))
    (setq result (apply 'call-process program infile destination display args))
    (if delete
	(delete-region start end))
    (delete-file infile)
    result))


(defun start-process(name destination program &rest args)
  (let ((cmdline program))
    (dolist (arg args nil)
      (setq cmdline (concatenate 'string cmdline " \"" arg "\"")))
    (let ((proc
           (make-process cmdline :output destination :eol-code *eol-crlf*)))
      proc)))



(defun process-send-region(proc start end)
  (process-send-string proc (buffer-substring start end)))

(defun process-send-eof(proc)
  (process-send-string proc "\032\n"))

(defun number-to-string(number)
  (lisp:format nil "~D" number))

(defun string-to-number(string)
  (parse-integer string))



(defun re-search-forward (exp &optional limit fail count)
  (let ((result (ed:re-search-forward exp fail)))
    (if result
        (goto-char (match-end 0)))
    result))

(defun search-forward (exp &optional limit fail)
  (let ((result (ed:search-forward exp fail)))
    (if result
        (progn
          (goto-char (match-end 0))
          (point))
      nil)))


(defun forward-line (&optional (n 1))
  (let ((actual (ed:forward-line n)))
    (if actual
        (- n actual)
      n)))


(defun mapae-change-process-coding-system ()
  (make-variable-buffer-local '*default-process-encoding*)
  (setq *default-process-encoding*
        (cdr (assoc mapae-default-process-coding-system
                    emacs-xyzzy-encode-alist))))


(defun one-window-p (&optional minibuf all-frames)
  (= 1 (count-windows minibuf)))

(defun file-name-sans-extension (name)
  "Return FILENAME sans extension"
  (substring name 0
             (or (string-match "\\.[^.]*$" name)
                 (length name))))

(defun file-name-extension (name &optional period)
  "Return extension of FILENAME"
  (if (string-match "\\.\\([^.]*\\)$" name)
      (if period
          (match-string 0)
        (match-string 1))
    (if period "" nil)))

(defun put-text-property (start end property value &optional object)
  (cond ((eq property 'invisible)
         (if value
	     (apply #'set-text-attribute start end property invisible-attribute))))
  t)


(defun map-y-or-n-p (prompter actor list)
  (let ((count 0))
    (do* ((ls list (if (consp list) (cdr ls) list))
          (l (if (consp list)
                 (car ls)
               (funcall list))
             (if (consp list)
                 (car ls)
               (funcall list))))
        ((null l) count)
      (let ((reply (funcall prompter l)))
        (when (cond ((stringp reply)
                     (y-or-n-p reply))
                    ((null reply)
                     nil)
                    (t
                     t))
          (incf count)
          (funcall actor l))))))


(defun make-overlay (begin end)
  (let ((sym (gensym)))
    (set-text-attribute begin end sym)
    sym))

(defun overlay-put (overlay prop value)
  (setf (get overlay prop) value)
  (cond ((eq prop 'face)
         (cond ((eq value 'underline)
                (apply #'modify-text-attributes overlay 
		       underline-attribute))
               ((eq value 'highlight)
                (apply #'modify-text-attributes overlay 
		       highlight-attribute))))
        ((eq prop 'invisible)
         (if value
             (apply #'modify-text-attributes overlay 
		    invisible-attribute)))))


(defun overlay-get (overlay prop)
  (get overlay prop))

(defun overlays-in (start end)
  (let (ol from to ols)
    (do ((next start to))
        ((or (null next) (> next end)) ols)
      (multiple-value-setq (from to ol)
          (find-text-attribute t :test #'(lisp:lambda (a b) t) :start next))
      (if ol (setq ols (append ols (list ol)))))))


(defun move-overlay (overlay begin end)
  (delete-text-attributes overlay)
  (set-text-attribute begin end overlay)
  (let (attributes (face (get overlay 'face)))
    (cond ((eq face 'highlight)
           (setq attributes (append attributes highlight-attribute)))
          ((eq face 'underline)
           (setq attributes (append attributes underline-attribute))))
    (apply #'modify-text-attributes overlay attributes)))


(defun delete-overlay(overlay)
  (delete-text-attributes overlay))


(defun format (string &rest objects)
  (let ((newstring (substitute-string string "%." "~A")))
    (apply #'lisp:format nil newstring objects)))

(defun message (string &rest objects)
  (let ((newstring (substitute-string string "%." "~A")))
    (apply #'ed:message newstring objects)))

(defun file-executable-p (path)
  (and (file-exist-p path)
       (member (pathname-type path) '("exe" "bat") :test #'equal)
       t))

(eval-when (:compile-toplevel)
  (let ((el (find-load-path "mapae.el")))
    (if (string= (pathname-type el) "lc")
	(setq el (pathname-name el)))
    (byte-compile-file el)))

(load-library "mapae.el")

;;文字化け対応
(setq mapae-default-process-coding-system 'sjis)
(setq mapae-browser-option '("<URL>"))

;;; mapae のコード終わり
(in-package 'user)
(use-package 'mapae)

(provide 'mapae)


t