Monday, May 23, 2011

Emacs flush duplicated lines function

(defun flush-duplicated-lines (&optional arg)
  "Flush duplicated lines down on buffer. When region is active,
operate on region instead of rest of buffer.

By default it will flush only exatly matched lines only dropping
spaces on begin and end, prefix argument allows specify more
options."
  (interactive "P")

  (flet ((option (name default-value)
                 (if arg
                     (read-from-minibuffer (concat name " (default " (format "%S" default-value) "): "))
                   default-value)))
    
    (let ((start (if (region-active-p)
                     (region-beginning)
                   (point)))
          (end (if (region-active-p)
                   (region-end)
                 (buffer-end 1)))

          (line-side-ignore-space (not (string-equal
                                        (option "Ignore spaces on sides of line?" t)
                                        ""))))

      (labels ((shift-to-next-line ()
                                   (and (zerop (forward-line 1))
                                        (<= (line-end-position)
                                            end)))
                (chomp (str)
                      (let ((s (if (symbolp str) (symbol-name str) str)))
                        (replace-regexp-in-string "\\(^[[:space:]\n]*\\|[[:space:]\n]*$\\)" "" s)))
               
                (line-matches (line line-matcher)
                
                              (and (<= (line-end-position)
                                       end)
                                   (string-equal
                                    (if line-side-ignore-space
                                        (chomp line)
                                      line)
                                    (if line-side-ignore-space
                                        (chomp line-matcher)
                                      line-matcher))))
               
               (current-line ()
                             (buffer-substring-no-properties (line-beginning-position)
                                                             (line-end-position)))

               (delete-current-line ()

                                    (setf end
                                          (- end
                                             (- (line-end-position)
                                                (line-beginning-position))
                                             1))
                                    
                                    ;; delete line region
                                    (delete-region (line-beginning-position)
                                                   (line-end-position))
                                    ;; delete newline character
                                    (delete-char 1))

               (delete-lines-matching (line-matcher)
                                      (save-excursion
                                        (when (shift-to-next-line)
                                          (loop if (line-matches (current-line)
                                                                 line-matcher)

                                                do (delete-current-line)
                                                
                                                else if (not (shift-to-next-line))
                                                return nil)))))
        (save-excursion
          (goto-char start)
          (loop do (delete-lines-matching (current-line))
                while (shift-to-next-line)))))))

No comments: