;;;;; mw32misc.el ---- For Multilingul Windows. ;; ;; Author H.Miyashita ;; ;;;;; (defun set-clipboard-coding-system (coding-system) "Set windows clipboard coding sytem. This coding system is used when emacs read or write windows clipboard." (interactive "zClipboard-coding-system:") (check-coding-system coding-system) (setq w32-clipboard-coding-system coding-system)) (defun set-w32-system-coding-system (coding-system) "Set coding sytem used by windows. " (interactive "zWindows-system-coding-system:") (check-coding-system coding-system) (setq w32-system-coding-system coding-system)) (fmakunbound 'font-menu-add-default) (defun mouse-set-font (&rest fonts) "Select an emacs font from a list of known good fonts and fontsets." (interactive (x-popup-menu last-nonmenu-event (let ((fslist (w32-font-list))) (append (list "font,fontset Select Menu" (cons "Select font" (mapcar (function (lambda (fse) (list fse fse))) fslist))) (list (generate-fontset-menu)))))) (if fonts (let (font) (while fonts (condition-case nil (progn (set-default-font (car fonts)) (setq font (car fonts)) (setq fonts nil)) (error (setq fonts (cdr fonts))))) (if (null font) (error "Font not found"))))) (defun w32-mouse-operation-init () (if (= (w32-get-system-metrics 43) 3) (progn (setq w32-lbutton-to-emacs-button 0) (setq w32-mbutton-to-emacs-button 1) (setq w32-rbutton-to-emacs-button 2) ))) (add-hook 'after-init-hook (lambda () (if (featurep 'meadow) (setq keyboard-type (w32-keyboard-type))))) (defun w32-change-logfont-name (logfont name) "change name of logfont." (w32-check-logfont logfont) (let ((logfontc (copy-sequence logfont))) (setcar (nthcdr 1 logfontc) name) logfontc)) (defun w32-change-logfont-width (logfont width) "change width of logfont." (w32-check-logfont logfont) (let ((logfontc (copy-sequence logfont))) (setcar (nthcdr 2 logfontc) width) logfontc)) (defun w32-change-logfont-height (logfont height) "change height of logfont." (w32-check-logfont logfont) (let ((logfontc (copy-sequence logfont))) (setcar (nthcdr 3 logfontc) height) logfontc)) (defun w32-change-logfont-weight (logfont add) "change weight of logfont. Add ADD to weight." (w32-check-logfont logfont) (let ((weight (nth 4 logfont)) (logfontc (copy-sequence logfont))) (setcar (nthcdr 4 logfontc) (+ weight add)) logfontc)) (defun w32-change-logfont-italic-p (logfont italic-p) "change italic-p of logfont." (w32-check-logfont logfont) (if (null (or (eq italic-p nil) (eq italic-p t))) (error "italic-p must be nil or t.")) (let ((logfontc (copy-sequence logfont))) (setcar (nthcdr 6 logfontc) italic-p) logfontc)) (defun w32-logfont-fixed-p (logfont) (/= (logand (nth 12 logfont) 1) 0)) (defun w32-change-logfont-charset (logfont charset) "change charset of logfont." (w32-check-logfont logfont) (let ((logfontc (copy-sequence logfont))) (setcar (nthcdr 9 logfontc) charset) logfontc)) (defun w32-logfont-name (logfont) "Return name of logfont." (w32-check-logfont logfont) (nth 1 logfont)) (defun w32-logfont-width (logfont) "Return width of logfont." (w32-check-logfont logfont) (nth 2 logfont)) (defun w32-logfont-height (logfont) "Return height of logfont." (w32-check-logfont logfont) (nth 3 logfont)) (defun w32-logfont-weight (logfont) "Return weight of logfont." (w32-check-logfont logfont) (nth 4 logfont)) (defun w32-logfont-italic-p (logfont) "Return italic-p of logfont." (w32-check-logfont logfont) (nth 6 logfont)) (defun w32-logfont-charset (logfont) "change charset of logfont." (w32-check-logfont logfont) (nth 9 logfont)) (setq x-fixed-font-alist nil) (defun w32-regist-font-encoder (name real-encoder) (cond ((get real-encoder 'ccl-program-idx) (put name 'ccl-program real-encoder)) (t (error "Not yet supported encoder! %S" real-encoder)))) (w32-regist-font-encoder 'encode-koi8-font 'ccl-encode-koi8-font) (w32-regist-font-encoder 'encode-alternativnyj-font 'ccl-encode-alternativnyj-font) (w32-regist-font-encoder 'encode-big5-font 'ccl-encode-big5-font) (w32-regist-font-encoder 'encode-viscii-font 'ccl-encode-viscii-font) (w32-regist-font-encoder 'encode-ethio-font 'ccl-encode-ethio-font) (defvar w32-charset-encoding-alist '((ascii 0 0) ; ANSI_CHARSET (latin-iso8859-1 0 1) ; ANSI_CHARSET (ascii-right-to-left 0 0) ; ANSI_CHARSET (latin-iso8859-2 238 1) ; EASTEUROPE_CHARSET (latin-iso8859-3 1 1) ; DEFAULT_CHARSET (latin-iso8859-4 1 1) ; DEFAULT_CHARSET (cyrillic-iso8859-5 204 1) ; RUSSIAN_CHARSET(1251!=8859) (arabic-iso8859-6 178 1) ; ARABIC_CHARSET (greek-iso8859-7 161 1) ; GREEK_CHARSET (hebrew-iso8859-8 177 1) ; HEBREW_CHARSET (latin-iso8859-9 162 1) ; TURKISH_CHARSET (latin-jisx0201 128 0) ; SHIFTJIS_CHARSET (katakana-jisx0201 128 4) ; SHIFTJIS_CHARSET (japanese-jisx0208 128 4) ; SHIFTJIS_CHARSET (japanese-jisx0212 1 0) ; DEFAULT_CHARSET (chinese-big5-1 136 encode-big5-font) ; CHINESEBIG5_CHARSET (chinese-big5-2 136 encode-big5-font) ; CHINESEBIG5_CHARSET (chinese-gb2312 134 1) ; GB2312_CHARSET (korean-ksc5601 129 1) ; HANGEUL_CHARSET (thai-tis620 222 0) ; THAI_CHARSET (vietnamese-viscii-lower 163 encode-viscii-font) ; VIETNAMESE_CHARSET (vietnamese-viscii-upper 163 encode-viscii-font) ; VIETNAMESE_CHARSET ; (chinese-cns11643-1 1 0) ; DEFAULT_CHARSET ; (chinese-cns11643-2 1 0) ; DEFAULT_CHARSET ; (chinese-cns11643-3 1 0) ; DEFAULT_CHARSET ; (chinese-cns11643-4 1 0) ; DEFAULT_CHARSET ; (chinese-cns11643-5 1 0) ; DEFAULT_CHARSET ; (chinese-cns11643-6 1 0) ; DEFAULT_CHARSET ; (chinese-cns11643-7 1 0) ; DEFAULT_CHARSET ; (arabic-digit 1 0) ; DEFAULT_CHARSET ; (arabic-1-column 1 0) ; DEFAULT_CHARSET ; (arabic-2-column 1 0) ; DEFAULT_CHARSET ; (lao 1 0) ; DEFAULT_CHARSET ; (ipa 1 0) ; DEFAULT_CHARSET ; (ethiopic 1 0) ; DEFAULT_CHARSET ; (indian-is13194 1 0) ; DEFAULT_CHARSET ; (indian-2-column 1 0) ; DEFAULT_CHARSET ; (indian-1-column 1 0) ; DEFAULT_CHARSET )) ; JOHAB_CHARSET (defvar w32-default-logfont '(w32-logfont "FixedSys" 0 0 400 0 nil nil nil 0 1 1 1) "Default font is generated from this.") (defun w32-automatic-font-regist (name lflist &optional encoding-type) (w32-add-font name '((width . 0) (height . 0) (base . 0) (overhang . 0) (encoding-type . 0))) (let (lf metric num encoder (i 0) (width 0) (height 0) (base 0) (overhang 0)) (if (not (numberp encoding-type)) (progn (setq encoder encoding-type) (setq encoding-type 0))) (while (setq lf (car lflist)) (setq metric (w32-get-logfont-info lf) num (cdr (assq 'width metric))) (if (> num width) (setq width num)) (setq num (cdr (assq 'height metric))) (if (> num height) (setq height num)) (setq num (cdr (assq 'base metric))) (if (> num base) (setq base num)) (setq num (cdr (assq 'overhang metric))) (if (> num overhang) (setq overhang num)) (w32-change-font-logfont name i lf) (setq lflist (cdr lflist)) (setq i (1+ i))) (w32-change-font-attribute name (list (cons 'width width) (cons 'height height) (cons 'base base) (cons 'overhang overhang) (cons 'encoding-type encoding-type) (cons 'encoder encoder))))) (defun w32-generate-tribial-logfont-list (logfont) (let* ((bold-font (w32-change-logfont-weight logfont 300)) (italic-font (w32-change-logfont-italic-p logfont t)) (italic-bold-font (w32-change-logfont-italic-p bold-font t))) (list logfont bold-font italic-font italic-bold-font))) (defun w32-regist-initial-font () (w32-automatic-font-regist "initial" (w32-generate-tribial-logfont-list w32-default-logfont) 0)) (defun w32-automatic-fontset-regist (name orgfont) (let ((encoding-alist w32-charset-encoding-alist) x ret) (while encoding-alist (setq x (car encoding-alist)) (setq encoding-alist (cdr encoding-alist)) (let* ((charset (car x)) (ms-charset (car (cdr x))) (encoding-type (car (cdr (cdr x)))) (font-name (format "%s-%s" orgfont (symbol-name charset))) orglf newlf metric) (setq orglf (w32-change-logfont-charset (cond ((w32-get-font-logfont orgfont 0)) (t w32-default-logfont)) ms-charset)) (setq metric (w32-get-logfont-info orglf)) (if (= ms-charset (cdr (assq 'charset-num metric))) (progn (w32-automatic-font-regist font-name (mapcar (lambda (x) (setq metric (w32-get-logfont-info orglf) newlf (w32-change-logfont-width orglf (cdr (assq 'width metric))) newlf (w32-change-logfont-height newlf (cdr (assq 'height metric)))) newlf) '(0 1 2 3)) encoding-type) (setq ret (cons (cons charset font-name) ret)))))) (new-fontset name ret))) ;(new-fontset "default-fontset" '((ascii . "default") ; (japanese-jisx0208 . "default") ; (katakana-jisx0201 . "default"))) ; ;(set-default-font "default-fontset") ;;;;; ;;;;; ;;;;; High level font selection API ;;;;; ;;;;; (defun w32-auto-regist-bdf-font (fontname bdffile &optional encoding) (if (null encoding) (setq encoding 0)) (let ((bdfatt (w32-get-logfont-info (list 'bdf-font bdffile)))) (if bdfatt (progn (cond ((symbolp encoding) (setq bdfatt (append (list (cons 'encoder encoding) (cons 'encoding-type 0)) bdfatt))) ((numberp encoding) (setq bdfatt (cons (cons 'encoding-type encoding) bdfatt)))) (w32-add-font fontname bdfatt) (w32-change-font-logfont fontname 0 (list 'bdf-font bdffile)))))) (defun create-font-from-logfont-list (name logfont-list &optional encoding-type alist) ; (w32-check-logfont logfont) (if (null encoding-type) (setq encoding-type 0)) (let ((prop (append (list (cons 'encoding-type encoding-type)) alist (w32-get-logfont-info (car logfont-list)))) (i 0) logfont) (w32-add-font name prop) (while (setq logfont (car logfont-list)) (w32-change-font-logfont name i logfont) (setq i (1+ i)) (setq logfont-list (cdr logfont-list))))) (defun set-font-from-logfont (name logfont charset pnum &optional encoding-type alist) (w32-check-logfont logfont) (if (and (null encoding-type) (eq (car logfont) 'w32-logfont)) (setq encoding-type (nth 2 (assq charset w32-charset-encoding-alist)))) (let ((prop (append (if (numberp encoding-type) (list (cons 'encoding-type encoding-type)) (list (cons 'encoding-type 0) (cons 'encoder encoding-type))) alist (w32-get-logfont-info logfont)))) (condition-case nil (w32-add-font name prop) (error)) (w32-change-font-logfont name pnum logfont))) ; request type ; family, width, height, italic, weight, fixed ; ?? base ?? (defvar logfont-from-request-functions nil "* Functions that return logical font from your request. These functions are called passing CHARSET-SYMBOL, REQUIRED-ALIST, RECOMMENDED-ALIST. These functions must return a logical font or nil when no logical fonts are found.") (defvar w32-font-list-cache nil) (defsubst logfont-list-from-request (required recommended &optional fontset) (let* ((charset-list (if (null fontset) (charset-list) (let* ((chlist (aref (fontset-info fontset) 2)) (curlist chlist)) (while (setq curlist (cdr curlist)) (setcar curlist (car (car curlist)))) chlist))) (curchl charset-list) curch logfont result) (while (setq curch (car curchl)) (if (setq logfont (run-hook-with-args-until-success 'logfont-from-request-functions curch required recommended fontset)) (setq result (cons (cons curch logfont) result))) (setq curchl (cdr curchl))) result)) (defsubst w32-candidate-scalable-p (cand) (eq (nth 2 cand) 'scalable)) (defun w32-candidate-satisfy-request-p (cand request) (let* ((item (car request)) (cont (cdr request)) (logfont (nth 3 cand)) (info (w32-get-logfont-info logfont))) (cond ((eq item 'width) (or (w32-candidate-scalable-p cand) (= (cdr (assq 'width info)) cont))) ((eq item 'height) (or (w32-candidate-scalable-p cand) (= (cdr (assq 'height info)) cont))) ((eq item 'weight) t) ; (or (w32-candidate-scalable-p cand) ; (= (cdr (assq 'weight info)) cont))) ((eq item 'italic) (if cont (w32-logfont-italic-p logfont) (not (w32-logfont-italic-p logfont)))) ((eq item 'fixed) (if cont (w32-logfont-fixed-p logfont) (not (w32-logfont-fixed-p logfont)))) ((eq item 'family) (string= (car cand) cont)) (t t)))) (defun w32-select-logfont-from-required (candidate required) (let ((curreq required) curcand curcand1 curre curce) (while (setq curre (car curreq)) (setq curcand candidate curcand1 candidate) (while (setq curce (car curcand)) (if (not (w32-candidate-satisfy-request-p curce curre)) (if (eq curcand curcand1) (setq curcand (cdr curcand) curcand1 curcand candidate curcand) (setq curcand (cdr curcand))) (if (eq curcand curcand1) (setq candidate curcand) (setcdr curcand1 curcand)) (setq curcand1 curcand curcand (cdr curcand)))) (if curcand1 (setcdr curcand1 nil)) (setq curreq (cdr curreq)))) candidate) (defun w32-select-logfont-from-recommended (candidate recommended) (let ((currec recommended) (scorelist (make-list (length candidate) 0)) curcand curre curce scorep bestcand max) (while (setq curre (car currec)) (setq curcand candidate scorep scorelist) (while (setq curce (car curcand)) (if (w32-candidate-satisfy-request-p curce curre) (setcar scorep (1+ (car scorep)))) (setq curcand (cdr curcand) scorep (cdr scorep))) (setq currec (cdr currec))) (setq scorep scorelist curcand candidate bestcand (car candidate) max 0) (while (setq curce (car curcand)) (if (> (car scorep) max) (progn (setq max (car scorep) bestcand curce))) (setq curcand (cdr curcand) scorep (cdr scorep))) bestcand)) (defsubst w32-logfont-valid-charset-p (logfont charset) (= ; (cdr ; (assq 'charset-num ; (w32-get-logfont-info ; (w32-change-logfont-charset ; logfont charset)))) (w32-logfont-charset logfont) charset)) (defun w32-modify-logfont-from-request (logfont required recommended) (let ((width (or (assq 'width required) (assq 'width recommended))) (height (or (assq 'height required) (assq 'height recommended))) (weight (or (assq 'weight required) (assq 'weight recommended))) result) (if width (setq result (w32-change-logfont-width logfont (cdr width)))) ;;; for speed, I don't use w32-change-logfont-* (if height (setcar (nthcdr 3 result) (cdr height))) (if weight (setcar (nthcdr 4 result) (cdr weight))) result)) (defun w32-logfont-list-from-request (charset required recommended fontset) (if (null w32-font-list-cache) (setq w32-font-list-cache (w32-enum-logfont))) (let ((ms-charset (nth 1 (assq charset w32-charset-encoding-alist))) request curlist curelem lfname testlf cand1 result) (if (null ms-charset) nil (if (setq request (assq 'family required)) (and (setq testlf (nth 3 (assoc (cdr request) w32-font-list-cache))) (w32-logfont-valid-charset-p testlf ms-charset) (setq cand1 (w32-enum-logfont (cdr request)))) (setq curlist w32-font-list-cache) (while (setq curelem (car curlist)) (setq lfname (nth 1 (nth 3 curelem)) cand1 (nconc cand1 (and (> (length lfname) 0) (/= (aref lfname 0) ?@) (w32-logfont-valid-charset-p (nth 3 curelem) ms-charset) (w32-enum-logfont (w32-logfont-name (nth 3 curelem))))) curlist (cdr curlist)))) (setq cand1 (w32-select-logfont-from-required cand1 required) result (nth 3 (w32-select-logfont-from-recommended cand1 recommended))) (if result (w32-modify-logfont-from-request result required recommended))))) (add-hook 'logfont-from-request-functions (function w32-logfont-list-from-request)) (defun create-fontset-from-request (name required recommended) "Create fontset from your request." (let* ((logfont-list (logfont-list-from-request required recommended)) (curll logfont-list) curle logfont fontname charset) (while (setq curle (car curll)) (setq logfont (cdr curle) charset (car curle) fontname (concat name "-" (symbol-name charset))) (set-font-from-logfont fontname logfont charset 0) (setcdr curle fontname) (setq curll (cdr curll))) (new-fontset name logfont-list))) (defun change-fontset-from-request (name required recommended &optional property) "Change fontset from your request." (if (null property) (setq property 0)) (let* ((fontset-font-data (aref (fontset-info name) 2)) (logfont-list (logfont-list-from-request required recommended name)) (curll logfont-list) curle logfont fontname) (while (setq curle (car curll)) (setq logfont (cdr (car curll)) fontname (nth 1 (assq (car (car curll)) fontset-font-data))) (w32-change-font-logfont fontname property logfont) (setq curll (cdr curll))))) ;;;;; ;;;;; For Argument Editing. ;;;;; ;;;;; (defvar process-argument-editing-alist nil) (defvar default-process-argument-editing-function (lambda (x) (general-process-argument-editing-function x 'msvc t)) "Default argument editing function. When any argument editing functions are NOT found, this function is used for argument editing.") (defun remove-process-argument-editing (process) "Remove argument editing configuration of PROCESS, if exists." (let ((curelem process-argument-editing-alist)) (if (string= (car (car curelem)) process) (setq process-argument-editing-alist (cdr process-argument-editing-alist)) (while (progn (if (not (string= (car (car (cdr curelem))) process)) (setq curelem (cdr curelem)) (setcdr curelem (cdr (cdr curelem))) nil)))))) (defun define-process-argument-editing (process function &optional method) "Define argument editing configuration of PROCESS to FUNCTION" (indirect-function function) (let ((elem (cons process function)) (oelem (assoc process process-argument-editing-alist))) (cond ((eq method 'last) (remove-process-argument-editing process) (nconc process-argument-editing-alist (list elem))) ((eq method 'first) (remove-process-argument-editing process) (setq process-argument-editing-alist (cons elem process-argument-editing-alist))) ((eq method 'append) (if oelem nil (setq process-argument-editing-alist (cons elem process-argument-editing-alist)))) ((eq method 'replace) (if oelem (setcdr oelem function))) (t (if oelem (setcdr oelem function) (setq process-argument-editing-alist (cons elem process-argument-editing-alist))))))) (defun find-process-argument-editing-function (process) "Find a function of argument editing to invoke PROCESS." (let ((alist process-argument-editing-alist) (elem nil)) (while (and (null elem) (setq elem (car alist))) (if (string-match (car elem) process) (setq elem (cdr elem)) (setq alist (cdr alist)) (setq elem nil))) (if elem elem default-process-argument-editing-function))) (defun msvc-process-argument-quoting (arg) (mapcar (lambda (x) (let ((start 0) (result "\"") pos end) (while (string-match "\\\\*\"" x start) (setq pos (match-beginning 0) end (match-end 0) result (concat result (substring x start pos) (make-string (* (- end pos 1) 2) ?\\ ) "\\\"") start end)) (concat result (substring x start) "\""))) arg)) (defun cygnus-process-argument-quoting (arguments) (mapcar (lambda (arg) (let ((result "\"") (start 0) pos) (while (string-match "\"" arg start) (setq pos (match-end 0) result (concat result (substring arg start pos) "\"") start pos)) (concat result (substring arg start) "\""))) arguments)) (defun general-process-argument-editing-function (argument quoting argv0isp &optional ep h2sp qp s2isp) (setq argument (cond ((eq quoting 'msvc) (msvc-process-argument-quoting argument)) ((eq quoting 'cygnus) (cygnus-process-argument-quoting argument)) (t argument))) (if (null argv0isp) (unix-to-dos-argument (mapconcat (function concat) argument " ") ep h2sp qp s2isp) (concat (unix-to-dos-filename (car argument)) " " (unix-to-dos-argument (mapconcat (function concat) (cdr argument) " ") ep h2sp qp s2isp)))) (define-process-argument-editing "/\\(tcp\\|movemail\\|fakemail\\|emacsserver\\|m2ps\\|hexl\\|wakeup\\|ctags\\|etags\\|ftp\\)\\.exe\\'" (lambda (x) (general-process-argument-editing-function x 'msvc t))) (define-process-argument-editing "/cmd\\.exe\\'" (lambda (x) (general-process-argument-editing-function x nil t t nil t t))) (define-process-argument-editing "/command\\.com\\'" (lambda (x) (general-process-argument-editing-function x nil t t nil t t))) (define-process-argument-editing "/tcsh\\.exe\\'" (lambda (x) (general-process-argument-editing-function x 'msvc t))) (define-process-argument-editing "/bash\\.exe\\'" (lambda (x) (general-process-argument-editing-function x 'cygnus t))) (define-process-argument-editing "/trr.*\\.exe\\'" (lambda (x) (general-process-argument-editing-function x 'msvc t)))