wok-6.x view emacs-pkg-text-translator/stuff/text-translator.el @ rev 22792
recompiled xneur
| author | Hans-G?nter Theisgen |
|---|---|
| date | Mon Jan 27 09:19:20 2020 +0100 (2020-01-27) |
| parents | |
| children |
line source
1 ;;; text-translator.el --- Text Translator
3 ;; Copyright (C) 2007-2010 khiker
5 ;; Author: khiker <khiker.mail+elisp@gmail.com>
6 ;; plus <MLB33828@nifty.com>
8 ;; This file is free software; you can redistribute it and/or modify
9 ;; it under the terms of the GNU General Public License as published by
10 ;; the Free Software Foundation; either version 2, or (at your option)
11 ;; any later version.
13 ;; This file is distributed in the hope that it will be useful,
14 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 ;; GNU General Public License for more details.
18 ;; You should have received a copy of the GNU General Public License
19 ;; along with GNU Emacs; see the file COPYING. If not, write to
20 ;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
21 ;; Boston, MA 02110-1301, USA.
23 ;;; Commentary:
25 ;; Translates character strings on Emacs.
26 ;; This package use the text translation service that exists on the internet.
28 ;; Read README.en (English) or README.ja (Japanese).
30 ;;; Code:
32 (require 'text-translator-vars)
34 (defun text-translator (arg &optional last engine-or-func)
35 "The function which does text translation.
36 Use Excite, Google and so translation site.
37 1. Mark is active
38 - Prefix was supplied.
39 1. Choose translation site which you use.
40 2. Translate by type which you selected.
41 - Prefix was not supplied.
42 Translate range of region that you selected by
43 first element of `text-translator-engine-history'.
44 (If `text-translator-engine-history' is nil,
45 use `text-translator-default-engine'.)
46 2. Mark is deactive
47 - Prefix was supplied.
48 1. Choose translation site which you use.
49 2. Translate value which you input from minibuffer by type you selected.
50 - Prefix was not supplied.
51 Translate value which you input from minibuffer by
52 first element of `text-translator-engine-history'.
53 (If `text-translator-engine-history' is nil,
54 use `text-translator-default-engine'.)"
55 (interactive "P")
56 (add-to-list 'text-translator-engine-history text-translator-default-engine)
57 (let ((minibuffer-history text-translator-engine-history)
58 (engine (text-translator-check-valid-translation-engine
59 engine-or-func (car text-translator-engine-history)))
60 str)
61 ;; If prefix-arg is non-nil, change translation type.
62 (when (or arg last)
63 (setq engine (completing-read
64 (format "Select translation engine (default %s): " engine)
65 text-translator-site-data-alist nil t nil nil engine)))
66 (setq str
67 (cond
68 (last
69 text-translator-last-string)
70 (t
71 (text-translator-region-or-read-string
72 (format "Enter string translated by %s: " engine)))))
73 (text-translator-client
74 (text-translator-check-valid-translation-engine
75 (and (functionp engine-or-func) (funcall engine-or-func engine str))
76 engine)
77 str)))
79 (defun text-translator-translate-by-auto-selection (arg)
80 "Function that translates by auto selection of translation engine.
81 Function that select automatically is value of `text-translator-auto-selection-func'."
82 (interactive "P")
83 (text-translator arg nil text-translator-auto-selection-func))
85 (defun text-translator-translate-by-auto-selection-enja (engine str)
86 "Automatic selection function for English to Japanese(or Japanese to English)
87 translation.
88 If alphabet ratio is over 40%, select engine which is translating from English to Japanese.
89 Otherwise, from Japanese to English."
90 (setq str (or str ""))
91 (format
92 "%s_%s"
93 (text-translator-get-engine-type-or-site engine t)
94 (if (> (/ (* (length (replace-regexp-in-string "[^A-Za-z]+" "" str)) 100)
95 (length str))
96 40)
97 "enja" "jaen")))
99 (defun text-translator-translate-last-string ()
100 "The function to translate in the translation site that
101 I choose with the character string that I translated in the last time."
102 (interactive)
103 (text-translator nil t))
106 (defun text-translator-region-or-read-string (&optional prompt)
107 "If mark is active, return the region, otherwise, read string with PROMPT."
108 (cond
109 (mark-active
110 (buffer-substring-no-properties (region-beginning) (region-end)))
111 (t
112 (read-string (or prompt "Enter string: ")))))
114 (defun text-translator-all (arg &optional key str)
115 "The function to translate in all of translate sites that matches
116 the selected type."
117 (interactive "P")
118 (let ((hash text-translator-sitedata-hash)
119 keys)
120 (setq str (or str (text-translator-region-or-read-string)))
121 (when (or (null hash)
122 arg)
123 (setq text-translator-sitedata-hash
124 (text-translator-update-hashtable))
125 (setq hash text-translator-sitedata-hash))
126 (maphash '(lambda (x y)
127 (setq keys (cons x keys)))
128 hash)
129 (setq key (or key (completing-read "Select type: " keys nil t)))
130 (when key
131 (save-selected-window
132 (pop-to-buffer text-translator-buffer)
133 (setq buffer-read-only nil)
134 (erase-buffer)
135 (text-translator-mode))
136 (let ((sites (gethash key hash)))
137 (setq text-translator-last-string str)
138 (setq text-translator-search-regexp-or-func
139 (concat "_" key))
140 (dolist (i sites)
141 (text-translator-client i str t))))))
143 (defun text-translator-all-by-auto-selection (arg)
144 "The function to translate in all of translate sites, whose translation engine is selected automatically.
145 The selection function is the value of `text-translator-auto-selection-func'."
146 (interactive "P")
147 (let ((str (text-translator-region-or-read-string)))
148 (text-translator-all
149 arg
150 (substring (funcall text-translator-auto-selection-func "" str) 1)
151 str)))
153 (defun text-translator-client (engine str &optional all)
154 "Function that throws out words and phrases that want to translate into
155 specified site, and receives translation result."
156 (let* ((history-delete-duplicates t)
157 (buf (cond (all
158 (concat text-translator-work-buffer
159 (replace-regexp-in-string "_.*"
160 ""
161 engine)))
162 (t
163 text-translator-work-buffer)))
164 (alist
165 (cond
166 ((not text-translator-do-fill-region)
167 text-translator-pre-string-replace-alist)
168 ;; for example, if engine is "excite.co.jp_enja",
169 ;; this code returns "en".
170 ((member (substring
171 (text-translator-get-engine-type-or-site engine) 0 2)
172 text-translator-space-division-languages)
173 ;; replace "\n" to " ".
174 (append '(("\n" . " ") ("\r" . ""))
175 text-translator-pre-string-replace-alist))
176 (t
177 ;; replace "\n" to "".
178 (append '(("\n" . "") ("\r" . ""))
179 text-translator-pre-string-replace-alist))))
180 (str (text-translator-replace-string str alist))
181 (type (assoc engine text-translator-site-data-alist))
182 (proc (open-network-stream "Web Connection" buf
183 (or text-translator-proxy-server
184 (nth 1 type))
185 (or (and text-translator-proxy-server
186 text-translator-proxy-port)
187 80)))
188 ;;(process-connection-type nil)
189 (enc-str (text-translator-url-encode-string str (nth 4 type)))
190 (post-str (if (nth 3 type) (format (nth 3 type) enc-str) nil))
191 (truncate-partial-width-windows nil))
192 (unless all
193 (add-to-history 'text-translator-engine-history engine)
194 (setq text-translator-search-regexp-or-func (nth 5 type))
195 (setq text-translator-last-string str))
196 (with-current-buffer (get-buffer-create buf)
197 (erase-buffer)
198 (set-process-coding-system proc (nth 4 type) 'binary)
199 (set-process-filter proc 'text-translator-client-filter)
200 (process-send-string
201 proc
202 (concat
203 (cond
204 (post-str
205 ;; use POST method
206 (concat "POST " (nth 2 type) "\r\n"))
207 (t
208 ;; use GET method
209 (concat "GET " (format (nth 2 type) enc-str) "\r\n")))
210 (and text-translator-proxy-server
211 text-translator-proxy-user
212 text-translator-proxy-password
213 (format "Proxy-Authorization: Basic %s \r\n"
214 (base64-encode-string
215 (concat text-translator-proxy-user ":"
216 text-translator-proxy-password))))
217 "HOST: " (nth 1 type) "\r\n"
218 "User-Agent: " text-translator-user-agent "\r\n"
219 ;; "Accept: text/xml,application/xml,application/xhtml+xml,text/html;q=0.9,text/plain;q=0.8,image/png,*/*;q=0.5" "\r\n"
220 ;; "Accept-Language: ja,en-us;q=0.7,en;q=0.3" "\r\n"
221 "Accept-Encoding: identity\r\n"
222 "Accept-Charset: Shift_JIS,utf-8;q=0.7,*;q=0.7\r\n"
223 "Keep-Alive: 300" "\r\n"
224 "Connection: keep-alive" "\r\n"
225 (when post-str
226 (concat
227 "Content-Type: application/x-www-form-urlencoded\r\n"
228 "Content-Length: "
229 (number-to-string (string-bytes post-str)) "\r\n"
230 "\r\n"
231 post-str "\r\n"))
232 "\r\n"))
233 (message "Translating...")
234 (unless (or all
235 text-translator-display-popup)
236 (save-selected-window
237 (pop-to-buffer text-translator-buffer)
238 (setq buffer-read-only nil)
239 (erase-buffer)
240 (text-translator-mode)
241 (setq mode-line-buffer-identification
242 `("%b [" ,(car text-translator-engine-history) "]")))))))
244 (defun text-translator-client-filter (proc str)
245 (let ((regex-or-func text-translator-search-regexp-or-func)
246 bname all-flag)
247 (with-current-buffer (process-buffer proc)
248 (goto-char (process-mark proc))
249 (insert (format "%s" str))
250 (set-marker (process-mark proc) (point))
251 (setq bname (buffer-name))
252 (setq all-flag (not (string= bname text-translator-work-buffer)))
253 (when all-flag
254 (setq regex-or-func
255 (nth 5
256 (assoc (concat
257 (substring bname
258 (length text-translator-work-buffer)
259 (length bname))
260 regex-or-func)
261 text-translator-site-data-alist))))
262 (setq str (text-translator-replace-string
263 (or (cond
264 ((functionp regex-or-func)
265 (funcall regex-or-func))
266 ((re-search-backward regex-or-func nil t)
267 (match-string 1)))
268 "")
269 text-translator-post-string-replace-alist))
270 (unless (string= "" str)
271 (delete-process proc)
272 (setq bname (buffer-name))
273 (setq all-flag (not (string= bname text-translator-work-buffer)))
274 (when (or all-flag
275 (not text-translator-display-popup))
276 (text-translator-display-window str bname all-flag))))
277 ;; To display in popup-tip, buffer is out of with-current-buffer.
278 (when (and (not (string= "" str))
279 (not all-flag)
280 (fboundp 'popup-tip)
281 (eq text-translator-display-popup t))
282 (text-translator-display-popup str))))
284 (defun text-translator-display-window (str buf all-flag)
285 (let ((window (get-buffer-window text-translator-buffer))
286 (window-min-height
287 (if (> text-translator-window-min-height (/ (frame-height) 2))
288 (/ (frame-height) 2)
289 (1+ text-translator-window-min-height))))
290 (set-buffer text-translator-buffer)
291 (setq buffer-read-only nil)
292 (cond
293 (all-flag
294 (insert (concat
295 (propertize
296 (format "----- %s -----\n"
297 (substring buf
298 (length text-translator-work-buffer)
299 (length buf)))
300 'face font-lock-keyword-face)
301 str "\n\n")))
302 (t (when text-translator-leave-string
303 (insert
304 (concat
305 (propertize "----- Original -----\n"
306 'face font-lock-keyword-face)
307 text-translator-last-string
308 "\n\n"
309 (propertize "***** Translation *****\n"
310 'face font-lock-keyword-face))))
311 (insert (concat str "\n"))
312 (when text-translator-do-fill-region
313 (goto-char (- (point) (/ (length str) 2)))
314 (call-interactively 'fill-paragraph))
315 (set-buffer-modified-p nil)
316 ;; adjust window height
317 (when (and text-translator-auto-window-adjust
318 (window-live-p window))
319 (balance-windows)
320 (shrink-window-if-larger-than-buffer window))
321 (message "") ; prevent minibuffer from becoming two line.
322 (ding)
323 (message "Translating...done")))))
325 (defun text-translator-display-popup (str)
326 (let ((read-only-p buffer-read-only))
327 (setq str (with-temp-buffer
328 (insert str)
329 (when text-translator-do-fill-region
330 (goto-char (- (point) (/ (length str) 2)))
331 (call-interactively 'fill-paragraph))
332 (buffer-string)))
333 (ding)
334 (message "Translating...done")
335 (if read-only-p
336 ;; temporay cancel buffer-read-only
337 (unwind-protect (progn
338 (setq buffer-read-only nil)
339 (popup-tip str :margin t))
340 (setq buffer-read-only t))
341 (popup-tip str :margin t))))
343 (defun text-translator-update-hashtable ()
344 (let ((hash (make-hash-table :test 'equal)))
345 (mapc '(lambda (x)
346 (let ((matched (replace-regexp-in-string "\\([^_]*\\)_"
347 ""
348 (car x))))
349 (unless (or (string= (car x) matched)
350 (eq ?* (aref matched 0)))
351 (cond
352 ((gethash matched hash)
353 (puthash matched
354 (cons (car x) (gethash matched hash))
355 hash))
356 (t
357 (puthash matched (list (car x)) hash))))))
358 text-translator-site-data-alist)
359 hash))
361 (defun text-translator-replace-string (str replace)
362 "Function that converts character string specified for argument STR
363 according to rule REPLACE."
364 (with-temp-buffer
365 (insert str)
366 ;; convert unusable string
367 (format-replace-strings replace)
368 (buffer-string)))
370 (defun text-translator-extract-tag-exclusion-string (regex &optional dont-convert-br)
371 ;; (when (re-search-backward regex nil t)
372 (when (re-search-backward regex nil t)
373 ;; first: convert <br> tag to '\n' (when variable dont-convert-br is nil)
374 ;; second: convert any another tags to empty string.
375 (let ((matchstr (match-string 1)))
376 (setq matchstr
377 (text-translator-replace-string
378 matchstr
379 text-translator-post-string-replace-alist))
380 (replace-regexp-in-string
381 "<.*?>" "" (if dont-convert-br
382 matchstr
383 (replace-regexp-in-string
384 "<[bB][rR]\\( /\\)?>" "\n" matchstr))))))
386 ;;;; major-mode text-translator-mode
388 ;; variables for major mode
389 (defvar text-translator-mode nil)
390 (defvar text-translator-mode-map nil)
391 (defvar text-translator-mode-pkey-map nil)
392 (defvar text-translator-mode-syntax-table nil)
393 (defvar text-translator-mode-abbrev-table nil)
394 (define-abbrev-table 'text-translator-mode-abbrev-table ())
396 ;; keymap definition
397 (unless text-translator-mode-map
398 (setq text-translator-mode-map (make-sparse-keymap))
399 (define-prefix-command 'text-translator-mode-pkey-map)
400 (let ((map text-translator-mode-pkey-map))
401 (define-key map "\C-q" 'text-translator-quit)
402 (define-key map "\C-a" 'text-translator-translate-recent-type)
403 (define-key map "\C-l" 'text-translator-display-last-string)
404 (define-key map "\C-d" 'text-translator-translate-default)
405 (define-key map "\C-s" 'text-translator-toggle-leave-string)))
407 ;; major-mode
408 (defun text-translator-mode ()
409 "Major mode for text-translator."
410 (kill-all-local-variables)
411 (setq local-abbrev-table text-translator-mode-abbrev-table)
412 (set-syntax-table text-translator-mode-syntax-table)
413 (setq mode-name text-translator-mode-name)
414 (setq major-mode 'text-translator-mode)
415 (define-key text-translator-mode-map
416 text-translator-prefix-key text-translator-mode-pkey-map)
417 (use-local-map text-translator-mode-map)
418 (run-hooks 'text-translator-mode-hook))
420 ;; syntax-table
421 (unless text-translator-mode-syntax-table
422 (setq text-translator-mode-syntax-table (make-syntax-table)))
424 ;; functions for major-mode
425 (defun text-translator-quit ()
426 "Function that closes buffer for text-translator.
427 If window only have *translated* buffer, change another buffer."
428 (interactive)
429 (bury-buffer)
430 (unless (one-window-p)
431 (delete-window)))
433 (defun text-translator-toggle-leave-string ()
434 "Function that change value of `text-translator-leave-string'.
435 Toggle to display a translation result buffer of character
436 string that used last time."
437 (interactive)
438 (setq text-translator-leave-string (not text-translator-leave-string))
439 (message "Pretranslational string switched %s to leave."
440 (if text-translator-leave-string "" " not")))
442 (defun text-translator-display-last-string (arg)
443 "Function that displays translated character string last time.
444 Default display to minibuffer.
445 With prefix-arg, insert buffer."
446 (interactive "P")
447 (if arg
448 (insert text-translator-last-string)
449 (message "%s" text-translator-last-string)))
451 (defun text-translator-translate-recent-type ()
452 "Function that translates by type corresponding to the language
453 that used last time.
454 For example, last time, if you have used excite.co.jp_enja,
455 this time select from **_enja, and, translates."
456 (interactive)
457 (let* ((minibuffer-history text-translator-engine-history)
458 (engine (car text-translator-engine-history))
459 (last-type
460 (concat "_" (text-translator-get-engine-type-or-site engine)))
461 (type (completing-read
462 (format "Select translation engine (last %s): " engine)
463 (delq nil
464 (mapcar
465 (lambda (x)
466 (when (string-match last-type (car x))
467 x))
468 text-translator-site-data-alist))
469 nil t)))
470 (unless (string= "" type)
471 (text-translator-client type text-translator-last-string))))
473 (defun text-translator-translate-default ()
474 "Function that translates by default type only.
475 Default is value of `text-translator-default-engine'."
476 (interactive)
477 (text-translator nil nil text-translator-default-engine))
479 (defun text-translator-check-valid-translation-engine (engine valid-engine)
480 "Check ENGINE that is registered in `text-translator-site-data-alist'.
481 Return ENGINE if it is already registered, otherwise return VALID-ENGINE."
482 (or (car (member engine (mapcar 'car text-translator-site-data-alist)))
483 valid-engine))
485 (defun text-translator-get-engine-type-or-site (engine &optional get-site)
486 "Get a translation engine type or site name.
487 If optional argument GET-SITE is nil, return a translation engine type.
488 Otherwise return a translation site name."
489 (nth (if get-site 0 1) (split-string engine "_")))
491 ;; by google2.el
492 (defun text-translator-url-encode-string (str &optional coding)
493 (apply (function concat)
494 (mapcar
495 (lambda (ch)
496 (cond
497 ((eq ch ?\n) ; newline
498 "%0D%0A")
499 ((string-match "[-a-zA-Z0-9_:/]" (char-to-string ch)) ; xxx?
500 (char-to-string ch)) ; printable
501 ((char-equal ch ?\x20) ; space
502 "+")
503 (t
504 (format "%%%02X" ch)))) ; escape
505 ;; Coerce a string to a list of chars.
506 (append (encode-coding-string (or str "") (or coding 'iso-2022-jp))
507 nil))))
509 ;; initialization function
510 (defun text-translator-site-data-init ()
511 ;; initialize
512 (setq text-translator-site-data-alist nil)
513 (setq text-translator-site-data-alist
514 text-translator-site-data-minimum-alist)
515 (dolist (site text-translator-site-data-template-alist)
516 (let ((tt-convert-name '(lambda (lang)
517 (let ((match-lang (assoc lang
518 (nth 7 site))))
519 (if match-lang
520 (cdr match-lang)
521 lang))))
522 (tt-replace-string '(lambda (pstr olang tlang)
523 (when olang
524 (setq pstr
525 (replace-regexp-in-string "%o"
526 olang
527 pstr)))
528 (when tlang
529 (setq pstr
530 (replace-regexp-in-string "%t"
531 tlang
532 pstr))
533 pstr)))
534 tt-alist)
535 (dolist (i (nth 6 site))
536 (add-to-list 'text-translator-site-data-alist
537 (list (format "%s"
538 (concat (nth 0 site)
539 "_"
540 (funcall tt-convert-name (car i))
541 (funcall tt-convert-name (cdr i))))
542 (nth 1 site)
543 (nth 2 site)
544 (funcall tt-replace-string
545 (nth 3 site) (car i) (cdr i))
546 (nth 4 site)
547 (nth 5 site)))))))
548 (text-translator-site-data-init) ; init
550 (provide 'text-translator)
551 ;;; text-translator.el ends here
553 ;; Local Variables:
554 ;; Coding: utf-8
555 ;; End: