;;; hnf-mode.el --- major mode for editing hnf. ;; Copyright (C) 1998-2001 by Akihiro Arisawa ;; Author: Akihiro Arisawa ;; Version: $Id: hnf-mode.el,v 3.37 2002/03/29 12:55:29 ari Exp $ ;; Keywords: hnf nikki hns ;; 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. ;;; Code: (defconst hnf-mode-version "2.5") (eval-when-compile (require 'cl)) (require 'poe) (require 'pcustom) (defgroup hnf nil "Hyper Nikki File" :group 'hypermedia) (defcustom hnf-diary-dir "~/diary" "Name of the hns diary directory." :group 'hnf :type 'directory) (defcustom hnf-html-dir "~/public_html/diary" "Name of the hns web directory." :group 'hnf :type 'directory) (defcustom hnf-hns-program (concat hnf-html-dir "/index.cgi") "Program name of the hns." :group 'hnf :type 'file) (defcustom hnf-document-root "/usr/local/apache/htdocs" "The directory of server's DocumentRoot." :group 'hnf :type 'directory) (defcustom hnf-diary-year-directory-flag t "Non-nil means hnf file is put at yearly directory. If this flag is nil, hnf file is put at directly under `hnf-diary-directory'." :group 'hnf :type 'boolean) (defcustom hnf-diary-url (concat "http://" (system-name) "/" "~" (user-login-name) "/diary/") "The URL of diary." :group 'hnf :type 'string) (defcustom hnf-index-name-list '("index.html" "index.shtml" "index.phtml") "File name as index." :group 'hnf :type 'list) (defcustom hnf-mode-hook nil "Hook colled by `hnf-mode'." :group 'hnf :type 'hook) (defcustom hnf-mode-load-hook nil "Hook called when `hnf-mode' is loaded." :group 'hnf :type 'hook) (defcustom hnf-initial-function nil "Functions called when visit new file." :group 'hnf :type 'function) (defcustom hnf-variable nil "Variable name used in hnf." :group 'hnf :type 'list) (defcustom hnf-rlink nil "RLINK name used in hnf." :group 'hnf :type 'list) (defcustom hnf-cat nil "Category name used in hnf." :group 'hnf :type 'list) (defcustom hnf-group nil "Group name used in hnf." :group 'hnf :type 'list) (defcustom hnf-class nil "Class name used in hnf." :group 'hnf :type 'list) (defcustom hnf-mark nil "MARK name used in hnf." :group 'hnf :type 'list) (defcustom hnf-alias nil "ALIAS name used in hnf." :group 'hnf :type 'list) (defcustom hnf-font-lock-flag t "Non-nil means font-lock is used." :group 'hnf :type 'boolean) (defcustom hnf-outline-flag t "Non-nil means outline-minor-mode is used." :group 'hnf :type 'boolean) (defcustom hnf-complete-command-insert-space-flag t "Non-nil means insert space character after complete command." :group 'hnf :type 'boolean) (defcustom hnf-complete-command-insert-newline-function 'hnf-newline "Functions call after complete command taking no argument." :group 'hnf :type 'function) (defcustom hnf-time-format "(%H:%M)" "Format for `hnf-insert-time'. See also `format-time-string'." :group 'hnf :type 'string) (defcustom hnf-time-regexp "([0-9][0-9]:[0-9][0-9])" "Regexp for string inserted by `hnf-insert-time'." :group 'hnf :type 'regexp) (defcustom hnf-namazu-index-dir (concat hnf-diary-dir "/namazu/index") "Name of the directory put index of namazu." :group 'hnf :type 'directory) (defcustom hnf-tab-command 'tab-to-tab-stop "Functions called in `hnf-tab-complete' when not completed/expanded." :group 'hnf :type 'function) (defcustom hnf-new-link-name-format "?%Y%m%h&to=%Y%m%d%N#%Y%m%d%N" "The format specification of NEW line link name in `hnf-get-link'. %Y is the year. %m is the month. %d is the day. %h is the day-hi. (The day divided by 10.) %a is the day-abc. (1st - 10th is \"a\", 11th - 20th is \"b\", other is \"c\".) %N is the new count. %S is the sub count. %% is \"%\". For example, hns-1.03pl0 or earlyer format is \"?%Y%m%h#%Y%m%d%N\", hns-2.10 or later format is \"?%Y%m%a&to=%Y%m%d%N#%Y%m%d%N\", static format is \"%Y%m.html#%Y%m%d%N\".") (defcustom hnf-sub-link-name-format "?%Y%m%d%N&to=%Y%m%d%NS%S#%Y%m%d%NS%S" "The format specification of SUB line link name in `hnf-get-link'. See the documentation of the `hnf-new-link-name-format' for more detail. For example, hns-1.03pl0 or earlyer format is \"?%Y%m%h#%Y%m%d%NS%S\", hns-2.10 or later format is \"?%Y%m%a&to=%Y%m%d%NS%S#%Y%m%d%NS%S\", static format is \"%Y%m.html#%Y%m%d%NS%S\".") (defcustom hnf-hour-not-today 0 "Till the specified hour, considered as the day before. Set integer from 0 to 23. eg. If you specify 6, from 0:00 to 5:59 is considered as the day before, and you type M-x hnf then open yesterday hnf. Also, you type M-x hnf-insert-time then inserte like \"25:00\"." :group 'hnf :type 'integer) (defcustom hnf-browse-url-browser-function browse-url-browser-function "Function to display the diary in a WWW browser. See also `browse-url-browser-function'." :group 'hnf :type 'function) (defface hnf-cat-face '((((class color) (background light)) (:foreground "Purple" :bold t)) (((class color) (background dark)) (:foreground "Cyan" :bold t)) (t (:bold t))) "Face for CAT line in hnf." :group 'hnf) (defface hnf-new-face '((((class color) (background light)) (:foreground "Purple" :bold t)) (((class color) (background dark)) (:foreground "Cyan" :bold t)) (t (:bold t))) "Face for NEW line in hnf." :group 'hnf) (defface hnf-sub-face '((((class color) (background light)) (:foreground "Purple")) (((class color) (background dark)) (:foreground "Cyan")) (t ())) "Face for SUB line in hnf." :group 'hnf) (defface hnf-link-face '((((class color) (background light)) (:foreground "Blue")) (((class color) (background dark)) (:foreground "LightSkyBlue")) (t ())) "Face for link in hnf." :group 'hnf) (defface hnf-image-face '((((class color) (background light)) (:foreground "Blue")) (((class color) (background dark)) (:foreground "LightSkyBlue")) (t ())) "Face for image in hnf." :group 'hnf) (defface hnf-comment-face '((((class color) (background light)) (:foreground "Red")) (((class color) (background dark)) (:foreground "Pink")) (t ())) "Face for image line in hnf." :group 'hnf) (defface hnf-command-face '((((class color) (background light)) (:foreground "firebrick")) (((class color) (background dark)) (:foreground "Chocolate1")) (t ())) "Face for command in hnf." :group 'hnf) (defface hnf-tilde-face '((((class color) (background light)) (:foreground "orange")) (((class color) (background dark)) (:foreground "orange")) (t ())) "Face for \"~\" in hnf." :group 'hnf) (defface hnf-variable-face '((((class color) (background light)) (:foreground "DarkGoldenrod")) (((class color) (background dark)) (:foreground "LightGoldenrod")) (t ())) "Face for variable in hnf." :group 'hnf) (defvar hnf-mode-map nil) (defvar hnf-mode-command-map nil) (defvar hnf-cat-face 'hnf-cat-face) (defvar hnf-new-face 'hnf-new-face) (defvar hnf-sub-face 'hnf-sub-face) (defvar hnf-link-face 'hnf-link-face) (defvar hnf-image-face 'hnf-image-face) (defvar hnf-comment-face 'hnf-comment-face) (defvar hnf-command-face 'hnf-command-face) (defvar hnf-tilde-face 'hnf-tilde-face) (defvar hnf-variable-face 'hnf-variable-face) (defvar hnf-complete-ok t "If this is non-nil, \"OK\" is included for completion.") (defconst hnf-completion-buffer-name "*HNF Completions*") (defvar hnf-command-type-alist '((new . ((outline-level . 1) (face . hnf-new-face))) (sub . ((outline-level . 2) (face . hnf-sub-face))))) (defmacro hnf-command-type-get-variable (type key) (` (cdr (assq (, key) (cdr (assq (, type) hnf-command-type-alist)))))) (defvar hnf-commands-table '(("NEW" . ((type . new) (args . (("title"))) (key . "n"))) ("SUB" . ((type . sub) (args . (("title"))) (key . "s"))) ("CAT" . ((args . (("category" . ((complete . hnf-cat))) any)) (face . hnf-cat-face) (outline-level . 1) (next-command . "NEW") (key . "c"))) ("LNEW" . ((type . new) (args . (link ("title"))))) ("RLNEW" . ((type . new) (args . (rlink ("append") ("title"))))) ; hns-2.10 ("LSUB" . ((type . sub) (args . (link ("title"))))) ("RLSUB" . ((type . sub) (args . (rlink ("append") ("title"))))) ; hns-2.10 ("P" . ((need-close) (key . "p"))) ; hns-2.10 ("GRP" . ((args . (("group" . ((complete . hnf-group))) any)) (outline-level . 1))) ; hns-2.10 ("LINK" . ((args . (link ("sentence"))) (key . "l"))) ("URL" . ((args . (("url" . ((face . hnf-link-face))) ("sentence"))))) ("RLINK" . ((args . (rlink ("append") ("sentence"))))) ("FONT" . ((args . (("arg1") ("arg2") ("sentence"))))) ("STRIKE" . ((args . (("sentence"))))) ("LSTRIKE" . ((args . (link ("sentence"))))) ("STRONG" . ((args . (("sentence"))))) ("SPAN" . ((args . (("class" . ((complete . hnf-class))) ("sentence"))))) ; hns-2.10 ("DIV" . ((args . (("class" . ((complete . hnf-class))))) (need-close))) ; hns-2.10 ("IMG" . ((args . (("place" . ((complete . (("r") ("l") ("n"))))) image ("alt"))))) ("LIMG" . ((args . (link ("place" . ((complete . (("r") ("l") ("n"))))) image ("alt"))))) ; hns-2.10 ("MARK" . ((args . (("mark" . ((complete . hnf-mark))))))) ("UL" . ((need-close) (next-command . "LI") (key . "u"))) ("OL" . ((need-close) (next-command . "LI") (key . "o"))) ("LI" . ((args . (("sentence"))))) ("DL" . ((need-close) (next-command . "DT") (key . "d"))) ; hns-2.10 ("DT" . ((args . (("sentence"))))) ; hns-2.10 ("DD" . ((args . (("sentence"))))) ; hns-2.10 ("PRE" . ((need-close))) ; hns-2.10 ("CITE" . ((need-close))) ; hns-2.10 ("RT" . ((need-close))) ; hns-2.2 ("!" . ((args . (("sentence"))) (face . hnf-comment-face))) ("!#" . ((args . (("sentence"))) (face . hnf-comment-face))) ("FN" . ((need-close))) ("ALIAS" . ((args . (("alias" . ((complete . hnf-alias))))))) ) "Table of hnf commands.") (defmacro hnf-command-get-command (command-name) (` (assoc (, command-name) hnf-commands-table))) (defmacro hnf-command-get-type (command) (` (cdr (assq 'type (cdr (, command)))))) (defmacro hnf-command-get-variable (command key) (` (cond ((cdr (assq (, key) (cdr (, command))))) ((hnf-command-type-get-variable (hnf-command-get-type (, command)) (, key)))))) (defmacro hnf-command-get-arg-detail (command count) (` (let ((args (hnf-command-get-variable (, command) 'args))) (if (or (eq (nth (, count) args) 'any) (eq (nth 1 args) 'any)) (nth 0 args) (nth (, count) args))))) (defmacro hnf-command-need-close-p (command) (` (assq 'need-close (cdr (, command))))) (defvar hnf-font-lock-keywords nil "Expressions to highlight in hnf mode.") (defun hnf-font-lock-keywords-creation () "Create font-lock-keywords from `hnf-commands-table'." (setq hnf-font-lock-keywords (let ((commands hnf-commands-table) command type face ret1 ret2 ret3) (while (setq command (car commands)) (if (setq face (hnf-command-get-variable command 'face)) (add-to-list 'ret1 (cons (concat "^" (car command) ".*") face)) (let ((args (hnf-command-get-variable command 'args)) (cnt 0) arg) (while (setq arg (car args)) (if (setq face (cond ((eq arg 'link) 'hnf-link-face) ((eq arg 'image) 'hnf-image-face) ((consp arg) (cdr (assq 'face (cdr arg)))))) (add-to-list 'ret2 (list (concat "^" (car command) " +" (apply (function concat) (make-list cnt "[^ ]+ +")) "\\([^ ]+\\)") 1 face))) (setq cnt (1+ cnt) args (cdr args))))) (add-to-list 'ret3 (if (hnf-command-need-close-p command) (concat (car command) "\\|/" (car command)) (car command))) (setq commands (cdr commands))) (append ret1 ret2 (list (cons (concat "^\\(" (mapconcat (function identity) ret3 "\\|") "\\)\\>") hnf-command-face)) (list '(eval . (list (concat "^\\(" (mapconcat (function car) hnf-variable "\\|") "\\)\\>") '(0 (if (hnf-header-p) hnf-variable-face))))) (list (cons "~$" hnf-tilde-face)))))) (defvar hnf-outline-regexp (let ((commands hnf-commands-table) command outline-commands) (while (setq command (car commands)) (if (hnf-command-get-variable command 'outline-level) (add-to-list 'outline-commands (car command))) (setq commands (cdr commands))) (mapconcat (function identity) outline-commands "\\|")) "Regular expression to match the beginning of heading.") (defvar hnf-imenu-generic-expression (let ((commands hnf-commands-table) command ret) (while (setq command (car commands)) (if (eq (hnf-command-get-type command) 'new) (let ((args (hnf-command-get-variable command 'args)) (cnt -1)) (while args (setq args (cdr args) cnt (1+ cnt))) (add-to-list 'ret (list nil (concat "^" (car command) " " (apply (function concat) (make-list cnt "[^ ]+ ")) "\\(.*\\)") 1)))) (setq commands (cdr commands))) ret) "Imenu generic expression for `hnf-mode'. See `imenu-generic-expression'.") (defun hnf-mode-set-keymap () (setq hnf-mode-command-map (make-sparse-keymap)) (let ((commands hnf-commands-table) command key) (while (setq command (car commands)) (when (setq key (hnf-command-get-variable command 'key)) (define-key hnf-mode-command-map key `(lambda () (interactive) (hnf-insert-command ,(car command))))) (setq commands (cdr commands)))) (setq hnf-mode-map (make-sparse-keymap)) (define-key hnf-mode-map "\t" 'hnf-tab-complete) (define-key hnf-mode-map "\C-c\C-m" 'hnf-newline) (define-key hnf-mode-map "\C-c?" 'hnf-command-help) (define-key hnf-mode-map "\C-c=" 'hnf-get-link) (define-key hnf-mode-map "\C-c\C-f" 'hnf-link-find-file) (define-key hnf-mode-map "\C-c\C-t" 'hnf-insert-time) (define-key hnf-mode-map "\C-c\C-s" 'hnf-write-file-insert-time) (define-key hnf-mode-map "\C-c\C-b" 'hnf-browse-recent-diary) (define-key hnf-mode-map "\C-c\C-p" 'hnf-preview-diary) (define-key hnf-mode-map "\C-c\C-n" 'hnf-namazu) (define-key hnf-mode-map "\C-c\C-c" hnf-mode-command-map) ) (unless hnf-mode-map (hnf-mode-set-keymap)) ;;;###autoload (defun hnf-mode () "Major mode for editing hnf. \\{hnf-mode-map}" (interactive) (use-local-map hnf-mode-map) (setq mode-name "HNF") (setq major-mode 'hnf-mode) ;; font-lock (when hnf-font-lock-flag (require 'font-lock) (unless hnf-font-lock-keywords (hnf-font-lock-keywords-creation)) (make-local-variable 'font-lock-defaults) (setq font-lock-defaults '(hnf-font-lock-keywords t)) (font-lock-mode t)) ;; outline (when hnf-outline-flag (make-local-variable 'outline-regexp) (setq outline-regexp hnf-outline-regexp) (make-local-variable 'outline-level) (setq outline-level (function hnf-outline-level)) (outline-minor-mode 1)) ;; imenu (make-local-variable 'imenu-generic-expression) (setq imenu-generic-expression hnf-imenu-generic-expression) ;; hook (and (functionp hnf-initial-function) (= (buffer-size) 0) (buffer-file-name) (not (file-exists-p (buffer-file-name))) (funcall hnf-initial-function)) (run-hooks 'hnf-mode-hook)) ;;;###autoload (defun hnf (&optional arg) "Open hnf of today. If numerical argument is specified, open hnf of that days ago." (interactive "P") (let* ((days-ago (if (listp arg) nil arg)) (now (hnf-current-time days-ago)) (dir (concat hnf-diary-dir "/" (and hnf-diary-year-directory-flag (hnf-format-time-string "%Y/" now)))) (name (concat dir (unless (and arg (listp arg)) (hnf-format-time-string "d%Y%m%d.hnf" now))))) (if (and arg (listp arg)) (setq name (read-file-name "Find file: " name))) (or (file-directory-p (file-name-directory name)) (make-directory dir)) (find-file name) (hnf-mode))) (defun hnf-tab-complete () "Complete and expantion in hnf." (interactive) (let ((spaces (hnf-count-spaces)) (command-word (hnf-command-word)) detail complete-list) (cond ((hnf-header-p) ; header part (or (and (eq spaces 0) (or (and hnf-variable (not (eq (hnf-complete hnf-variable) 'no-match))) (and hnf-complete-ok (not (eq (hnf-complete '(("OK"))) 'no-match))))) (funcall hnf-tab-command))) ((eq (setq detail (and (> spaces 0) (hnf-command-get-arg-detail (hnf-command-get-command command-word) (1- spaces)))) 'rlink) (hnf-complete hnf-rlink)) ((or (eq detail 'link) (eq detail 'image)) (hnf-complete-link)) ((setq complete-list (cdr (assq 'complete (cdr detail)))) (hnf-complete (if (symbolp complete-list) (symbol-value complete-list) complete-list))) ((and (string= "/" command-word) (= spaces 0)) (hnf-close-command)) ((and (= spaces 0) (not (eq (hnf-complete-command) 'no-match)))) (t (funcall hnf-tab-command))))) (defun hnf-insert-command (command-name) (let* ((command (hnf-command-get-command command-name)) (args (hnf-command-get-variable command 'args)) (detail (car args)) prompt complete-list m p) (insert command-name) (setq p (point)) (when (hnf-command-need-close-p command) (save-excursion (insert "\n" "/" command-name "\n"))) (when (hnf-command-get-variable command 'next-command) (hnf-insert-command (hnf-command-get-variable command 'next-command))) (set-marker (setq m (make-marker)) (point)) (set-marker-insertion-type m t) (goto-char p) (if detail (progn (insert " ") (save-excursion (insert "\n")) (cond ((eq detail 'rlink) (setq prompt "rlink" complete-list hnf-rlink)) ((setq complete-list (cdr (assq 'complete (cdr-safe detail)))) (when (symbolp complete-list) (setq complete-list (symbol-value complete-list))) (setq prompt (car detail)))) (if complete-list (progn (insert (completing-read (concat prompt ": ") complete-list)) (unless (or (= (length args) 1) (eq (nth 1 args) 'any)) ;; rest args (insert " ") (set-marker m (point)))) ;; some args. (set-marker m (point)))) (insert "\n")) (goto-char (marker-position m)) (set-marker m nil))) ;;; various command (defun hnf-newline () "Insert newline and various string fit for the situation." (interactive) (let* ((command-word (hnf-command-word)) (command (hnf-command-get-command command-word)) (case-fold-search nil) str) (when (hnf-command-need-close-p command) (save-excursion (insert (concat "\n/" command-word "\n")))) (newline) (when (hnf-command-get-variable command 'next-command) (hnf-insert-command (hnf-command-get-variable command 'next-command))))) (defun hnf-command-help (&optional command-word) "Display help of command." (interactive "P") (unless command-word (setq command-word (hnf-command-word))) (let ((command (hnf-command-get-command command-word)) mes) (when command (setq mes command-word) (let ((args (hnf-command-get-variable command 'args)) arg) (while (setq arg (car args)) (setq mes (concat mes " " (if (symbolp arg) (if (eq arg 'any) "[...]" (symbol-name arg)) (car arg))) args (cdr args))) (message mes))))) (defun hnf-link-find-file () "Open file specifed by LINK or LSUB. Suppore only relative path." (interactive) (if (eq (hnf-command-get-arg-detail (hnf-command-get-command (hnf-command-word)) 0) 'link) (let (p fname) (save-excursion (beginning-of-line) (skip-chars-forward "^ \t\n") (skip-chars-forward " ") (setq p (point)) (skip-chars-forward "^ \t\n#") (setq fname (buffer-substring-no-properties p (point)))) (if (string-match "^\\(http\\|ftp\\)://" fname) (funcall hnf-browse-url-browser-function fname) (setq fname (expand-file-name fname (if (char-equal (string-to-char fname) ?/) hnf-document-root hnf-html-dir))) (when (file-directory-p fname) (when (not (string-match "/$" fname)) (setq fname (concat fname "/"))) (let ((index-list hnf-index-name-list)) (while (and index-list (not (file-exists-p (concat fname (car index-list))))) (setq index-list (cdr index-list))) (if index-list (setq fname (concat fname (car index-list))) (setq fname (read-file-name "Find file: " fname))))) (find-file fname))))) (defun hnf-get-link (&optional arg) "Obtain name of NEW or SUB." (interactive "P") (let ((date-list (hnf-buffer-hnf-p))) (if (null date-list) (error "This is not hnf") (let ((day-num (string-to-number (nth 2 date-list))) (command-word (hnf-command-word)) command-type new-cnt sub-cnt link-name) (save-excursion (when (eq (setq command-type (hnf-command-get-type (hnf-command-get-command command-word))) 'sub) (setq sub-cnt 1) (while (and (= (forward-line -1) 0) (not (eq (setq command-type (hnf-command-get-type (hnf-command-get-command (setq command-word (hnf-command-word))))) 'new))) (if (eq command-type 'sub) (setq sub-cnt (1+ sub-cnt))))) (when (eq command-type 'new) (setq new-cnt 1) (while (= (forward-line -1) 0) (if (eq (hnf-command-get-type (hnf-command-get-command (hnf-command-word))) 'new) (setq new-cnt (1+ new-cnt)))))) (when new-cnt (let* ((fmt (if sub-cnt hnf-sub-link-name-format hnf-new-link-name-format)) (fmt-spec (list (cons ?Y (nth 0 date-list)) (cons ?m (nth 1 date-list)) (cons ?d (nth 2 date-list)) (cons ?h (number-to-string (/ day-num 10))) (cons ?a (cond ((< day-num 11) "a") ((< day-num 21) "b") (t "c"))) (cons ?N (number-to-string new-cnt)) (cons ?S (if sub-cnt (number-to-string sub-cnt))))) (fmt-len (length fmt)) (ind 0) (result "") cur-char) (while (< ind fmt-len) (setq cur-char (aref fmt ind)) (setq result (concat result (if (eq cur-char ?%) (progn (setq ind (1+ ind) cur-char (aref fmt ind)) (or (cdr (assq cur-char fmt-spec)) (char-to-string cur-char))) (char-to-string cur-char)))) (setq ind (1+ ind))) (message "%s" result) (if arg (kill-new result)))))))) (defun hnf-insert-time (&optional arg) "Insert time stamp." (interactive "P") (if (and arg (re-search-forward hnf-time-regexp nil t)) (replace-match (save-match-data (hnf-format-time-string hnf-time-format (hnf-current-time)))) (insert (hnf-format-time-string hnf-time-format (hnf-current-time))))) (defun hnf-write-file-insert-time () "Execute `hnf-insert-time', and save file." (interactive) (save-excursion (goto-char (point-max)) (hnf-insert-time)) (save-buffer)) (defun hnf-check () "Check curernt hnf file." (interactive) (let ((case-fold-search nil) word) ;; find all capitalized word in top of line (save-excursion (goto-char (point-min)) (search-forward "\n\n" nil t) (while (re-search-forward "^/?\\([A-Z]+\\)\\([ \t]\\|$\\)" nil t) ;; is it valid command? (unless (assoc (setq word (match-string 1)) hnf-commands-table) (if (y-or-n-p (format "Undefined keyword '%s'. Insert space? " word)) (save-excursion (goto-char (match-beginning 0)) (insert " ")) ;; leave it (error "Edit it!"))))) (if (interactive-p) (message "Good!")))) ;;; for namazu.el (defun hnf-namazu (key) (interactive (progn (require 'namazu) (list (read-from-minibuffer "Enter Keyword: " nil (if (boundp 'namazu-minibuffer-field-map) namazu-minibuffer-field-map) nil 'namazu-history)))) (namazu 0 hnf-namazu-index-dir key)) (defun hnf-namazu-find-file () "Open hnf at point in \*namazu\*." (interactive) (save-excursion (if (re-search-forward "#\\([1-9][0-9][0-9][0-9]\\)\\([0-1][0-9][0-3][0-9]\\)0" nil t) (find-file (concat hnf-diary-dir "/" (and hnf-diary-year-directory-flag (concat (match-string 1) "/")) "d" (match-string 1) (match-string 2) ".hnf"))))) ;;; for calendar.el (eval-when-compile (require 'calendar)) (defun hnf-filename-from-date (date) (concat hnf-diary-dir "/" (and hnf-diary-year-directory-flag (format "%d/" (extract-calendar-year date))) (format "d%04d%02d%02d.hnf" (extract-calendar-year date) (extract-calendar-month date) (extract-calendar-day date)))) ;;;###autoload (defun hnf-insert-diary-entry () "Open hnf for the date indicated by point." (interactive) (find-file-other-window (hnf-filename-from-date (calendar-cursor-to-date t)))) ;;;###autoload (defun hnf-mark-diary-entries () "Mark days in the calendar window that have hnf." (interactive) (let (y m first-date last-date tmp) (save-excursion (set-buffer calendar-buffer) (setq m displayed-month) (setq y displayed-year)) (increment-calendar-month m y -1) (setq first-date (calendar-absolute-from-gregorian (list m 1 y))) (increment-calendar-month m y 2) (setq last-date (calendar-absolute-from-gregorian (list m (calendar-last-day-of-month m y) y))) (calendar-for-loop date from first-date to last-date do (if (file-exists-p (hnf-filename-from-date (setq tmp (calendar-gregorian-from-absolute date)))) (mark-visible-calendar-date tmp))))) ;;; for browse-url (defun hnf-browse-recent-diary () "Ask a WWW browser to load recent diary." (interactive) (let ((browse-url-browser-function hnf-browse-url-browser-function)) (browse-url hnf-diary-url))) (defun hnf-browse-diary () "Ask a WWW browser to load current editting diary." (interactive) (let ((date-list (hnf-buffer-hnf-p)) (browse-url-browser-function hnf-browse-url-browser-function)) (if (null date-list) (error "This is not hnf") (browse-url (concat hnf-diary-url "?" (mapconcat (function identity) date-list "")))))) (defvar hnf-temp-file-list '()) (defun hnf-preview-diary () "Ask a WWW browser to load current editting diary." (interactive) (let ((date-list (hnf-buffer-hnf-p)) (browse-url-browser-function hnf-browse-url-browser-function)) (if (null date-list) (error "This is not hnf") (let ((temp-file (concat temporary-file-directory "hnf" (apply (function concat) date-list) ".html")) (default-directory (file-name-directory hnf-hns-program))) (with-temp-file temp-file (call-process hnf-hns-program nil t t (apply (function concat) date-list))) (browse-url-of-file temp-file) (add-to-list 'hnf-temp-file-list temp-file))))) (defun hnf-delete-temp-file-list () "Remove file of `hnf-temp-file-list'." (while hnf-temp-file-list (if (file-exists-p (car hnf-temp-file-list)) (delete-file (car hnf-temp-file-list))) (setq hnf-temp-file-list (cdr hnf-temp-file-list)))) (add-hook 'kill-emacs-hook 'hnf-delete-temp-file-list) ;;; miscellaneous functions (defun hnf-buffer-hnf-p (&optional buffer) "Judge whether buffer is hnf. If buffer is ommitted, judge for `current-buffer'. If buffer is hnf, return list of (year mon day)." (let ((fname (buffer-file-name buffer))) (if (and fname (string-match "d\\([0-9][0-9][0-9][0-9]\\)\\([0-1][0-9]\\)\\([0-3][0-9]\\)\\.hnf" (setq fname (file-name-nondirectory fname)))) (list (match-string 1 fname) (match-string 2 fname) (match-string 3 fname))))) (defun hnf-header-p () "Judge whether in header." (save-excursion (not (search-backward "\n\n" nil t)))) (defun hnf-count-spaces () "Count space character from beginning of line to point." (save-excursion (let ((p (point)) (cnt 0)) (beginning-of-line) (while (re-search-forward "[ \t]+" p t) (setq cnt (+ cnt 1))) cnt))) (defun hnf-cur-word (&optional erase) "Extract word at point." (save-excursion (let ((p (point)) string) (skip-chars-backward "^ \t\n") (setq string (buffer-substring-no-properties p (point))) (if erase (delete-region p (point))) string))) (defun hnf-command-word () "Obtain command word at the line." (save-excursion (beginning-of-line) (let ((p (point))) (skip-chars-forward "^ \t\n") (buffer-substring-no-properties p (point))))) (defun hnf-close-command () "Insert close command." (let ((commands hnf-commands-table) command close-commands regexp stack command) (while (setq command (car commands)) (if (hnf-command-need-close-p command) (add-to-list 'close-commands (car command))) (setq commands (cdr commands))) (setq regexp (concat "^/?\\(" (mapconcat (function identity) close-commands "\\|") "\\)$")) (save-excursion (while (progn (or (re-search-backward regexp nil t) (error "Command unmatch")) (setq command (match-string 1)) (if (eq (char-after) ?/) (push command stack) (if (string= command (car stack)) (pop stack)))))) (if stack (error "%s unmatched" command)) (if command (insert command)))) (defun hnf-current-time (&optional days-ago) "Return `current-time'. But, if `hnf-hour-not-today' is set, return the time of specified hours ago." (let ((time (current-time))) (if (not (numberp days-ago)) (setq days-ago 0)) (hnf-time-float (- (hnf-float-time time) (* days-ago 24 60 60) (* (or hnf-hour-not-today 0) 60 60))))) (defun hnf-format-time-string (time-format &optional time) "Same as `format-time-string'. But, \"%H\" is translated into feature hour for `hnf-hour-not-today'." (let ((case-fold-search nil) sub-format hour) (while (string-match "%[a-zA-Z]" time-format) (setq sub-format (match-string 0 time-format)) (setq time-format (replace-match (if (string= sub-format "%H") (format "%d" (+ (or hnf-hour-not-today 0) (string-to-number (format-time-string "%H" time)))) (format-time-string sub-format time)) nil nil time-format))) time-format)) (defalias 'hnf-float-time (if (fboundp 'float-time) ; emacs21 'float-time (lambda (&optional tm) (let ((time (or tm (current-time)))) (+ (* (float (ash 1 16)) (nth 0 time)) (float (nth 1 time))))))) (defun hnf-time-float (num) (let* ((most-time (floor num 65536)) (least-time (floor (- num (* 65536.0 most-time))))) (list most-time least-time 0))) (defun hnf-outline-level () "Return the depth to which a statement is nested in the outline. Point must be at the beginning of a header line. See `hnf-commands-table'." (save-excursion (if (looking-at outline-regexp) (hnf-command-get-variable (hnf-command-get-command (buffer-substring (match-beginning 0) (match-end 0))) 'outline-level)))) (eval-after-load "speedbar" '(speedbar-add-supported-extension ".hnf")) ;;; upper function for completion (defun hnf-complete (alist) "Complete at point. ALIST is set of permissible completions." (hnf-complete-string (hnf-cur-word t) alist)) (defun hnf-complete-link () "Complete LINK." (let* ((cur (hnf-cur-word t)) (dname (file-name-directory cur)) (fname (file-name-nondirectory cur)) (basedir (cond ((char-equal (string-to-char cur) ?/) (concat hnf-document-root dname)) (dname (expand-file-name dname hnf-html-dir)) (t hnf-html-dir))) files) (when (file-directory-p basedir) (setq files (file-name-all-completions fname basedir))) (if (null files) (when (require 'w3m nil t) (w3m-arrived-setup) (mapatoms (lambda (x) (when x (push (list (symbol-name x)) files))) w3m-arrived-db) (hnf-complete-string cur files)) (when dname (insert dname)) (hnf-complete-string fname (mapcar (function list) files))))) (defun hnf-complete-command () "Complete command name." (let ((sts (hnf-complete hnf-commands-table))) (when (eq sts 'match) (if (null (hnf-command-get-variable (hnf-command-get-command (hnf-command-word)) 'args)) (if hnf-complete-command-insert-newline-function (funcall hnf-complete-command-insert-newline-function)) (and hnf-complete-command-insert-space-flag (insert " ")))) sts)) ;;; lower function for completion (defun hnf-complete-string (string alist) (let* ((completion-ignore-case t) (completions (all-completions string alist)) (cur (current-buffer)) comp) (cond ((= (length completions) 1) ; only one. (if (string= (car completions) string) (progn (insert (car completions)) (hnf-delete-completion-window)) (insert (car completions))) 'match) ((and (setq comp (try-completion string alist)) (not (string= comp string))) ; halfway (insert comp) 'complete) (t (insert string) (if (not comp) (progn ; no match (hnf-delete-completion-window) 'no-match) ; display (buffer-disable-undo (get-buffer-create hnf-completion-buffer-name)) (with-output-to-temp-buffer hnf-completion-buffer-name (display-completion-list (sort completions 'string<))) 'complete-list))))) (defun hnf-delete-completion-window () (and (get-buffer hnf-completion-buffer-name) (let ((w (get-buffer-window hnf-completion-buffer-name))) (and w (delete-window w)) (kill-buffer hnf-completion-buffer-name)))) (run-hooks 'hnf-mode-load-hook) (provide 'hnf-mode) ;;; hnf-mode.el ends here