code.delx.au - gnu-emacs-elpa/blob - packages/nhexl-mode/nhexl-mode.el

   1 ;;; nhexl-mode.el --- Minor mode to edit files via hex-dump format  -*- lexical-binding: t -*-
   2
   3 ;; Copyright (C) 2010, 2012  Free Software Foundation, Inc.
   4
   5 ;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
   6 ;; Keywords: data
   7 ;; Version: 0.1
   8
   9 ;; This program is free software; you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation, either version 3 of the License, or
  12 ;; (at your option) any later version.
  13
  14 ;; This program is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  21
  22 ;;; Commentary:
  23
  24 ;; This package implements NHexl mode, a minor mode for editing files
  25 ;; in hex dump format.  The mode command is called `nhexl-mode'.
  26 ;;
  27 ;; This minor mode implements similar functionality to `hexl-mode',
  28 ;; but using a different implementation technique, which makes it
  29 ;; usable as a "plain" minor mode.  It works on any buffer, and does
  30 ;; not mess with the undo boundary or with the major mode.
  31 ;;
  32 ;; In theory it could also work just fine even on very large buffers,
  33 ;; although in practice it seems to make the display engine suffer.
  34
  35 ;;; Todo:
  36 ;; - Clicks on the hex side should put point at the right place.
  37
  38 ;;; Code:
  39
  40 (eval-when-compile (require 'cl))
  41 (require 'hexl)                         ;For faces.
  42
  43 (defgroup nhexl nil
  44   "Edit a file in a hex dump format."
  45   :group 'data)
  46
  47 (defvar nhexl-line-width 16
  48   "Number of bytes per line.")
  49
  50 (defvar nhexl--display-table
  51   (let ((dt (make-display-table)))
  52     ;; (aset dt ?\n [?␊])
  53     (aset dt ?\t [?␉])
  54     dt))
  55
  56 (defvar nhexl--saved-vars nil)
  57 (make-variable-buffer-local 'nhexl--saved-vars)
  58 (defvar nhexl--point nil)
  59 (make-variable-buffer-local 'nhexl--point)
  60
  61 ;;;###autoload
  62 (define-minor-mode nhexl-mode
  63   "Minor mode to edit files via hex-dump format"
  64   :lighter " NHexl"
  65   (if (not nhexl-mode)
  66       (progn
  67         (dolist (varl nhexl--saved-vars)
  68           (set (make-local-variable (car varl)) (cdr varl)))
  69         (kill-local-variable 'nhexl--saved-vars)
  70         (jit-lock-unregister #'nhexl--jit)
  71         (remove-hook 'after-change-functions #'nhexl--change-function 'local)
  72         (remove-hook 'post-command-hook #'nhexl--post-command 'local)
  73         ;; FIXME: This will conflict with any other use of `display'.
  74         (with-silent-modifications
  75           (put-text-property (point-min) (point-max) 'display nil))
  76         (remove-overlays (point-min) (point-max) 'nhexl t))
  77     (unless (local-variable-p 'nhexl--saved-vars)
  78       (dolist (var '(buffer-display-table buffer-invisibility-spec
  79                      overwrite-mode header-line-format))
  80         (push (cons var (symbol-value var)) nhexl--saved-vars)))
  81     (setq nhexl--point (point))
  82     (setq header-line-format '(:eval (nhexl--header-line)))
  83     (binary-overwrite-mode 1)
  84     (setq buffer-invisibility-spec ())
  85     (set (make-local-variable 'buffer-display-table) nhexl--display-table)
  86     (jit-lock-register #'nhexl--jit)
  87     (add-hook 'change-major-mode-hook (lambda () (nhexl-mode -1)) nil 'local)
  88     (add-hook 'post-command-hook #'nhexl--post-command nil 'local)
  89     (add-hook 'after-change-functions #'nhexl--change-function nil 'local)))
  90
  91 (defun nhexl--change-function (beg end len)
  92   ;; Jit-lock already takes care of refreshing the changed area, so we
  93   ;; only have to make sure the tail's addresses are refreshed when
  94   ;; text is inserted/removed.
  95   (when (/= len (- end beg))
  96     (put-text-property beg (point-max) 'fontified nil)))
  97
  98 (defvar nhexl--overlay-counter 100)
  99 (make-variable-buffer-local 'nhexl--overlay-counter)
 100
 101 (defun nhexl--debug-count-ols ()
 102   (let ((i 0))
 103     (dolist (ol (overlays-in (point-min) (point-max)))
 104       (when (overlay-get ol 'nhexl) (incf i)))
 105     i))
 106
 107 (defun nhexl--flush-overlays (buffer)
 108   (with-current-buffer buffer
 109     (kill-local-variable 'nhexl--overlay-counter)
 110     ;; We've created many overlays in this buffer, which can slow
 111     ;; down operations significantly.  Let's flush them.
 112     ;; An easy way to flush them is
 113     ;;   (remove-overlays min max 'nhexl t)
 114     ;;   (put-text-property min max 'fontified nil)
 115     ;; but if the visible part of the buffer requires more than
 116     ;; nhexl--overlay-counter overlays, then we'll inf-loop.
 117     ;; So let's be more careful about removing overlays.
 118     (let ((windows (get-buffer-window-list nil nil t))
 119           (start (point-min))
 120           (zero (save-restriction (widen) (point-min)))
 121           (debug-count (nhexl--debug-count-ols)))
 122       (with-silent-modifications
 123         (while (< start (point-max))
 124           (let ((end (point-max)))
 125             (dolist (window windows)
 126               (cond
 127                ((< start (1- (window-start window)))
 128                 (setq end (min (1- (window-start window)) end)))
 129                ((< start (1+ (window-end window)))
 130                 (setq start (1+ (window-end window))))))
 131             ;; Round to multiple of nhexl-line-width.
 132             (setq start (+ zero (* (ceiling (- start zero) nhexl-line-width)
 133                                    nhexl-line-width)))
 134             (setq end (+ zero (* (truncate (- end zero) nhexl-line-width)
 135                                  nhexl-line-width)))
 136             (when (< start end)
 137               (remove-overlays start end 'nhexl t)
 138               (put-text-property start end 'fontified nil)
 139               (setq start (+ end nhexl-line-width))))))
 140       (let ((debug-new-count (nhexl--debug-count-ols)))
 141         (message "Flushed %d overlays, %d remaining"
 142                  (- debug-count debug-new-count) debug-new-count)))))
 143
 144 (defun nhexl--make-line (from next zero)
 145   (let* ((nextpos (min next (point-max)))
 146          (bufstr (buffer-substring from nextpos))
 147          (i -1)
 148          (s (concat
 149              (unless (eq zero from) "\n")
 150              (format (propertize "%08x:" 'face
 151                                  (if (or (< nhexl--point from)
 152                                          (>= nhexl--point next))
 153                                      'hexl-address-region
 154                                    '(highlight hexl-address-region)))
 155                      (- from zero))
 156              (propertize " " 'display '(space :align-to 12))
 157              (mapconcat (lambda (c)
 158                           (setq i (1+ i))
 159                           ;; FIXME: In multibyte buffers,
 160                           ;; do something clever about
 161                           ;; non-ascii chars.
 162                           (let ((s (format "%02x" c)))
 163                             (when (eq nhexl--point (+ from i))
 164                               (put-text-property 0 (length s)
 165                                                  'face 'highlight
 166                                                  s))
 167                             (if (zerop (mod i 2))
 168                                 s (concat s " "))))
 169                         bufstr
 170                         "")
 171              (if (> next nextpos)
 172                  (make-string (+ (/ (1+ (- next nextpos)) 2)
 173                                  (* (- next nextpos) 2))
 174                               ?\s))
 175              (propertize "  " 'display
 176                          `(space :align-to
 177                                  ,(+ (/ (* nhexl-line-width 5) 2)
 178                                      12 3))))))
 179     (font-lock-append-text-property 0 (length s) 'face 'default s)
 180     s))
 181
 182 (defun nhexl--jit (from to)
 183   (let ((zero (save-restriction (widen) (point-min))))
 184     (setq from (+ zero (* (truncate (- from zero) nhexl-line-width)
 185                           nhexl-line-width)))
 186     (setq to (+ zero (* (ceiling (- to zero) nhexl-line-width)
 187                         nhexl-line-width)))
 188     (remove-overlays from (min to (point-max)) 'nhexl t)
 189     (save-excursion
 190       (goto-char from)
 191       (while (search-forward "\n" to t)
 192         (put-text-property (match-beginning 0) (match-end 0)
 193                            'display (copy-sequence "␊"))))
 194     (while (< from to)
 195
 196       (decf nhexl--overlay-counter)
 197       (when (and (= nhexl--overlay-counter 0)
 198                  ;; If the user enabled jit-lock-stealth fontification, then
 199                  ;; removing overlays is just a waste since
 200                  ;; jit-lock-stealth will restore them anyway.
 201                  (not jit-lock-stealth-time))
 202         ;; (run-with-idle-timer 0 nil 'nhexl--flush-overlays (current-buffer))
 203         )
 204
 205       (let* ((next (+ from nhexl-line-width))
 206              (ol (make-overlay from next))
 207              (s (nhexl--make-line from next zero)))
 208         (overlay-put ol 'nhexl t)
 209         (overlay-put ol 'face 'hexl-ascii-region)
 210         (overlay-put ol 'before-string s)
 211         (setq from next)))))
 212
 213 (defun nhexl--header-line ()
 214   ;; FIXME: merge with nhexl--make-line.
 215   (let* ((zero (save-restriction (widen) (point-min)))
 216          (text
 217           (let ((tmp ()))
 218             (dotimes (i nhexl-line-width)
 219               (push (if (< i 10) (+ i ?0) (+ i -10 ?a)) tmp))
 220             (apply 'string (nreverse tmp))))
 221          (pos (mod (- nhexl--point zero) nhexl-line-width))
 222          (i -1))
 223     (put-text-property pos (1+ pos) 'face 'highlight text)
 224     (concat
 225      (propertize " " 'display '(space :align-to 0))
 226      "Address:"
 227      (propertize " " 'display '(space :align-to 12))
 228      (mapconcat (lambda (c)
 229                   (setq i (1+ i))
 230                   (let ((s (string c c)))
 231                     (when (eq i pos)
 232                       (put-text-property 0 (length s)
 233                                          'face 'highlight
 234                                          s))
 235                     (if (zerop (mod i 2)) s
 236                       (concat
 237                        s (propertize " " 'display
 238                                      `(space :align-to
 239                                              ,(+ (/ (* i 5) 2) 12 3)))))))
 240                 text
 241                 "")
 242      (propertize "  " 'display
 243                  `(space :align-to
 244                          ,(+ (/ (* nhexl-line-width 5) 2)
 245                              12 3)))
 246      text)))
 247
 248
 249 (defun nhexl--post-command ()
 250   (when (/= (point) nhexl--point)
 251     (let ((zero (save-restriction (widen) (point-min)))
 252           (oldpoint nhexl--point))
 253       (setq nhexl--point (point))
 254       (with-silent-modifications
 255         (nhexl--jit (point) (1+ (point)))
 256         (if (/= (truncate (- (point) zero) nhexl-line-width)
 257                 (truncate (- oldpoint zero) nhexl-line-width))
 258             (nhexl--jit oldpoint (1+ oldpoint)))))))
 259
 260
 261 (provide 'nhexl-mode)
 262 ;;; nhexl-mode.el ends here