X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-pathname.lisp;h=760399aaed7792ba70498764daba590f9091dc82;hb=92a258eda6d6f0cadd1251200285671ec92aa45f;hp=817082572aa15bcbce14cd2e51444631d26982da;hpb=09957fcf57b49ed5ae5f05d62ad12d7ddbfd8e1d;p=sbcl.git diff --git a/src/code/target-pathname.lisp b/src/code/target-pathname.lisp index 8170825..760399a 100644 --- a/src/code/target-pathname.lisp +++ b/src/code/target-pathname.lisp @@ -499,6 +499,7 @@ a host-structure or string." ;; It seems an error message is appropriate. (host (typecase host (host host) ; A valid host, use it. + ((string 0) *unix-host*) ; "" cannot be a logical host (string (find-logical-host host t)) ; logical-host or lose. (t default-host))) ; unix-host (diddle-args (and (eq (host-customary-case host) :lower) @@ -605,6 +606,41 @@ a host-structure or string." ;;;; namestrings +;;; Handle the case for PARSE-NAMESTRING parsing a potentially +;;; syntactically valid logical namestring with an explicit host. +;;; +;;; This then isn't fully general -- we are relying on the fact that +;;; we will only pass to parse-namestring namestring with an explicit +;;; logical host, so that we can pass the host return from +;;; parse-logical-namestring through to %PARSE-NAMESTRING as a truth +;;; value. Yeah, this is probably a KLUDGE - CSR, 2002-04-18 +(defun parseable-logical-namestring-p (namestr start end) + (catch 'exit + (handler-bind + ((namestring-parse-error (lambda (c) + (declare (ignore c)) + (throw 'exit nil)))) + (let ((colon (position #\: namestr :start start :end end))) + (when colon + (let ((potential-host + (logical-word-or-lose (subseq namestr start colon)))) + ;; depending on the outcome of CSR comp.lang.lisp post + ;; "can PARSE-NAMESTRING create logical hosts, we may need + ;; to do things with potential-host (create it + ;; temporarily, parse the namestring and unintern the + ;; logical host potential-host on failure. + (declare (ignore potential-host)) + (let ((result + (handler-bind + ((simple-type-error (lambda (c) + (declare (ignore c)) + (throw 'exit nil)))) + (parse-logical-namestring namestr start end)))) + ;; if we got this far, we should have an explicit host + ;; (first return value of parse-logical-namestring) + (aver result) + result))))))) + ;;; Handle the case where PARSE-NAMESTRING is actually parsing a ;;; namestring. We pick off the :JUNK-ALLOWED case then find a host to ;;; use for parsing, call the parser, then check whether the host matches. @@ -618,16 +654,42 @@ a host-structure or string." (%parse-namestring namestr host defaults start end nil) (namestring-parse-error (condition) (values nil (namestring-parse-error-offset condition)))) - (let* ((end (or end (length namestr))) - (parse-host (or host - (extract-logical-host-prefix namestr start end) - (pathname-host defaults)))) - (unless parse-host - (error "When no HOST argument is supplied, the DEFAULTS argument ~ - must have a non-null PATHNAME-HOST.")) - + (let* ((end (or end (length namestr)))) (multiple-value-bind (new-host device directory file type version) - (funcall (host-parse parse-host) namestr start end) + ;; Comments below are quotes from the HyperSpec + ;; PARSE-NAMESTRING entry, reproduced here to demonstrate + ;; that we actually have to do things this way rather than + ;; some possibly more logical way. - CSR, 2002-04-18 + (cond + ;; "If host is a logical host then thing is parsed as a + ;; logical pathname namestring on the host." + (host (funcall (host-parse host) namestr start end)) + ;; "If host is nil and thing is a syntactically valid + ;; logical pathname namestring containing an explicit + ;; host, then it is parsed as a logical pathname + ;; namestring." + ((parseable-logical-namestring-p namestr start end) + (parse-logical-namestring namestr start end)) + ;; "If host is nil, default-pathname is a logical + ;; pathname, and thing is a syntactically valid logical + ;; pathname namestring without an explicit host, then it + ;; is parsed as a logical pathname namestring on the + ;; host that is the host component of default-pathname." + ;; + ;; "Otherwise, the parsing of thing is + ;; implementation-defined." + ;; + ;; Both clauses are handled here, as the default + ;; *DEFAULT-PATHNAME-DEFAULTS has a SB-IMPL::UNIX-HOST + ;; for a host. + ((pathname-host defaults) + (funcall (host-parse (pathname-host defaults)) namestr start end)) + ;; I don't think we should ever get here, as the default + ;; host will always have a non-null HOST, given that we + ;; can't create a new pathname without going through + ;; *DEFAULT-PATHNAME-DEFAULTS*, which has a non-null + ;; host... + (t (bug "Fallen through COND in %PARSE-NAMESTRING"))) (when (and host new-host (not (eq new-host host))) (error 'simple-type-error :datum new-host @@ -643,7 +705,7 @@ a host-structure or string." "The host in the namestring, ~S,~@ does not match the explicit HOST argument, ~S." :format-arguments (list new-host host))) - (let ((pn-host (or new-host parse-host))) + (let ((pn-host (or new-host host (pathname-host defaults)))) (values (%make-maybe-logical-pathname pn-host device directory file type version) end)))))) @@ -697,6 +759,12 @@ a host-structure or string." ;; A logical host is an object of implementation-dependent nature. In ;; SBCL, it's a member of the HOST class (a subclass of STRUCTURE-OBJECT). (let ((found-host (etypecase host + ((string 0) + ;; This is a special host. It's not valid as a + ;; logical host, so it is a sensible thing to + ;; designate the physical Unix host object. So + ;; we do that. + *unix-host*) (string ;; In general ANSI-compliant Common Lisps, a ;; string might also be a physical pathname host, @@ -1079,6 +1147,12 @@ a host-structure or string." ;;; contains only legal characters. (defun logical-word-or-lose (word) (declare (string word)) + (when (string= word "") + (error 'namestring-parse-error + :complaint "Attempted to treat invalid logical hostname ~ + as a logical host:~% ~S" + :args (list word) + :namestring word :offset 0)) (let ((word (string-upcase word))) (dotimes (i (length word)) (let ((ch (schar word i))) @@ -1086,7 +1160,7 @@ a host-structure or string." (error 'namestring-parse-error :complaint "logical namestring character which ~ is not alphanumeric or hyphen:~% ~S" - :arguments (list ch) + :args (list ch) :namestring word :offset i)))) word)) @@ -1139,7 +1213,7 @@ a host-structure or string." (error 'namestring-parse-error :complaint "double asterisk inside of logical ~ word: ~S" - :arguments (list chunk) + :args (list chunk) :namestring namestring :offset (+ (cdar chunks) pos))) (pattern (subseq chunk last-pos pos))) @@ -1173,7 +1247,7 @@ a host-structure or string." (unless (member ch '(#\; #\: #\.)) (error 'namestring-parse-error :complaint "illegal character for logical pathname:~% ~S" - :arguments (list ch) + :args (list ch) :namestring namestr :offset i)) (chunks (cons ch i))))) @@ -1193,7 +1267,7 @@ a host-structure or string." (unless (and chunks (simple-string-p (caar chunks))) (error 'namestring-parse-error :complaint "expecting ~A, got ~:[nothing~;~S~]." - :arguments (list what (caar chunks) (caar chunks)) + :args (list what (caar chunks) (caar chunks)) :namestring namestr :offset (if chunks (cdar chunks) end))) (caar chunks)) @@ -1235,7 +1309,7 @@ a host-structure or string." (unless (eql (caar chunks) #\.) (error 'namestring-parse-error :complaint "expecting a dot, got ~S." - :arguments (list (caar chunks)) + :args (list (caar chunks)) :namestring namestr :offset (cdar chunks))) (if type @@ -1258,7 +1332,7 @@ a host-structure or string." (error 'namestring-parse-error :complaint "expected a positive integer, ~ got ~S" - :arguments (list str) + :args (list str) :namestring namestr :offset (+ pos (cdar chunks)))) (setq version res)))))