code.delx.au - gnu-emacs-elpa/blob - packages/vlf/vlf-occur.el

   1 ;;; vlf-occur.el --- Occur-like functionality for VLF  -*- lexical-binding: t -*-
   2
   3 ;; Copyright (C) 2014 Free Software Foundation, Inc.
   4
   5 ;; Keywords: large files, indexing, occur
   6 ;; Author: Andrey Kotlarski <m00naticus@gmail.com>
   7 ;; URL: https://github.com/m00natic/vlfi
   8
   9 ;; This file 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, or (at your option)
  12 ;; any later version.
  13
  14 ;; This file 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 GNU Emacs; see the file COPYING.  If not, write to
  21 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  22 ;; Boston, MA 02111-1307, USA.
  23
  24 ;;; Commentary:
  25 ;; This package provides the `vlf-occur' command which builds
  26 ;; index of search occurrences in large file just like occur.
  27
  28 ;;; Code:
  29
  30 (require 'vlf)
  31
  32 (defvar vlf-occur-vlf-file nil "VLF file that is searched.")
  33 (make-variable-buffer-local 'vlf-occur-vlf-file)
  34
  35 (defvar vlf-occur-vlf-buffer nil "VLF buffer that is scanned.")
  36 (make-variable-buffer-local 'vlf-occur-vlf-buffer)
  37
  38 (defvar vlf-occur-regexp)
  39 (make-variable-buffer-local 'vlf-occur-regexp)
  40
  41 (defvar vlf-occur-hexl nil "Is `hexl-mode' active?")
  42 (make-variable-buffer-local 'vlf-occur-hexl)
  43
  44 (defvar vlf-occur-lines 0 "Number of lines scanned by `vlf-occur'.")
  45 (make-variable-buffer-local 'vlf-occur-lines)
  46
  47 (defvar vlf-occur-mode-map
  48   (let ((map (make-sparse-keymap)))
  49     (define-key map "n" 'vlf-occur-next-match)
  50     (define-key map "p" 'vlf-occur-prev-match)
  51     (define-key map "\C-m" 'vlf-occur-visit)
  52     (define-key map "\M-\r" 'vlf-occur-visit-new-buffer)
  53     (define-key map [mouse-1] 'vlf-occur-visit)
  54     (define-key map "o" 'vlf-occur-show)
  55     (define-key map [remap save-buffer] 'vlf-occur-save)
  56     map)
  57   "Keymap for command `vlf-occur-mode'.")
  58
  59 (define-derived-mode vlf-occur-mode special-mode "VLF[occur]"
  60   "Major mode for showing occur matches of VLF opened files."
  61   (add-hook 'write-file-functions 'vlf-occur-save nil t))
  62
  63 (defun vlf-occur-next-match ()
  64   "Move cursor to next match."
  65   (interactive)
  66   (if (eq (get-text-property (point) 'face) 'match)
  67       (goto-char (next-single-property-change (point) 'face)))
  68   (goto-char (or (text-property-any (point) (point-max) 'face 'match)
  69                  (text-property-any (point-min) (point)
  70                                     'face 'match))))
  71
  72 (defun vlf-occur-prev-match ()
  73   "Move cursor to previous match."
  74   (interactive)
  75   (if (eq (get-text-property (point) 'face) 'match)
  76       (goto-char (previous-single-property-change (point) 'face)))
  77   (while (not (eq (get-text-property (point) 'face) 'match))
  78     (goto-char (or (previous-single-property-change (point) 'face)
  79                    (point-max)))))
  80
  81 (defun vlf-occur-show (&optional event)
  82   "Visit current `vlf-occur' link in a vlf buffer but stay in the \
  83 occur buffer.  If original VLF buffer has been killed,
  84 open new VLF session each time.
  85 EVENT may hold details of the invocation."
  86   (interactive (list last-nonmenu-event))
  87   (let ((occur-buffer (if event
  88                           (window-buffer (posn-window
  89                                           (event-end event)))
  90                         (current-buffer))))
  91     (vlf-occur-visit event)
  92     (pop-to-buffer occur-buffer)))
  93
  94 (defun vlf-occur-visit-new-buffer ()
  95   "Visit `vlf-occur' link in new vlf buffer."
  96   (interactive)
  97   (let ((current-prefix-arg t))
  98     (vlf-occur-visit)))
  99
 100 (defun vlf-occur-visit (&optional event)
 101   "Visit current `vlf-occur' link in a vlf buffer.
 102 With prefix argument or if original VLF buffer has been killed,
 103 open new VLF session.
 104 EVENT may hold details of the invocation."
 105   (interactive (list last-nonmenu-event))
 106   (when event
 107     (set-buffer (window-buffer (posn-window (event-end event))))
 108     (goto-char (posn-point (event-end event))))
 109   (let* ((pos (point))
 110          (pos-relative (- pos (line-beginning-position) 1))
 111          (chunk-start (get-text-property pos 'chunk-start)))
 112     (if chunk-start
 113         (let ((chunk-end (get-text-property pos 'chunk-end))
 114               (file (if (file-exists-p vlf-occur-vlf-file)
 115                         vlf-occur-vlf-file
 116                       (setq vlf-occur-vlf-file
 117                             (read-file-name
 118                              (concat vlf-occur-vlf-file
 119                                      " doesn't exist, locate it: ")))))
 120               (vlf-buffer vlf-occur-vlf-buffer)
 121               (not-hexl (not vlf-occur-hexl))
 122               (occur-buffer (current-buffer))
 123               (match-pos (+ (get-text-property pos 'line-pos)
 124                             pos-relative)))
 125           (cond (current-prefix-arg
 126                  (setq vlf-buffer (vlf file t))
 127                  (or not-hexl (vlf-tune-hexlify))
 128                  (switch-to-buffer occur-buffer))
 129                 ((not (buffer-live-p vlf-buffer))
 130                  (unless (catch 'found
 131                            (dolist (buf (buffer-list))
 132                              (set-buffer buf)
 133                              (and vlf-mode
 134                                   (equal file buffer-file-name)
 135                                   (eq (not (derived-mode-p 'hexl-mode))
 136                                       not-hexl)
 137                                   (setq vlf-buffer buf)
 138                                   (throw 'found t))))
 139                    (setq vlf-buffer (vlf file t))
 140                    (or not-hexl (vlf-tune-hexlify)))
 141                  (switch-to-buffer occur-buffer)
 142                  (setq vlf-occur-vlf-buffer vlf-buffer)))
 143           (pop-to-buffer vlf-buffer)
 144           (vlf-move-to-chunk chunk-start chunk-end)
 145           (goto-char match-pos)))))
 146
 147 (defun vlf-occur-other-buffer (regexp)
 148   "Make whole file occur style index for REGEXP branching to new buffer.
 149 Prematurely ending indexing will still show what's found so far."
 150   (let ((vlf-buffer (current-buffer))
 151         (file buffer-file-name)
 152         (batch-size vlf-batch-size)
 153         (is-hexl (derived-mode-p 'hexl-mode))
 154         (insert-bps vlf-tune-insert-bps)
 155         (encode-bps vlf-tune-encode-bps)
 156         (hexl-bps vlf-tune-hexl-bps)
 157         (dehexlify-bps vlf-tune-dehexlify-bps))
 158     (with-temp-buffer
 159       (setq buffer-file-name file
 160             buffer-file-truename file
 161             buffer-undo-list t)
 162       (set-buffer-modified-p nil)
 163       (set (make-local-variable 'vlf-batch-size) batch-size)
 164       (when vlf-tune-enabled
 165         (setq vlf-tune-insert-bps insert-bps
 166               vlf-tune-encode-bps encode-bps)
 167         (if is-hexl
 168             (progn (setq vlf-tune-hexl-bps hexl-bps
 169                          vlf-tune-dehexlify-bps dehexlify-bps)
 170                    (vlf-tune-batch '(:hexl :dehexlify :insert :encode)))
 171           (vlf-tune-batch '(:insert :encode))))
 172       (vlf-mode 1)
 173       (if is-hexl (vlf-tune-hexlify))
 174       (goto-char (point-min))
 175       (vlf-with-undo-disabled
 176        (vlf-build-occur regexp vlf-buffer))
 177       (when vlf-tune-enabled
 178         (setq insert-bps vlf-tune-insert-bps
 179               encode-bps vlf-tune-encode-bps)
 180         (if is-hexl
 181             (setq insert-bps vlf-tune-insert-bps
 182                   encode-bps vlf-tune-encode-bps))))
 183     (when vlf-tune-enabled              ;merge back tune measurements
 184       (setq vlf-tune-insert-bps insert-bps
 185             vlf-tune-encode-bps encode-bps)
 186       (if is-hexl
 187           (setq vlf-tune-insert-bps insert-bps
 188                 vlf-tune-encode-bps encode-bps)))))
 189
 190 (defun vlf-occur (regexp)
 191   "Make whole file occur style index for REGEXP.
 192 Prematurely ending indexing will still show what's found so far."
 193   (interactive (list (read-regexp "List lines matching regexp"
 194                                   (if regexp-history
 195                                       (car regexp-history)))))
 196   (run-hook-with-args 'vlf-before-batch-functions 'occur)
 197   (if (or (buffer-modified-p)
 198           (< vlf-batch-size vlf-start-pos))
 199       (vlf-occur-other-buffer regexp)
 200     (let ((start-pos vlf-start-pos)
 201           (end-pos vlf-end-pos)
 202           (pos (point))
 203           (batch-size vlf-batch-size)
 204           (is-hexl (derived-mode-p 'hexl-mode)))
 205       (vlf-tune-batch (if (derived-mode-p 'hexl-mode)
 206                           '(:hexl :dehexlify :insert :encode)
 207                         '(:insert :encode)))
 208       (vlf-with-undo-disabled
 209        (vlf-move-to-batch 0)
 210        (goto-char (point-min))
 211        (unwind-protect (vlf-build-occur regexp (current-buffer))
 212          (vlf-move-to-chunk start-pos end-pos)
 213          (if is-hexl (vlf-tune-hexlify))
 214          (goto-char pos)
 215          (setq vlf-batch-size batch-size)))))
 216   (run-hook-with-args 'vlf-after-batch-functions 'occur))
 217
 218 (defvar tramp-verbose)
 219
 220 (defun vlf-build-occur (regexp vlf-buffer)
 221   "Build occur style index for REGEXP over VLF-BUFFER."
 222   (let* ((tramp-verbose (if (boundp 'tramp-verbose)
 223                             (min tramp-verbose 2)))
 224          (case-fold-search t)
 225          (line 1)
 226          (last-match-line 0)
 227          (last-line-pos (point-min))
 228          (total-matches 0)
 229          (match-end-pos (+ vlf-start-pos (position-bytes (point))))
 230          (occur-buffer (generate-new-buffer
 231                         (concat "*VLF-occur " (file-name-nondirectory
 232                                                buffer-file-name)
 233                                 "*")))
 234          (line-regexp (concat "\\(?5:[\n\C-m]\\)\\|\\(?10:"
 235                               regexp "\\)"))
 236          (batch-step (min 1024 (/ vlf-batch-size 8)))
 237          (is-hexl (derived-mode-p 'hexl-mode))
 238          (end-of-file nil)
 239          (time (float-time))
 240          (tune-types (if is-hexl '(:hexl :dehexlify :insert :encode)
 241                        '(:insert :encode)))
 242          (reporter (make-progress-reporter
 243                     (concat "Building index for " regexp "...")
 244                     vlf-start-pos vlf-file-size)))
 245     (with-current-buffer occur-buffer
 246       (setq buffer-undo-list t))
 247     (unwind-protect
 248         (progn
 249           (while (not end-of-file)
 250             (if (re-search-forward line-regexp nil t)
 251                 (progn
 252                   (setq match-end-pos (+ vlf-start-pos
 253                                          (position-bytes
 254                                           (match-end 0))))
 255                   (if (match-string 5)
 256                       (setq line (1+ line) ; line detected
 257                             last-line-pos (point))
 258                     (let* ((chunk-start vlf-start-pos)
 259                            (chunk-end vlf-end-pos)
 260                            (line-pos (line-beginning-position))
 261                            (line-text (buffer-substring
 262                                        line-pos (line-end-position))))
 263                       (with-current-buffer occur-buffer
 264                         (unless (= line last-match-line) ;new match line
 265                           (insert "\n:") ; insert line number
 266                           (let* ((overlay-pos (1- (point)))
 267                                  (overlay (make-overlay
 268                                            overlay-pos
 269                                            (1+ overlay-pos))))
 270                             (overlay-put overlay 'before-string
 271                                          (propertize
 272                                           (number-to-string line)
 273                                           'face 'shadow)))
 274                           (insert (propertize line-text ; insert line
 275                                               'chunk-start chunk-start
 276                                               'chunk-end chunk-end
 277                                               'mouse-face '(highlight)
 278                                               'line-pos line-pos
 279                                               'help-echo
 280                                               (format "Move to line %d"
 281                                                       line))))
 282                         (setq last-match-line line
 283                               total-matches (1+ total-matches))
 284                         (let ((line-start (1+
 285                                            (line-beginning-position)))
 286                               (match-pos (match-beginning 10)))
 287                           (add-text-properties ; mark match
 288                            (+ line-start match-pos (- last-line-pos))
 289                            (+ line-start (match-end 10)
 290                               (- last-line-pos))
 291                            (list 'face 'match
 292                                  'help-echo
 293                                  (format "Move to match %d"
 294                                          total-matches))))))))
 295               (setq end-of-file (= vlf-end-pos vlf-file-size))
 296               (unless end-of-file
 297                 (vlf-tune-batch tune-types)
 298                 (let ((batch-move (- vlf-end-pos batch-step)))
 299                   (vlf-move-to-batch (if (or is-hexl
 300                                              (< match-end-pos
 301                                                 batch-move))
 302                                          batch-move
 303                                        match-end-pos) t))
 304                 (goto-char (if (or is-hexl
 305                                    (<= match-end-pos vlf-start-pos))
 306                                (point-min)
 307                              (or (byte-to-position (- match-end-pos
 308                                                       vlf-start-pos))
 309                                  (point-min))))
 310                 (setq last-match-line 0
 311                       last-line-pos (line-beginning-position))
 312                 (progress-reporter-update reporter vlf-end-pos))))
 313           (progress-reporter-done reporter))
 314       (set-buffer-modified-p nil)
 315       (if (zerop total-matches)
 316           (progn (kill-buffer occur-buffer)
 317                  (message "No matches for \"%s\" (%f secs)"
 318                           regexp (- (float-time) time)))
 319         (let ((file buffer-file-name)
 320               (dir default-directory))
 321           (with-current-buffer occur-buffer
 322             (goto-char (point-min))
 323             (insert (propertize
 324                      (format "%d matches from %d lines for \"%s\" \
 325 in file: %s" total-matches line regexp file)
 326                      'face 'underline))
 327             (set-buffer-modified-p nil)
 328             (forward-char 2)
 329             (vlf-occur-mode)
 330             (setq default-directory dir
 331                   vlf-occur-vlf-file file
 332                   vlf-occur-vlf-buffer vlf-buffer
 333                   vlf-occur-regexp regexp
 334                   vlf-occur-hexl is-hexl
 335                   vlf-occur-lines line)))
 336         (display-buffer occur-buffer)
 337         (message "Occur finished for \"%s\" (%f secs)"
 338                  regexp (- (float-time) time))))))
 339
 340 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 341 ;;; save, load vlf-occur data
 342
 343 (defun vlf-occur-save (file)
 344   "Serialize `vlf-occur' results to FILE which can later be reloaded."
 345   (interactive (list (or buffer-file-name
 346                          (read-file-name "Save vlf-occur results in: "
 347                                          nil nil nil
 348                                          (concat
 349                                           (file-name-nondirectory
 350                                            vlf-occur-vlf-file)
 351                                           ".vlfo")))))
 352   (setq buffer-file-name file)
 353   (let ((vlf-occur-save-buffer
 354          (generate-new-buffer (concat "*VLF-occur-save "
 355                                       (file-name-nondirectory file)
 356                                       "*"))))
 357     (with-current-buffer vlf-occur-save-buffer
 358       (setq buffer-file-name file
 359             buffer-undo-list t)
 360       (insert ";; -*- eval: (vlf-occur-load) -*-\n"))
 361     (prin1 (list vlf-occur-vlf-file vlf-occur-regexp vlf-occur-hexl
 362                  vlf-occur-lines)
 363            vlf-occur-save-buffer)
 364     (save-excursion
 365       (goto-char (point-min))
 366       (while (zerop (forward-line))
 367         (let* ((pos (1+ (point)))
 368                (line (get-char-property (1- pos) 'before-string)))
 369           (if line
 370               (prin1 (list (string-to-number line)
 371                            (get-text-property pos 'chunk-start)
 372                            (get-text-property pos 'chunk-end)
 373                            (get-text-property pos 'line-pos)
 374                            (buffer-substring-no-properties
 375                             pos (line-end-position)))
 376                      vlf-occur-save-buffer)))))
 377     (with-current-buffer vlf-occur-save-buffer
 378       (save-buffer))
 379     (kill-buffer vlf-occur-save-buffer))
 380   t)
 381
 382 ;;;###autoload
 383 (defun vlf-occur-load ()
 384   "Load serialized `vlf-occur' results from current buffer."
 385   (interactive)
 386   (goto-char (point-min))
 387   (let* ((vlf-occur-data-buffer (current-buffer))
 388          (header (read vlf-occur-data-buffer))
 389          (vlf-file (nth 0 header))
 390          (regexp (nth 1 header))
 391          (all-lines (nth 3 header))
 392          (file buffer-file-name)
 393          (vlf-occur-buffer
 394           (generate-new-buffer (concat "*VLF-occur "
 395                                        (file-name-nondirectory file)
 396                                        "*"))))
 397     (switch-to-buffer vlf-occur-buffer)
 398     (setq buffer-file-name file
 399           buffer-undo-list t)
 400     (goto-char (point-min))
 401     (let ((match-count 0)
 402           (form 0))
 403       (while (setq form (ignore-errors (read vlf-occur-data-buffer)))
 404         (goto-char (point-max))
 405         (insert "\n:")
 406         (let* ((overlay-pos (1- (point)))
 407                (overlay (make-overlay overlay-pos (1+ overlay-pos)))
 408                (line (number-to-string (nth 0 form)))
 409                (pos (point)))
 410           (overlay-put overlay 'before-string
 411                        (propertize line 'face 'shadow))
 412           (insert (propertize (nth 4 form) 'chunk-start (nth 1 form)
 413                               'chunk-end (nth 2 form)
 414                               'mouse-face '(highlight)
 415                               'line-pos (nth 3 form)
 416                               'help-echo (concat "Move to line "
 417                                                  line)))
 418           (goto-char pos)
 419           (while (re-search-forward regexp nil t)
 420             (add-text-properties
 421              (match-beginning 0) (match-end 0)
 422              (list 'face 'match 'help-echo
 423                    (format "Move to match %d"
 424                            (setq match-count (1+ match-count))))))))
 425       (kill-buffer vlf-occur-data-buffer)
 426       (goto-char (point-min))
 427       (insert (propertize
 428                (format "%d matches from %d lines for \"%s\" in file: %s"
 429                        match-count all-lines regexp vlf-file)
 430                'face 'underline)))
 431     (set-buffer-modified-p nil)
 432     (vlf-occur-mode)
 433     (setq vlf-occur-vlf-file vlf-file
 434           vlf-occur-regexp regexp
 435           vlf-occur-hexl (nth 2 header)
 436           vlf-occur-lines all-lines)))
 437
 438 (provide 'vlf-occur)
 439
 440 ;;; vlf-occur.el ends here