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           (run-hook-with-args 'vlf-before-batch-functions 'occur)
 135           (vlf-with-undo-disabled
 136            (vlf-build-occur regexp vlf-buffer))
 137           (run-hook-with-args 'vlf-after-batch-functions 'occur)))
 138     (run-hook-with-args 'vlf-before-batch-functions 'occur)
 139     (let ((start-pos vlf-start-pos)
 140           (end-pos vlf-end-pos)
 141           (pos (point)))
 142       (vlf-with-undo-disabled
 143        (vlf-beginning-of-file)
 144        (goto-char (point-min))
 145        (unwind-protect (vlf-build-occur regexp (current-buffer))
 146          (vlf-move-to-chunk start-pos end-pos)
 147          (goto-char pos))))
 148     (run-hook-with-args 'vlf-after-batch-functions 'occur)))
 149
 150 (defun vlf-build-occur (regexp vlf-buffer)
 151   "Build occur style index for REGEXP over VLF-BUFFER."
 152   (let ((tramp-verbose (if (boundp 'tramp-verbose)
 153                            (min tramp-verbose 2)))
 154         (case-fold-search t)
 155         (line 1)
 156         (last-match-line 0)
 157         (last-line-pos (point-min))
 158         (file buffer-file-name)
 159         (total-matches 0)
 160         (match-end-pos (+ vlf-start-pos (position-bytes (point))))
 161         (occur-buffer (generate-new-buffer
 162                        (concat "*VLF-occur " (file-name-nondirectory
 163                                               buffer-file-name)
 164                                "*")))
 165         (line-regexp (concat "\\(?5:[\n\C-m]\\)\\|\\(?10:"
 166                              regexp "\\)"))
 167         (batch-step (/ vlf-batch-size 8))
 168         (end-of-file nil)
 169         (reporter (make-progress-reporter
 170                    (concat "Building index for " regexp "...")
 171                    vlf-start-pos vlf-file-size)))
 172     (unwind-protect
 173         (progn
 174           (while (not end-of-file)
 175             (if (re-search-forward line-regexp nil t)
 176                 (progn
 177                   (setq match-end-pos (+ vlf-start-pos
 178                                          (position-bytes
 179                                           (match-end 0))))
 180                   (if (match-string 5)
 181                       (setq line (1+ line) ; line detected
 182                             last-line-pos (point))
 183                     (let* ((chunk-start vlf-start-pos)
 184                            (chunk-end vlf-end-pos)
 185                            (line-pos (line-beginning-position))
 186                            (line-text (buffer-substring
 187                                        line-pos (line-end-position))))
 188                       (with-current-buffer occur-buffer
 189                         (unless (= line last-match-line) ;new match line
 190                           (insert "\n:") ; insert line number
 191                           (let* ((overlay-pos (1- (point)))
 192                                  (overlay (make-overlay
 193                                            overlay-pos
 194                                            (1+ overlay-pos))))
 195                             (overlay-put overlay 'before-string
 196                                          (propertize
 197                                           (number-to-string line)
 198                                           'face 'shadow)))
 199                           (insert (propertize line-text ; insert line
 200                                               'file file
 201                                               'buffer vlf-buffer
 202                                               'chunk-start chunk-start
 203                                               'chunk-end chunk-end
 204                                               'mouse-face '(highlight)
 205                                               'line-pos line-pos
 206                                               'help-echo
 207                                               (format "Move to line %d"
 208                                                       line))))
 209                         (setq last-match-line line
 210                               total-matches (1+ total-matches))
 211                         (let ((line-start (1+
 212                                            (line-beginning-position)))
 213                               (match-pos (match-beginning 10)))
 214                           (add-text-properties ; mark match
 215                            (+ line-start match-pos (- last-line-pos))
 216                            (+ line-start (match-end 10)
 217                               (- last-line-pos))
 218                            (list 'face 'match
 219                                  'help-echo
 220                                  (format "Move to match %d"
 221                                          total-matches))))))))
 222               (setq end-of-file (= vlf-end-pos vlf-file-size))
 223               (unless end-of-file
 224                 (let ((batch-move (- vlf-end-pos batch-step)))
 225                   (vlf-move-to-batch (if (< batch-move match-end-pos)
 226                                          match-end-pos
 227                                        batch-move) t))
 228                 (goto-char (if (< vlf-start-pos match-end-pos)
 229                                (or (byte-to-position (- match-end-pos
 230                                                         vlf-start-pos))
 231                                    (point-min))
 232                              (point-min)))
 233                 (setq last-match-line 0
 234                       last-line-pos (line-beginning-position))
 235                 (progress-reporter-update reporter vlf-end-pos))))
 236           (progress-reporter-done reporter))
 237       (set-buffer-modified-p nil)
 238       (if (zerop total-matches)
 239           (progn (with-current-buffer occur-buffer
 240                    (set-buffer-modified-p nil))
 241                  (kill-buffer occur-buffer)
 242                  (message "No matches for \"%s\"" regexp))
 243         (with-current-buffer occur-buffer
 244           (goto-char (point-min))
 245           (insert (propertize
 246                    (format "%d matches in %d lines for \"%s\" \
 247 in file: %s" total-matches line regexp file)
 248                    'face 'underline))
 249           (set-buffer-modified-p nil)
 250           (forward-char 2)
 251           (vlf-occur-mode))
 252         (display-buffer occur-buffer)))))
 253
 254 (provide 'vlf-occur)
 255
 256 ;;; vlf-occur.el ends here