X-Git-Url: https://code.delx.au/gnu-emacs-elpa/blobdiff_plain/7281b77c3c38ca4ab7cff8d60df4ef05f9fa7a89..0d834ff627ae024cd1edfb21023f506737139f24:/packages/vlf/vlf-occur.el

diff --git a/packages/vlf/vlf-occur.el b/packages/vlf/vlf-occur.el
index 3b7be8510..71d162846 100644
--- a/packages/vlf/vlf-occur.el
+++ b/packages/vlf/vlf-occur.el
@@ -29,6 +29,24 @@
 
 (require 'vlf)
 
+(defvar vlf-occur-vlf-file nil "VLF file that is searched.")
+(make-variable-buffer-local 'vlf-occur-vlf-file)
+
+(defvar vlf-occur-vlf-buffer nil "VLF buffer that is scanned.")
+(make-variable-buffer-local 'vlf-occur-vlf-buffer)
+
+(defvar vlf-occur-regexp)
+(make-variable-buffer-local 'vlf-occur-regexp)
+
+(defvar vlf-occur-hexl nil "Is `hexl-mode' active?")
+(make-variable-buffer-local 'vlf-occur-hexl)
+
+(defvar vlf-occur-lines 0 "Number of lines scanned by `vlf-occur'.")
+(make-variable-buffer-local 'vlf-occur-lines)
+
+(defvar tramp-verbose)
+(defvar hexl-bits)
+
 (defvar vlf-occur-mode-map
   (let ((map (make-sparse-keymap)))
     (define-key map "n" 'vlf-occur-next-match)
@@ -37,16 +55,18 @@
     (define-key map "\M-\r" 'vlf-occur-visit-new-buffer)
     (define-key map [mouse-1] 'vlf-occur-visit)
     (define-key map "o" 'vlf-occur-show)
+    (define-key map [remap save-buffer] 'vlf-occur-save)
     map)
   "Keymap for command `vlf-occur-mode'.")
 
 (define-derived-mode vlf-occur-mode special-mode "VLF[occur]"
-  "Major mode for showing occur matches of VLF opened files.")
+  "Major mode for showing occur matches of VLF opened files."
+  (add-hook 'write-file-functions 'vlf-occur-save nil t))
 
 (defun vlf-occur-next-match ()
   "Move cursor to next match."
   (interactive)
-  (if (eq (get-char-property (point) 'face) 'match)
+  (if (eq (get-text-property (point) 'face) 'match)
       (goto-char (next-single-property-change (point) 'face)))
   (goto-char (or (text-property-any (point) (point-max) 'face 'match)
                  (text-property-any (point-min) (point)
@@ -55,9 +75,9 @@
 (defun vlf-occur-prev-match ()
   "Move cursor to previous match."
   (interactive)
-  (if (eq (get-char-property (point) 'face) 'match)
+  (if (eq (get-text-property (point) 'face) 'match)
       (goto-char (previous-single-property-change (point) 'face)))
-  (while (not (eq (get-char-property (point) 'face) 'match))
+  (while (not (eq (get-text-property (point) 'face) 'match))
     (goto-char (or (previous-single-property-change (point) 'face)
                    (point-max)))))
 
@@ -90,161 +110,370 @@ EVENT may hold details of the invocation."
     (set-buffer (window-buffer (posn-window (event-end event))))
     (goto-char (posn-point (event-end event))))
   (let* ((pos (point))
-         (pos-relative (- pos (line-beginning-position) 1))
-         (file (get-char-property pos 'file)))
-    (if file
-        (let ((chunk-start (get-char-property pos 'chunk-start))
-              (chunk-end (get-char-property pos 'chunk-end))
-              (vlf-buffer (get-char-property pos 'buffer))
+         (pos-relative (- pos (previous-single-char-property-change
+                               pos 'vlf-match)))
+         (chunk-start (get-text-property pos 'chunk-start)))
+    (if chunk-start
+        (let ((chunk-end (get-text-property pos 'chunk-end))
+              (file (if (file-exists-p vlf-occur-vlf-file)
+                        vlf-occur-vlf-file
+                      (setq vlf-occur-vlf-file
+                            (read-file-name
+                             (concat vlf-occur-vlf-file
+                                     " doesn't exist, locate it: ")))))
+              (vlf-buffer vlf-occur-vlf-buffer)
+              (not-hexl (not vlf-occur-hexl))
               (occur-buffer (current-buffer))
-              (match-pos (+ (get-char-property pos 'line-pos)
+              (match-pos (+ (get-text-property pos 'line-pos)
                             pos-relative)))
           (cond (current-prefix-arg
-                 (setq vlf-buffer (vlf file))
+                 (let ((original-occur-buffer vlf-occur-vlf-buffer))
+                   (setq vlf-buffer (vlf file t))
+                   (if (buffer-live-p original-occur-buffer)
+                       (vlf-tune-copy-profile original-occur-buffer)))
+                 (or not-hexl (hexl-mode))
                  (switch-to-buffer occur-buffer))
                 ((not (buffer-live-p vlf-buffer))
-                 (or (catch 'found
-                       (dolist (buf (buffer-list))
-                         (set-buffer buf)
-                         (and vlf-mode (equal file buffer-file-name)
-                              (setq vlf-buffer buf)
-                              (throw 'found t))))
-                     (setq vlf-buffer (vlf file)))
-                 (switch-to-buffer occur-buffer)))
+                 (unless (catch 'found
+                           (dolist (buf (buffer-list))
+                             (set-buffer buf)
+                             (and vlf-mode
+                                  (equal file buffer-file-name)
+                                  (eq (not (derived-mode-p 'hexl-mode))
+                                      not-hexl)
+                                  (setq vlf-buffer buf)
+                                  (throw 'found t))))
+                   (setq vlf-buffer (vlf file t))
+                   (or not-hexl (hexl-mode)))
+                 (switch-to-buffer occur-buffer)
+                 (setq vlf-occur-vlf-buffer vlf-buffer)))
           (pop-to-buffer vlf-buffer)
           (vlf-move-to-chunk chunk-start chunk-end)
           (goto-char match-pos)))))
 
+(defun vlf-occur-other-buffer (regexp)
+  "Make whole file occur style index for REGEXP branching to new buffer.
+Prematurely ending indexing will still show what's found so far."
+  (let ((vlf-buffer (current-buffer))
+        (file buffer-file-name)
+        (file-size vlf-file-size)
+        (batch-size vlf-batch-size)
+        (is-hexl (derived-mode-p 'hexl-mode)))
+    (with-temp-buffer
+      (setq buffer-file-name file
+            buffer-file-truename file
+            buffer-undo-list t
+            vlf-file-size file-size)
+      (set-buffer-modified-p nil)
+      (set (make-local-variable 'vlf-batch-size) batch-size)
+      (when vlf-tune-enabled
+        (vlf-tune-copy-profile vlf-buffer)
+        (vlf-tune-batch (if is-hexl
+                            '(:hexl :raw)
+                          '(:insert :encode)) t))
+      (vlf-mode 1)
+      (if is-hexl (hexl-mode))
+      (goto-char (point-min))
+      (vlf-build-occur regexp vlf-buffer)
+      (if vlf-tune-enabled
+          (vlf-tune-copy-profile (current-buffer) vlf-buffer)))))
+
 (defun vlf-occur (regexp)
   "Make whole file occur style index for REGEXP.
 Prematurely ending indexing will still show what's found so far."
   (interactive (list (read-regexp "List lines matching regexp"
                                   (if regexp-history
                                       (car regexp-history)))))
-  (if (buffer-modified-p) ;use temporary buffer not to interfere with modifications
-      (let ((vlf-buffer (current-buffer))
-            (file buffer-file-name)
-            (batch-size vlf-batch-size))
-        (with-temp-buffer
-          (setq buffer-file-name file)
-          (set-buffer-modified-p nil)
-          (set (make-local-variable 'vlf-batch-size) batch-size)
-          (vlf-mode 1)
-          (goto-char (point-min))
-          (vlf-with-undo-disabled
-           (vlf-build-occur regexp vlf-buffer))))
+  (run-hook-with-args 'vlf-before-batch-functions 'occur)
+  (if (or (buffer-modified-p)
+          (consp buffer-undo-list)
+          (< vlf-batch-size vlf-start-pos))
+      (vlf-occur-other-buffer regexp)
     (let ((start-pos vlf-start-pos)
           (end-pos vlf-end-pos)
-          (pos (point)))
-      (vlf-with-undo-disabled
-       (vlf-beginning-of-file)
-       (goto-char (point-min))
-       (unwind-protect (vlf-build-occur regexp (current-buffer))
-         (vlf-move-to-chunk start-pos end-pos)
-         (goto-char pos))))))
+          (pos (point))
+          (batch-size vlf-batch-size))
+      (vlf-tune-batch (if (derived-mode-p 'hexl-mode)
+                          '(:hexl :raw)
+                        '(:insert :encode)) t)
+      (vlf-move-to-batch 0)
+      (goto-char (point-min))
+      (unwind-protect (vlf-build-occur regexp (current-buffer))
+        (vlf-move-to-chunk start-pos end-pos)
+        (goto-char pos)
+        (setq vlf-batch-size batch-size))))
+  (run-hook-with-args 'vlf-after-batch-functions 'occur))
 
 (defun vlf-build-occur (regexp vlf-buffer)
   "Build occur style index for REGEXP over VLF-BUFFER."
-  (let ((tramp-verbose (min 2 tramp-verbose))
-        (case-fold-search t)
-        (line 1)
-        (last-match-line 0)
-        (last-line-pos (point-min))
-        (file buffer-file-name)
-        (total-matches 0)
-        (match-end-pos (+ vlf-start-pos (position-bytes (point))))
-        (occur-buffer (generate-new-buffer
-                       (concat "*VLF-occur " (file-name-nondirectory
-                                              buffer-file-name)
-                               "*")))
-        (line-regexp (concat "\\(?5:[\n\C-m]\\)\\|\\(?10:"
-                             regexp "\\)"))
-        (batch-step (/ vlf-batch-size 8))
-        (end-of-file nil)
-        (reporter (make-progress-reporter
-                   (concat "Building index for " regexp "...")
-                   vlf-start-pos vlf-file-size)))
+  (let* ((tramp-verbose (if (boundp 'tramp-verbose)
+                            (min tramp-verbose 1)))
+         (case-fold-search t)
+         (line 1)
+         (last-match-line 0)
+         (total-matches 0)
+         (first-line-offset 0)
+         (first-line-incomplete nil)
+         (match-start-point (point-min))
+         (match-end-point match-start-point)
+         (last-match-insert-point nil)
+         (occur-buffer (generate-new-buffer
+                        (concat "*VLF-occur " (file-name-nondirectory
+                                               buffer-file-name)
+                                "*")))
+         (is-hexl (derived-mode-p 'hexl-mode))
+         (end-of-file nil)
+         (time (float-time))
+         (tune-types (if is-hexl '(:hexl :raw)
+                       '(:insert :encode)))
+         (reporter (make-progress-reporter
+                    (concat "Building index for " regexp "...")
+                    vlf-start-pos vlf-file-size)))
+    (with-current-buffer occur-buffer
+      (setq buffer-undo-list t))
     (unwind-protect
         (progn
           (while (not end-of-file)
-            (if (re-search-forward line-regexp nil t)
+            (if (re-search-forward regexp nil t)
                 (progn
-                  (setq match-end-pos (+ vlf-start-pos
-                                         (position-bytes
-                                          (match-end 0))))
-                  (if (match-string 5)
-                      (setq line (1+ line) ; line detected
-                            last-line-pos (point))
-                    (let* ((chunk-start vlf-start-pos)
-                           (chunk-end vlf-end-pos)
-                           (line-pos (line-beginning-position))
-                           (line-text (buffer-substring
-                                       line-pos (line-end-position))))
-                      (with-current-buffer occur-buffer
-                        (unless (= line last-match-line) ;new match line
-                          (insert "\n:") ; insert line number
-                          (let* ((overlay-pos (1- (point)))
-                                 (overlay (make-overlay
-                                           overlay-pos
-                                           (1+ overlay-pos))))
-                            (overlay-put overlay 'before-string
-                                         (propertize
-                                          (number-to-string line)
-                                          'face 'shadow)))
-                          (insert (propertize line-text ; insert line
-                                              'file file
-                                              'buffer vlf-buffer
-                                              'chunk-start chunk-start
-                                              'chunk-end chunk-end
-                                              'mouse-face '(highlight)
-                                              'line-pos line-pos
-                                              'help-echo
-                                              (format "Move to line %d"
-                                                      line))))
-                        (setq last-match-line line
-                              total-matches (1+ total-matches))
-                        (let ((line-start (1+
-                                           (line-beginning-position)))
-                              (match-pos (match-beginning 10)))
-                          (add-text-properties ; mark match
-                           (+ line-start match-pos (- last-line-pos))
-                           (+ line-start (match-end 10)
-                              (- last-line-pos))
-                           (list 'face 'match
+                  (setq line (+ line -1
+                                (count-lines match-start-point
+                                             (1+ (match-beginning 0))))
+                        match-start-point (match-beginning 0)
+                        match-end-point (match-end 0))
+                  (let* ((chunk-start vlf-start-pos)
+                         (chunk-end vlf-end-pos)
+                         (line-pos (save-excursion
+                                     (goto-char match-start-point)
+                                     (line-beginning-position)))
+                         (line-text (buffer-substring
+                                     line-pos (line-end-position))))
+                    (if (/= line-pos (point-min))
+                        (setq first-line-offset 0
+                              first-line-incomplete nil))
+                    (with-current-buffer occur-buffer
+                      (unless (= line last-match-line) ;new match line
+                        (insert "\n:") ; insert line number
+                        (let* ((column-point (1- (point)))
+                               (overlay-pos column-point)
+                               (overlay (make-overlay
+                                         overlay-pos
+                                         (1+ overlay-pos))))
+                          (overlay-put overlay 'before-string
+                                       (propertize
+                                        (number-to-string line)
+                                        'face 'shadow))
+                          (overlay-put overlay 'vlf-match t)
+                          (setq last-match-insert-point column-point
+                                first-line-offset 0)))
+                      (when (or first-line-incomplete
+                                (/= line last-match-line))
+                        (insert (propertize
+                                 (if first-line-incomplete
+                                     (substring line-text
+                                                first-line-incomplete)
+                                   line-text)
+                                 'chunk-start chunk-start
+                                 'chunk-end chunk-end
+                                 'mouse-face '(highlight)
+                                 'line-pos line-pos
                                  'help-echo
-                                 (format "Move to match %d"
-                                         total-matches))))))))
+                                 (format "Move to line %d"
+                                         line)))
+                        (setq first-line-incomplete nil))
+                      (setq last-match-line line
+                            total-matches (1+ total-matches))
+                      (let ((line-start (+ last-match-insert-point
+                                           first-line-offset 1
+                                           (- line-pos))))
+                        (add-text-properties ; mark match
+                         (+ line-start match-start-point)
+                         (+ line-start match-end-point)
+                         (list 'face 'match
+                               'help-echo (format "Move to match %d"
+                                                  total-matches)))))))
               (setq end-of-file (= vlf-end-pos vlf-file-size))
               (unless end-of-file
-                (let ((batch-move (- vlf-end-pos batch-step)))
-                  (vlf-move-to-batch (if (< batch-move match-end-pos)
-                                         match-end-pos
-                                       batch-move) t))
-                (goto-char (if (< vlf-start-pos match-end-pos)
-                               (or (byte-to-position (- match-end-pos
-                                                        vlf-start-pos))
-                                   (point-min))
-                             (point-min)))
-                (setq last-match-line 0
-                      last-line-pos (line-beginning-position))
-                (progress-reporter-update reporter vlf-end-pos))))
+                (let ((start
+                       (if is-hexl
+                           (progn
+                             (goto-char (point-max))
+                             (forward-line -10)
+                             (setq line
+                                   (+ line
+                                      (if (< match-end-point (point))
+                                          (count-lines match-start-point
+                                                       (point))
+                                        (goto-char match-end-point)
+                                        (1- (count-lines match-start-point
+                                                         match-end-point)))))
+                             (- vlf-end-pos (* (- 10 (forward-line 10))
+                                               hexl-bits)))
+                         (let* ((pmax (point-max))
+                                (batch-step (min 1024 (/ vlf-batch-size
+                                                         10)))
+                                (batch-point
+                                 (max match-end-point
+                                      (or
+                                       (byte-to-position
+                                        (- vlf-batch-size batch-step))
+                                       (progn
+                                         (goto-char pmax)
+                                         (let ((last (line-beginning-position)))
+                                           (if (= last (point-min))
+                                               (1- (point))
+                                             last)))))))
+                           (goto-char batch-point)
+                           (setq first-line-offset
+                                 (- batch-point (line-beginning-position))
+                                 line
+                                 (+ line
+                                    (count-lines match-start-point
+                                                 batch-point)
+                                    (if (< 0 first-line-offset) -1 0)))
+                           ;; last match is on the last line?
+                           (goto-char match-end-point)
+                           (forward-line)
+                           (setq first-line-incomplete
+                                 (if (= (point) pmax)
+                                     (- pmax match-end-point)))
+                           (vlf-byte-position batch-point)))))
+                  (vlf-tune-batch tune-types)
+                  (setq vlf-end-pos start) ;not to adjust start
+                  (vlf-move-to-chunk start (+ start vlf-batch-size)))
+                (setq match-start-point (point-min)
+                      match-end-point match-start-point)
+                (goto-char match-end-point)
+                (progress-reporter-update reporter vlf-start-pos))))
           (progress-reporter-done reporter))
       (set-buffer-modified-p nil)
       (if (zerop total-matches)
-          (progn (with-current-buffer occur-buffer
-                   (set-buffer-modified-p nil))
-                 (kill-buffer occur-buffer)
-                 (message "No matches for \"%s\"" regexp))
-        (with-current-buffer occur-buffer
-          (goto-char (point-min))
-          (insert (propertize
-                   (format "%d matches in %d lines for \"%s\" \
+          (progn (kill-buffer occur-buffer)
+                 (message "No matches for \"%s\" (%f secs)"
+                          regexp (- (float-time) time)))
+        (let ((file buffer-file-name)
+              (dir default-directory))
+          (with-current-buffer occur-buffer
+            (insert "\n")
+            (goto-char (point-min))
+            (insert (propertize
+                     (format "%d matches from %d lines for \"%s\" \
 in file: %s" total-matches line regexp file)
-                   'face 'underline))
-          (set-buffer-modified-p nil)
-          (forward-char 2)
-          (vlf-occur-mode))
-        (display-buffer occur-buffer)))))
+                     'face 'underline))
+            (set-buffer-modified-p nil)
+            (forward-char 2)
+            (vlf-occur-mode)
+            (setq default-directory dir
+                  vlf-occur-vlf-file file
+                  vlf-occur-vlf-buffer vlf-buffer
+                  vlf-occur-regexp regexp
+                  vlf-occur-hexl is-hexl
+                  vlf-occur-lines line)))
+        (display-buffer occur-buffer)
+        (message "Occur finished for \"%s\" (%f secs)"
+                 regexp (- (float-time) time))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; save, load vlf-occur data
+
+(defun vlf-occur-save (file)
+  "Serialize `vlf-occur' results to FILE which can later be reloaded."
+  (interactive (list (or buffer-file-name
+                         (read-file-name "Save vlf-occur results in: "
+                                         nil nil nil
+                                         (concat
+                                          (file-name-nondirectory
+                                           vlf-occur-vlf-file)
+                                          ".vlfo")))))
+  (setq buffer-file-name file)
+  (let ((vlf-occur-save-buffer
+         (generate-new-buffer (concat "*VLF-occur-save "
+                                      (file-name-nondirectory file)
+                                      "*"))))
+    (with-current-buffer vlf-occur-save-buffer
+      (setq buffer-file-name file
+            buffer-undo-list t)
+      (insert ";; -*- eval: (vlf-occur-load) -*-\n"))
+    (prin1 (list vlf-occur-vlf-file vlf-occur-regexp vlf-occur-hexl
+                 vlf-occur-lines)
+           vlf-occur-save-buffer)
+    (save-excursion
+      (goto-char (point-min))
+      (let ((pmax (point-max)))
+        (while (/= pmax (goto-char (next-single-char-property-change
+                                    (1+ (point)) 'vlf-match)))
+          (let* ((pos (1+ (point)))
+                 (line (get-char-property (1- pos) 'before-string)))
+            (if line
+                (prin1 (list (string-to-number line)
+                             (get-text-property pos 'chunk-start)
+                             (get-text-property pos 'chunk-end)
+                             (get-text-property pos 'line-pos)
+                             (buffer-substring-no-properties
+                              pos (1- (next-single-char-property-change
+                                       pos 'vlf-match))))
+                       vlf-occur-save-buffer))))))
+    (with-current-buffer vlf-occur-save-buffer
+      (save-buffer))
+    (kill-buffer vlf-occur-save-buffer))
+  t)
+
+;;;###autoload
+(defun vlf-occur-load ()
+  "Load serialized `vlf-occur' results from current buffer."
+  (interactive)
+  (goto-char (point-min))
+  (let* ((vlf-occur-data-buffer (current-buffer))
+         (header (read vlf-occur-data-buffer))
+         (vlf-file (nth 0 header))
+         (regexp (nth 1 header))
+         (all-lines (nth 3 header))
+         (file buffer-file-name)
+         (vlf-occur-buffer
+          (generate-new-buffer (concat "*VLF-occur "
+                                       (file-name-nondirectory file)
+                                       "*"))))
+    (switch-to-buffer vlf-occur-buffer)
+    (setq buffer-file-name file
+          buffer-undo-list t)
+    (goto-char (point-min))
+    (let ((match-count 0)
+          (form 0))
+      (while (setq form (ignore-errors (read vlf-occur-data-buffer)))
+        (goto-char (point-max))
+        (insert "\n:")
+        (let* ((overlay-pos (1- (point)))
+               (overlay (make-overlay overlay-pos (1+ overlay-pos)))
+               (line (number-to-string (nth 0 form)))
+               (pos (point)))
+          (overlay-put overlay 'before-string
+                       (propertize line 'face 'shadow))
+          (overlay-put overlay 'vlf-match t)
+          (insert (propertize (nth 4 form) 'chunk-start (nth 1 form)
+                              'chunk-end (nth 2 form)
+                              'mouse-face '(highlight)
+                              'line-pos (nth 3 form)
+                              'help-echo (concat "Move to line "
+                                                 line)))
+          (goto-char pos)
+          (while (re-search-forward regexp nil t)
+            (add-text-properties
+             (match-beginning 0) (match-end 0)
+             (list 'face 'match 'help-echo
+                   (format "Move to match %d"
+                           (setq match-count (1+ match-count))))))))
+      (kill-buffer vlf-occur-data-buffer)
+      (goto-char (point-min))
+      (insert (propertize
+               (format "%d matches from %d lines for \"%s\" in file: %s"
+                       match-count all-lines regexp vlf-file)
+               'face 'underline)))
+    (set-buffer-modified-p nil)
+    (vlf-occur-mode)
+    (setq vlf-occur-vlf-file vlf-file
+          vlf-occur-regexp regexp
+          vlf-occur-hexl (nth 2 header)
+          vlf-occur-lines all-lines)))
 
 (provide 'vlf-occur)