[prev in list] [next in list] [prev in thread] [next in thread]
List: sbcl-commits
Subject: [Sbcl-commits] master: Fix and improve UNPARSE-PHYSICAL-PIECE
From: Jan Moringen via Sbcl-commits <sbcl-commits () lists ! sourceforge ! net>
Date: 2017-12-31 20:07:58
Message-ID: 1514750878.760086.355 () sfp-scm-3 ! v30 ! ch3 ! sourceforge ! com
[Download RAW message or body]
The branch "master" has been updated in SBCL:
via 1e9551821d614ef415f083921be46367ed920734 (commit)
from 270ba3fb9d55b72dcd02427b702550efb837ef55 (commit)
- Log -----------------------------------------------------------------
commit 1e9551821d614ef415f083921be46367ed920734
Author: Jan Moringen <jmoringe@techfak.uni-bielefeld.de>
Date: Sun Dec 31 19:15:02 2017 +0100
Fix and improve UNPARSE-PHYSICAL-PIECE
* String fragments within patterns were output without escaping.
* The return value always was a fresh string, even if it would be
identical to the input.
* The implementation strategy and as result performance was very
irregular: strings were handled very efficiently while patterns
simply used a STRING-OUTPUT-STREAM.
---
NEWS | 2 +
src/code/filesys.lisp | 121 ++++++++++++++++++++++++++----------------
src/code/target-pathname.lisp | 2 +-
tests/pathnames.impure.lisp | 14 +++++
4 files changed, 92 insertions(+), 47 deletions(-)
diff --git a/NEWS b/NEWS
index 480b41f..ad6bc14 100644
--- a/NEWS
+++ b/NEWS
@@ -8,6 +8,8 @@ changes relative to sbcl-1.4.3:
roundtrips properly when both use the same :case. (lp#1739906)
* bug fix: DIRECTORY no longer gets confused when the value of
*DEFAULT-PATHNAME-DEFAULTS* has a name or type component. (lp#1740563)
+ * bug fix: pattern pieces in pathname components are correctly escaped
+ during unparsing
changes in sbcl-1.4.3 relative to sbcl-1.4.2:
* enhancement: SLEEP respects deadlines established by SB-SYS:WITH-DEADLINE.
diff --git a/src/code/filesys.lisp b/src/code/filesys.lisp
index 426055c..cc22d4b 100644
--- a/src/code/filesys.lisp
+++ b/src/code/filesys.lisp
@@ -150,53 +150,82 @@
(t
(make-pattern (pattern))))))
+(declaim (ftype (sfunction ((or (eql :wild) simple-string pattern) character)
+ simple-string)
+ unparse-physical-piece))
(defun unparse-physical-piece (thing escape-char)
- (etypecase thing
- ((member :wild) "*")
- (simple-string
- (let* ((srclen (length thing))
- (dstlen srclen))
- (dotimes (i srclen)
- (let ((char (schar thing i)))
- (case char
- ((#\* #\? #\[)
- (incf dstlen))
- (t (when (char= char escape-char)
- (incf dstlen))))))
- (let ((result (make-string dstlen))
- (dst 0))
- (dotimes (src srclen)
- (let ((char (schar thing src)))
- (case char
- ((#\* #\? #\[)
- (setf (schar result dst) escape-char)
- (incf dst))
- (t (when (char= char escape-char)
- (setf (schar result dst) escape-char)
- (incf dst))))
- (setf (schar result dst) char)
- (incf dst)))
- result)))
- (pattern
- (with-simple-output-to-string (s)
- (dolist (piece (pattern-pieces thing))
- (etypecase piece
- (simple-string
- (write-string piece s))
- (symbol
- (ecase piece
- (:multi-char-wild
- (write-string "*" s))
- (:single-char-wild
- (write-string "?" s))))
- (cons
- (case (car piece)
- (:character-set
- (write-string "[" s)
- (write-string (cdr piece) s)
- (write-string "]" s))
- (t
- (error "invalid pattern piece: ~S" piece))))))))))
+ (let ((length 0)
+ (complicated nil))
+ (declare (type index length))
+ (labels ((inspect-fragment (fragment)
+ (etypecase fragment
+ ((eql :wild)
+ (incf length)
+ t)
+ (simple-string
+ (incf length (length fragment))
+ (Loop with complicated = nil
+ for char across (the simple-string fragment)
+ when (or (char= char #\*) (char= char #\?)
+ (char= char #\[) (char= char escape-char))
+ do (setf complicated t)
+ (incf length)
+ finally (return complicated)))
+ (pattern
+ (mapcar (lambda (piece)
+ (etypecase piece
+ (simple-string
+ (inspect-fragment piece))
+ ((member :multi-char-wild :single-char-wild)
+ (incf length 1)
+ t)
+ ((cons (eql :character-set))
+ (incf length (+ 2 (length (cdr piece))))
+ t)))
+ (pattern-pieces fragment))))))
+ (setf complicated (inspect-fragment thing)))
+ (unless complicated
+ (return-from unparse-physical-piece thing))
+ (let ((result (make-string length))
+ (index 0))
+ (declare (type (simple-array character 1) result)
+ (type index index))
+ (labels ((output (character)
+ (setf (aref result index) character)
+ (incf index))
+ (output-string (string)
+ (declare (type (simple-array character 1) string))
+ (setf (subseq result index) string)
+ (incf index (length string)))
+ (unparse-fragment (fragment)
+ (etypecase fragment
+ ((eql :wild)
+ (output #\*))
+ (simple-string
+ (loop for char across (the simple-string fragment)
+ when (or (char= char #\*) (char= char #\?)
+ (char= char #\[) (char= char escape-char))
+ do (output escape-char)
+ do (output char)))
+ (pattern
+ (mapc (lambda (piece piece-complicated)
+ (etypecase piece
+ (simple-string
+ (if piece-complicated
+ (unparse-fragment piece)
+ (output-string piece)))
+ ((eql :multi-char-wild)
+ (output #\*))
+ ((eql :single-char-wild)
+ (output #\?))
+ ((cons (eql :character-set))
+ (output #\[)
+ (output-string (cdr piece))
+ (output #\]))))
+ (pattern-pieces fragment) complicated)))))
+ (declare (inline output output-string))
+ (unparse-fragment thing))
+ result)))
(defun make-matcher (piece)
(cond ((eq piece :wild)
diff --git a/src/code/target-pathname.lisp b/src/code/target-pathname.lisp
index 1fc4aed..9fe1b36 100644
--- a/src/code/target-pathname.lisp
+++ b/src/code/target-pathname.lisp
@@ -756,7 +756,7 @@ a host-structure or string."
(namestring-parse-error (condition)
(values nil (namestring-parse-error-offset condition)))))
(t
- (let* ((end (%check-vector-sequence-bounds namestr start end)))
+ (let ((end (%check-vector-sequence-bounds namestr start end)))
(multiple-value-bind (new-host device directory file type version)
;; Comments below are quotes from the HyperSpec
;; PARSE-NAMESTRING entry, reproduced here to demonstrate
diff --git a/tests/pathnames.impure.lisp b/tests/pathnames.impure.lisp
index c20a9fc..3c0c721 100644
--- a/tests/pathnames.impure.lisp
+++ b/tests/pathnames.impure.lisp
@@ -498,6 +498,8 @@
(with-test (:name enough-namestring)
(assert (equal (enough-namestring #p"foo" #p"./") "foo")))
+;;;; NAMESTRING
+
;;; bug reported by Artem V. Andreev: :WILD not handled in unparsing
;;; directory lists. lp#1738775, reported by Richard M. Kreuter, added
;;; more cases.
@@ -522,6 +524,18 @@
(test "/../" #P"/../")
(test "/../" (make-pathname :directory '(:absolute :up)))))
+(with-test (:name (namestring :escape-pattern-pieces))
+ (labels ((prepare (namestring)
+ #-win32 (substitute #\\ #\E namestring)
+ #+win32 (substitute #\^ #\E namestring))
+ (test (expected namestring)
+ (let ((pathname (pathname (prepare namestring))))
+ (assert (string= (prepare expected) (namestring pathname))))))
+ (test "*E?" "*E?")
+ (test "*E*" "*E*")
+ (test "*E[ab]" "*E[ab]")
+ (test "*EE" "*EE")))
+
;;; Printing of pathnames; see CLHS 22.1.3.1. This section was started
;;; to confirm that pathnames are printed as their namestrings under
;;; :escape nil :readably nil.
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL
------------------------------------------------------------------------------
Check out the vibrant tech community on one of the world's most
engaging tech sites, Slashdot.org! http://sdm.link/slashdot
_______________________________________________
Sbcl-commits mailing list
Sbcl-commits@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/sbcl-commits
[prev in list] [next in list] [prev in thread] [next in thread]
Configure |
About |
News |
Add a list |
Sponsored by KoreLogic