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-mode-map
  33   (let ((map (make-sparse-keymap)))
  34     (define-key map "n" 'vlf-occur-next-match)
  35     (define-key map "p" 'vlf-occur-prev-match)
  36     (define-key map "\C-m" 'vlf-occur-visit)
  37     (define-key map "\M-\r" 'vlf-occur-visit-new-buffer)
  38     (define-key map [mouse-1] 'vlf-occur-visit)
  39     (define-key map "o" 'vlf-occur-show)
  40     map)
  41   "Keymap for command `vlf-occur-mode'.")
  42
  43 (define-derived-mode vlf-occur-mode special-mode "VLF[occur]"
  44   "Major mode for showing occur matches of VLF opened files.")
  45
  46 (defun vlf-occur-next-match ()
  47   "Move cursor to next match."
  48   (interactive)
  49   (if (eq (get-char-property (point) 'face) 'match)
  50       (goto-char (next-single-property-change (point) 'face)))
  51   (goto-char (or (text-property-any (point) (point-max) 'face 'match)
  52                  (text-property-any (point-min) (point)
  53                                     'face 'match))))
  54
  55 (defun vlf-occur-prev-match ()
  56   "Move cursor to previous match."
  57   (interactive)
  58   (if (eq (get-char-property (point) 'face) 'match)
  59       (goto-char (previous-single-property-change (point) 'face)))
  60   (while (not (eq (get-char-property (point) 'face) 'match))
  61     (goto-char (or (previous-single-property-change (point) 'face)
  62                    (point-max)))))
  63
  64 (defun vlf-occur-show (&optional event)
  65   "Visit current `vlf-occur' link in a vlf buffer but stay in the \
  66 occur buffer.  If original VLF buffer has been killed,
  67 open new VLF session each time.
  68 EVENT may hold details of the invocation."
  69   (interactive (list last-nonmenu-event))
  70   (let ((occur-buffer (if event
  71                           (window-buffer (posn-window
  72                                           (event-end event)))
  73                         (current-buffer))))
  74     (vlf-occur-visit event)
  75     (pop-to-buffer occur-buffer)))
  76
  77 (defun vlf-occur-visit-new-buffer ()
  78   "Visit `vlf-occur' link in new vlf buffer."
  79   (interactive)
  80   (let ((current-prefix-arg t))
  81     (vlf-occur-visit)))
  82
  83 (defun vlf-occur-visit (&optional event)
  84   "Visit current `vlf-occur' link in a vlf buffer.
  85 With prefix argument or if original VLF buffer has been killed,
  86 open new VLF session.
  87 EVENT may hold details of the invocation."
  88   (interactive (list last-nonmenu-event))
  89   (when event
  90     (set-buffer (window-buffer (posn-window (event-end event))))
  91     (goto-char (posn-point (event-end event))))
  92   (let* ((pos (point))
  93          (pos-relative (- pos (line-beginning-position) 1))
  94          (file (get-char-property pos 'file)))
  95     (if file
  96         (let ((chunk-start (get-char-property pos 'chunk-start))
  97               (chunk-end (get-char-property pos 'chunk-end))
  98               (vlf-buffer (get-char-property pos 'buffer))
  99               (occur-buffer (current-buffer))
 100               (match-pos (+ (get-char-property pos 'line-pos)
 101                             pos-relative)))
 102           (cond (current-prefix-arg
 103                  (setq vlf-buffer (vlf file))
 104                  (switch-to-buffer occur-buffer))
 105                 ((not (buffer-live-p vlf-buffer))
 106                  (or (catch 'found
 107                        (dolist (buf (buffer-list))
 108                          (set-buffer buf)
 109                          (and vlf-mode (equal file buffer-file-name)
 110                               (setq vlf-buffer buf)
 111                               (throw 'found t))))
 112                      (setq vlf-buffer (vlf file)))
 113                  (switch-to-buffer occur-buffer)))
 114           (pop-to-buffer vlf-buffer)
 115           (vlf-move-to-chunk chunk-start chunk-end)
 116           (goto-char match-pos)))))
 117
 118 (defun vlf-occur (regexp)
 119   "Make whole file occur style index for REGEXP.
 120 Prematurely ending indexing will still show what's found so far."
 121   (interactive (list (read-regexp "List lines matching regexp"
 122                                   (if regexp-history
 123                                       (car regexp-history)))))
 124   (if (buffer-modified-p) ;use temporary buffer not to interfere with modifications
 125       (let ((vlf-buffer (current-buffer))
 126             (file buffer-file-name)
 127             (batch-size vlf-batch-size))
 128         (with-temp-buffer
 129           (setq buffer-file-name file)
 130           (set-buffer-modified-p nil)
 131           (set (make-local-variable 'vlf-batch-size) batch-size)
 132           (vlf-mode 1)
 133           (goto-char (point-min))
 134           (vlf-with-undo-disabled
 135            (vlf-build-occur regexp vlf-buffer))))
 136     (let ((start-pos vlf-start-pos)
 137           (end-pos vlf-end-pos)
 138           (pos (point)))
 139       (vlf-with-undo-disabled
 140        (vlf-beginning-of-file)
 141        (goto-char (point-min))
 142        (unwind-protect (vlf-build-occur regexp (current-buffer))
 143          (vlf-move-to-chunk start-pos end-pos)
 144          (goto-char pos))))))
 145
 146 (defun vlf-build-occur (regexp vlf-buffer)
 147   "Build occur style index for REGEXP over VLF-BUFFER."
 148   (let ((tramp-verbose (min 2 tramp-verbose))
 149         (case-fold-search t)
 150         (line 1)
 151         (last-match-line 0)
 152         (last-line-pos (point-min))
 153         (file buffer-file-name)
 154         (total-matches 0)
 155         (match-end-pos (+ vlf-start-pos (position-bytes (point))))
 156         (occur-buffer (generate-new-buffer
 157                        (concat "*VLF-occur " (file-name-nondirectory
 158                                               buffer-file-name)
 159                                "*")))
 160         (line-regexp (concat "\\(?5:[\n\C-m]\\)\\|\\(?10:"
 161                              regexp "\\)"))
 162         (batch-step (/ vlf-batch-size 8))
 163         (end-of-file nil)
 164         (reporter (make-progress-reporter
 165                    (concat "Building index for " regexp "...")
 166                    vlf-start-pos vlf-file-size)))
 167     (unwind-protect
 168         (progn
 169           (while (not end-of-file)
 170             (if (re-search-forward line-regexp nil t)
 171                 (progn
 172                   (setq match-end-pos (+ vlf-start-pos
 173                                          (position-bytes
 174                                           (match-end 0))))
 175                   (if (match-string 5)
 176                       (setq line (1+ line) ; line detected
 177                             last-line-pos (point))
 178                     (let* ((chunk-start vlf-start-pos)
 179                            (chunk-end vlf-end-pos)
 180                            (line-pos (line-beginning-position))
 181                            (line-text (buffer-substring
 182                                        line-pos (line-end-position))))
 183                       (with-current-buffer occur-buffer
 184                         (unless (= line last-match-line) ;new match line
 185                           (insert "\n:") ; insert line number
 186                           (let* ((overlay-pos (1- (point)))
 187                                  (overlay (make-overlay
 188                                            overlay-pos
 189                                            (1+ overlay-pos))))
 190                             (overlay-put overlay 'before-string
 191                                          (propertize
 192                                           (number-to-string line)
 193                                           'face 'shadow)))
 194                           (insert (propertize line-text ; insert line
 195                                               'file file
 196                                               'buffer vlf-buffer
 197                                               'chunk-start chunk-start
 198                                               'chunk-end chunk-end
 199                                               'mouse-face '(highlight)
 200                                               'line-pos line-pos
 201                                               'help-echo
 202                                               (format "Move to line %d"
 203                                                       line))))
 204                         (setq last-match-line line
 205                               total-matches (1+ total-matches))
 206                         (let ((line-start (1+
 207                                            (line-beginning-position)))
 208                               (match-pos (match-beginning 10)))
 209                           (add-text-properties ; mark match
 210                            (+ line-start match-pos (- last-line-pos))
 211                            (+ line-start (match-end 10)
 212                               (- last-line-pos))
 213                            (list 'face 'match
 214                                  'help-echo
 215                                  (format "Move to match %d"
 216                                          total-matches))))))))
 217               (setq end-of-file (= vlf-end-pos vlf-file-size))
 218               (unless end-of-file
 219                 (let ((batch-move (- vlf-end-pos batch-step)))
 220                   (vlf-move-to-batch (if (< batch-move match-end-pos)
 221                                          match-end-pos
 222                                        batch-move) t))
 223                 (goto-char (if (< vlf-start-pos match-end-pos)
 224                                (or (byte-to-position (- match-end-pos
 225                                                         vlf-start-pos))
 226                                    (point-min))
 227                              (point-min)))
 228                 (setq last-match-line 0
 229                       last-line-pos (line-beginning-position))
 230                 (progress-reporter-update reporter vlf-end-pos))))
 231           (progress-reporter-done reporter))
 232       (set-buffer-modified-p nil)
 233       (if (zerop total-matches)
 234           (progn (with-current-buffer occur-buffer
 235                    (set-buffer-modified-p nil))
 236                  (kill-buffer occur-buffer)
 237                  (message "No matches for \"%s\"" regexp))
 238         (with-current-buffer occur-buffer
 239           (goto-char (point-min))
 240           (insert (propertize
 241                    (format "%d matches in %d lines for \"%s\" \
 242 in file: %s" total-matches line regexp file)
 243                    'face 'underline))
 244           (set-buffer-modified-p nil)
 245           (forward-char 2)
 246           (vlf-occur-mode))
 247         (display-buffer occur-buffer)))))
 248
 249 (provide 'vlf-occur)
 250
 251 ;;; vlf-occur.el ends here