Mercurial > hg > xemacs-beta

comparison lisp/quail/quail-tit.el @ 70:131b0175ea99 r20-0b30

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-0b30
author cvs
date Mon, 13 Aug 2007 09:02:59 +0200
parents
children fe104dbd9147
comparison
equal deleted inserted replaced
69:804d1389bcd6 70:131b0175ea99
1 ;; Convert tit format dictionary (of cxterm) to quail-package.
2 ;; Usage (within mule):
3 ;; M-x tit-to-quail<CR>tit-file-name<CR>
4 ;; Usage (from shell):
5 ;; % mule -batch -l quail/tit -f batch-tit-to-quail [dirname|filename] ...
6 ;; When you run tit-to-quail within Mule, you are shown lines for setting
7 ;; key bindings. You can modify them as you wish. After that, save the
8 ;; buffer into somewhere under your `load-path'.
9 ;; You may also modify the second arg PROMPT of quail-define-pacakge
10 ;; to shorter string.
11 ;; As for Big5 file, Big5-HKU is not supported, you must
12 ;; at first convert Big5-HKU to Big5-ETen before you run `tit-to-quail'.
13
14 (defun tit-value-head ()
15 (skip-chars-forward "^:")
16 (forward-char 1)
17 (skip-chars-forward " \t"))
18
19 (defun tit-set-keys ()
20 (let (limit str)
21 (save-excursion
22 (end-of-line)
23 (setq limit (point)))
24 (if (re-search-forward "[^ \t\n]+" limit t)
25 (progn
26 (setq str
27 (concat "\""
28 (buffer-substring (match-beginning 0) (match-end 0))
29 "\""))
30 (car (read-from-string str))))))
31
32 (defun tit-insert (arg)
33 (let ((pos (point)))
34 (insert arg)
35 (if (or (string-match "\"" arg) (string-match "\\\\" arg))
36 (save-excursion
37 (while (re-search-backward "\"\\|\\\\" pos t)
38 (insert "\\")
39 (forward-char -1))))))
40
41 (defun tit-buffer-substring (key)
42 (let ((i 0) ch)
43 (while (and (/= (setq ch (following-char)) ? )
44 (/= ch ?\t)
45 (/= ch ?\n))
46 (aset key i ch)
47 (setq i (1+ i))
48 (forward-char 1))
49 (aset key i 0)))
50
51 (defun tit-looking-at (key)
52 (let ((pos (point)) (i 0) ch)
53 (while (eq (char-after (+ pos i)) (aref key i))
54 (setq i (1+ i)))
55 (and (integerp (setq ch (char-after (+ pos i))))
56 (or (= ch ? ) (= ch ?\t))
57 (= (aref key i) 0))))
58
59 (defun tit-message (&rest args)
60 (if (null noninteractive)
61 (apply 'message args)))
62
63 ;; make quail-package name (e.g. ZOZY.tit -> .../quail/zozy.el)
64 (defun tit-dest-file (file &optional dir)
65 (expand-file-name
66 (concat (if dir "" "quail/")
67 (downcase (file-name-nondirectory (substring file 0 -4)))
68 ".el")
69 (or dir (car load-path))))
70
71 (defun tit-to-quail (tit-file &optional dest-dir)
72 (interactive "Ftit file: ")
73 (let ((buf (get-buffer-create "*tit-work*"))
74 pos
75 ;; tit keywords and default values
76 (encode '*euc-china*)
77 (multichoice t)
78 prompt
79 comment
80 validinputkey
81 (selectkey '["1 " "2" "3" "4" "5" "6" "7" "8" "9" "0"
82 nil nil nil nil nil nil])
83 (selectkey-idx 0)
84 (backspace "\177")
85 (deleteall "\C-u")
86 (moveright ".>")
87 (moveleft ",<")
88 keyprompt
89 phrase)
90 (save-excursion
91 (set-buffer buf)
92 (erase-buffer)
93 (if (null (string-match "\\.tit$" tit-file))
94 (setq tit-file (concat tit-file ".tit")))
95 (let ((file-coding-system-for-read '*noconv*))
96 (insert-file-contents tit-file))
97
98 (set-visited-file-name (tit-dest-file tit-file dest-dir))
99 (set-file-coding-system '*junet*unix)
100
101 ;; convert GB or BIG5 to Mule's internal code
102 (save-excursion
103 (if (re-search-forward "^ENCODE:" nil t)
104 (progn
105 (skip-chars-forward " \t")
106 (if (looking-at "GB")
107 (setq encode '*euc-china*)
108 (setq encode '*big5*)))))
109 (tit-message "Converting %s to Mule's internal code..." encode)
110 (code-convert 1 (point-max) encode '*internal*)
111
112 (goto-char 1)
113 ;; setting headers
114 (insert "(require 'quail)\n")
115
116 (tit-message "Extracting header information...")
117 (while (null (looking-at "BEGINDICTIONARY\\|BEGINPHRASE"))
118 (insert ";; ")
119 (let ((ch (following-char)))
120 (cond ((= ch ?C) ; COMMENT
121 (forward-word 1)
122 (setq pos (point))
123 (end-of-line)
124 (setq comment (cons (buffer-substring pos (point)) comment)))
125 ((= ch ?M) ; MULTICHOICE, MOVERIGHT, MOVELEFT
126 (cond ((looking-at "MULTI")
127 (tit-value-head)
128 (setq multichoice (looking-at "YES")))
129 ((looking-at "MOVERIGHT")
130 (tit-value-head)
131 (setq moveright (tit-set-keys)))
132 ((looking-at "MOVELEFT")
133 (tit-value-head)
134 (setq moveleft (tit-set-keys)))))
135 ((= ch ?P) ; PROMPT
136 (tit-value-head)
137 (setq pos (point))
138 (end-of-line)
139 (setq comment (cons (buffer-substring pos (point)) comment))
140 (setq pos (point))
141 (skip-chars-backward "^ \t")
142 (setq prompt (buffer-substring (point) pos)))
143 ((= ch ?S) ; SELECTKEY
144 (tit-value-head)
145 (let (key)
146 (while (and (< selectkey-idx 16) (setq key (tit-set-keys)))
147 (aset selectkey selectkey-idx key)
148 (setq selectkey-idx (1+ selectkey-idx)))))
149 ((= ch ?B) ; BACKSPACE
150 (tit-value-head)
151 (setq backspace (tit-set-keys)))
152 ((= ch ?K) ; KEYPROMPT
153 (forward-word 1)
154 (forward-char 1)
155 (setq pos (point))
156 (let (key str)
157 (search-forward ")" nil t)
158 (setq key (buffer-substring pos (1- (point))))
159 (skip-chars-forward ": \t")
160 (setq pos (point))
161 (forward-char 1)
162 (setq str (buffer-substring pos (point)))
163 (setq keyprompt (cons (cons key str) keyprompt))))
164 ))
165 (forward-line 1))
166
167 (setq phrase (looking-at "BEGINPHRASE"))
168 ;; comment out the line BEGINDICTIONARY/BEGINPHRASE
169 (insert ";; ")
170 (forward-line 1)
171
172 (tit-message "Defining quail-package...")
173 (insert "(quail-define-package \""
174 (substring (file-name-nondirectory buffer-file-name) 0 -3)
175 "\" \"")
176 (if (string-match "[:$A!K$(0!(!J(B]\\(.*\\)[:$A!K$(0!(!K(B]" prompt)
177 (tit-insert (substring prompt (match-beginning 1) (match-end 1)))
178 (tit-insert prompt))
179 (insert "\"\n")
180 (if multichoice
181 (insert " t\n")
182 (if keyprompt
183 (let (key)
184 (insert " '(")
185 (while keyprompt
186 (setq key (car keyprompt))
187 (insert "(?")
188 (tit-insert (car key))
189 (insert " . \"")
190 (tit-insert (cdr key))
191 (insert "\")\n ")
192 (setq keyprompt (cdr keyprompt)))
193 (setq pos (point))
194 (forward-char -4)
195 (delete-region (point) pos)
196 (insert ")\n"))
197 (insert " nil\n")))
198 (if comment
199 (progn
200 (insert " \"")
201 (setq comment (nreverse comment))
202 (while comment
203 (tit-insert (car comment))
204 (insert "\n")
205 (setq comment (cdr comment)))
206 (forward-char -1)
207 (insert "\"")
208 (forward-char 1))
209 (insert " \"\"\n"))
210 (let (i len key)
211 (insert " '(\n")
212 (setq i 0 len (length moveright))
213 (while (< i len)
214 (setq key (aref moveright i))
215 (if (and (>= key ? ) (< key 127))
216 (progn
217 (insert " (\"")
218 (tit-insert (char-to-string (aref moveright i)))
219 (insert "\" . quail-next-candidate-block)\n")))
220 (setq i (1+ i)))
221 (setq i 0 len (length moveleft))
222 (while (< i len)
223 (setq key (aref moveleft i))
224 (if (and (>= key ? ) (< key 127))
225 (progn
226 (insert " (\"")
227 (tit-insert (char-to-string (aref moveleft i)))
228 (insert "\" . quail-prev-candidate-block)\n")))
229 (setq i (1+ i)))
230 (if (string-match " " (aref selectkey 0))
231 (insert " (\" \" . quail-select-current)\n"))
232 (insert " )\n"))
233 (insert " nil" (if multichoice " nil" " t") ")\n\n")
234
235 (tit-message "Formatting translation rules...")
236 (let ((mc-flag nil)
237 (key (make-string 30 0)))
238 (while (null (eobp))
239 (if (or (= (following-char) ?#) (= (following-char) ?\n))
240 (progn
241 (insert ";; ")
242 (forward-line 1))
243 (insert (if phrase "(qd \"" "(qdv \""))
244 (setq pos (point))
245 (tit-buffer-substring key)
246 (save-excursion
247 (while (re-search-backward "\"\\|\\\\[^0-9]" pos t)
248 (insert "\\")
249 (forward-char -1)))
250 (insert "\"")
251 (skip-chars-forward " \t")
252 (if (eolp)
253 (progn
254 (beginning-of-line)
255 (setq pos (point))
256 (forward-line 1)
257 (delete-region pos (point)))
258 (insert (if phrase "'(" "\""))
259 (setq pos (point))
260 (forward-line 1)
261 (while (tit-looking-at key)
262 (let (p)
263 (skip-chars-backward " \t\n")
264 (if phrase (insert " "))
265 (setq p (point))
266 (skip-chars-forward " \t\n")
267 (skip-chars-forward "^ \t")
268 (skip-chars-forward " \t")
269 (delete-region p (point)))
270 (forward-line 1))
271 (goto-char pos)
272 (if phrase
273 (while (null (eolp))
274 (insert "\"")
275 (skip-chars-forward "^ \t\n")
276 (insert "\"")
277 (skip-chars-forward " \t"))
278 (let ((mc-flag t)) (forward-char 1))
279 (if (= (following-char) ?\n)
280 (progn
281 (beginning-of-line)
282 (forward-char 3)
283 (delete-char 1))))
284 (end-of-line)
285 (insert (if phrase "))" "\")"))
286 (forward-line 1)))))
287 (insert "\n(quail-setup-current-package)\n")
288 )
289
290 (if noninteractive
291 (save-excursion
292 (set-buffer buf)
293 (write-file buffer-file-name))
294 ;; show user the line for keymap definition.
295 (switch-to-buffer buf)
296 (goto-char 1)
297 (search-forward "defconst" nil t)
298 (beginning-of-line)
299 (recenter 1)
300 (tit-message
301 "Modify key bindings or prompt as you wish and save this file.")
302 )
303 ))
304
305 (defun batch-tit-to-quail ()
306 "Run `tit-to-quail' on the files remaining on the command line.
307 Use this from the command line, with `-batch';
308 it won't work in an interactive Emacs.
309 For example, invoke \"emacs -batch -f batch-tit-to-quail $emacs/ ~/*.el\""
310 (defvar command-line-args-left) ;Avoid 'free variable' warning
311 (if (not noninteractive)
312 (error "`batch-tit-to-quail' is to be used only with -batch"))
313 (let ((error nil))
314 (while command-line-args-left
315 (if (file-directory-p (expand-file-name (car command-line-args-left)))
316 (let ((files (directory-files (car command-line-args-left)))
317 file)
318 (while files
319 (setq file (expand-file-name (car files)
320 (car command-line-args-left)))
321 (if (and (string-match "\\.tit$" file)
322 (file-newer-than-file-p
323 file
324 (tit-dest-file file default-directory)))
325 (progn
326 (message "Converting %s to quail-package..." file)
327 (tit-to-quail file default-directory)))
328 (setq files (cdr files))))
329 (tit-to-quail (car command-line-args-left) default-directory))
330 (setq command-line-args-left (cdr command-line-args-left)))
331 (kill-emacs 0)))