[Emacs-diffs] trunk r117396: Do not allow out-of-range character position in Fcompare_strings.

[Dmitry Antipov]

------------------------------------------------------------
revno: 117396
revision-id: address@hidden
parent: address@hidden
committer: Dmitry Antipov <address@hidden>
branch nick: trunk
timestamp: Wed 2014-06-25 14:36:51 +0400
message:
  Do not allow out-of-range character position in Fcompare_strings.
  * src/fns.c (validate_subarray): Add prototype.
  (Fcompare_substring): Use validate_subarray to check ranges.
  Adjust comment to mention that the semantics was changed.  Also see
  http://lists.gnu.org/archive/html/emacs-devel/2014-06/msg00447.html.
  * lisp/files.el (dir-locals-find-file, file-relative-name):
  * lisp/info.el (Info-complete-menu-item):
  * lisp/minibuffer.el (completion-table-subvert): Prefer string-prefix-p
  to compare-strings to avoid out-of-range errors.
  * lisp/subr.el (string-prefix-p): Adjust to match strict range
  checking in compare-strings.
  * test/automated/fns-tests.el (fns-tests-compare-string): New test.
modified:
  lisp/ChangeLog                 changelog-20091113204419-o5vbwnq5f7feedwu-1432
  lisp/files.el                  files.el-20091113204419-o5vbwnq5f7feedwu-265
  lisp/info.el                   info.el-20091113204419-o5vbwnq5f7feedwu-261
  lisp/minibuffer.el             
minibuffer.el-20091113204419-o5vbwnq5f7feedwu-8622
  lisp/subr.el                   subr.el-20091113204419-o5vbwnq5f7feedwu-151
  src/ChangeLog                  changelog-20091113204419-o5vbwnq5f7feedwu-1438
  src/fns.c                      fns.c-20091113204419-o5vbwnq5f7feedwu-203
  test/ChangeLog                 changelog-20091113204419-o5vbwnq5f7feedwu-8588
  test/automated/fns-tests.el    fnstests.el-20140515083159-ls2r7gfl9o74ajzm-1

=== modified file 'lisp/ChangeLog'
--- a/lisp/ChangeLog    2014-06-25 01:29:07 +0000
+++ b/lisp/ChangeLog    2014-06-25 10:36:51 +0000
@@ -1,3 +1,12 @@
+2014-06-25  Dmitry Antipov  <address@hidden>
+
+       * files.el (dir-locals-find-file, file-relative-name):
+       * info.el (Info-complete-menu-item):
+       * minibuffer.el (completion-table-subvert): Prefer string-prefix-p
+       to compare-strings to avoid out-of-range errors.
+       * subr.el (string-prefix-p): Adjust to match strict range
+       checking in compare-strings.
+
 2014-06-24  Leonard Randall  <address@hidden>  (tiny change)
 
        * textmodes/reftex-parse.el (reftex-using-biblatex-p): Make search

=== modified file 'lisp/files.el'
--- a/lisp/files.el     2014-06-12 02:14:45 +0000
+++ b/lisp/files.el     2014-06-25 10:36:51 +0000
@@ -3659,10 +3659,9 @@
 ;;;     (setq locals-file nil))
     ;; Find the best cached value in `dir-locals-directory-cache'.
     (dolist (elt dir-locals-directory-cache)
-      (when (and (eq t (compare-strings file nil (length (car elt))
-                                       (car elt) nil nil
-                                       (memq system-type
-                                             '(windows-nt cygwin ms-dos))))
+      (when (and (string-prefix-p (car elt) file
+                                 (memq system-type
+                                       '(windows-nt cygwin ms-dos)))
                 (> (length (car elt)) (length (car dir-elt))))
        (setq dir-elt elt)))
     (if (and dir-elt
@@ -4507,18 +4506,14 @@
         (let ((ancestor ".")
              (filename-dir (file-name-as-directory filename)))
           (while (not
-                 (or
-                  (eq t (compare-strings filename-dir nil (length directory)
-                                         directory nil nil fold-case))
-                  (eq t (compare-strings filename nil (length directory)
-                                         directory nil nil fold-case))))
+                 (or (string-prefix-p directory filename-dir fold-case)
+                     (string-prefix-p directory filename fold-case)))
             (setq directory (file-name-directory (substring directory 0 -1))
                  ancestor (if (equal ancestor ".")
                               ".."
                             (concat "../" ancestor))))
           ;; Now ancestor is empty, or .., or ../.., etc.
-          (if (eq t (compare-strings filename nil (length directory)
-                                    directory nil nil fold-case))
+          (if (string-prefix-p directory filename fold-case)
              ;; We matched within FILENAME's directory part.
              ;; Add the rest of FILENAME onto ANCESTOR.
              (let ((rest (substring filename (length directory))))

=== modified file 'lisp/info.el'
--- a/lisp/info.el      2014-05-11 03:49:53 +0000
+++ b/lisp/info.el      2014-06-25 10:36:51 +0000
@@ -2691,9 +2691,7 @@
                      (equal (nth 1 Info-complete-cache) Info-current-node)
                      (equal (nth 2 Info-complete-cache) Info-complete-next-re)
                      (equal (nth 5 Info-complete-cache) Info-complete-nodes)
-                     (let ((prev (nth 3 Info-complete-cache)))
-                       (eq t (compare-strings string 0 (length prev)
-                                              prev 0 nil t))))
+                     (string-prefix-p (nth 3 Info-complete-cache) string) t)
                 ;; We can reuse the previous list.
                 (setq completions (nth 4 Info-complete-cache))
               ;; The cache can't be used.

=== modified file 'lisp/minibuffer.el'
--- a/lisp/minibuffer.el        2014-06-02 00:18:22 +0000
+++ b/lisp/minibuffer.el        2014-06-25 10:36:51 +0000
@@ -244,8 +244,7 @@
 form (concat S1 S) in the same way as TABLE completes strings of
 the form (concat S2 S)."
   (lambda (string pred action)
-    (let* ((str (if (eq t (compare-strings string 0 (length s1) s1 nil nil
-                                           completion-ignore-case))
+    (let* ((str (if (string-prefix-p s1 string completion-ignore-case)
                     (concat s2 (substring string (length s1)))))
            (res (if str (complete-with-action action table str pred))))
       (when res
@@ -257,8 +256,7 @@
                     (+ beg (- (length s1) (length s2))))
               . ,(and (eq (car-safe res) 'boundaries) (cddr res)))))
          ((stringp res)
-          (if (eq t (compare-strings res 0 (length s2) s2 nil nil
-                                     completion-ignore-case))
+          (if (string-prefix-p s2 string completion-ignore-case)
               (concat s1 (substring res (length s2)))))
          ((eq action t)
           (let ((bounds (completion-boundaries str table pred "")))

=== modified file 'lisp/subr.el'
--- a/lisp/subr.el      2014-06-15 00:06:30 +0000
+++ b/lisp/subr.el      2014-06-25 10:36:51 +0000
@@ -3677,12 +3677,14 @@
       (setq matches (cons (substring string start l) matches)) ; leftover
       (apply #'concat (nreverse matches)))))
 
-(defun string-prefix-p (str1 str2 &optional ignore-case)
-  "Return non-nil if STR1 is a prefix of STR2.
+(defun string-prefix-p (prefix string &optional ignore-case)
+  "Return non-nil if PREFIX is a prefix of STRING.
 If IGNORE-CASE is non-nil, the comparison is done without paying attention
 to case differences."
-  (eq t (compare-strings str1 nil nil
-                         str2 0 (length str1) ignore-case)))
+  (let ((prefix-length (length prefix)))
+    (if (> prefix-length (length string)) nil
+      (eq t (compare-strings prefix 0 prefix-length string
+                            0 prefix-length ignore-case)))))
 
 (defun string-suffix-p (suffix string  &optional ignore-case)
   "Return non-nil if SUFFIX is a suffix of STRING.

=== modified file 'src/ChangeLog'
--- a/src/ChangeLog     2014-06-24 08:10:48 +0000
+++ b/src/ChangeLog     2014-06-25 10:36:51 +0000
@@ -1,3 +1,11 @@
+2014-06-25  Dmitry Antipov  <address@hidden>
+
+       Do not allow out-of-range character position in Fcompare_strings.
+       * fns.c (validate_subarray): Add prototype.
+       (Fcompare_substring): Use validate_subarray to check ranges.
+       Adjust comment to mention that the semantics was changed.  Also see
+       http://lists.gnu.org/archive/html/emacs-devel/2014-06/msg00447.html.
+
 2014-06-24  Paul Eggert  <address@hidden>
 
        Be more consistent about the 'Qfoo' naming convention.

=== modified file 'src/fns.c'
--- a/src/fns.c 2014-05-21 03:49:58 +0000
+++ b/src/fns.c 2014-06-25 10:36:51 +0000
@@ -50,7 +50,9 @@
 static Lisp_Object Qmd5, Qsha1, Qsha224, Qsha256, Qsha384, Qsha512;
 
 static bool internal_equal (Lisp_Object, Lisp_Object, int, bool, Lisp_Object);
-
+static void validate_subarray (Lisp_Object, Lisp_Object, Lisp_Object,
+                              ptrdiff_t, EMACS_INT *, EMACS_INT *);
+
 DEFUN ("identity", Fidentity, Sidentity, 1, 1, 0,
        doc: /* Return the argument unchanged.  */)
   (Lisp_Object arg)
@@ -232,6 +234,7 @@
 \(exclusive).  If START1 is nil, it defaults to 0, the beginning of
 the string; if END1 is nil, it defaults to the length of the string.
 Likewise, in string STR2, compare the part between START2 and END2.
+Like in `substring', negative values are counted from the end.
 
 The strings are compared by the numeric values of their characters.
 For instance, STR1 is "less than" STR2 if its first differing
@@ -244,43 +247,25 @@
   - 1 - N is the number of characters that match at the beginning.
 If string STR1 is greater, the value is a positive number N;
   N - 1 is the number of characters that match at the beginning.  */)
-  (Lisp_Object str1, Lisp_Object start1, Lisp_Object end1, Lisp_Object str2, 
Lisp_Object start2, Lisp_Object end2, Lisp_Object ignore_case)
+  (Lisp_Object str1, Lisp_Object start1, Lisp_Object end1, Lisp_Object str2,
+   Lisp_Object start2, Lisp_Object end2, Lisp_Object ignore_case)
 {
-  register ptrdiff_t end1_char, end2_char;
-  register ptrdiff_t i1, i1_byte, i2, i2_byte;
+  EMACS_INT from1, to1, from2, to2;
+  ptrdiff_t i1, i1_byte, i2, i2_byte;
 
   CHECK_STRING (str1);
   CHECK_STRING (str2);
-  if (NILP (start1))
-    start1 = make_number (0);
-  if (NILP (start2))
-    start2 = make_number (0);
-  CHECK_NATNUM (start1);
-  CHECK_NATNUM (start2);
-  if (! NILP (end1))
-    CHECK_NATNUM (end1);
-  if (! NILP (end2))
-    CHECK_NATNUM (end2);
-
-  end1_char = SCHARS (str1);
-  if (! NILP (end1) && end1_char > XINT (end1))
-    end1_char = XINT (end1);
-  if (end1_char < XINT (start1))
-    args_out_of_range (str1, start1);
-
-  end2_char = SCHARS (str2);
-  if (! NILP (end2) && end2_char > XINT (end2))
-    end2_char = XINT (end2);
-  if (end2_char < XINT (start2))
-    args_out_of_range (str2, start2);
-
-  i1 = XINT (start1);
-  i2 = XINT (start2);
+
+  validate_subarray (str1, start1, end1, SCHARS (str1), &from1, &to1);
+  validate_subarray (str2, start2, end2, SCHARS (str2), &from2, &to2);
+
+  i1 = from1;
+  i2 = from2;
 
   i1_byte = string_char_to_byte (str1, i1);
   i2_byte = string_char_to_byte (str2, i2);
 
-  while (i1 < end1_char && i2 < end2_char)
+  while (i1 < to1 && i2 < to2)
     {
       /* When we find a mismatch, we must compare the
         characters, not just the bytes.  */
@@ -307,12 +292,8 @@
 
       if (! NILP (ignore_case))
        {
-         Lisp_Object tem;
-
-         tem = Fupcase (make_number (c1));
-         c1 = XINT (tem);
-         tem = Fupcase (make_number (c2));
-         c2 = XINT (tem);
+         c1 = XINT (Fupcase (make_number (c1)));
+         c2 = XINT (Fupcase (make_number (c2)));
        }
 
       if (c1 == c2)
@@ -322,15 +303,15 @@
         past the character that we are comparing;
         hence we don't add or subtract 1 here.  */
       if (c1 < c2)
-       return make_number (- i1 + XINT (start1));
+       return make_number (- i1 + from1);
       else
-       return make_number (i1 - XINT (start1));
+       return make_number (i1 - from1);
     }
 
-  if (i1 < end1_char)
-    return make_number (i1 - XINT (start1) + 1);
-  if (i2 < end2_char)
-    return make_number (- i1 + XINT (start1) - 1);
+  if (i1 < to1)
+    return make_number (i1 - from1 + 1);
+  if (i2 < to2)
+    return make_number (- i1 + from1 - 1);
 
   return Qt;
 }

=== modified file 'test/ChangeLog'
--- a/test/ChangeLog    2014-06-24 07:48:19 +0000
+++ b/test/ChangeLog    2014-06-25 10:36:51 +0000
@@ -1,3 +1,7 @@
+2014-06-25  Dmitry Antipov  <address@hidden>
+
+       * automated/fns-tests.el (fns-tests-compare-string): New test.
+
 2014-06-24  Michael Albinus  <address@hidden>
 
        * automated/tramp-tests.el (tramp-test26-process-file): Extend test

=== modified file 'test/automated/fns-tests.el'
--- a/test/automated/fns-tests.el       2014-05-22 01:09:51 +0000
+++ b/test/automated/fns-tests.el       2014-06-25 10:36:51 +0000
@@ -69,3 +69,34 @@
     (nreverse A)
     (should (equal [nil nil nil nil nil t t t t t] (vconcat A)))
     (should (equal [t t t t t nil nil nil nil nil] (vconcat (nreverse A))))))
+
+(ert-deftest fns-tests-compare-strings ()
+  (should-error (compare-strings))
+  (should-error (compare-strings "xyzzy" "xyzzy"))
+  (should-error (compare-strings "xyzzy" 0 10 "zyxxy" 0 5))
+  (should-error (compare-strings "xyzzy" 0 5 "zyxxy" -1 2))
+  (should-error (compare-strings "xyzzy" 'foo nil "zyxxy" 0 1))
+  (should-error (compare-strings "xyzzy" 0 'foo "zyxxy" 2 3))
+  (should-error (compare-strings "xyzzy" 0 2 "zyxxy" 'foo 3))
+  (should-error (compare-strings "xyzzy" nil 3 "zyxxy" 4 'foo))
+  (should (compare-strings "" nil nil "" nil nil))
+  (should (compare-strings "" 0 0 "" 0 0))
+  (should (compare-strings "test" nil nil "test" nil nil))
+  (should (compare-strings "test" nil nil "test" nil nil t))
+  (should (compare-strings "test" nil nil "test" nil nil nil))
+  (should (compare-strings "Test" nil nil "test" nil nil t))
+  (should (= (compare-strings "Test" nil nil "test" nil nil) -1))
+  (should (= (compare-strings "Test" nil nil "test" nil nil) -1))
+  (should (= (compare-strings "test" nil nil "Test" nil nil) 1))
+  (should (= (compare-strings "foobaz" nil nil "barbaz" nil nil) 1))
+  (should (= (compare-strings "barbaz" nil nil "foobar" nil nil) -1))
+  (should (= (compare-strings "foobaz" nil nil "farbaz" nil nil) 2))
+  (should (= (compare-strings "farbaz" nil nil "foobar" nil nil) -2))
+  (should (compare-strings "abcxyz" 0 2 "abcprq" 0 2))
+  (should (compare-strings "abcxyz" 0 -3 "abcprq" 0 -3))
+  (should (= (compare-strings "abcxyz" 0 6 "abcprq" 0 6) 4))
+  (should (= (compare-strings "abcprq" 0 6 "abcxyz" 0 6) -4))
+  (should (compare-strings "xyzzy" -3 4 "azza" -3 3))
+  (should (compare-strings "こんにちはｺﾝﾆﾁﾊ" nil nil "こんにちはｺﾝﾆﾁﾊ" nil nil))
+  (should (= (compare-strings "んにちはｺﾝﾆﾁﾊこ" nil nil "こんにちはｺﾝﾆﾁﾊ" nil nil) 1))
+  (should (= (compare-strings "こんにちはｺﾝﾆﾁﾊ" nil nil "んにちはｺﾝﾆﾁﾊこ" nil nil) -1)))