(defvar my-libdir (expand-file-name "" (file-name-directory
(or load-file-name buffer-file-name))))
(dolist (dir (nreverse (list my-libdir "/usr/local/share/emacs/site-lisp")))
(if (member dir load-path) nil
(setq load-path (cons dir load-path))
(let ((default-directory dir))
(load (expand-file-name "subdirs.el") t t t))))
(defvar my-emacs-new-version nil)
(let ((coding-system-for-write 'no-conversion)
my-previous-emacs-build-system my-previous-emacs-build-time)
(with-current-buffer (find-file-noselect
(expand-file-name "previous_version" my-libdir)
t)
(eval-buffer)
;; 同じマシンで6時間以内にビルドしたものは同じと見做す (X11 と Carbon とか)
(unless (and (equal emacs-build-system my-previous-emacs-build-system)
(< (abs (- (float-time emacs-build-time)
(float-time my-previous-emacs-build-time)))
(* 6 3600)))
(setq my-emacs-new-version t)
(setq buffer-undo-list t)
(erase-buffer)
(insert ";;; -*- coding: no-conversion; -*-\n")
(insert (format "(setq my-previous-emacs-build-system '%S)\n"
emacs-build-system))
(insert (format "(setq my-previous-emacs-build-time '%S)\n"
emacs-build-time))
(save-buffer))
(kill-buffer nil)))
(let ((my-initdefs-file (expand-file-name "initdefs" my-libdir)))
(when (and (or my-emacs-new-version
(not (file-exists-p my-initdefs-file)))
(null (get-file-buffer my-initdefs-file)))
(let ((print-length 3)
(print-level 2)
(coding-system-for-write 'no-conversion)
my-fun)
(with-current-buffer (find-file-noselect my-initdefs-file t)
(setq buffer-undo-list t)
(erase-buffer)
(insert "-*- coding: no-conversion; -*-\n")
(mapatoms (lambda (sym)
(when (boundp sym)
(insert (format "v: %s == %S\n" sym (symbol-value sym))))
(when (fboundp sym)
(setq my-fun (symbol-function sym))
(insert (format "f: %s == %S\n" sym
(cond ((eq (car-safe my-fun) 'autoload)
`(autoload ,(nth 1 my-fun)
,(nth 4 my-fun)))
((consp my-fun)
(car my-fun))
(t
"function")))))))
(save-buffer)
;; (kill-buffer nil)
))))
(defmacro my-funcall-with-current-buffer (buffer fun &rest args)
(declare (indent 1))
""
(let ((temp-args (make-symbol "temp-args"))
(temp-fun (make-symbol "temp-fun")))
`(let ((,temp-args (list ,@args))
(,temp-fun ,fun))
(with-current-buffer ,buffer (apply ,temp-fun ,temp-args)))))
(defmacro my-with-current-buffer (buffer bindings &rest body)
(declare (indent 2))
""
(let (vars values)
(dolist (binding bindings)
(if (consp binding)
(progn
(push (car binding) vars)
(push (cadr binding) values))
(push binding vars)
(push nil values)))
`(my-funcall-with-current-buffer ,buffer
(lambda ,vars ,@body)
,@values)))
(defvar my-ignore-error-handler (lambda (err) (message "%S" err) nil))
(defmacro my-ignore-error (&rest body)
(declare (indent 0))
(let ((temp-err (make-symbol "temp-err")))
`(condition-case ,temp-err
(progn ,@body)
(error (funcall my-ignore-error-handler ,temp-err)))))
(defmacro my-get-transient-region-or (&rest forms)
(declare (indent 0))
`(if (and transient-mark-mode mark-active)
(buffer-substring (region-beginning) (region-end))
,@forms))
(defmacro my-force-list (symbol)
`(if (listp ,symbol) ,symbol
(setq ,symbol (list ,symbol))))
(let ((getenvs-command '("zsh" "-c" "env"))
(buffer-name "*my-env*")
(ignore-envs '("_" "SHLVL" "PWD" "OLDPWD")))
(with-current-buffer (get-buffer-create buffer-name)
(setq buffer-undo-list t)
(erase-buffer)
(apply 'call-process (car getenvs-command) nil t t (cdr getenvs-command))
(goto-char (point-min))
;; error of re-search-forward in middle of the buffer is fatal
(while (and (< (point) (point-max))
(re-search-forward "\\=\\([^=\n]*\\)=\\(.*\\)\n"))
(let ((var (match-string 1))
(val (match-string 2)))
(unless (member var ignore-envs)
(setenv var val))
(when (string-equal var "PATH")
(let ((new-exec-path nil))
(dolist (elt (split-string val ":" t))
(add-to-list 'new-exec-path elt))
(dolist (elt exec-path)
(add-to-list 'new-exec-path elt))
(setq exec-path (nreverse new-exec-path))))
))
;;(kill-buffer nil)
))
(global-font-lock-mode 0)
(setq-default comint-scroll-show-maximum-output nil)
(eval-when-compile 'comint) (setq-default comint-get-old-input (lambda () (comint-bol) ; skip prompt (buffer-substring-no-properties (point) (let ((inhibit-field-text-motion t)) (line-end-position)))))
(setq process-connection-type t)
(setq system-uses-terminfo nil)
(fringe-mode '(5 . 5)) (unless (eq window-system 'mac) (menu-bar-mode 0)) (when window-system (tool-bar-mode 0)) (when window-system (scroll-bar-mode -1))
(blink-cursor-mode 0)
(set-input-mode t nil t)
(eval-when-compile
(require 'wnn7egg-leim nil t)
(require 'wnn7egg nil t)
(require 'boiled-egg "boiled-egg7" t))
(when (require 'wnn7egg-leim nil t)
(set-input-method "japanese-egg-wnn7")
(toggle-egg-mode) ;XXX: うきー
(set-language-info "Japanese" 'input-method 'japanese-egg-wnn7)
(setq wnn7-server-name "jserver")
(when (require 'boiled-egg "boiled-egg7" t)
(define-key global-map rK-trans-key 'rK-trans)
(define-key global-map rhkR-trans-key 'rhkR-trans)
;; (define-key global-map rRkh-trans-key 'rRkh-trans)
))
(eval-when-compile
(require 'egg nil t)
(or (fboundp 'wnn-make-backend) (load "wnn" t))
(or (fboundp 'boiling-rK-trans) (load "boiling-egg" t)))
(when (and (not (featurep 'wnn7egg-leim))
(require 'egg nil t))
(setq its-enable-fullwidth-alphabet nil)
(define-key egg-conversion-map " " 'egg-exit-conversion-unread-char)
(define-key egg-conversion-map "\C-j" 'egg-next-candidate)
(define-key egg-conversion-map "\C-g" 'egg-abort-conversion)
(define-key egg-conversion-map "\C-l" 'egg-exit-conversion)
(define-key its-mode-map "\C-g" 'its-cancel-input)
(when (or (fboundp 'boiling-rK-trans) (load "boiling-egg" t))
(global-set-key "\C-j" 'boiling-rK-trans)
(global-set-key "\ej" 'boiling-rhkR-trans))
(setq wnn-jserver "jserver"))
(setq mac-pass-command-to-system nil)
(setq mac-pass-control-to-system nil)
(setq mac-ts-script-language-on-focus (cons 0 0))
(eval-when-compile
(require 'smtpmail nil t)
(require 'starttls nil t))
(setq user-full-name "Nozomu Ando")
(setq user-mail-address "nand@mac.com")
(setq smtpmail-smtp-server (or (getenv "SMTPSERVER") "smtp.mac.com"))
(setq smtpmail-smtp-service 587)
;;(setq smtpmail-debug-info t)
;;(setq send-mail-function 'smtpmail-send-it) ; if you use `mail'
(setq mail-user-agent 'message-user-agent)
(setq read-mail-command 'gnus)
(setq message-send-mail-function 'smtpmail-send-it) ; if you use message/Gnus
(setq smtpmail-auth-credentials ; or use ~/.authinfo
'(("smtp.mac.com" 587 "nand" nil)))
(setq smtpmail-starttls-credentials
'(("smtp.mac.com" 587 nil nil)))
(setq starttls-gnutls-program "/usr/local/bin/gnutls-cli")
(when (or (locate-file "aspell" exec-path exec-suffixes 'file-executable-p)
(locate-file "ispell" exec-path exec-suffixes 'file-executable-p))
(add-hook 'message-setup-hook (lambda () (flyspell-mode 1))))
(add-to-list 'ispell-skip-region-alist '("[[:nonascii:]]+"))
;;(setq max-specpdl-size 6000) ;;(setq max-lisp-eval-depth 3000)
(set-language-environment "Japanese") (prefer-coding-system 'iso-2022-jp) (setq default-process-coding-system '(utf-8 . utf-8))
;;(condition-case err ;; (utf-translate-cjk-mode t) ;; (error (message "failed execution utf-translate-cjk-mode: %s" err)))
(set-file-name-coding-system 'utf-8)
(push '(top . 0) default-frame-alist)
(defun my-frame-height-to-fit ()
(/ (- (display-pixel-height) 50)
(frame-char-height)))
(when window-system
(let ((fun (lambda () (set-frame-height nil (my-frame-height-to-fit)))))
(add-hook 'after-setting-font-hook fun)
(push (cons 'height (my-frame-height-to-fit)) default-frame-alist)
(funcall fun)))
(when (eq window-system 'mac) (setq mac-allow-anti-aliasing t))
(setq visible-bell t)
(setq auto-save-interval 500)
(setq backup-by-copying t)
(add-to-list 'global-mode-string '("" default-directory "-"))
(setq require-final-newline 1)
(require 'uniquify) (setq uniquify-buffer-name-style 'reverse)
(add-hook 'write-file-hooks 'copyright-update)
(setq enable-recursive-minibuffers t) (setq inhibit-splash-screen t) (setq list-directory-verbose-switches "-lF") (setq list-matching-lines-default-context-lines 2) (setq truncate-partial-width-windows nil) (setq save-abbrevs 'silently) (setq isearch-allow-scroll t) (column-number-mode 1)
(defun my-current-file-names (default &optional prompt)
"Return `current' file names. It can be list of file / directory names,
or nil."
(let ((arg (cond ((consp current-prefix-arg) 'query)
((eq current-prefix-arg '-) 'finder)
((integerp current-prefix-arg)
(if (zerop current-prefix-arg) 'dired current-prefix-arg))
(t default))))
(my-current-file-names-by arg prompt)))
(defun my-current-file-names-by (arg &optional prompt)
(or (cond ((eq arg 'query) (let ((fn (read-file-name (or prompt
"File name: "))))
(and (> (length fn) 0)
(list (expand-file-name fn)))))
((eq arg 'finder) (my-finder-selection))
((eq arg 'dired) (my-latest-dired-marked-files))
((integerp arg) (get-register arg))
(t (my-current-file-names-default)))
(progn
(message "No file.")
nil)))
(eval-when-compile (require 'dired))
(autoload 'dired-get-marked-files "dired")
(defun my-current-file-names-default ()
(if (eq major-mode 'dired-mode)
(dired-get-marked-files)
(list
(or buffer-file-name
(expand-file-name default-directory)))))
(defun my-latest-buffer (a-predicate)
(catch 'result
(dolist (buffer (buffer-list))
(when (with-current-buffer buffer a-predicate)
(throw 'result buffer)))))
(defun my-latest-dired-marked-files ()
(let ((buffer (my-latest-buffer (lambda () (eq major-mode 'dired-mode)))))
(and buffer
(with-current-buffer buffer
(dired-get-marked-files)))))
(make-local-variable (defvar my-insert-screencapture-func nil)) (make-local-variable (defvar my-insert-file-names-func nil))
(autoload 'gtags-mode "gtags" nil t) (defun my-c-mode-hook () (my-ignore-error (gtags-mode 1))) (add-hook 'c-mode-hook 'my-c-mode-hook) (eval-when-compile (require 'cc-mode)) (setq c-tab-always-indent nil)
(defconst netbsd-knf-style
'((c-auto-newline . nil)
(c-tab-always-indent . nil)
(c-recognize-knr-p . t)
(c-basic-offset . 8)
(c-comment-only-line-offset . 0)
(c-cleanup-list . (brace-else-brace
empty-defun-braces
defun-close-semi
list-close-comma
scope-operator))
(c-hanging-braces-alist . ((defun-open . (before after))
(defun-close . (before))
(class-open . (after))
(class-close . nil)
(inline-open . nil)
(inline-close . nil)
(block-open . (after))
(block-close . (before))
(substatement-open . nil)
(statement-case-open . nil)
(brace-list-open . nil)
(brace-list-close . nil)
(brace-list-intro . nil)
(brace-list-entry . nil)
))
(c-offsets-alist . ((knr-argdecl-intro . +)
(arglist-cont-nonempty . 4)
(knr-argdecl . 0)
(block-open . -)
(label . -)
(statement-cont . 4)
)))
"NetBSD KNF Style")
(eval-after-load "cc-mode"
`(funcall
,(lambda ()
(c-add-style "NetBSD KNF" netbsd-knf-style nil)
;; XXX: what to do this
(c-set-offset 'member-init-intro '++)
)))
;;(add-hook 'text-mode-hook (lambda () (auto-fill-mode 1)))
(eval-when-compile (require 'shell))
(eval-after-load "shell"
`(funcall
,(lambda ()
(define-key shell-mode-map "\C-c\C-f" 'shell-resync-dirs))))
(defun my-shell-insert-file-names (filenames)
(mapcar (lambda (filename) (insert " " (comint-quote-filename filename)))
filenames))
(defun my-shell-mode-hook ()
(setq my-insert-file-names-func 'my-shell-insert-file-names))
(add-hook 'shell-mode-hook 'my-shell-mode-hook)
(eval-when-compile (require 'picture))
(eval-after-load "picture"
`(funcall
,(lambda ()
(define-key picture-mode-map "\C-c4" 'picture-movement-left)
(define-key picture-mode-map "\C-c6" 'picture-movement-right)
(define-key picture-mode-map "\C-c8" 'picture-movement-up)
(define-key picture-mode-map "\C-c2" 'picture-movement-down)
(define-key picture-mode-map "\C-c7" 'picture-movement-nw)
(define-key picture-mode-map "\C-c9" 'picture-movement-ne)
(define-key picture-mode-map "\C-c1" 'picture-movement-sw)
(define-key picture-mode-map "\C-c3" 'picture-movement-se)
)))
(setq-default terminal-more-processing nil) (setq-default terminal-scrolling t) (setq-default terminal-redisplay-interval 500)
(eval-when-compile (require 'sml-mode nil t)) (defun my-sml-mode-hook () (define-key sml-mode-map "|" 'sml-electric-pipe)) (add-hook 'sml-mode-hook 'my-sml-mode-hook)
(eval-when-compile (require 'scheme)) (setq scheme-program-name "guile") (put 'scheme-program-name 'risky-local-variable t)
(autoload 'vhdl-mode "vhdl-mode" "VHDL Editing Mode" t)
(push '("\\.vhdl?\\'" . vhdl-mode) auto-mode-alist)
(eval-when-compile (require 'vhdl-mode))
(eval-after-load "vhdl-mode"
`(funcall
,(lambda ()
(define-key vhdl-mode-map [delete] 'backward-delete-char-untabify)
(define-key vhdl-mode-map [S-delete] 'backward-delete-char-untabify)
(define-key vhdl-mode-map [C-delete] 'backward-delete-char-untabify)
)))
(eval-when-compile
(require 'ruby-mode nil t)
(require 'inf-ruby nil t))
(autoload 'ruby-mode "ruby-mode" "Major mode for editing ruby scripts." t)
(autoload 'run-ruby "inf-ruby" "Run an inferior Ruby process." t)
(push '("\\.rb\\'" . ruby-mode) auto-mode-alist)
(push '("ruby" . ruby-mode) interpreter-mode-alist)
(autoload 'inf-ruby-keys "inf-ruby"
"Set local key defs for inf-ruby in ruby-mode." t)
(add-hook 'ruby-mode-hook 'inf-ruby-keys)
(add-to-list 'auto-mode-alist '("\\.e\\'" . eiffel-mode))
(autoload 'eiffel-mode "eiffel" "Major mode for Eiffel programs" t)
(add-to-list 'auto-mode-alist '("\\.p\\'" . prolog-mode))
(add-to-list 'auto-mode-alist '("\\.nr\\'" . nroff-mode))
(add-to-list 'auto-mode-alist '("\\.st\\'" . smalltalk-mode))
(add-to-list 'auto-mode-alist '("[0-9]\\'" . text-mode))
;;(setq gc-cons-threshold 200)
;;(setq gc-cons-threshold 2000000)
(put 'narrow-to-region 'disabled nil) (put 'downcase-region 'disabled nil)
(global-set-key "\C-z" 'scroll-down) (global-set-key "\M-\C-z" 'scroll-other-window-down)
(defun goto-line-piggyback ()
(interactive)
(goto-line
(string-to-number
(read-string "Goto line: "
(substring (this-command-keys) -1)))))
(dolist (digit '(?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9))
(define-key esc-map (vector ?g digit) 'goto-line-piggyback))
(define-key ctl-x-map [?\C-b] 'buffer-menu-other-window) (define-key ctl-x-map [?m] 'man) (defun my-previous-window (n) "select previous window." (interactive "p") (other-window (- n))) ;;(global-set-key "\C-xp" 'my-previous-window) (define-key ctl-x-map [?p] 'next-buffer) (define-key global-map [M-right] 'next-buffer) (define-key global-map [M-left] 'previous-buffer) (define-key global-map "\C-x\M-\C-o" 'other-frame)
(define-key function-key-map [C-return] "\C-m") (define-key function-key-map [S-return] "\C-m") (define-key function-key-map [C-tab] "\C-i") (define-key function-key-map [S-tab] "\C-i") (define-key global-map [S-delete] "\C-?") (define-key global-map [C-delete] "\C-?") (define-key global-map [M-return] "\C-m")
(dolist (ch '(?\C-2 ?\C-3 ?\C-4 ?\C-5 ?\C-6 ?\C-7 ?\C-8)) (define-key global-map (vector ch) nil)) (define-key function-key-map [?\C-2] [?\C-@]) (define-key function-key-map [?\C-3] [?\C-[]) (define-key function-key-map [?\C-5] [?\C-]]) (define-key function-key-map [?\C-6] [?\C-^]) (define-key function-key-map [?\C-7] [?\C-_]) (define-key function-key-map [?\C-8] [?\C-?])
(when (boundp 'minibuffer-local-filename-completion-map) (setq minibuffer-local-filename-completion-map minibuffer-local-completion-map minibuffer-local-must-match-filename-map minibuffer-local-must-match-map ))
(eval-when-compile (require 'hexl))
(eval-after-load "hexl"
`(funcall
,(lambda ()
(define-key hexl-mode-map "\e\C-x" 'hexl-insert-hex-string)
)))
(defvar my-shell-number 0 "count of shells invoked")
(defun my-new-shell (basename prog)
"invoke new shell with new buffer."
(let* ((buffer-name (concat basename
(int-to-string my-shell-number)))
(symbol (intern-soft (concat "my-shell-prog-" prog)))
(explicit-shell-file-name
(if (and symbol (boundp symbol))
(symbol-value symbol)
prog))
(inhibit-field-text-motion t)
(process-connection-type t))
(setq my-shell-number (1+ my-shell-number))
(shell buffer-name)))
(defun sh ()
"invoke new zsh."
(interactive)
(my-new-shell "," "zsh"))
(defun csh ()
"invoke new csh."
(interactive)
(my-new-shell ",csh" "csh"))
(defun bash ()
"invoke new bash."
(interactive)
(my-new-shell ",bash" "bash"))
(defun my-first-invoke-shell ()
(when (zerop my-shell-number)
(sh)
(delete-other-windows)))
(add-hook 'after-init-hook 'my-first-invoke-shell)
(eval-when-compile (require 'session nil t)) (defun my-session-initialize () ;;(when my-emacs-new-version ;; (my-ignore-error (delete-file session-save-file))) (setq session-save-file (expand-file-name ".session" my-libdir)) (session-initialize) (define-key ctl-x-map [?\C-_] 'session-jump-to-last-change)) (when (require 'session nil t) (add-hook 'after-init-hook 'my-session-initialize))
(defvar my-html-basedir "~/nand/Sites/" "base directory of my Site's files.")
(defvar my-html-filename "test.html" "file name of my Site's file.")
(defvar my-html-title "test" "title of my Site's file.")
(defvar my-html-cvs-headers (format "$%s$ $%s$\n" "Revision" "Date"))
(defvar my-html-header
'("<!DOCTYPE html PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\">
<html>
<head>
<title>" my-html-title "</title>
<meta http-equiv=\"content-type\" content=\"text/html; charset=iso-2022-jp\">
<style type=\"text/css\">
<!--
.paragraph { margin: 1em; }
-->
</style>
</head>
<body>
<h3>" my-html-title "</h3>
<hr>
") "HTML top part: list of (string|symbol)")
(defvar my-html-footer
'("<hr><!--
-->
<div class=paragraph>
<a href=\"mailto:" user-mail-address "\">" user-mail-address "</a>
<a href=\"index.html\">目次へ</a>
<img src=\"http://nand.homeunix.net/cgi-bin/counter/" my-html-filename
"\" alt=\"counter\">
" my-html-cvs-headers
"</div>
</body>
</html>
") "HTML bottom part: list of (string|symbol)")
(defun my-replace-in-sequence (lst beg end)
(save-excursion
(when (integerp end)
(setq end (copy-marker end)))
(dolist (param lst)
(goto-char beg)
(while (search-forward (car param) end t)
(replace-match (cdr param) t t)))))
(defvar my-pre-to-html-alist
'(("&" . "&") ("<" . "<") (">" . ">")
("«" . "«") ("»" . "»")
))
(defun my-pre-to-html (beg end)
"convert &<> for html."
(interactive "r")
(my-replace-in-sequence my-pre-to-html-alist beg end))
(defun my-html-eval-header-elt (elt)
(if (symbolp elt)
(or (and (boundp elt) (symbol-value elt)) "")
elt))
(defun my-emacs-to-html ()
"convert current buffer contents to html."
(interactive)
(let ((target-filename (and (bound-and-true-p my-html-basedir)
(bound-and-true-p my-html-filename)
(concat my-html-basedir my-html-filename)))
(buffer (current-buffer))
(target-buffer (get-buffer-create (generate-new-buffer-name
(concat (buffer-name) ".html"))))
(headers (mapcar 'my-html-eval-header-elt my-html-header))
(footers (mapcar 'my-html-eval-header-elt my-html-footer))
obuffer)
(setq obuffer (get-file-buffer target-filename))
(when obuffer (kill-buffer obuffer))
(save-excursion
(with-current-buffer target-buffer
(setq buffer-undo-list t)
(erase-buffer)
(apply 'insert headers)
(insert "<ul>\n"))
(goto-char (point-min))
(while (re-search-forward "\\(\\(?:^;;;.*\n\\)+\\)" nil 1)
(let ((lines (split-string (match-string 1) "\n\\|;;; *" t))
(beg (point))
(end (if (re-search-forward "\n+;;;" nil 1)
(match-beginning 0)
(point-max))))
(with-current-buffer target-buffer
(insert "<li>\n")
(dolist (x lines)
(insert x ?\n))
(when (< beg end)
(insert "<blockquote><pre>\n")
(let ((pos (point)))
(insert-buffer-substring buffer beg end)
(my-pre-to-html pos (point)))
(insert "\n</pre></blockquote>\n"))
(insert "</li>\n")))
(beginning-of-line))
(with-current-buffer target-buffer
(insert "</ul>\n")
(apply 'insert footers)
(write-file target-filename (null target-filename))))
;;(kill-buffer target-buffer)
(switch-to-buffer target-buffer))) ;XXX: evil for old Emacs
(define-key emacs-lisp-mode-map [menu-bar emacs-lisp separator-my] '("--"))
(define-key emacs-lisp-mode-map [menu-bar emacs-lisp my-emacs-to-html]
'("my-emacs-to-html" . my-emacs-to-html))
(defun my-undo-buffer (buffer undo-list old-undo-list)
(my-ignore-error
(my-with-current-buffer buffer
((undo-list undo-list)
l this-command pending-undo-list)
(setq l buffer-undo-list)
(while (null (car l))
(setq l (cdr l)))
(when (eq buffer-undo-list l)
(push nil buffer-undo-list))
(if (eq undo-list l)
(progn
(undo)
(setq buffer-undo-list old-undo-list))
(message "Undo failed in buffer %s" buffer)))))
(defmacro my-with-current-buffer-undoable (buffer bindings &rest body)
(declare (indent 2))
""
(let ((temp-buffer (make-symbol "temp-buffer"))
(temp-undo (make-symbol "temp-undo")))
`(let ((,temp-buffer ,buffer)
,temp-undo)
(prog1 (my-with-current-buffer ,temp-buffer ,bindings
(setq ,temp-undo buffer-undo-list)
(prog1 (progn ,@body)
(setq ,temp-undo (list 'apply 'my-undo-buffer ,temp-buffer
buffer-undo-list ,temp-undo))))
(push ,temp-undo buffer-undo-list)))))
(defun my-string-prefix-p (str1 str2)
"true if and only if STR1 is prefix of STR2."
(and (stringp str1) (stringp str2)
(= (compare-strings str2 nil nil str1 nil nil)
(1+ (length str1)))))
(defun my-get-html-filename-of-current-buffer ()
"make html-filename from current buffer's filename."
(if (and (local-variable-p 'my-html-filename)
(bound-and-true-p my-html-filename))
my-html-filename
(let ((bd (expand-file-name (bound-and-true-p my-html-basedir))))
(if (my-string-prefix-p bd buffer-file-name)
(substring buffer-file-name (length bd))
(file-name-nondirectory buffer-file-name)
(buffer-name)))))
(defun my-html-date-string (&optional time)
(let ((tm (decode-time (or time (current-time)))))
(format "%d/%d/%d" (nth 5 tm) (nth 4 tm) (nth 3 tm))))
(defun my-html-prepare (title)
"Insert headers and footers into the current buffer."
(interactive (list
(progn
(barf-if-buffer-read-only)
(my-get-transient-region-or
(read-string "HTML Title: " nil nil nil t)))))
(let ((my-html-title title)
(my-html-filename (my-get-html-filename-of-current-buffer))
(flg (> (point) (point-min)))
(date-string (my-html-date-string)))
(when flg
(push-mark (point) t)
(goto-char (point-min)))
(apply 'insert (mapcar 'my-html-eval-header-elt my-html-header))
(insert "<h4>[" date-string "]</h4>\n")
(unless flg
(push-mark (point) t))
(goto-char (point-max))
(apply 'insert (mapcar 'my-html-eval-header-elt my-html-footer))
(goto-char (mark))
(pop-mark)
(when (my-string-prefix-p (expand-file-name my-html-basedir)
buffer-file-name)
;; add a entry to index.html
(my-with-current-buffer-undoable (find-file-noselect "index.html" t)
((filename (file-name-nondirectory buffer-file-name))
(title title)
(date-string date-string))
(push-mark (point) t)
(goto-char (point-min))
(when (search-forward "<div class=\"toc\">\n" nil t)
(insert "\n <a href=\"" filename "\">" title "</a>\n"
" (" date-string ")<br>\n"))
(goto-char (mark))
(pop-mark)))))
(defvar my-html-image-mag 1 "*Maginificant ratio for my-html-image.")
(defun my-html-image (filenames &optional mag)
""
(interactive (list (my-current-file-names 'query "Image file: ")
(cond ((null current-prefix-arg) 1)
(t my-html-image-mag))))
(dolist (filename filenames)
(insert "<img src=\"" (file-relative-name filename) "\"")
(if (stringp mag)
(insert " width=\"" mag "\"")
(my-ignore-error
(let* ((image (create-image filename))
(size (image-size image t)))
(insert (format " width=%d height=%d"
(* mag (car size)) (* mag (cdr size)))))))
(insert " alt=\"" (file-name-nondirectory filename) "\">")
(newline)))
(defun my-html-fileref (filenames)
""
(interactive (list (my-current-file-names 'query "Href file: ")))
(dolist (filename filenames)
(insert "<a href=\"" (file-relative-name filename) "\">")
(push-mark (point) t)
(insert "</a>")
(newline))
(when filenames
(goto-char (mark))
(pop-mark)))
(defun my-html-date-id (&optional time)
(let ((tm (decode-time (or time (current-time)))))
(format "date-%d-%02d-%02d" (nth 5 tm) (nth 4 tm) (nth 3 tm))))
(defun my-html-date ()
""
(interactive)
(let* ((tm (current-time))
(date-id (my-html-date-id tm))
(date-string (my-html-date-string tm)))
(insert "<h4 id=\"" date-id "\">[" date-string "]")
(push-mark (point) t)
(insert "</h4>")
(goto-char (mark))
(pop-mark)
(when (file-exists-p "index.html")
(my-with-current-buffer-undoable (find-file-noselect "index.html" t)
((filename (file-name-nondirectory buffer-file-name))
(date-id date-id)
(date-string date-string))
(save-excursion
(goto-char (point-min))
(search-forward (concat "<a href=\"" filename "\">"))
(search-forward-regexp "</a>[[:space:]]+([[:digit:]/]+\\([^)]*\\))")
(replace-match (format " - <a href=\"%s#%s\">%s</a>"
filename date-id date-string)
t t nil 1))))))
(eval-when-compile (require 'sgml-mode))
(eval-after-load "sgml-mode"
`(funcall
,(lambda ()
(define-skeleton html-paragraph
"HTML paragraph tag."
nil
(if (looking-back "^\\s *") '> '\n)
"<div class=paragraph>" \n _ \n "</div>" >)
(define-skeleton my-html-code
""
nil
"<code>" _ "</code>")
(define-skeleton my-html-blockquote-code
""
nil
(if (looking-back "^\\s *") '> '\n)
"<blockquote><code>" \n _ \n "</code></blockquote>" >)
(define-key html-mode-map "\C-cc" 'my-html-code)
(define-key html-mode-map [menu-bar html my-html-code]
'("my-html-code" . my-html-code))
(define-key html-mode-map "\C-cC" 'my-html-blockquote-code)
(define-key html-mode-map [menu-bar html my-html-blockquote-code]
'("my-html-blockquote-code" . my-html-blockquote-code))
(define-key html-mode-map "\C-ci" 'my-html-image)
(define-key html-mode-map [menu-bar html my-html-image]
'("my-html-image" . my-html-image))
(define-key html-mode-map "\C-cf" 'my-html-fileref)
(define-key html-mode-map [menu-bar html my-html-fileref]
'("my-html-fileref" . my-html-fileref))
(define-key html-mode-map "\C-cd" 'my-html-date)
(define-key html-mode-map [menu-bar html my-html-date]
'("my-html-date" . my-html-date))
(define-key html-mode-map "\C-cv" 'my-pre-to-html)
(define-key html-mode-map [menu-bar html my-pre-to-html]
'("my-pre-to-html" . my-pre-to-html))
)))
(defun my-html-mode-hook ()
(setq my-insert-screencapture-func 'my-html-image)
(setq my-insert-file-names-func 'my-html-fileref))
(add-hook 'html-mode-hook 'my-html-mode-hook)
(defvar my-call-process nil)
(defun my-call-process (program &optional infile options &rest args)
"Call program synchronously for interactive usage.
Arguments INFILE and ARGS are as for `call-process'.
Display output of the program in the echo area if poessilbe, or, pop-up buffer
unless 'noshow is a element of list OPTIONS.
Do not erase previous `my-call-process' result if 'noerase is a element of
list OPTIONS.
Do not raise error if 'noerr is a element of list OPTIONS."
(let ((buffer (get-buffer-create " *my-process-output*"))
(noerase (memq 'noerase options))
(noerr (memq 'noerr options))
(noshow (memq 'noshow options))
(to-string (memq 'to-string options))
exitcode result)
(unless noerase
(with-current-buffer buffer
(erase-buffer)))
(setq exitcode
(if my-call-process
(funcall my-call-process program infile buffer nil args)
(apply 'call-process program infile buffer nil args)))
(unless (or noerr (zerop exitcode))
(with-current-buffer buffer
(error "External program `%s' exit(%d): %s"
program exitcode (buffer-string))))
(unless noshow
(display-message-or-buffer buffer))
(if to-string
(cons exitcode (with-current-buffer buffer (buffer-string)))
exitcode)))
(defvar my-screencapture-default-directory
(expand-file-name "~/Pictures/")
"*Default directory of my-screencapture.")
(defvar my-screencapture-type "png"
"*Type of my-screencapture. one of png, pdf, tiff, pict or jpeg.")
(defvar my-image-relpath ""
"*Relative directory for the resutl of my-screencapture.")
(defun my-screencapture (num)
"Take screencaptures.
Inserts image tags when html-mode."
(interactive "P")
(setq num (cond ((consp num) 1000)
((null num) 1)
(t num)))
(let ((basename "")
(dirname (expand-file-name default-directory))
regex maxnum imagename imagefullname imagelist insertfunc)
(unless (file-writable-p dirname)
(setq dirname my-screencapture-default-directory))
(when buffer-file-name
(setq basename (file-name-sans-extension
(file-name-nondirectory buffer-file-name))
insertfunc (and (not buffer-read-only)
my-insert-screencapture-func)))
(setq basename (if (equal basename "")
"capture"
(concat basename "_")))
(setq regex (concat (regexp-quote basename) "\\([0-9]+\\)\\."
(regexp-quote my-screencapture-type)))
(save-match-data
(setq maxnum (apply 'max 0
(mapcar (lambda (fn)
(if (string-match regex fn)
(string-to-number (match-string 1 fn))
0))
(directory-files dirname nil regex t)))))
(my-ignore-error
(dotimes (i num)
(setq imagename (concat my-image-relpath basename
(number-to-string (+ maxnum 1 i))
"." my-screencapture-type))
(setq imagefullname (concat dirname imagename))
(my-call-process "screencapture" nil nil
"-iW"
(concat "-t" my-screencapture-type)
imagefullname)
(unless (file-readable-p imagefullname)
(error "Screencapture aborted"))
(beep)
(push imagename imagelist)
(when insertfunc
(funcall insertfunc imagefullname))))
(setq imagelist (nreverse imagelist))
(message "%s: %s" dirname imagelist)
imagelist))
(defun my-query-save-or-not-buffer (buffer)
"If BUFFER is modified, prompt user to save it or not .
Nothing done if BUFFER is nil or noninteractive."
(unless noninteractive
(when (and buffer (buffer-modified-p buffer)
(y-or-n-p (format "Save buffer %s first? "
(buffer-name buffer))))
(with-current-buffer buffer (save-buffer)))))
(when (eq system-type 'darwin)
(defvar my-mac-open-app-hist nil)
(defvar my-mac-open-app-completion-list
'("iCab" "Firefox"))
(defvar my-mac-open-program "open")
(defun my-mac-open (application filenames &rest otherfiles)
"Invoke `open' external command with FILENAMES and OTHERFILES.
If APPLICATION is non-nil, invoke open with -a APPLICATOIN.
Interactively, FILENAMES is taken from file name of the current buffer
and prompts for APPLICATION and FILENAMES when you supply a prefix argument.
FILENAMES may be a file name or list of file names."
(interactive
(list (when current-prefix-arg
(completing-read "mac-open Application: "
my-mac-open-app-completion-list nil nil nil
my-mac-open-app-hist))
(my-current-file-names nil "Mac-open file: ")))
(my-force-list filenames)
(let (appargs exitcode)
(dolist (fn filenames)
(my-query-save-or-not-buffer (get-file-buffer fn)))
(setq appargs (when (and application (> (length application) 0))
(list "-a" application)))
(setq exitcode
(apply 'my-call-process my-mac-open-program nil '(noerr)
(append appargs filenames otherfiles)))
(when (and application (zerop exitcode))
(add-to-list 'my-mac-open-app-completion-list application))))
(global-set-key "\C-x\M-o" 'my-mac-open)
)
(when (eq system-type 'darwin)
(defun my-google (str)
"search STR via google.
Interactively, search transient-region or prompt user."
(interactive (list
(my-get-transient-region-or
(read-string "Google: " nil nil nil t))))
(let ((url (concat "http://www.google.com/search?q="
(mapconcat (lambda (ch) (format "%%%02X" ch))
(encode-coding-string str 'utf-8) ""))))
(browse-url url)))
(global-set-key "\C-x\M-g" 'my-google)
)
(when (eq system-type 'darwin)
(defvar my-mac-pb-coding-cache nil "cache for `my-mac-pb'")
(defconst my-mac-pb-env-name "__CF_USER_TEXT_ENCODING")
(defun my-mac-pb (encoding func)
"Funcall FUNC with process-environment whose \"__CF_USER_TEXT_ENCODING\"
contains ENCODING.
ENCODING is number or string defiend in \"TextCommon.h\".
Do not affect Emacs process itself. Please use call-process in FUNC."
(unless my-mac-pb-coding-cache
(let* ((oldcoding (getenv my-mac-pb-env-name))
(fmt (if (string-match "[^:]*:\\([^:]*\\):[^:]*" oldcoding)
(replace-match "%s" t t oldcoding 1)
(format "0x%X:%%s:0" (user-uid)))))
(setenv my-mac-pb-env-name nil)
(setq my-mac-pb-coding-cache
(cons oldcoding fmt))))
(setenv my-mac-pb-env-name (format (cdr my-mac-pb-coding-cache) encoding))
(unwind-protect
(funcall func)
(setenv my-mac-pb-env-name (car my-mac-pb-coding-cache))))
(defun my-mac-pbpaste ()
"Call pbpaste."
(interactive "*")
(my-mac-pb "0x8000100"
(lambda ()
(push-mark (point) t)
(call-process "pbpaste" nil t t))))
(defun my-mac-pbcopy (start end)
"Call pbcopy."
(interactive "r")
(my-mac-pb "0x8000100"
(lambda ()
(call-process-region start end "pbcopy"))))
(global-set-key "\C-x\M-y" 'my-mac-pbpaste)
(global-set-key "\C-x\M-w" 'my-mac-pbcopy))
(when (eq system-type 'darwin)
(defun my-do-applescript (str &optional options)
(let ((my-call-process my-call-process)
(program "osascript"))
(if nil ;; (fboundp 'do-applescript)
(progn
(setq my-call-process
(lambda (program &optional infile buffer display &reset args)
(condition-case err
(let ((result (do-applescript (cadr args))))
(when buffer (prin1 result buffer))
0)
(error (progn
(when buffer (prin1 err buffer))
1)))))
(setq program "do-applescript")))
(my-call-process program nil options "-e" str)))
(defconst my-mac-as-utf8string-begin
(encode-coding-string " & («data utf8" 'mac-roman))
(defconst my-mac-as-utf8string-end
(encode-coding-string "» as Unicode text)" 'mac-roman))
(defun my-mac-as-utf8string (str)
(let ((len (length str))
(len1 31) ;XXX: 240/8. utf-8 is 4byte per code point at most.
(reslist '(")"))
pos epos)
(setq pos len)
(while (> pos 0)
(setq epos pos
pos (max (- pos len1) 0)
reslist (cons my-mac-as-utf8string-begin
(nconc (mapcar (lambda (ch) (format "%02X" ch))
(encode-coding-string
(substring str pos epos) 'utf-8))
(cons my-mac-as-utf8string-end
reslist)))))
(apply 'concat "(\"\"" reslist)))
(defun my-mac-select-in-finder (filenames)
"Select FILENAMES in Finder and pop Finder to front."
(interactive (list (my-current-file-names nil "Select in finder: ")))
(my-force-list filenames)
(when filenames
(my-do-applescript
(concat "tell application \"Finder\" to select { "
(mapconcat 'my-mac-as-utf8string filenames
" as POSIX file, ")
" as POSIX file }")))
(my-call-process my-mac-open-program nil nil "-a" "Finder"))
(defalias 'my-select-in-finder 'my-mac-select-in-finder)
(define-key ctl-x-map [?\M-f] 'my-select-in-finder)
;; endif 'darwin
)
(when (eq system-type 'darwin)
(defconst my-mac-finder-selection-as-text
(encode-coding-string "tell application \"Finder\"
set nul to «data utf800» as Unicode text
set str to \"\"
repeat with x in (get selection)
set str to str & POSIX path of ((contents of x) as Unicode text) & nul
end repeat
end tell" 'mac-roman))
(defun my-mac-finder-selection ()
"Return a list of file names selected by Finder's front window."
(nbutlast
(split-string
(cdr (my-do-applescript my-mac-finder-selection-as-text
'(to-string noshow)))
"\000") 1))
(defalias 'my-finder-selection 'my-mac-finder-selection)
;; endif 'darwin
)
(when (eq system-type 'darwin)
(defun my-current-url ()
"Get URL of front window of Safari."
(interactive)
(my-do-applescript
"tell application \"Safari\" to get URL of document of window 1")))
(defun my-start-another-emacs (arg) "" (interactive "P") (apply 'call-process (concat invocation-directory invocation-name) nil 0 nil (cond ((consp arg) (list "-Q")) ((eq arg '-) (list "-q")) (arg (list "--debug-init"))))) (define-key ctl-x-map [?\M-e] 'my-start-another-emacs) (define-key ctl-x-map [?\M-u] 'browse-url)
(eval-when-compile (require 'find-func))
(unless (file-directory-p source-directory)
(setq source-directory
(and (string-match "^\\(.*\\)\\.[0-9]+\\'" emacs-version)
(concat "/work/emacs-" (match-string 1 emacs-version) "/"))
find-function-C-source-directory (expand-file-name "src"
source-directory)))
(let ((source-lisp-dir (concat source-directory "lisp"))
(regexp (concat "^"
(regexp-quote
(progn
(string-match "/etc/\\'" data-directory)
(replace-match "/lisp" t t data-directory)))
"\\(\\(?:/.*\\)?\\)"))
result)
(dolist (elt load-path)
(if (string-match regexp elt)
(push (concat source-lisp-dir (match-string 1 elt)) result)
(push elt result)))
(setq find-function-source-path (nreverse result)))
(define-ccl-program test-ccl
`(1
(loop
(read-if (r1 == ?%)
((read-if (r1 <= ?9)
(r1 &= 15)
((r1 &= 15) (r1 += 9)))
(read-if (r2 <= ?9)
(r2 &= 15)
((r2 &= 15) (r2 += 9)))
(r1 = ((r1 << 4) | r2))
(write-repeat r1))
(write-repeat r1)))))
(define-key global-map "\M-v" 'yank)
(eval-when-compile (require 'newsticker)) (setq newsticker-wget-name "curl") (setq newsticker-wget-arguments nil)
(setq recentf-max-saved-items 1000) (setq recentf-keep '(file-remote-p file-readable-p))
(eval-when-compile
(require 'iswitchb)
(require 'recentf))
(defvar my-iswitchb-text nil)
(defvar my-iswitchb-mode nil)
(iswitchb-mode 1)
(recentf-mode 1)
(defadvice iswitchb-find-file (before my-ad-iswitchb-find-file activate)
(setq my-iswitchb-text iswitchb-text))
(defadvice read-file-name (before my-ad-read-file-name activate)
(when my-iswitchb-text
(if (eq my-iswitchb-mode 'end-of-line)
(ad-set-arg 1 (expand-file-name my-iswitchb-text default-directory))
(ad-set-arg 4 my-iswitchb-text)) ; initial
(ad-set-arg 2 (expand-file-name my-iswitchb-text default-directory))
(setq my-iswitchb-text nil)))
(defadvice find-file-read-args (around my-ad-find-file-read-args activate)
(if (ad-get-arg 1) ; mustmatch
ad-do-it
(unwind-protect
(let ((iswitchb-make-buflist-hook
(lambda ()
(setq iswitchb-temp-buflist recentf-list)))
filename)
(setq filename (iswitchb-read-buffer (ad-get-arg 0) ; prompt
nil nil my-iswitchb-text))
(if (eq iswitchb-exit 'findfile)
ad-do-it
(setq ad-return-value (list filename nil))))
(setq my-iswitchb-text nil))))
(defun my-iswitchb-find-file-or-forward-char (&optional arg)
""
(interactive "p")
(if (eolp)
(progn
(setq my-iswitchb-mode 'forward-char)
(iswitchb-find-file))
(forward-char arg)))
(defun my-iswitchb-find-file-or-end-of-line (&optional arg)
""
(interactive "p")
(if (eolp)
(progn
(setq my-iswitchb-mode 'end-of-line)
(iswitchb-find-file))
(move-end-of-line arg)))
(defun my-iswitchb-define-mode-map-hook ()
(define-key iswitchb-mode-map "\C-f" 'my-iswitchb-find-file-or-forward-char)
(define-key iswitchb-mode-map "\C-e" 'my-iswitchb-find-file-or-end-of-line)
(define-key iswitchb-mode-map "\C-k" nil))
(add-hook 'iswitchb-define-mode-map-hook 'my-iswitchb-define-mode-map-hook)
(defun my-kill-buffer-query-functions ()
(let ((buffer (current-buffer))
(buffer-name (buffer-name)))
(if (cond (buffer-file-name t)
((string-equal buffer-name "*scratch*") nil)
((get-buffer-process buffer)
(yes-or-no-p
(format "Buffer %s has process; kill anyway? " buffer-name)))
(t t))
t
;; XXX: need some bury-buffer function here
nil)))
(add-hook 'kill-buffer-query-functions 'my-kill-buffer-query-functions)
(defvar my-window-configuration-max 20)
(defvar my-window-configuration nil)
(defun my-push-window-configuration ()
(interactive)
(push (cons (current-window-configuration) (point-marker))
my-window-configuration)
(when (> (length my-window-configuration) my-window-configuration-max)
(let ((last-elt (nthcdr (1- my-window-configuration-max)
my-window-configuration)))
(move-marker (cdar (cdr last-elt)) nil)
(setcdr last-elt nil))))
(defun my-pop-window-configuration ()
(interactive)
(when my-window-configuration
(let ((elt (pop my-window-configuration)))
(set-window-configuration (car elt))
(goto-char (cdr elt)))))
(define-key global-map "\C-cp" 'my-pop-window-configuration)
(define-key global-map "\C-c\M-p" 'my-push-window-configuration)
(defadvice describe-function (before my-ad-describe-function activate)
(my-push-window-configuration))
(defadvice man (before my-ad-man activate)
(my-push-window-configuration))
(defun my-find-file (&optional filenames)
""
(interactive)
(if (and (interactive-p)
(null current-prefix-arg))
(call-interactively 'find-file)
(when (interactive-p)
(setq filenames (my-current-file-names nil "My find file: ")))
(dolist (filename (reverse filenames))
(find-file filename))))
(define-key ctl-x-map [?\C-f] 'my-find-file)
(defun my-insert-current-file-names (filenames)
""
(interactive (list (my-current-file-names nil)))
(barf-if-buffer-read-only)
(if my-insert-file-names-func
(funcall my-insert-file-names-func filenames)
(mapcar (lambda (str) (insert str) (newline)) filenames)))
(define-key ctl-x-map [?\M-i] 'my-insert-current-file-names)
(defvar my-short-system-name (if (string-match "\\`[^.]*" system-name) (match-string 0 system-name) system-name)) (when window-system (setq frame-title-format (list "%b - " invocation-name "@" my-short-system-name "." (number-to-string (emacs-pid)))))
(setq user-init-file (concat my-libdir "/my-custom")) (load user-init-file t nil t)