;; -*- mode: emacs-lisp; coding: hebrew-iso-8bit-unix; -*- ;; swhelp.el --- use swhelp from within emacs (with fonts for X) ;; Copyright (C) 1992-2000 Ehud karni ;; This file is NOT part of GNU Emacs, distribution conditions below. ;; ;; EHUD KARNI ינרק דוהא ;; Ben Gurion st' 14 ןוירוג ןב 'חר ;; Kfar - Sava 44 257 אבס - רפכ ;; =================================== ;; 972-(0)9-7659599 ;; =================================== ;; RCS: $Id: swhelp.el,v 1.102 2000/03/05 13:37:28 ehud Exp ehud $ ;; ;; LOG: $Log: swhelp.el,v $ ;; LOG: Revision 1.102 2000/03/05 13:37:28 ehud ;; LOG: Comment headers changes (NOT GNU), change word regexp to use `Alef-is'. ;; LOG: ;; Revision 1.101 1998/03/15 17:46:34 ehud ;; Last revision for 19.34 ;; ;; Revision 1.100 1996/02/19 10:58:25 ehud ;; Emacs 19.30 version (Initial saved version) ;; This program 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 of the License, or ;; (at your option) any later version. ;; ;; This program 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 this program; if not, write to the Free Software ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA (defvar swhelp-history nil "history list for swhelp") (defun buffer-current-word () "return the buffer word the point is on as a string" (let (beg end (igxp (concat "[^a-zA-Z" (vector Alef-is ?- Tav-is) "0-9\.]")) (pos (point))) (if (looking-at "[^ \n\t]") ;;on non blank (progn (forward-char 1) ;;move 1 char forward for search (backward-to-non-blank) ;search 1st non-blank backward (while (looking-at igxp) ; ignor () and \" (forward-char 1)) (setq beg (point)) (if (re-search-forward "[^ \t\n][ \t\n]" (point-max) t) (backward-char 2) (goto-char (1- (point-max)))) (while (looking-at igxp) ; ignor () and \" (backward-char 1)) (setq end (1+ (point))) (setq beg (buffer-substring beg end)))) (goto-char pos) beg)) ;;return string or nil (defun swhelp-entry (topic &optional index) "Display Simon & Wiezel help for TOPIC. TOPIC is either the title of the entry, or has the form: -i SUB-TOPIC where TOPIC is a name of SW added commands, use -i for index of all SW helps." (interactive (list (read-string "Simon & Wiezel help name (with optional -i): " (or (buffer-current-word) "-i ") 'swhelp-history))) (if (null index) (setq index "") (setq index "-i")) (if (string-match "^[ ]*-[iI][ ]+" topic) (progn (setq index "-i") (setq topic (substring topic (match-end 0))))) (with-output-to-temp-buffer "*SW help*" (save-excursion (set-buffer standard-output) (message "Executing swhelp %s %s ..." index topic) (call-process "env" nil t nil "LINES=32000" "TERM=dumb" "swhelp" (if faces-on "-row" " ") index topic) (set-buffer-modified-p nil) (setq buffer-read-only t) (message "") (if (< (buffer-size) 80) (error "No help found for %s" topic) (if faces-on (swhelp-fontify-page topic)))))) (defun swhelp-fontify-page (&optional topic) "Convert swhelp page encoded with embedded (^x) commands to fontfied page. For Control Chars supported see help of `swhelp-CC-replace-one' Embeded Commands supported: ^^ - one ^ ^N - normal char - terminate fontifying ^I - invisible - change chars to space ^A - alternate - set face to swhelp-alt-font ^H - highlight - set face to swhelp-bold-font ^R - reversed - set face to swhelp-rvrs-font ^U - underline - set face to swhelp-under-font ^S - standout - set face to swhelp-stand-font ^B - blink - ignored ^G - bell - ignored (omitted)" (interactive) (let* (overwrite-mode ;; set to insert because of bug in backward-delete-char buffer-read-only ;; ensure no barfing while editing (attr-pos '(0 1))) ;; last attribute & position (swhelp-make-fonts) ;; call make swhelp fonts (if topic (message "Please wait: making up the %s swhelp page..." topic)) (goto-char (point-min)) (insert "\n") ;; add extar new line in the beginning ;; cc replacement loop (while (not (eobp)) ;; do until eof (swhelp-CC-replace-one) ;; char after \n (search-forward "\n" nil 1)) ;; search new line (no error) (goto-char (point-min)) (delete-char 1) ;; delete the extara char ;; fontify (swhelp-fontify-region (point) (point-max)) ;;fontify the whole buffer (goto-char (point-min)) ;; start showing from the top (if topic (message "%s swhelp page is ready" topic)))) (defun swhelp-fontify-region (beg end) "Convert swhelp region from BEG to END, encoded with embedded (^x) commands to fontfied region. See help of `swhelp-fontify-page' for supported commands." (interactive) (let* (overwrite-mode ;; set to insert because of bug in backward-delete-char (attr-pos (list 0 beg)) ;; last attribute & position max-pos) (swhelp-make-fonts) ;; call make swhelp fonts (goto-char end) (insert "^N") ;; ensure return to normal (setq max-pos (point-marker)) ;; marker of end of region (goto-char beg) ;; goto start of region ;; fontify (while (search-forward "^" (marker-position max-pos) t) ;; search "^" (no error) limited by region end (setq attr-pos (swhelp-embeded-one attr-pos))) ;; treat char after ^ )) ;; stop where we stand (defun swhelp-fontify-mark () "Fontify marked area according to swhelp embedded (^x) commands. See help of `swhelp-fontify-page' for supported commands." (interactive) (if (mark-exist-chk t) (save-excursion (set-buffer (marker-buffer (car mark-1st))) (if (/= type-mark-set 2) (swhelp-fontify-region (marker-position (car mark-1st)) (marker-position (car mark-2nd))) (progn (mark-block-to-tmp) (swhelp-fontify-region (point-min) (point-max)) (mark-block-restore))))) (setq both-marked t)) (defun swhelp-embeded-one (attr-pos) "internal defun for fontifying swhelp" (let* ((embed '( (?^ ?^ -1) ;; 1 char ^ no face change (?n 0 0) ;; set font to 0 (absolute) normal (?i 63 0) ;; set font to 63 (absolute) invisible (?h 1 1) ;; or 1 for highlight (?a 2 1) ;; or 2 for alternate (?r 4 1) ;; or 4 for reversed (?s 8 1) ;; or 8 for standout (?u 16 1))) ;; or 16 for underline (oatr (nth 0 attr-pos)) (opos (nth 1 attr-pos)) (pos (point)) (char (downcase (char-after pos))) ;; char after ^ (down cased) val act ;; value, action ) (delete-region (1- pos) (1+ pos)) ;; delete the ^ & the char after (while embed (setq act (car embed)) (setq embed (cdr embed)) (if (= char (car act)) ;; is it this char ? (progn (setq embed nil) ;; dont loop any more (setq val (nth 1 act)) ;; value to or/set/put (setq act (nth 2 act)) ;; action (-1=insert, 0=set, 1=or) (cond ((< act 0) ;; replace (insert val) (goto-char pos) ;; position after the inserted char (setq val oatr)) ;; insure no change ;; set/or - may be change text property ((= act 1) ;; or, compute atrb value (setq val (logior val oatr)))) (if (= opos (point)) ;; if same position (setq oatr val)) ;; change atribute only (if (/= oatr val) ;; do only if atributed changed (progn (put-text-property opos (point) 'face (intern (format "swhelp-font-%02d" oatr))) (setq oatr val) (setq opos (point))))))) (list oatr opos))) ;; return new list (defun swhelp-CC-replace-one () "replace 1 CC (must be standing on it) Control Chars supported: 1 - Top of Form - changed to separation line, - single space - omit the CC 0 - double space - add empty line - - triple space - add 2 empty line ! - continuation omit the \\n! pair all other CC's are ignored - the entire line is deleted" (let* ((topl (concat "^I" (make-string 72 ? ) "^n\n")) ; top separation line (pos (point)) ;; save current position (char (char-after pos)) ;; CC (bksp-switch nil) ;; backspace switch ) (cond ((or (= char ?1) ;; topl is the replacing string for 1 (= char ?V)) ;; or V (if (< pos 3) ;; is it 1st char of buffer ? (setq topl ""))) ;; yes, treat as space (single space) ((= char ? ) (setq topl "")) ;; \n(space) is changed to \n(empty) ((= char ?0) (setq topl "\n")) ;; \n0 is changed to \n\n ((= char ?-) (setq topl "\n\n")) ;; \n- is changed to \n\n\n ((= char ?\n) (setq bksp-switch t) ;; backspace over the \n (setq topl "\n")) ;; \n\n is saved as \n\n ((= char ?!) (delete-char -1) ;; delete pervious \n (setq topl "")) ;; \n! is changed to (empty) (t ;; unknown CC (setq bksp-switch t) ;; backspace over the \n (end-of-line) ;; position on the end of line (delete-region pos (point)) ;; delete, including the next \n (setq topl ""))) ;; replace by empty string (delete-char 1) ;; delete old CC (insert topl) ;; replace it (and bksp-switch ;; back space requested ? (> pos 1) ;; not 1st char ? (backward-char 1)) ;; back space by backward )) (defun swhelp-unfontify-page () "Convert fontified swhelp page into a page encoded with embedded (^x) commands and control characters. See help for `swhelp-unfontify-page'" (interactive) (let* (overwrite-mode ;; set to insert because of bug in backward-delete-char buffer-read-only ;; ensure no barfing while editing (swhelp-font-z (face-id 'swhelp-font-00)) (embed-cons '("^N" "^U" "^H" "^A" "^R" "^S" "^I")) ;; 0 1 2 4 8 16 32 embeded strings for bits ;; norm high altr rvrs stnd undr invis (lfc 0) ;; last face (swhelp) (spos 1) ;; start last face position nfc ;; new face (swhelp) nstr ;; string for the new string embed ;; temp embed for loop ) (swhelp-make-fonts) ;; call make swhelp fonts ;; replace all ^ into ^^ ;; encode ^ to embded ^^ (goto-char (point-min)) (while (search-forward "^" nil t) (insert "^")) ;; add ^ after found ^ ;; unfontify (goto-char (point-min)) (while (not (eobp)) (or (and (setq nfc (get-text-property (point) 'face)) (facep nfc) (setq nfc (- (face-id nfc) swhelp-font-z)) (>= nfc -1) ;; 1st font = -1 (invis) (< nfc 32)) ;; last swhelp font = 32 (setq nfc 0)) ;; set to 0 if not (if (/= nfc lfc) ;; current font != last (progn (setq nstr nil) ;; start with empty string (if (= nfc -1) ;; change -1 (setq lfc 31)) ;; to 32 (invis) (setq embed embed-cons) ;; temp area (and (/= nfc (logior nfc lfc)) ;; check if lfc not included in nfc (setq nstr (car embed)) ;; set to normal before changing (setq lfc 0)) ;; (pseudo) old is normal (setq lfc (logand (logxor nfc lfc) 63)) ;; bits to set (6 bits) (while (> lfc 0) ;; any bit left ? (setq embed (cdr embed)) ;; omit 1st entry from embed (and (= (logand lfc 1) 1) ;; this bit set ? (setq nstr (concat nstr (car embed)))) ;; yes add string (setq lfc (ash lfc -1))) ;; shift right 1 place (setq lfc nfc) ;; save new face (insert nstr))) ;; add fontify string (forward-char 1)) ;; next char (if (> lfc 0) ;; not normal ? (insert "^N")) ;; add ^n at the end (remove-text-properties (point-min) (point-max) '(face)) ;; remove face ;; cc replacement loop (goto-char (point-min)) ;; start adding CC from the top (insert "\n") ;; add new line at the beginning (goto-char (point-min)) (while (search-forward "\n" nil 1) ;; search new line (no error) (cond ((looking-at "\n\n") (delete-char 2) (insert "-")) ((looking-at "\n") (delete-char 1) (insert "0")) (t (insert " ")))) (goto-char (point-min)) (delete-char 1) (while (re-search-forward (concat "[-0 ]^I" (make-string 72 ? ) "^N\n\\([-0 ]\\)") nil t) (setq nfc (char-after (nth 2 (match-data)))) (replace-match "1") (cond ((= nfc ?-) (insert "\n0")) ((= nfc ?0) (insert "\n ")))) (goto-char (point-min)) ;reposition to the beginning )) (defun swhelp-make-fonts () "Make fonts foe swhelp use. The fonts names are swhelp-font-NN where NN is 2 digits number 00-31 or 63, reflecting the font attributes which are ORed. Highlight=1, Alternate=2, Reversed=4, Standout=8, Underline=16, invisible=63." (or (facep 'swhelp-font-63) ;; only if non existent (let ((sw-fcs (list '("LightBlue" "LightBlue") ; 63 - Invisible (any) (list "Yellow" face-default-background) ; 00 - normal (list "White" face-default-background) ; 01 - High (list "Red" face-default-background) ; 02 - Alternate (list "Cyan" face-default-background) ; 03 - A + H '("Blue" "SteelBlue") ; 04 - Reversed '("White" "SteelBlue") ; 05 - R + H '("Red" "SteelBlue") ; 06 - R + A '("Brown" "SteelBlue") ; 07 - R + A + H ;; '("Magenta" "SteelBlue") ; 07 - R + A + H '("yellow" "DarkGreen") ; 08 - Standout '("White" "DarkGreen") ; 09 - S + H '("Red" "DarkGreen") ; 10 - S + A '("Pink" "DarkGreen") ; 11 - S + A + H '("Yellow" "Brown") ; 12 - S + R '("Cyan" "Brown") ; 13 - S + R + H '("Violet" "Brown") ; 14 - S + R + A '("Green" "Brown") ; 15 - S + R + A + H )) (cnt 63) fg bg fnt fntu) (message "Please wait: creating swhelp fonts ...") (while sw-fcs (setq bg (car sw-fcs)) (setq sw-fcs (cdr sw-fcs)) (setq fg (car bg)) (setq bg (nth 1 bg)) (setq fnt (intern (format "swhelp-font-%02d" cnt))) (setq fntu (intern (format "swhelp-font-%02d" (logior 16 cnt)))) (setq cnt (logand (1+ cnt) 31)) ;; for starting with 63 abnormality (make-face fnt) (set-face-background fnt bg) (set-face-foreground fnt fg) (copy-face fnt fntu) ;; (set-face-underline-p fntu 'underline))))) (set-face-underline-p fntu t))))) ;;============================== end of swhelp ================================