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