Download
(eval-and-compile
(and (let (case-fold-search)
(string-match "XEmacs\\|Lucid\\|Epoch" emacs-version))
(not (require 'overlay))
(error "`ascii' requires `overlay' package.")))
(or (fboundp 'characterp)
(defalias 'characterp 'char-valid-p))
(defgroup ascii nil
"ASCII code display"
:link '(emacs-library-link :tag "Source Lisp File" "ascii.el")
:prefix "ascii-"
:group 'data)
(defcustom ascii-code '(quoted html backslash elisp)
"*Specify list of character code to display.
If list is nil, display only ASCII code.
If list is non-nil, valid element values are:
quoted display quoted and ASCII code.
Quoted code is specified by `=HH' where H is a hexadecimal
character or by `=' followed by newline. This character coding
is used on MIME. For example:
=FF =1f =20 =
html display HTML and ASCII code.
HTML code is specified by `&CODE;', for example:
á Á À
backslash display backslash and ASCII code.
Backslash code is specified by `\\CODE' like in C, for example:
\\177 \\xFF \\x1f \\t \\Z \\\\
elisp display Emacs Lisp and ASCII code.
Emacs Lisp code is specified by `?CODE', see how Emacs Lisp
specify a character. For example:
?? ?a ?A ?\\^A ?\\C-A
?\\177 ?\\xFF ?\\x1f ?\\t ?\\Z ?\\\\
Any other value is ignored."
:type '(repeat :tag "ASCII Code List"
(choice :menu-tag "ASCII Code"
:tag "ASCII Code"
(const :tag "Quoted" quoted)
(const :tag "HTML" html)
(const :tag "Backslash" backslash)
(const :tag "Elisp" elisp)))
:group 'ascii)
(defcustom ascii-show-nonascii t
"*Non-nil means converts to unibyte and display the ascii code."
:type 'boolean
:group 'ascii)
(defcustom ascii-show-nonascii-message t
"*Non-nil means show a message when character is above 255."
:type 'boolean
:group 'ascii)
(defcustom ascii-window-size 6
"*Specify initial ASCII window size."
:type 'integer
:group 'ascii)
(defcustom ascii-display-code '((?\000 . ?\377))
"*Specify list of character range to be displayed.
Each element has the following form:
(LOWER . UPPER)
LOWER and UPPER are the minimum and maximum character code, respectively.
A character is displayed if:
LOWER <= character <= UPPER
and 0 <= LOWER <= 255
and 0 <= UPPER <= 255"
:type '(repeat :tag "Range List"
(cons :tag "Range"
(integer :tag "From")
(integer :tag "To")))
:group 'ascii)
(defcustom ascii-keep-window t
"*Non-nil means to keep ASCII window active."
:type 'boolean
:group 'ascii)
(defcustom ascii-table-separator "|"
"*Specify string used to separate ASCII table columns."
:type 'string
:group 'ascii)
(defcustom ascii-ascii-face 'ascii-ascii-face
"*Specify symbol face used to highlight ascii code."
:type 'face
:group 'ascii)
(defface ascii-ascii-face
'((((type tty) (class color))
(:background "cyan" :foreground "black"))
(((class color) (background light))
(:background "paleturquoise"))
(((class color) (background dark))
(:background "SkyBlue4"))
(t (:inverse-video t)))
"Face used to highlight ascii code.")
(defcustom ascii-non-ascii-face 'ascii-non-ascii-face
"*Specify symbol face used to highlight non-ascii code."
:type 'face
:group 'ascii)
(defface ascii-non-ascii-face
'((((type tty) (class color))
(:background "green"))
(((class color) (background light))
(:background "darkseagreen2"))
(((class color) (background dark))
(:background "darkolivegreen"))
(t (:inverse-video t)))
"Face used to highlight non-ascii code.")
(defun ascii-customize ()
"Customize ASCII options."
(interactive)
(customize-group 'ascii))
(defconst ascii-buffer-name " *ASCII*")
(defvar ascii-overlay nil)
(defvar ascii-reference-count 0)
(defvar ascii-display nil)
(make-variable-buffer-local 'ascii-display)
(defun ascii-display (&optional arg)
"Toggle ASCII code display.
If ARG is null, toggle ASCII code display.
If ARG is a number and is greater than zero, turn on display; otherwise, turn
off display.
If ARG is anything else, turn on display."
(interactive "P")
(if (if arg
(> (prefix-numeric-value arg) 0)
(not ascii-display))
(ascii-on)
(ascii-off)))
(defun ascii-on ()
"Turn on ASCII code display."
(interactive)
(unless ascii-display
(setq ascii-display t
ascii-reference-count (1+ ascii-reference-count))
(add-hook 'post-command-hook 'ascii-post-command nil t)
(add-hook 'kill-buffer-hook 'ascii-off nil t)
(run-hooks 'ascii-hook)
(ascii-post-command)))
(defun ascii-off ()
"Turn off ASCII code display."
(interactive)
(when ascii-display
(setq ascii-display nil
ascii-reference-count (1- ascii-reference-count))
(remove-hook 'post-command-hook 'ascii-post-command t)
(remove-hook 'kill-buffer-hook 'ascii-off t)
(if (> ascii-reference-count 0)
(or ascii-keep-window
(ascii-hide-table))
(and ascii-overlay
(delete-overlay ascii-overlay))
(let ((buffer (get-buffer ascii-buffer-name)))
(and buffer
(save-excursion
(delete-windows-on buffer)
(kill-buffer buffer)))))))
(defconst ascii-table
(concat
" OCT DEC HX |- OCT DEC HX |- OCT DEC HX \
|- OCT DEC HX\n"
(let ((str "")
(c -1)
(cod [
"C-@ NUL ^@ "
"C-a SOH ^A "
"C-b STX ^B "
"C-c ETX ^C "
"C-d EOT ^D "
"C-e ENQ ^E "
"C-f ACK ^F "
"C-g BEL ^G \\a"
"C-h BS ^H \\b"
"TAB HT ^I \\t"
"C-j LF ^J \\n"
"C-k VT ^K \\v"
"C-l FF ^L \\f"
"RET CR ^M \\r"
"C-n SO ^N "
"C-o SI ^O "
"C-p DLE ^P "
"C-q DC1 ^Q "
"C-r DC2 ^R "
"C-s DC3 ^S "
"C-t DC4 ^T "
"C-u NAK ^U "
"C-v SYN ^V "
"C-w ETB ^W "
"C-x CAN ^X "
"C-y EM ^Y "
"C-z SUB ^Z "
"ESC ESC ^[ \\e"
"C-\\ FS ^\\ "
"C-] GS ^] "
"C-^ RS ^^ "
"C-_ US ^_ "
])
c32 c64 c96)
(while (< c 31)
(setq c (1+ c)
c32 (+ c 32)
c64 (+ c 64)
c96 (+ c 96)
str (concat
str
(format "\\%03o %03d %02x %s|| \\%03o %03d %02x %s|| \
\\%03o %03d %02x %c || \\%03o %03d %02x %s\n"
c c c (aref cod c)
c32 c32 c32
(if (= c32 ?\x20) "SPC" (format " %c "c32))
c64 c64 c64 c64
c96 c96 c96
(if (= c96 ?\x7F) "DEL ^?" (format " %c" c96))))))
str)
"\n OCT DEC HX |- OCT DEC HX |- OCT DEC HX \
|- OCT DEC HX\n"
(let ((str "")
(c 127)
c32 c64 c96)
(while (< c 159)
(setq c (1+ c)
c32 (+ c 32)
c64 (+ c 64)
c96 (+ c 96)
str (concat
str
(format "\\%03o %03d %02x \\%03o || \
\\%03o %03d %02x %c || \\%03o %03d %02x %c || \\%03o %03d %02x %c\n"
c c c c
c32 c32 c32 c32
c64 c64 c64 c64
c96 c96 c96 c96))))
str))
"ASCII table.")
(defconst ascii-position
(vector
[2 0 23 0] [3 0 23 0] [4 0 23 0] [5 0 23 0]
[6 0 23 0] [7 0 23 0] [8 0 23 0] [9 0 26 0]
[10 0 26 0] [11 0 26 0] [12 0 26 0] [13 0 26 0]
[14 0 26 0] [15 0 26 0] [16 0 23 0] [17 0 23 0]
[18 0 23 0] [19 0 23 0] [20 0 23 0] [21 0 23 0]
[22 0 23 0] [23 0 23 0] [24 0 23 0] [25 0 23 0]
[26 0 23 0] [27 0 23 0] [28 0 23 0] [29 0 26 0]
[30 0 23 0] [31 0 23 0] [32 0 23 0] [33 0 23 0]
[2 28 43 1] [3 28 42 1] [4 28 42 1] [5 28 42 1]
[6 28 42 1] [7 28 42 1] [8 28 42 1] [9 28 42 1]
[10 28 42 1] [11 28 42 1] [12 28 42 1] [13 28 42 1]
[14 28 42 1] [15 28 42 1] [16 28 42 1] [17 28 42 1]
[18 28 42 1] [19 28 42 1] [20 28 42 1] [21 28 42 1]
[22 28 42 1] [23 28 42 1] [24 28 42 1] [25 28 42 1]
[26 28 42 1] [27 28 42 1] [28 28 42 1] [29 28 42 1]
[30 28 42 1] [31 28 42 1] [32 28 42 1] [33 28 42 1]
[2 45 59 2] [3 45 59 2] [4 45 59 2] [5 45 59 2]
[6 45 59 2] [7 45 59 2] [8 45 59 2] [9 45 59 2]
[10 45 59 2] [11 45 59 2] [12 45 59 2] [13 45 59 2]
[14 45 59 2] [15 45 59 2] [16 45 59 2] [17 45 59 2]
[18 45 59 2] [19 45 59 2] [20 45 59 2] [21 45 59 2]
[22 45 59 2] [23 45 59 2] [24 45 59 2] [25 45 59 2]
[26 45 59 2] [27 45 59 2] [28 45 59 2] [29 45 59 2]
[30 45 59 2] [31 45 59 2] [32 45 59 2] [33 45 59 2]
[2 62 76 3] [3 62 76 3] [4 62 76 3] [5 62 76 3]
[6 62 76 3] [7 62 76 3] [8 62 76 3] [9 62 76 3]
[10 62 76 3] [11 62 76 3] [12 62 76 3] [13 62 76 3]
[14 62 76 3] [15 62 76 3] [16 62 76 3] [17 62 76 3]
[18 62 76 3] [19 62 76 3] [20 62 76 3] [21 62 76 3]
[22 62 76 3] [23 62 76 3] [24 62 76 3] [25 62 76 3]
[26 62 76 3] [27 62 76 3] [28 62 76 3] [29 62 76 3]
[30 62 76 3] [31 62 76 3] [32 62 76 3] [33 62 80 3]
[36 0 17 0] [37 0 17 0] [38 0 17 0] [39 0 17 0]
[40 0 17 0] [41 0 17 0] [42 0 17 0] [43 0 17 0]
[44 0 17 0] [45 0 17 0] [46 0 17 0] [47 0 17 0]
[48 0 17 0] [49 0 17 0] [50 0 17 0] [51 0 17 0]
[52 0 17 0] [53 0 17 0] [54 0 14 0] [55 0 17 0]
[56 0 17 0] [57 0 17 0] [58 0 17 0] [59 0 17 0]
[60 0 17 0] [61 0 17 0] [62 0 17 0] [63 0 17 0]
[64 0 17 0] [65 0 17 0] [66 0 17 0] [67 0 17 0]
[36 28 42 1] [37 28 42 1] [38 28 42 1] [39 28 42 1]
[40 28 42 1] [41 28 42 1] [42 28 42 1] [43 28 42 1]
[44 28 42 1] [45 28 42 1] [46 28 42 1] [47 28 42 1]
[48 28 42 1] [49 28 42 1] [50 28 42 1] [51 28 42 1]
[52 28 42 1] [53 28 42 1] [54 28 42 1] [55 28 42 1]
[56 28 42 1] [57 28 42 1] [58 28 42 1] [59 28 42 1]
[60 28 42 1] [61 28 42 1] [62 28 42 1] [63 28 42 1]
[64 28 42 1] [65 28 42 1] [66 28 42 1] [67 28 42 1]
[36 45 59 2] [37 45 59 2] [38 45 59 2] [39 45 59 2]
[40 45 59 2] [41 45 59 2] [42 45 59 2] [43 45 59 2]
[44 45 59 2] [45 45 59 2] [46 45 59 2] [47 45 59 2]
[48 45 59 2] [49 45 59 2] [50 45 59 2] [51 45 59 2]
[52 45 59 2] [53 45 59 2] [54 45 59 2] [55 45 59 2]
[56 45 59 2] [57 45 59 2] [58 45 59 2] [59 45 59 2]
[60 45 59 2] [61 45 59 2] [62 45 59 2] [63 45 59 2]
[64 45 59 2] [65 45 59 2] [66 45 59 2] [67 45 59 2]
[36 62 76 3] [37 62 76 3] [38 62 76 3] [39 62 76 3]
[40 62 76 3] [41 62 76 3] [42 62 76 3] [43 62 76 3]
[44 62 76 3] [45 62 76 3] [46 62 76 3] [47 62 76 3]
[48 62 76 3] [49 62 76 3] [50 62 76 3] [51 62 76 3]
[52 62 76 3] [53 62 76 3] [54 62 76 3] [55 62 76 3]
[56 62 76 3] [57 62 76 3] [58 62 76 3] [59 62 76 3]
[60 62 76 3] [61 62 76 3] [62 62 76 3] [63 62 76 3]
[64 62 76 3] [65 62 76 3] [66 62 76 3] [67 62 76 3]
)
"Vector with position of each ASCII code in ASCII buffer.
Each element has the following form:
[LINE COL-BEG COL-END COL-INDEX]
LINE is the line number in ASCII buffer.
COL-BEG is the ASCII beginning column.
COL-END is the ASCII end column.
COL-INDEX is the ASCII table column index.")
(defun ascii-post-command ()
(let* ((char (following-char))
(code (if ascii-show-nonascii
(string-to-char (string-make-unibyte (char-to-string char)))
char))
mess)
(cond ((and (boundp 'ascii-display)
ascii-display
(< code 256)
(ascii-display-code code))
(setq mess (ascii-show-table code (< char 256))))
((and (not ascii-keep-window)
(not (string= (buffer-name) ascii-buffer-name)))
(ascii-hide-table))
(ascii-overlay
(delete-overlay ascii-overlay))
)
(cond ((and (boundp 'ascii-display)
ascii-display
ascii-show-nonascii-message
(cond
((> char 255)
(message "Character code above 255 (\\0%o, %d, 0x%x)"
char char char))
((< char 0)
(message "Character code below 0 (\\0%o, %d, 0x%x)"
char char char))
)))
(mess
(message "%s code" mess))
)))
(defun ascii-hide-table ()
(let ((buffer (get-buffer ascii-buffer-name)))
(and buffer
(delete-windows-on buffer))))
(defconst ascii-html-alist
'(("copy" . 169) ("reg" . 174) ("trade" . 174) ("Aacute" . 192)
("Agrave" . 193) ("Acirc" . 194) ("Atilde" . 195) ("Auml" . 196)
("Aring" . 197) ("AElig" . 198) ("Ccedil" . 199) ("Eacute" . 200)
("Egrave" . 201) ("Ecirc" . 202) ("Euml" . 203) ("Iacute" . 204)
("Igrave" . 205) ("Icirc" . 206) ("Iuml" . 207) ("ETH" . 208)
("Ntilde" . 209) ("Oacute" . 210) ("Ograve" . 211) ("Ocirc" . 212)
("Otilde" . 213) ("Ouml" . 214) ("Oslash" . 216) ("Uacute" . 217)
("Ugrave" . 218) ("Ucirc" . 219) ("Uuml" . 220) ("Yacute" . 221)
("THORN" . 222) ("szlig" . 223) ("aacute" . 224) ("agrave" . 225)
("acirc" . 226) ("atilde" . 227) ("auml" . 228) ("aring" . 229)
("aelig" . 230) ("ccedil" . 231) ("eacute" . 232) ("egrave" . 233)
("ecirc" . 234) ("euml" . 235) ("iacute" . 236) ("igrave" . 237)
("icirc" . 238) ("iuml" . 239) ("eth" . 240) ("ntilde" . 241)
("oacute" . 242) ("ograve" . 243) ("ocirc" . 244) ("otilde" . 245)
("ouml" . 246) ("oslash" . 248) ("uacute" . 249) ("ugrave" . 250)
("ucirc" . 251) ("uuml" . 252) ("yacute" . 253) ("thorn" . 254)
("yuml" . 255)))
(defconst ascii-html-regexp
(concat "&\\([aeiouy]acute\\|[aeiou]circ\\|[aeiou]grave\\|[aeiouy]uml\\|"
"aelig\\|aring\\|[ano]tilde\\|ccedil\\|copy\\|eth\\|oslash\\|"
"reg\\|szlig\\|thorn\\|trade\\|"
"#[0-9]+\\);"))
(defconst ascii-backslash-regexp
"\\\\\\([0-7]+\\|x[0-9A-Fa-f]+\\|\n\\|.\\)")
(defconst ascii-elisp-regexp
(concat "?\\(\\\\\\(\\^\\|C-\\)[@A-Za-_]\\|"
ascii-backslash-regexp
"\\|.\\)"))
(defsubst ascii-string-matched (level)
(buffer-substring-no-properties
(match-beginning level) (match-end level)))
(defsubst ascii-string-to-char (str)
(string-to-char (car (read-from-string (concat "\"" str "\"")))))
(defsubst ascii-char-matched (level)
(ascii-string-to-char (ascii-string-matched level)))
(defsubst ascii-code (code var-sym)
(save-match-data
(cond
((and (memq 'quoted ascii-code)
(cond ((looking-at "=\n")
(set var-sym "Quoted")
?\n)
((looking-at "=\\([0-9A-Fa-f][0-9A-Fa-f]\\)")
(set var-sym "Quoted")
(string-to-number (ascii-string-matched 1) 16)))))
((and (memq 'html ascii-code)
(let ((case-fold-search t))
(looking-at ascii-html-regexp)))
(set var-sym "HTML")
(let ((str (ascii-string-matched 1)))
(cond ((eq (aref str 0) ?#)
(aset str 0 ?\ )
(let ((int (string-to-number str)))
(if (and (<= 0 int) (<= int 255))
int
(set var-sym nil)
code)))
((cdr (assoc str ascii-html-alist)))
(t
(set var-sym nil)
code))))
((and (memq 'backslash ascii-code)
(looking-at ascii-backslash-regexp))
(set var-sym "Backslash")
(let* ((str (ascii-string-matched 0))
(last (aref str (1- (length str)))))
(if (memq last '(?^ ?C ?\n))
last
(ascii-string-to-char str))))
((and (memq 'elisp ascii-code)
(looking-at ascii-elisp-regexp))
(set var-sym "Elisp")
(ascii-char-matched 1))
(t
(set var-sym nil)
code))))
(defvar ascii-sep-len 0)
(defvar ascii-charset-base 0)
(defun ascii-show-table (code ascii-p)
(let ((buffer (ascii-get-buffer code))
mess)
(and
(cond ((get-buffer-window buffer)
t)
((>= (window-height) (+ ascii-window-size ascii-window-size))
(set-window-buffer
(split-window nil (- (window-height) ascii-window-size))
buffer)
t)
(t
(ascii-off)
(message "Window height too small for ASCII window.")
(ding)
nil)
)
(let ((code (ascii-code code 'mess))
(window (get-buffer-window ascii-buffer-name))
(old-window (selected-window)))
(save-excursion
(and window
(select-window window))
(set-buffer ascii-buffer-name)
(let ((pos (aref ascii-position code))
beg end)
(goto-char (point-min))
(forward-line (1- (aref pos 0)))
(if (and (> code 127) (/= ascii-charset-base 127))
(save-match-data
(re-search-forward
(format "\\\\%o %d %x \\(\\\\..\\)?."
code code code)
nil t)
(setq beg (match-beginning 0)
end (match-end 0)))
(let ((here (point))
(bias (* (aref pos 3) ascii-sep-len)))
(setq end (+ (aref pos 2) here bias)
beg (+ (aref pos 1) here bias))))
(if ascii-overlay
(move-overlay ascii-overlay beg end)
(setq ascii-overlay (make-overlay beg end)))
(overlay-put ascii-overlay 'face (if ascii-p
ascii-ascii-face
ascii-non-ascii-face))))
(select-window old-window)))
mess))
(defvar ascii-mark-display-code nil)
(defvar ascii-vector-code (make-vector 256 t))
(defun ascii-display-code (code)
(or (eq ascii-mark-display-code ascii-display-code)
(let ((lis ascii-display-code)
(char 0)
end)
(setq ascii-mark-display-code ascii-display-code)
(while (<= char 255)
(aset ascii-vector-code char nil)
(setq char (1+ char)))
(while lis
(setq char (car lis)
lis (cdr lis)
end (cdr char)
char (car char))
(and (<= 0 end) (<= end 255)
(<= 0 char) (<= char 255)
(while (<= char end)
(aset ascii-vector-code char t)
(setq char (1+ char)))))))
(aref ascii-vector-code code))
(defun ascii-get-buffer (code)
(let ((base (- (following-char) (- code 127))))
(or (if (= ascii-charset-base base)
(get-buffer ascii-buffer-name)
(setq ascii-charset-base base)
(let ((buffer (get-buffer ascii-buffer-name)))
(when buffer
(delete-windows-on buffer)
(kill-buffer buffer)))
nil)
(save-excursion
(save-match-data
(prog1
(set-buffer (get-buffer-create ascii-buffer-name))
(set-buffer-multibyte t)
(setq buffer-read-only nil
ascii-sep-len (1- (length ascii-table-separator)))
(erase-buffer)
(insert ascii-table)
(goto-char (point-min))
(or (= base 127)
(save-excursion
(let ((char 127))
(while (< (setq char (1+ char)) 160)
(when (search-forward
(format "\\%o %d %x " char char char)
nil t)
(delete-char 4)
(setq base (1+ base))
(if (not (characterp base))
(insert "? ")
(insert base)
(let ((cols (- (current-column)
(progn
(forward-char -1)
(current-column)))))
(when (< cols 4)
(forward-char 1)
(insert (cond ((= cols 3) " ")
((= cols 2) " ")
(t " ")
)))))))
(setq char (1- char))
(while (< (setq char (1+ char)) 256)
(goto-char (point-min))
(when (search-forward
(format "\\%o %d %x " char char char)
nil t)
(delete-char 1)
(setq base (1+ base))
(if (not (characterp base))
(insert "?")
(insert base)
(let ((cols (- (current-column)
(progn
(forward-char -1)
(current-column)))))
(when (> cols 1)
(forward-char 1)
(or (equal (following-char) ?\n)
(delete-char 1))))))))))
(save-excursion
(while (search-forward "||" nil t)
(replace-match ascii-table-separator t t)))
(let ((spaces (make-string (1+ ascii-sep-len) ?\ )))
(save-excursion
(while (search-forward "|-" nil t)
(replace-match spaces t t))))
(set-buffer-modified-p nil)
(setq buffer-read-only t)))))))
(provide 'ascii)