[elpa] externals/nhexl-mode d3712d3 01/23: Add nhexl-mode.

[Stefan Monnier]

branch: externals/nhexl-mode
commit d3712d318994b70abd33e7b169172c57fac0e680
Author: Stefan Monnier <monnier@iro.umontreal.ca>
Commit: Stefan Monnier <monnier@iro.umontreal.ca>

    Add nhexl-mode.
---
 nhexl-mode.el | 259 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 259 insertions(+)

diff --git a/nhexl-mode.el b/nhexl-mode.el
new file mode 100644
index 0000000..447b185
--- /dev/null
+++ b/nhexl-mode.el
@@ -0,0 +1,259 @@
+;;; nhexl-mode.el --- Minor mode to edit files via hex-dump format  -*- 
lexical-binding: t -*-
+
+;; Copyright (C) 2010, 2012  Free Software Foundation, Inc.
+
+;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
+;; Keywords: data
+;; Version: 0.1
+
+;; 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 3 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, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This implements a similar functionality to `hexl-mode', but
+;; using a different implementation technique, which makes it usable
+;; as a "plain" minor mode.  I.e. it works on any buffer, does not
+;; mess with the undo boundary or even with the major mode.
+;;
+;; In theory it could also work just fine even on very large buffers,
+;; although in practice it seems to make the display engine suffer.
+
+;; Todo:
+;; - Clicks on the hex side should put point at the right place.
+
+;;; Code:
+
+(eval-when-compile (require 'cl))
+(require 'hexl)                         ;For faces.
+
+(defgroup nhexl nil
+  "Edit a file in a hex dump format."
+  :group 'data)
+
+(defvar nhexl-line-width 16
+  "Number of bytes per line.")
+
+(defvar nhexl--display-table
+  (let ((dt (make-display-table)))
+    ;; (aset dt ?\n [?␊])
+    (aset dt ?\t [?␉])
+    dt))
+
+(defvar nhexl--saved-vars nil)
+(make-variable-buffer-local 'nhexl--saved-vars)
+(defvar nhexl--point nil)
+(make-variable-buffer-local 'nhexl--point)
+
+;;;###autoload
+(define-minor-mode nhexl-mode
+  "Minor mode to edit files via hex-dump format"
+  :lighter " NHexl"
+  (if (not nhexl-mode)
+      (progn
+        (dolist (varl nhexl--saved-vars)
+          (set (make-local-variable (car varl)) (cdr varl)))
+        (kill-local-variable 'nhexl--saved-vars)
+        (jit-lock-unregister #'nhexl--jit)
+        (remove-hook 'after-change-functions #'nhexl--change-function 'local)
+        (remove-hook 'post-command-hook #'nhexl--post-command 'local)
+        ;; FIXME: This will conflict with any other use of `display'.
+        (with-silent-modifications
+          (put-text-property (point-min) (point-max) 'display nil))
+        (remove-overlays (point-min) (point-max) 'nhexl t))
+    (unless (local-variable-p 'nhexl--saved-vars)
+      (dolist (var '(buffer-display-table buffer-invisibility-spec
+                     overwrite-mode header-line-format))
+        (push (cons var (symbol-value var)) nhexl--saved-vars)))
+    (setq nhexl--point (point))
+    (setq header-line-format '(:eval (nhexl--header-line)))
+    (binary-overwrite-mode 1)
+    (setq buffer-invisibility-spec ())
+    (set (make-local-variable 'buffer-display-table) nhexl--display-table)
+    (jit-lock-register #'nhexl--jit)
+    (add-hook 'change-major-mode-hook (lambda () (nhexl-mode -1)) nil 'local)
+    (add-hook 'post-command-hook #'nhexl--post-command nil 'local)
+    (add-hook 'after-change-functions #'nhexl--change-function nil 'local)))
+
+(defun nhexl--change-function (beg end len)
+  ;; Jit-lock already takes care of refreshing the changed area, so we
+  ;; only have to make sure the tail's addresses are refreshed when
+  ;; text is inserted/removed.
+  (when (/= len (- end beg))
+    (put-text-property beg (point-max) 'fontified nil)))
+
+(defvar nhexl--overlay-counter 100)
+(make-variable-buffer-local 'nhexl--overlay-counter)
+
+(defun nhexl--debug-count-ols ()
+  (let ((i 0))
+    (dolist (ol (overlays-in (point-min) (point-max)))
+      (when (overlay-get ol 'nhexl) (incf i)))
+    i))
+
+(defun nhexl--flush-overlays (buffer)
+  (with-current-buffer buffer
+    (kill-local-variable 'nhexl--overlay-counter)
+    ;; We've created many overlays in this buffer, which can slow
+    ;; down operations significantly.  Let's flush them.
+    ;; An easy way to flush them is
+    ;;   (remove-overlays min max 'nhexl t)
+    ;;   (put-text-property min max 'fontified nil)
+    ;; but if the visible part of the buffer requires more than
+    ;; nhexl--overlay-counter overlays, then we'll inf-loop.
+    ;; So let's be more careful about removing overlays.
+    (let ((windows (get-buffer-window-list nil nil t))
+          (start (point-min))
+          (zero (save-restriction (widen) (point-min)))
+          (debug-count (nhexl--debug-count-ols)))
+      (with-silent-modifications
+        (while (< start (point-max))
+          (let ((end (point-max)))
+            (dolist (window windows)
+              (cond
+               ((< start (1- (window-start window)))
+                (setq end (min (1- (window-start window)) end)))
+               ((< start (1+ (window-end window)))
+                (setq start (1+ (window-end window))))))
+            ;; Round to multiple of nhexl-line-width.
+            (setq start (+ zero (* (ceiling (- start zero) nhexl-line-width)
+                                   nhexl-line-width)))
+            (setq end (+ zero (* (truncate (- end zero) nhexl-line-width)
+                                 nhexl-line-width)))
+            (when (< start end)
+              (remove-overlays start end 'nhexl t)
+              (put-text-property start end 'fontified nil)
+              (setq start (+ end nhexl-line-width))))))
+      (let ((debug-new-count (nhexl--debug-count-ols)))
+        (message "Flushed %d overlays, %d remaining"
+                 (- debug-count debug-new-count) debug-new-count)))))
+
+(defun nhexl--make-line (from next zero)
+  (let* ((nextpos (min next (point-max)))
+         (bufstr (buffer-substring from nextpos))
+         (i -1)
+         (s (concat
+             (unless (eq zero from) "\n")
+             (format (propertize "%08x:" 'face
+                                 (if (or (< nhexl--point from)
+                                         (>= nhexl--point next))
+                                     'hexl-address-region
+                                   '(highlight hexl-address-region)))
+                     (- from zero))
+             (propertize " " 'display '(space :align-to 12))
+             (mapconcat (lambda (c)
+                          (setq i (1+ i))
+                          ;; FIXME: In multibyte buffers,
+                          ;; do something clever about
+                          ;; non-ascii chars.
+                          (let ((s (format "%02x" c)))
+                            (when (eq nhexl--point (+ from i))
+                              (put-text-property 0 (length s)
+                                                 'face 'highlight
+                                                 s))
+                            (if (zerop (mod i 2))
+                                s (concat s " "))))
+                        bufstr
+                        "")
+             (if (> next nextpos)
+                 (make-string (+ (/ (1+ (- next nextpos)) 2)
+                                 (* (- next nextpos) 2))
+                              ?\s))
+             (propertize "  " 'display
+                         `(space :align-to
+                                 ,(+ (/ (* nhexl-line-width 5) 2)
+                                     12 3))))))
+    (font-lock-append-text-property 0 (length s) 'face 'default s)
+    s))
+
+(defun nhexl--jit (from to)
+  (let ((zero (save-restriction (widen) (point-min))))
+    (setq from (+ zero (* (truncate (- from zero) nhexl-line-width)
+                          nhexl-line-width)))
+    (setq to (+ zero (* (ceiling (- to zero) nhexl-line-width)
+                        nhexl-line-width)))
+    (remove-overlays from (min to (point-max)) 'nhexl t)
+    (save-excursion
+      (goto-char from)
+      (while (search-forward "\n" to t)
+        (put-text-property (match-beginning 0) (match-end 0)
+                           'display (copy-sequence "␊"))))
+    (while (< from to)
+
+      (decf nhexl--overlay-counter)
+      (when (and (= nhexl--overlay-counter 0)
+                 ;; If the user enabled jit-lock-stealth fontification, then
+                 ;; removing overlays is just a waste since
+                 ;; jit-lock-stealth will restore them anyway.
+                 (not jit-lock-stealth-time))
+        ;; (run-with-idle-timer 0 nil 'nhexl--flush-overlays (current-buffer))
+        )
+      
+      (let* ((next (+ from nhexl-line-width))
+             (ol (make-overlay from next))
+             (s (nhexl--make-line from next zero)))
+        (overlay-put ol 'nhexl t)
+        (overlay-put ol 'face 'hexl-ascii-region)
+        (overlay-put ol 'before-string s)
+        (setq from next)))))
+
+(defun nhexl--header-line ()
+  ;; FIXME: merge with nhexl--make-line.
+  (let* ((zero (save-restriction (widen) (point-min)))
+         (text
+          (let ((tmp ()))
+            (dotimes (i nhexl-line-width)
+              (push (if (< i 10) (+ i ?0) (+ i -10 ?a)) tmp))
+            (apply 'string (nreverse tmp))))
+         (pos (mod (- nhexl--point zero) nhexl-line-width))
+         (i -1))
+    (put-text-property pos (1+ pos) 'face 'highlight text)
+    (concat
+     (propertize " " 'display '(space :align-to 0))
+     "Address:"
+     (propertize " " 'display '(space :align-to 12))
+     (mapconcat (lambda (c)
+                  (setq i (1+ i))
+                  (let ((s (string c c)))
+                    (when (eq i pos)
+                      (put-text-property 0 (length s)
+                                         'face 'highlight
+                                         s))
+                    (if (zerop (mod i 2)) s
+                      (concat
+                       s (propertize " " 'display
+                                     `(space :align-to
+                                             ,(+ (/ (* i 5) 2) 12 3)))))))
+                text
+                "")
+     (propertize "  " 'display
+                 `(space :align-to
+                         ,(+ (/ (* nhexl-line-width 5) 2)
+                             12 3)))
+     text)))
+  
+
+(defun nhexl--post-command ()
+  (when (/= (point) nhexl--point)
+    (let ((zero (save-restriction (widen) (point-min)))
+          (oldpoint nhexl--point))
+      (setq nhexl--point (point))
+      (with-silent-modifications
+        (nhexl--jit (point) (1+ (point)))
+        (if (/= (truncate (- (point) zero) nhexl-line-width)
+                (truncate (- oldpoint zero) nhexl-line-width))
+            (nhexl--jit oldpoint (1+ oldpoint)))))))
+  
+
+(provide 'nhexl-mode)
+;;; nhexl-mode.el ends here