cl-grep

grep.lisp (7423B)

---

 (in-package :cl-grep)
 
 (declaim (optimize (speed 3) (debug 0) (safety 0)))
 (declaim (inline format-file-result search-line))
 
 (defparameter +numw+ 4)
 (defparameter +file-lc-blacklist+ '(#\~ #\#))
 (defparameter +file-ext-blacklist+
   '("pwd" "png" "svg" "jpeg" "gif" "mov" "mp4" "mkv"
     "blob" "o" "so" "a"))
 (defparameter +dir-blacklist+ '(".git" ".venv"))
 
 (defparameter *match* nil)
 
 (defparameter *queue* nil)
 (defparameter *print-queue* nil)
 (defun setup-tasks-mgmt ()
   (setf *queue* (lq:make-queue))
   (setf *print-queue* (lq:make-queue)))
 
 (defmacro color-magenta (str)
    `(format nil "~c[35m~a~c[0m" #\ESC ,str #\ESC))
 (defmacro color-green (str)
    `(format nil "~c[32m~a~c[0m" #\ESC ,str #\ESC))
 (defmacro color-red (str)
    `(format nil "~c[91m~a~c[0m" #\ESC ,str #\ESC))
 
 (defstruct file-result
   name entries)
 
 ;; rg like combined format
 (defun format-file-result (fr stream)
   (format stream "~a: ~%" (color-magenta (file-result-name fr)))
   (loop for e in (file-result-entries fr) do
     ;; print the file name
     (format stream "~a: " (color-green (car e)))
     ;; now print the line with color coding of matching portions
     (let ((line (cadr e))
           (locs (caddr e))
           (lm (length *match*)))
       (loop with s = 0
             for n from 0 below (length locs) do
             (let ((m (nth n locs)))
               (write-string (subseq line s m) stream)
               (write-string (color-red (subseq line m (+ m lm))) stream)
               (setf s (+ m lm)))
             finally
             (format stream "~a~%" (subseq line s (length line))))))
   (format stream "~%"))
 
 ;; ;; alternative grep like format to easily test parity
 ;; (defun format-file-result (fr stream)
 ;;   (loop for e in (file-result-entries fr) do
 ;;     (write-string (format nil "~a: ~a~%" (file-result-name fr) e) stream)))
 
 ;; Search a line for all matches of our target
 ;; returns a list of positions in the line
 (defun search-line (line match-idx fmatch)
   (declare (type fixnum fmatch))
   (loop with res = (list fmatch)
         ;; todo: of-type fixnum here leads to failure
         with curr = (+ fmatch (length *match*))
         while (setf curr (sm:search-bmh8 match-idx line :start2 curr))
         do
           (setf res (append res (list curr)))
           (incf curr (length *match*))
         finally (return res)))
 
 ;; TODO: de-duplicate the functions below
 ;; it has a lot of common code copied
 
 (defun grep-file-disk (file match-idx)
   (with-open-file (stream file)
     (let ((results
            (loop for line = (read-line stream nil :eof)
                  with i of-type fixnum = 0 with fmatch = nil
                  until (eq line :eof)
                  do (incf i)
                  ;; search for location of first match
                  if (setf fmatch (sm:search-bmh8 match-idx line))
                  ;; now run the rest of the matches
                  collect (list i line (search-line line match-idx fmatch)))))
       (when results
         (lq:push-queue (make-file-result :name file :entries results)
                        *print-queue*)))))
 
 (defun grep-file-memory (file match-idx)
   (let* ((mf (init-mfile file))
          (results (loop for line = (fetch-line mf)
                         with i of-type fixnum = 0 with fmatch = nil
                         until (eq line :eof)
                         do (incf i)
                         ;; search for location of first match
                         if (setf fmatch (sm:search-bmh8 match-idx line))
                         ;; now run the rest of the matches
                         collect (list i line (search-line line match-idx fmatch)))))
     (if results
       (lq:push-queue (make-file-result :name file :entries results) *print-queue*))
     (end-mfile mf)))
 
 (defparameter grep-file-mode 'disk)
 
 (defun grep-file (file match-idx)
   (lo "Grepping file: ~a" file)
   (handler-case
     (if (eq grep-file-mode 'disk)
       (grep-file-disk file match-idx)
       (grep-file-memory file match-idx))
     (stream-error (stream)
       (lo "Skipping binary file: ~a" file))
     (error (c)
       (lo "Unknown error: ~a when reading file ~a" c file))))
 
 (defun process-task ()
   (let ((match-idx (sm:initialize-bmh8 *match*)))
     (loop
      (let ((task (lq:pop-queue *queue*)))
        (if (eq task :done)
          (return))
        (grep-file task match-idx)))))
 
 (defun result-printer ()
   (let ((bufstream (make-string-output-stream))
         (count 0))
     (declare (type fixnum count))
     (loop
       (handler-case
         (let ((task (lq:pop-queue *print-queue*)))
           (when (eq task :done)
              ;; flush out remaining stuff
              (princ (get-output-stream-string bufstream))
              (return))
           (format-file-result task bufstream)
           (incf count)
           ;; buffer and print out
           (when (eq count 10)
             (princ (get-output-stream-string bufstream))
             (clear-output)
             (setf count 0)))
         (error (c)
           (lo "Error in printing: ~a~%" c))))))
 
 (defun queue-file (file)
   (lo "Visiting file: ~a" file)
   (let* ((name (pu:file-name file))
          (lc (char name (- (length name) 1))))
     (when (member lc +file-lc-blacklist+)
       (lo "Skipping ignorable file: ~a" file)
       (return-from queue-file nil))
     (when (member (pathname-type file) +file-ext-blacklist+ :test #'equalp)
       (return-from queue-file nil))
     ;; do the actual thing here
     (lq:push-queue file *queue*)))
 
 (defun fs-walker (dir)
   (lo "Visiting dir: ~a" dir)
   (when (not dir)
     (lo "Obtained invalid dir nil, somehow.")
     (return-from fs-walker nil))
 
   (handler-case
     (progn
       ;; check if we should visit this dir
       (let ((dirname (pu:directory-name dir)))
         (when (member dirname +dir-blacklist+ :test #'equalp)
           (lo "Skipping dir: ~a" dir)
           (return-from fs-walker nil)))
       ;; process files in this dir
       (fsu:map-directory #'queue-file dir
                          :type ':file)
       ;; go through sub-folders
       (fsu:map-directory #'fs-walker dir
                             :type ':directory))
     (error (c)
       (lo "Error in walking dir ~a: ~a" dir c))))
 
 ;; Main entrypoint for the grep functionality
 (defun grep-launcher (str dir)
   (log-setup)
   (setf *match* str)
   (setup-tasks-mgmt)
   (let* ((workers (loop for i from 0 below +numw+
                         collect (bt:make-thread #'process-task)))
          (print-worker (bt:make-thread #'result-printer)))
     (fs-walker dir)
     (lo "Finished processing target walking!")
     (loop for i from 0 below +numw+
           do (lq:push-queue :done *queue*))
     (loop for w in workers do (bt:join-thread w))
     (lq:push-queue :done *print-queue*)
     (bt:join-thread print-worker)))
 
 (defun grep-func (str dirstr)
   (let ((dir (car (directory dirstr))))
     (grep-launcher str dir)))
 
 (defun main ()
   (let* ((raw-args (uiop:command-line-arguments))
          (args (process-options raw-args))
          (nargs (length args)))
     (when (or (eq nargs 0) (> nargs 2))
       (format t "Incorrect number of args passed!~%")
       (format t "Usage: cl-grep <str> <dir>~%")
       (return-from main nil))
     (let* ((arg2 (if (eq nargs 2) (cadr args) "."))
            (dirs (directory arg2)))
       (when (not dirs)
         (format t "~a found to not be a valid directory.~%" arg2)
         (format t "Quitting!~%"))
       (grep-launcher (car args) (car dirs)))))