1 ;;; vlf-occur.el --- Occur-like functionality for VLF -*- lexical-binding: t -*-
3 ;; Copyright (C) 2014 Free Software Foundation, Inc.
5 ;; Keywords: large files, indexing, occur
6 ;; Author: Andrey Kotlarski <m00naticus@gmail.com>
7 ;; URL: https://github.com/m00natic/vlfi
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)
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.
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.
25 ;; This package provides the `vlf-occur' command which builds
26 ;; index of search occurrences in large file just like occur.
32 (defvar vlf-occur-vlf-file nil "VLF file that is searched.")
33 (make-variable-buffer-local 'vlf-occur-vlf-file)
35 (defvar vlf-occur-vlf-buffer nil "VLF buffer that is scanned.")
36 (make-variable-buffer-local 'vlf-occur-vlf-buffer)
38 (defvar vlf-occur-regexp)
39 (make-variable-buffer-local 'vlf-occur-regexp)
41 (defvar vlf-occur-hexl nil "Is `hexl-mode' active?")
42 (make-variable-buffer-local 'vlf-occur-hexl)
44 (defvar vlf-occur-lines 0 "Number of lines scanned by `vlf-occur'.")
45 (make-variable-buffer-local 'vlf-occur-lines)
47 (defvar tramp-verbose)
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)
60 "Keymap for command `vlf-occur-mode'.")
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))
66 (defun vlf-occur-next-match ()
67 "Move cursor to next match."
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)
75 (defun vlf-occur-prev-match ()
76 "Move cursor to previous match."
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)
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
94 (vlf-occur-visit event)
95 (pop-to-buffer occur-buffer)))
97 (defun vlf-occur-visit-new-buffer ()
98 "Visit `vlf-occur' link in new vlf buffer."
100 (let ((current-prefix-arg t))
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))
110 (set-buffer (window-buffer (posn-window (event-end event))))
111 (goto-char (posn-point (event-end event))))
113 (pos-relative (- pos (previous-single-char-property-change
115 (chunk-start (get-text-property pos 'chunk-start)))
117 (let ((chunk-end (get-text-property pos 'chunk-end))
118 (file (if (file-exists-p vlf-occur-vlf-file)
120 (setq vlf-occur-vlf-file
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)
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))
141 (equal file buffer-file-name)
142 (eq (not (derived-mode-p 'hexl-mode))
144 (setq vlf-buffer buf)
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)))))
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)))
163 (setq buffer-file-name file
164 buffer-file-truename file
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
173 '(:insert :encode)) t))
175 (if is-hexl (hexl-mode))
176 (goto-char (point-min))
177 (vlf-build-occur regexp vlf-buffer)
179 (vlf-tune-copy-profile (current-buffer) vlf-buffer)))))
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"
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)
195 (batch-size vlf-batch-size))
196 (vlf-tune-batch (if (derived-mode-p 'hexl-mode)
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)
204 (setq vlf-batch-size batch-size))))
205 (run-hook-with-args 'vlf-after-batch-functions 'occur))
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)))
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
224 (is-hexl (derived-mode-p 'hexl-mode))
227 (tune-types (if is-hexl '(:hexl :raw)
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))
236 (while (not end-of-file)
237 (if (re-search-forward regexp nil t)
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
262 (overlay-put overlay 'before-string
264 (number-to-string line)
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))
272 (if first-line-incomplete
274 first-line-incomplete)
276 'chunk-start chunk-start
278 'mouse-face '(highlight)
281 (format "Move to line %d"
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
289 (add-text-properties ; mark match
290 (+ line-start match-start-point)
291 (+ line-start match-end-point)
293 'help-echo (format "Move to match %d"
295 (setq end-of-file (= vlf-end-pos vlf-file-size))
300 (goto-char (point-max))
304 (if (< match-end-point (point))
305 (count-lines match-start-point
307 (goto-char match-end-point)
308 (1- (count-lines match-start-point
310 (- vlf-end-pos (* (- 10 (forward-line 10))
312 (let* ((pmax (point-max))
313 (batch-step (min 1024 (/ vlf-batch-size
319 (- vlf-batch-size batch-step))
322 (let ((last (line-beginning-position)))
323 (if (= last (point-min))
326 (goto-char batch-point)
327 (setq first-line-offset
328 (- batch-point (line-beginning-position))
331 (count-lines match-start-point
333 (if (< 0 first-line-offset) -1 0)))
334 ;; last match is on the last line?
335 (goto-char match-end-point)
337 (setq first-line-incomplete
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
358 (goto-char (point-min))
360 (format "%d matches from %d lines for \"%s\" \
361 in file: %s" total-matches line regexp file)
363 (set-buffer-modified-p nil)
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))))))
376 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
377 ;;; save, load vlf-occur data
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: "
385 (file-name-nondirectory
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)
393 (with-current-buffer vlf-occur-save-buffer
394 (setq buffer-file-name file
396 (insert ";; -*- eval: (vlf-occur-load) -*-\n"))
397 (prin1 (list vlf-occur-vlf-file vlf-occur-regexp vlf-occur-hexl
399 vlf-occur-save-buffer)
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)))
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
415 vlf-occur-save-buffer))))))
416 (with-current-buffer vlf-occur-save-buffer
418 (kill-buffer vlf-occur-save-buffer))
422 (defun vlf-occur-load ()
423 "Load serialized `vlf-occur' results from current buffer."
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)
433 (generate-new-buffer (concat "*VLF-occur "
434 (file-name-nondirectory file)
436 (switch-to-buffer vlf-occur-buffer)
437 (setq buffer-file-name file
439 (goto-char (point-min))
440 (let ((match-count 0)
442 (while (setq form (ignore-errors (read vlf-occur-data-buffer)))
443 (goto-char (point-max))
445 (let* ((overlay-pos (1- (point)))
446 (overlay (make-overlay overlay-pos (1+ overlay-pos)))
447 (line (number-to-string (nth 0 form)))
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 "
459 (while (re-search-forward regexp nil t)
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))
468 (format "%d matches from %d lines for \"%s\" in file: %s"
469 match-count all-lines regexp vlf-file)
471 (set-buffer-modified-p nil)
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)))
480 ;;; vlf-occur.el ends here