Subject: enable sorting by version in `ls-lisp-handle-switches'

From: Toru TSUNEYOSHI <[email-masked]>
Date: Sun, 07 Mar 2010 13:46:49 +0900

Package: emacs
Severity: wishlist
Tags: patch

[ resent from
  http://lists.gnu.org/archive/html/emacs-devel/2010-03/msg00206.html ]

Hello.

I made a function sorting by version in `ls-lisp-handle-switches', by
setting `dired-listing-switches' to "-alv".

At first, I made `string-version-lessp', by referring to
`glibc-2.11.1/string/strverscmp.c'.
But I was not satisfied with the spec.
So I made another function `string-logical-lessp'.

If no problems, please apply to `ls-lisp.el'.

Example:

  (sort '(
          "abc-1.0051.tgz"
          "abc-1.00501.tgz"
          "abc-1.007.tgz"
          "abc-1.012b.tgz"
          "abc-1.01a.tgz"
          )
        'string-logical-lessp)
  =>
  ("abc-1.01a.tgz"
   "abc-1.007.tgz"
   "abc-1.012b.tgz"
   "abc-1.0051.tgz"
   "abc-1.00501.tgz")

  (dired "d:/test/")
  =>
    d:/test:
    total used in directory 0 available 20000000
    drwxrwxrwx  1 Administrators none    0 Mar  7 12:03 .
    dr-xr-xr-x  1 Administrators none    0 Mar  7 12:23 ..
    -rw-rw-rw-  1 Administrators none    0 May  7 12:57 7
    -rw-rw-rw-  1 Administrators none    0 May  7 12:57 8
    -rw-rw-rw-  1 Administrators none    0 May  7 12:57 9
    -rw-rw-rw-  1 Administrators none    0 May  7 12:57 10
    -rw-rw-rw-  1 Administrators none    0 May  7 12:57 11
    -rw-rw-rw-  1 Administrators none    0 May  7 12:57 12
    -rw-rw-rw-  1 Administrators none    0 Mar  7 12:57 abc-1.01a.tgz
    -rw-rw-rw-  1 Administrators none    0 Mar  7 12:57 abc-1.007.tgz
    -rw-rw-rw-  1 Administrators none    0 Mar  7 12:57 abc-1.012b.tgz
    -rw-rw-rw-  1 Administrators none    0 Mar  7 12:57 abc-1.0051.tgz
    -rw-rw-rw-  1 Administrators none    0 Mar  7 12:57 abc-1.00501.tgz
(defun string-version-lessp (s1 s2 &optional ignore-case)
  "Return t if first arg string is less than second in version order.
Case is significant in this comparison if IGNORE-CASE is nil.
Symbols are also allowed; their print names are used instead.
See also `string-logical-lessp'.

Example:
  (sort
   '(\"foo.zml-1.gz\"          => (\"foo.zml-1.gz\"
     \"foo.zml-100.gz\"            \"foo.zml-2.gz\"
     \"foo.zml-12.gz\"             \"foo.zml-6.gz\"
     \"foo.zml-13.gz\"             \"foo.zml-12.gz\"
     \"foo.zml-2.gz\"              \"foo.zml-13.gz\"
     \"foo.zml-25.gz\"             \"foo.zml-25.gz\"
     \"foo.zml-6.gz\")             \"foo.zml-100.gz\")
   'string-version-lessp)

  (sort
   '(\"abc-1.01a.tgz\"         => (\"abc-1.007.tgz\"
     \"abc-1.007.tgz\"             \"abc-1.012b.tgz\"
     \"abc-1.012b.tgz\")           \"abc-1.01a.tgz\")
   'string-version-lessp)

  (sort
   '(\"9.000001.10.tgz\"       => (\"009.01.91.tgz\"
     \"009.01.91.tgz\")            \"9.000001.10.tgz\")
   'string-version-lessp)
"
  (let* (;; states
	 (S_N #x0)		     ; normal
	 (S_I #x3)		     ; comparing integral part
	 (S_F #x6)		     ; comparing fractionnal parts
	 (S_Z #x9)		     ; idem but with leading Zeroes only

	 ;; Symbol(s)    0       [1-9]   others
	 ;; Transition   (10) 0  (01) d  (00) x
	 ;;
	 ;;		      x   d   0	   ; state
	 (next-state (vector S_N S_I S_Z   ; S_N
			     S_N S_I S_I   ; S_I
			     S_N S_F S_F   ; S_F
			     S_N S_F S_Z)) ; S_Z

	 ;; result-type
	 (CMP 2)			; return diff
	 (LEN 3)			; compare using len_diff/diff

	 ;; `glibc-2.11.1/string/strverscmp.c'
	 ;;
	 ;;			  *p1	  *p1			    ; pair
	 ;;			      *p2	      *p2	    ;
	 ;;					  *p3	  *p3	    ;
	 ;;
	 ;;		      x/x x/d x/0 d/x d/d d/0 0/x 0/d 0/0   ; state
	 (result-type (vector CMP CMP CMP CMP LEN CMP CMP CMP CMP   ; S_N
			      CMP -1  -1  +1  LEN LEN +1  LEN LEN   ; S_I
			      CMP CMP CMP CMP CMP CMP CMP CMP CMP   ; S_F
			      CMP +1  +1  -1  CMP CMP -1  CMP CMP)) ; S_Z

;;;	 ;; like `coreutils-6.12/lib/strverscmp.c'
;;;	 ;;
;;;	 ;;		      x/x x/d x/0 d/x d/d d/0 0/x 0/d 0/0   ; state
;;;	 (result-type (vector CMP CMP CMP CMP LEN CMP CMP CMP CMP   ; S_N
;;;			      CMP -1  -1  +1  LEN LEN +1  LEN LEN   ; S_I
;;;			      CMP CMP CMP CMP LEN CMP CMP CMP CMP   ; S_F
;;;			      CMP +1  +1  -1  CMP CMP -1  CMP CMP)) ; S_Z

	 ret	     ; same style as return value of C language `strcmp'
	 l1 l2	     ; length of string s1, s2
	 (n 0)	     ; index of string s1, s2
	 c1 c2	     ; character of string s1, s2 at index n
	 state
	 diff)
    (setq ret (catch 'end
		(if (eq s1 s2)
		    (throw 'end 0))

		(if (symbolp s1)
		    (setq s1 (symbol-name s1)))
		(if (symbolp s2)
		    (setq s2 (symbol-name s2)))
		(unless (stringp s1)
		  (signal 'wrong-type-argument `(stringp ,s1)))
		(unless (stringp s2)
		  (signal 'wrong-type-argument `(stringp ,s2)))

		(if ignore-case
		    (setq s1 (upcase s1)
			  s2 (upcase s2)))

		(setq l1 (length s1)
		      l2 (length s2)

		      c1 (if (< n l1) (elt s1 n) ?\0) ; ?\0: null terminator
		      c2 (if (< n l2) (elt s2 n) ?\0)
		      n (1+ n)

		      ;; Hint: '0' is a digit too.
		      state (+ S_N
			       (if (= c1 ?0) 1 0)
			       (if (and (<= ?0 c1) (<= c1 ?9)) 1 0))) ; (isdigit (c1) != 0)

		(while (= (setq diff (- c1 c2)) 0)
		  (if (= c1 ?\0)
		      (throw 'end diff))

		  (setq state (aref next-state state)

			c1 (if (< n l1) (elt s1 n) ?\0)
			c2 (if (< n l2) (elt s2 n) ?\0)
			n (1+ n)

			state (+ state
				 (if (= c1 ?0) 1 0)
				 (if (and (<= ?0 c1) (<= c1 ?9)) 1 0))))

		(setq state (aref result-type (+ (* state 3)
						 (if (= c2 ?0) 1 0)
						 (if (and (<= ?0 c2) (<= c2 ?9)) 1 0))))

		(cond ((= state CMP)
		       (setq ret diff))
		      ((= state LEN)
		       (while (progn
				(setq c1 (if (< n l1) (elt s1 n) ?\0)
				      c2 (if (< n l2) (elt s2 n) ?\0)
				      n (1+ n))
				(and (<= ?0 c1) (<= c1 ?9)))
			 (if (not (and (<= ?0 c2) (<= c2 ?9)))
			     (throw 'end 1)))
		       (setq ret (if (and (<= ?0 c2) (<= c2 ?9)) -1 diff)))
		      (t
		       (setq ret state)))

		ret))

    ;; convert ret to the style of `string-lessp'
    (< ret 0)))

(defalias 'string-version< 'string-version-lessp)

(defun string-logical-lessp (s1 s2 &optional ignore-case)
  "Return t if first arg string is less than second in logical version order.
Case is significant in this comparison if IGNORE-CASE is nil.
Symbols are also allowed; their print names are used instead.
See also `string-version-lessp'.

Example:
  (sort
   '(\"foo.zml-1.gz\"          => (\"foo.zml-1.gz\"
     \"foo.zml-100.gz\"            \"foo.zml-2.gz\"
     \"foo.zml-12.gz\"             \"foo.zml-6.gz\"
     \"foo.zml-13.gz\"             \"foo.zml-12.gz\"
     \"foo.zml-2.gz\"              \"foo.zml-13.gz\"
     \"foo.zml-25.gz\"             \"foo.zml-25.gz\"
     \"foo.zml-6.gz\")             \"foo.zml-100.gz\")
   'string-logical-lessp)

  (sort
   '(\"abc-1.01a.tgz\"         => (\"abc-1.01a.tgz\"
     \"abc-1.007.tgz\"             \"abc-1.007.tgz\"
     \"abc-1.012b.tgz\")           \"abc-1.012b.tgz\")
   'string-logical-lessp)

  (sort
   '(\"9.000001.10.tgz\"       => (\"9.000001.10.tgz\"
     \"009.01.91.tgz\")            \"009.01.91.tgz\")
   'string-logical-lessp)
"
  (let (ret	     ; same style as return value of C language `strcmp'
	l1 l2	     ; length of string s1, s2
	(n1 0)	     ; index of string s1, s2
	(n2 0)
	(c1 -1)	; character of string s1, s2 at index n1, n2
	(c2 -1)	; (set dummy code as initial (and invalid as character) value)
	diff)
    (if (symbolp s1)
	(setq s1 (symbol-name s1)))
    (if (symbolp s2)
	(setq s2 (symbol-name s2)))
    (unless (stringp s1)
      (signal 'wrong-type-argument `(stringp ,s1)))
    (unless (stringp s2)
      (signal 'wrong-type-argument `(stringp ,s2)))

    (if ignore-case
	(setq s1 (upcase s1)
	      s2 (upcase s2)))

    (setq l1 (length s1)
	  l2 (length s2))

    (setq ret (catch 'end
		(while (= (setq diff (- c1 c2)) 0)
		  (if (or (= c1 ?\0) (= c2 ?\0))
		      (throw 'end diff))

		  (setq c1 (if (< n1 l1) (elt s1 n1) ?\0) ; ?\0: null terminator
			c2 (if (< n2 l2) (elt s2 n2) ?\0))

		  ;; encounter numbers ?
		  (if (and (<= ?0 c1) (<= c1 ?9)
			   (<= ?0 c2) (<= c2 ?9))
		      (let (sub-s1 sub-s2
			    sub-l1 sub-l2)
			;; skip needless "0"
			;;
			;; example:
			;;  "00...0" => "0"
			;;  "010"    => "10"
			;;  "000305" => "305"
			(string-match "0*\\([0-9]+\\)" s1 n1)
			(setq sub-s1 (match-string 1 s1)
			      sub-l1 (length sub-s1)
			      n1 (match-end 1))

			(string-match "0*\\([0-9]+\\)" s2 n2)
			(setq sub-s2 (match-string 1 s2)
			      sub-l2 (length sub-s2)
			      n2 (match-end 1))

			;; number whose length is shorter is smaller than another
			(cond ((< sub-l1 sub-l2)
			       (throw 'end -1))
			      ((> sub-l1 sub-l2)
			       (throw 'end 1))
			      (t
			       ;; don't use `number-to-string' because of overflow
			       (setq ret (compare-strings sub-s1 0 nil
							  sub-s2 0 nil))
			       (unless (eq ret t)
				 (throw 'end ret))))

			;; as both numbers are equal, prepare for next step
			(setq c1 (if (< n1 l1) (elt s1 n1) ?\0)
			      c2 (if (< n2 l2) (elt s2 n2) ?\0))))

		  (setq n1 (1+ n1)
			n2 (1+ n2)))

		diff))

    ;; convert ret to the style of `string-lessp'
    (< ret 0)))

(defalias 'string-logical< 'string-logical-lessp)
--- ls-lisp.el.orig	2009-06-21 13:37:45.000000000 +0900
+++ ls-lisp.el	2010-03-07 11:09:33.595406400 +0900
@@ -196,6 +196,9 @@
 (or (featurep 'ls-lisp)  ; FJW: unless this file is being reloaded!
     (setq original-insert-directory (symbol-function 'insert-directory)))
 
+;;(defalias 'ls-lisp-version-lessp 'string-version-lessp)
+(defalias 'ls-lisp-version-lessp 'string-logical-lessp)
+
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
@@ -493,6 +496,32 @@
 	(error (message "Unsorted (ls-lisp sorting error) - %s"
 			(error-message-string err))
 	       (ding) (sit-for 2))))	; to show user the message!
+  ;; Should execute `ls-lisp-version-lessp'
+  ;; after sorting by `ls-lisp-string-lessp' or others
+  ;;
+  ;; The reason:
+  ;;    See the following numbers.
+  ;;      "1.5"
+  ;;	  "1.05"
+  ;;
+  ;;    `ls-lisp-string-lessp' *may* eval that both numbers are equal.
+  ;;    So the function returns `nil'. In other words, the order is unchanged.
+  ;;    But it is clear that these numbers shoud be sorted
+  ;;    in lexicographic order before.
+  (if (and (not (memq ?U switches)) ; unsorted
+	   (memq ?v switches))
+      ;; Catch and ignore unexpected sorting errors
+      (condition-case err
+	  (setq file-alist
+		(let (index)
+		  ;; Copy file-alist in case of error
+		  (sort (copy-sequence file-alist) ; modifies its argument!
+			(lambda (x y) ; sorted on version
+			  (ls-lisp-version-lessp (car x) (car y)
+						 ls-lisp-ignore-case)))))
+	(error (message "Unsorted (ls-lisp sorting error) - %s"
+			(error-message-string err))
+	       (ding) (sit-for 2)))) ; to show user the message!
   (if (memq ?F switches)		; classify switch
       (setq file-alist (mapcar 'ls-lisp-classify file-alist)))
   (if ls-lisp-dirs-first
;; (query-replace "string-version-lessp" "string-logical-lessp")
;; (query-replace "string-logical-lessp" "string-version-lessp")

(sort '(
	"foo.zml-1.gz"
	"foo.zml-100.gz"
	"foo.zml-12.gz"
	"foo.zml-13.gz"
	"foo.zml-2.gz"
	"foo.zml-25.gz"
	"foo.zml-6.gz"
	)
      'string-version-lessp)

(sort '(
	"foo.zml-1 gz"
	"foo.zml-100 gz"
	"foo.zml-12 gz"
	"foo.zml-13 gz"
	"foo.zml-2 gz"
	"foo.zml-25 gz"
	"foo.zml-6 gz"
	)
      'string-version-lessp)

(sort '(
	"foo.zml-1~gz"
	"foo.zml-100~gz"
	"foo.zml-12~gz"
	"foo.zml-13~gz"
	"foo.zml-2~gz"
	"foo.zml-25~gz"
	"foo.zml-6~gz"
	)
      'string-version-lessp)

(sort '(
	"abc-1.0051.tgz"
	"abc-1.00501.tgz"
	"abc-1.007.tgz"
	"abc-1.012b.tgz"
	"abc-1.01a.tgz"
	)
      'string-version-lessp)

(sort '(
	"1.007.tgz"
	"1.01a.tgz"
	)
      'string-version-lessp)

(sort '(
	"012b.tgz"
	"01a.tgz"
	)
      'string-version-lessp)

(sort '(
	"01.012b.tgz"
	"009.01a.tgz"
	)
      'string-version-lessp)

(sort '(
	"9.011.tgz"
	"009.01.tgz"
	)
      'string-version-lessp)

(sort '(
	"9.000001.10tgz"
	"009.01.91tgz"
	;;"009.01.9tgz"
	;;"009.01.50tgz"
	)
      'string-version-lessp)

(sort '(
	"9,001.tgz"
	"9000.tgz"
	"9,000.tgz"
	)
      'string-version-lessp)

(sort '(
	"0123.tgz"
	"01012.tgz"
	)
      'string-version-lessp)

(sort '(
	"1.05.txt"
	"1.5.txt"
	)
      'string-version-lessp)

(sort '(
	"a001b.txt"
	"a0b.txt"
	)
      'string-version-lessp)

(sort '(
	"a01b.txt"
	"a0b.txt"
	)
      'string-version-lessp)

(sort '(
	"abc001.txt"
	"abc0a.txt"
	)
      'string-version-lessp)