/[cmucl]/src/code/filesys.lisp
ViewVC logotype

Diff of /src/code/filesys.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.104.4.4 by rtoy, Mon Jun 23 15:03:31 2008 UTC revision 1.114 by rtoy, Tue Mar 1 04:32:58 2011 UTC
# Line 18  Line 18 
18    
19  (in-package "LISP")  (in-package "LISP")
20    
21    (intl:textdomain "cmucl")
22    
23  (export '(truename probe-file user-homedir-pathname directory  (export '(truename probe-file user-homedir-pathname directory
24            rename-file delete-file file-write-date file-author))            rename-file delete-file file-write-date file-author))
25    
# Line 92  Line 94 
94                        (incf dst)))))))                        (incf dst)))))))
95      (when quoted      (when quoted
96        (error 'namestring-parse-error        (error 'namestring-parse-error
97               :complaint "Backslash in bad place."               :complaint (intl:gettext "Backslash in bad place.")
98               :namestring namestr               :namestring namestr
99               :offset (1- end)))               :offset (1- end)))
100      (shrink-vector result dst)))      (shrink-vector result dst)))
# Line 150  Line 152 
152                                (position #\] namestr :start index :end end)))                                (position #\] namestr :start index :end end)))
153                           (unless close-bracket                           (unless close-bracket
154                             (error 'namestring-parse-error                             (error 'namestring-parse-error
155                                    :complaint "``['' with no corresponding ``]''"                                    :complaint (intl:gettext "``['' with no corresponding ``]''")
156                                    :namestring namestr                                    :namestring namestr
157                                    :offset index))                                    :offset index))
158                           (pattern (list :character-set                           (pattern (list :character-set
# Line 320  Line 322 
322                       ;; same, we can't allow the creation of one when                       ;; same, we can't allow the creation of one when
323                       ;; the other is defined.                       ;; the other is defined.
324                       (when (find-logical-host search-list nil)                       (when (find-logical-host search-list nil)
325                         (error "~A already names a logical host" search-list))                         (error (intl:gettext "~A already names a logical host") search-list))
326                       (setf absolute t)                       (setf absolute t)
327                       (setf (car first) new-start))                       (setf (car first) new-start))
328                     search-list)))))                     search-list)))))
# Line 405  Line 407 
407    ;; this host designator needs to be recognized as a physical host in    ;; this host designator needs to be recognized as a physical host in
408    ;; PARSE-NAMESTRING. Until sbcl-0.7.3.x, we had "Unix" here, but    ;; PARSE-NAMESTRING. Until sbcl-0.7.3.x, we had "Unix" here, but
409    ;; that's a valid Logical Hostname, so that's a bad choice. -- CSR,    ;; that's a valid Logical Hostname, so that's a bad choice. -- CSR,
410      ;;
411      ;; No it isn't - in fact, I'm pretty sure "" is illegal here (and if
412      ;; it isn't, it should be - it ought to mean "the default host", from
413      ;; *default-pathname-defaults*)  -- P. Foley
414    "")    "")
415    
416  (defun unparse-unix-piece (thing)  (defun unparse-unix-piece (thing)
# Line 453  Line 459 
459                 (strings (second piece))                 (strings (second piece))
460                 (strings "]"))                 (strings "]"))
461                (t                (t
462                 (error "Invalid pattern piece: ~S" piece))))))                 (error (intl:gettext "Invalid pattern piece: ~S") piece))))))
463         (apply #'concatenate         (apply #'concatenate
464                'simple-string                'simple-string
465                (strings))))))                (strings))))))
# Line 479  Line 485 
485            ((member :up)            ((member :up)
486             (pieces "../"))             (pieces "../"))
487            ((member :back)            ((member :back)
488             (error ":BACK cannot be represented in namestrings."))             (error (intl:gettext ":BACK cannot be represented in namestrings.")))
489            ((member :wild-inferiors)            ((member :wild-inferiors)
490             (pieces "**/"))             (pieces "**/"))
491            ((or simple-string pattern (eql :wild))            ((or simple-string pattern (eql :wild))
492             (pieces (unparse-unix-piece dir))             (pieces (unparse-unix-piece dir))
493             (pieces "/"))             (pieces "/"))
494            (t            (t
495             (error "Invalid directory component: ~S" dir)))))             (error (intl:gettext "Invalid directory component: ~S") dir)))))
496      (apply #'concatenate 'simple-string (pieces))))      (apply #'concatenate 'simple-string (pieces))))
497    
498  (defun unparse-unix-directory (pathname)  (defun unparse-unix-directory (pathname)
# Line 510  Line 516 
516        (when name        (when name
517          (when (stringp name)          (when (stringp name)
518            (when (find #\/ name)            (when (find #\/ name)
519              (error "Cannot specify a directory separator in a pathname name: ~S" name))              (error (intl:gettext "Cannot specify a directory separator in a pathname name: ~S") name))
520            (when (and (not type-supplied)            (when (and (not type-supplied)
521                       (find #\. name :start 1))                       (find #\. name :start 1))
522              ;; A single leading dot is ok.              ;; A single leading dot is ok.
523              (error "Cannot specify a dot in a pathname name without a pathname type: ~S" name))              (error (intl:gettext "Cannot specify a dot in a pathname name without a pathname type: ~S") name))
524            (when (or (and (string= ".." name)            (when (or (and (string= ".." name)
525                           (not type-supplied))                           (not type-supplied))
526                      (and (string= "." name)                      (and (string= "." name)
527                           (not type-supplied)))                           (not type-supplied)))
528              ;; Can't have a name of ".." or "." without a type.              ;; Can't have a name of ".." or "." without a type.
529              (error "Invalid value for a pathname name: ~S" name)))              (error (intl:gettext "Invalid value for a pathname name: ~S") name)))
530          (strings (unparse-unix-piece name)))          (strings (unparse-unix-piece name)))
531        (when type-supplied        (when type-supplied
532          (unless name          (unless name
533            (error "Cannot specify the type without a file: ~S" pathname))            (error (intl:gettext "Cannot specify the type without a file: ~S") pathname))
534          (when (stringp type)          (when (stringp type)
535            (when (find #\/ type)            (when (find #\/ type)
536              (error "Cannot specify a directory separator in a pathname type: ~S" type))              (error (intl:gettext "Cannot specify a directory separator in a pathname type: ~S") type))
537            (when (find #\. type)            (when (find #\. type)
538              (error "Cannot specify a dot in a pathname type: ~S" type)))              (error (intl:gettext "Cannot specify a dot in a pathname type: ~S") type)))
539          (strings ".")          (strings ".")
540          (strings (unparse-unix-piece type)))          (strings (unparse-unix-piece type)))
541        (when (and (not (member version '(nil :newest :unspecific)))        (when (and (not (member version '(nil :newest :unspecific)))
542                   (not name))                   (not name))
543          ;; We don't want version without a name, because when we try          ;; We don't want version without a name, because when we try
544          ;; to read #p".~*~" back, the name is "", not NIL.          ;; to read #p".~*~" back, the name is "", not NIL.
545          (error "Cannot specify a version without a file: ~S" pathname))          (error (intl:gettext "Cannot specify a version without a file: ~S") pathname))
546        (when version-supplied        (when version-supplied
547          (strings (if (eq version :wild)          (strings (if (eq version :wild)
548                       (if logical-p ".*" ".~*~")                       (if logical-p ".*" ".~*~")
# Line 553  Line 559 
559  (defun unparse-unix-enough (pathname defaults)  (defun unparse-unix-enough (pathname defaults)
560    (declare (type pathname pathname defaults))    (declare (type pathname pathname defaults))
561    (flet ((lose ()    (flet ((lose ()
562             (error "~S cannot be represented relative to ~S"             (error (intl:gettext "~S cannot be represented relative to ~S")
563                    pathname defaults)))                    pathname defaults)))
564      ;; Only the first path in a search-list is considered.      ;; Only the first path in a search-list is considered.
565      (enumerate-search-list (pathname pathname)      (enumerate-search-list (pathname pathname)
# Line 654  Line 660 
660  ;;;; Wildcard matching stuff.  ;;;; Wildcard matching stuff.
661    
662  (defmacro enumerate-matches ((var pathname &optional result  (defmacro enumerate-matches ((var pathname &optional result
663                                    &key (verify-existance t) (follow-links t))                                    &key (verify-existence t) (follow-links t))
664                               &body body)                               &body body)
665    (let ((body-name (gensym)))    (let ((body-name (gensym)))
666      `(block nil      `(block nil
667         (flet ((,body-name (,var)         (flet ((,body-name (,var)
668                  ,@body))                  ,@body))
669           (%enumerate-matches (pathname ,pathname)           (%enumerate-matches (pathname ,pathname)
670                               ,verify-existance ,follow-links                               ,verify-existence ,follow-links
671                               #',body-name)                               #',body-name)
672           ,result))))           ,result))))
673    
674  (defun %enumerate-matches (pathname verify-existance follow-links function)  (defun %enumerate-matches (pathname verify-existence follow-links function)
675    (when (pathname-type pathname)    (when (pathname-type pathname)
676      (unless (pathname-name pathname)      (unless (pathname-name pathname)
677        (error "Cannot supply a type without a name:~%  ~S" pathname)))        (error (intl:gettext "Cannot supply a type without a name:~%  ~S") pathname)))
678    (let ((directory (pathname-directory pathname)))    (let ((directory (pathname-directory pathname)))
679      (if directory      (if directory
680          (ecase (car directory)          (ecase (car directory)
681            (:absolute            (:absolute
682             (%enumerate-directories "/" (cdr directory) pathname             (%enumerate-directories "/" (cdr directory) pathname
683                                     verify-existance follow-links                                     verify-existence follow-links
684                                     nil function))                                     nil function))
685            (:relative            (:relative
686             (%enumerate-directories "" (cdr directory) pathname             (%enumerate-directories "" (cdr directory) pathname
687                                     verify-existance follow-links                                     verify-existence follow-links
688                                     nil function)))                                     nil function)))
689          (%enumerate-files "" pathname verify-existance function))))          (%enumerate-files "" pathname verify-existence function))))
690    
691  ;;; %enumerate-directories  --   Internal  ;;; %enumerate-directories  --   Internal
692  ;;;  ;;;
693  ;;; The directory node and device numbers are maintained for the current path  ;;; The directory node and device numbers are maintained for the current path
694  ;;; during the search for the detection of path loops upon :wild-inferiors.  ;;; during the search for the detection of path loops upon :wild-inferiors.
695  ;;;  ;;;
696  (defun %enumerate-directories (head tail pathname verify-existance  (defun %enumerate-directories (head tail pathname verify-existence
697                                 follow-links nodes function)                                 follow-links nodes function)
698    (declare (simple-string head))    (declare (simple-string head))
699    (macrolet ((unix-xstat (name)    (macrolet ((unix-xstat (name)
# Line 721  Line 727 
727                 (with-directory-node-noted (head)                 (with-directory-node-noted (head)
728                   (%enumerate-directories (concatenate 'string head "/")                   (%enumerate-directories (concatenate 'string head "/")
729                                           (cdr tail) pathname                                           (cdr tail) pathname
730                                           verify-existance follow-links                                           verify-existence follow-links
731                                           nodes function))))                                           nodes function))))
732              ((member :wild-inferiors)              ((member :wild-inferiors)
733               (%enumerate-directories head (rest tail) pathname               (%enumerate-directories head (rest tail) pathname
734                                       verify-existance follow-links                                       verify-existence follow-links
735                                       nodes function)                                       nodes function)
736               (do-directory-entries (name head)               (do-directory-entries (name head)
737                 (let ((subdir (concatenate 'string head name)))                 (let ((subdir (concatenate 'string head name)))
# Line 740  Line 746 
746                         (let ((nodes (cons (cons dev ino) nodes))                         (let ((nodes (cons (cons dev ino) nodes))
747                               (subdir (concatenate 'string subdir "/")))                               (subdir (concatenate 'string subdir "/")))
748                           (%enumerate-directories subdir tail pathname                           (%enumerate-directories subdir tail pathname
749                                                   verify-existance follow-links                                                   verify-existence follow-links
750                                                   nodes function))))))))                                                   nodes function))))))))
751              ((or pattern (member :wild))              ((or pattern (member :wild))
752               (do-directory-entries (name head)               (do-directory-entries (name head)
# Line 754  Line 760 
760                         (let ((nodes (cons (cons dev ino) nodes))                         (let ((nodes (cons (cons dev ino) nodes))
761                               (subdir (concatenate 'string subdir "/")))                               (subdir (concatenate 'string subdir "/")))
762                           (%enumerate-directories subdir (rest tail) pathname                           (%enumerate-directories subdir (rest tail) pathname
763                                                   verify-existance follow-links                                                   verify-existence follow-links
764                                                   nodes function))))))))                                                   nodes function))))))))
765              ((member :up)              ((member :up)
766               (let ((head (concatenate 'string head "..")))               (let ((head (concatenate 'string head "..")))
767                 (with-directory-node-noted (head)                 (with-directory-node-noted (head)
768                   (%enumerate-directories (concatenate 'string head "/")                   (%enumerate-directories (concatenate 'string head "/")
769                                           (rest tail) pathname                                           (rest tail) pathname
770                                           verify-existance follow-links                                           verify-existence follow-links
771                                           nodes function))))))                                           nodes function))))))
772          (%enumerate-files head pathname verify-existance function))))          (%enumerate-files head pathname verify-existence function))))
773    
774  (defun %enumerate-files (directory pathname verify-existance function)  (defun %enumerate-files (directory pathname verify-existence function)
775    (declare (simple-string directory))    (declare (simple-string directory))
776    (let ((name (%pathname-name pathname))    (let ((name (%pathname-name pathname))
777          (type (%pathname-type pathname))          (type (%pathname-type pathname))
778          (version (%pathname-version pathname)))          (version (%pathname-version pathname)))
779      (cond ((member name '(nil :unspecific))      (cond ((member name '(nil :unspecific))
780             (when (or (not verify-existance)             (when (or (not verify-existence)
781                       (unix:unix-file-kind directory))                       (unix:unix-file-kind directory))
782               (funcall function directory)))               (funcall function directory)))
783            ((or (pattern-p name)            ((or (pattern-p name)
# Line 816  Line 822 
822                 (setf file (concatenate 'string file ".~"                 (setf file (concatenate 'string file ".~"
823                                         (quick-integer-to-string version)                                         (quick-integer-to-string version)
824                                         "~")))                                         "~")))
825               (when (or (not verify-existance)               (when (or (not verify-existence)
826                         (unix:unix-file-kind file t))                         (unix:unix-file-kind file t))
827                 (funcall function file)))))))                 (funcall function file)))))))
828    
# Line 862  Line 868 
868    (enumerate-search-list    (enumerate-search-list
869        (pathname path)        (pathname path)
870      (collect ((names))      (collect ((names))
871        (enumerate-matches (name pathname nil :verify-existance for-input        (enumerate-matches (name pathname nil :verify-existence for-input
872                                 :follow-links t)                                 :follow-links t)
873          (when (or (not executable-only)          (when (or (not executable-only)
874                    (and (eq (unix:unix-file-kind name) :file)                    (and (eq (unix:unix-file-kind name) :file)
# Line 872  Line 878 
878          (when names          (when names
879            (when (cdr names)            (when (cdr names)
880              (error 'simple-file-error              (error 'simple-file-error
881                     :format-control "~S is ambiguous:~{~%  ~A~}"                     :format-control (intl:gettext "~S is ambiguous:~{~%  ~A~}")
882                     :format-arguments (list pathname names)))                     :format-arguments (list pathname names)))
883            (return (car names))))))))            (return (car names))))))))
884    
# Line 889  Line 895 
895    or the pathname is wild."    or the pathname is wild."
896    (if (wild-pathname-p pathname)    (if (wild-pathname-p pathname)
897        (error 'simple-file-error        (error 'simple-file-error
898               :format-control "Bad place for a wild pathname."               :format-control (intl:gettext "Bad place for a wild pathname.")
899               :pathname pathname)               :pathname pathname)
900        (let ((result (probe-file pathname)))        (let ((result (probe-file pathname)))
901          (unless result          (unless result
902            (error 'simple-file-error            (error 'simple-file-error
903                   :pathname pathname                   :pathname pathname
904                   :format-control "The file ~S does not exist."                   :format-control (intl:gettext "The file ~S does not exist.")
905                   :format-arguments (list (namestring pathname))))                   :format-arguments (list (namestring pathname))))
906          result)))          result)))
907    
# Line 909  Line 915 
915    (if (wild-pathname-p pathname)    (if (wild-pathname-p pathname)
916        (error 'simple-file-error        (error 'simple-file-error
917               :pathname pathname               :pathname pathname
918               :format-control "Bad place for a wild pathname.")               :format-control (intl:gettext "Bad place for a wild pathname."))
919        (let ((namestring (unix-namestring (merge-pathnames pathname) t)))        (let ((namestring (unix-namestring (merge-pathnames pathname) t)))
920          (when (and namestring (unix:unix-file-kind namestring))          (when (and namestring (unix:unix-file-kind namestring))
921            (let ((truename (unix:unix-resolve-links            (let ((truename (unix:unix-resolve-links
# Line 934  Line 940 
940      (unless new-namestring      (unless new-namestring
941        (error 'simple-file-error        (error 'simple-file-error
942               :pathname new-name               :pathname new-name
943               :format-control "~S can't be created."               :format-control (intl:gettext "~S can't be created.")
944               :format-arguments (list new-name)))               :format-arguments (list new-name)))
945      (multiple-value-bind (res error)      (multiple-value-bind (res error)
946                           (unix:unix-rename original-namestring                           (unix:unix-rename original-namestring
# Line 942  Line 948 
948        (unless res        (unless res
949          (error 'simple-file-error          (error 'simple-file-error
950                 :pathname new-name                 :pathname new-name
951                 :format-control "Failed to rename ~A to ~A: ~A"                 :format-control (intl:gettext "Failed to rename ~A to ~A: ~A")
952                 :format-arguments (list original new-name                 :format-arguments (list original new-name
953                                         (unix:get-unix-error-msg error))))                                         (unix:get-unix-error-msg error))))
954        (when (streamp file)        (when (streamp file)
# Line 955  Line 961 
961  ;;;  ;;;
962  (defun delete-file (file)  (defun delete-file (file)
963    "Delete the specified file."    "Delete the specified file."
964    (let ((namestring (unix-namestring file t)))    (let ((namestring (unix-namestring (merge-pathnames file) t)))
965      (when (streamp file)      (when (streamp file)
966        ;; Close the file, but don't try to revert or anything.  We want        ;; Close the file, but don't try to revert or anything.  We want
967        ;; to delete it, man!        ;; to delete it, man!
# Line 963  Line 969 
969      (unless namestring      (unless namestring
970        (error 'simple-file-error        (error 'simple-file-error
971               :pathname file               :pathname file
972               :format-control "~S doesn't exist."               :format-control (intl:gettext "~S doesn't exist.")
973               :format-arguments (list file)))               :format-arguments (list file)))
974    
975      (multiple-value-bind (res err) (unix:unix-unlink namestring)      (multiple-value-bind (res err) (unix:unix-unlink namestring)
976        (unless res        (unless res
977          (error 'simple-file-error          (error 'simple-file-error
978                 :pathname namestring                 :pathname namestring
979                 :format-control "Could not delete ~A: ~A."                 :format-control (intl:gettext "Could not delete ~A: ~A.")
980                 :format-arguments (list namestring                 :format-arguments (list namestring
981                                         (unix:get-unix-error-msg err))))))                                         (unix:get-unix-error-msg err))))))
982    t)    t)
# Line 1028  optionally keeping some of the most rece Line 1034  optionally keeping some of the most rece
1034    (if (wild-pathname-p file)    (if (wild-pathname-p file)
1035        (error 'simple-file-error        (error 'simple-file-error
1036               :pathname file               :pathname file
1037               :format-control "Bad place for a wild pathname.")               :format-control (intl:gettext "Bad place for a wild pathname."))
1038        (let ((name (unix-namestring file t)))        (let ((name (unix-namestring (merge-pathnames file) t)))
1039          (when name          (when name
1040            (multiple-value-bind            (multiple-value-bind
1041                (res dev ino mode nlink uid gid rdev size atime mtime)                (res dev ino mode nlink uid gid rdev size atime mtime)
# Line 1047  optionally keeping some of the most rece Line 1053  optionally keeping some of the most rece
1053    (if (wild-pathname-p file)    (if (wild-pathname-p file)
1054        (error 'simple-file-error        (error 'simple-file-error
1055               :pathname file               :pathname file
1056               :format-control "Bad place for a wild pathname.")               :format-control (intl:gettext "Bad place for a wild pathname."))
1057        (let ((name (unix-namestring (pathname file) t)))        (let ((name (unix-namestring (merge-pathnames file) t)))
1058          (unless name          (unless name
1059            (error 'simple-file-error            (error 'simple-file-error
1060                   :pathname file                   :pathname file
1061                   :format-control "~S doesn't exist."                   :format-control (intl:gettext "~S doesn't exist.")
1062                   :format-arguments (list file)))                   :format-arguments (list file)))
1063          (multiple-value-bind (winp dev ino mode nlink uid)          (multiple-value-bind (winp dev ino mode nlink uid)
1064                               (unix:unix-stat name)                               (unix:unix-stat name)
# Line 1133  optionally keeping some of the most rece Line 1139  optionally keeping some of the most rece
1139    (let ((contents (directory pathname :all all :check-for-subdirs nil    (let ((contents (directory pathname :all all :check-for-subdirs nil
1140                               :truenamep nil))                               :truenamep nil))
1141          (result nil))          (result nil))
1142      (format t "Directory of ~A:~%" (namestring pathname))      (format t (intl:gettext "Directory of ~A:~%") (namestring pathname))
1143      (dolist (file contents)      (dolist (file contents)
1144        (let* ((namestring (unix-namestring file))        (let* ((namestring (unix-namestring file))
1145               (tail (subseq namestring               (tail (subseq namestring
# Line 1182  optionally keeping some of the most rece Line 1188  optionally keeping some of the most rece
1188                             (decode-universal-time-for-files mtime year)                             (decode-universal-time-for-files mtime year)
1189                             tail                             tail
1190                             (= (logand mode unix:s-ifmt) unix:s-ifdir))))                             (= (logand mode unix:s-ifmt) unix:s-ifdir))))
1191                  (t (format t "Couldn't stat ~A -- ~A.~%"                  (t (format t (intl:gettext "Couldn't stat ~A -- ~A.~%")
1192                             tail                             tail
1193                             (unix:get-unix-error-msg dev-or-err))))                             (unix:get-unix-error-msg dev-or-err))))
1194            (when return-list            (when return-list
# Line 1237  optionally keeping some of the most rece Line 1243  optionally keeping some of the most rece
1243             (cols (max (truncate width col-width) 1))             (cols (max (truncate width col-width) 1))
1244             (lines (ceiling cnt cols)))             (lines (ceiling cnt cols)))
1245        (declare (fixnum cols lines))        (declare (fixnum cols lines))
1246        (format t "Directory of ~A:~%" (namestring pathname))        (format t (intl:gettext "Directory of ~A:~%") (namestring pathname))
1247        (dotimes (i lines)        (dotimes (i lines)
1248          (declare (fixnum i))          (declare (fixnum i))
1249          (dotimes (j cols)          (dotimes (j cols)
# Line 1386  optionally keeping some of the most rece Line 1392  optionally keeping some of the most rece
1392             (parse-namestring (concatenate 'simple-string dir-or-error "/")             (parse-namestring (concatenate 'simple-string dir-or-error "/")
1393                               *unix-host*)))                               *unix-host*)))
1394          (error dir-or-error))))          (error dir-or-error))))
 ;;;  
 ;;; XXXX This code was modified by me (fmg) to avoid calling  
 ;;; concatenate.  The reason for this is that there have been  
 ;;; intermittent instabilities (segv on startup) when the function  
 ;;; environment-init (in save.lisp) is called.  Apparently the type  
 ;;; system is not completely sorted out at the time this function is  
 ;;; first called.  As a result, strange, not completely reproducable  
 ;;; things happen, related to something in the state of the  
 ;;; environment (e.g. the paths or the user environment variables or  
 ;;; something).  These errors occur in the course of calling  
 ;;; default-directory and the backtrace indicates they occur in the  
 ;;; context of the type system.  Since I haven't been able to figure  
 ;;; out why they happen, I decided to punt.  
 ;;;  
 ;;; Hopefully someone will really fix the problem someday.  
 ;;;  
 ;;; Seems like maybe it's fixed by changes made by Ray Toy to avoid heap corruption.  
 #- (and)  
 (defun default-directory ()  
   "Returns the pathname for the default directory.  This is the place where  
   a file will be written if no directory is specified.  This may be changed  
   with setf."  
   (multiple-value-bind (gr dir-or-error)  
                        (unix:unix-current-directory)  
     (if gr  
         (let ((*ignore-wildcards* t)  
               (string (make-string (1+ (length dir-or-error)) :initial-element #\/)))  
           (values  
            (parse-namestring (replace string dir-or-error) *unix-host*)))  
         (error dir-or-error))))  
   
   
   
1395    
1396  ;;; %Set-Default-Directory  --  Internal  ;;; %Set-Default-Directory  --  Internal
1397  ;;;  ;;;
# Line 1426  optionally keeping some of the most rece Line 1399  optionally keeping some of the most rece
1399    (let ((namestring (unix-namestring new-val t)))    (let ((namestring (unix-namestring new-val t)))
1400      (unless namestring      (unless namestring
1401        (error 'simple-file-error        (error 'simple-file-error
1402               :format-control "~S doesn't exist."               :format-control (intl:gettext "~S doesn't exist.")
1403               :format-arguments (list new-val)))               :format-arguments (list new-val)))
1404      (multiple-value-bind (gr error)      (multiple-value-bind (gr error)
1405                           (unix:unix-chdir namestring)                           (unix:unix-chdir namestring)
# Line 1452  optionally keeping some of the most rece Line 1425  optionally keeping some of the most rece
1425    "Tests whether the directories containing the specified file    "Tests whether the directories containing the specified file
1426    actually exist, and attempts to create them if they do not.    actually exist, and attempts to create them if they do not.
1427    Portable programs should avoid using the :MODE keyword argument."    Portable programs should avoid using the :MODE keyword argument."
1428    (let* ((pathname (pathname pathspec))    (let* ((pathname (merge-pathnames pathspec))
1429           (pathname (if (logical-pathname-p pathname)           (pathname (if (logical-pathname-p pathname)
1430                         (translate-logical-pathname pathname)                         (translate-logical-pathname pathname)
1431                         pathname))                         pathname))
1432           (created-p nil))           (created-p nil))
1433      (when (wild-pathname-p pathname)      (when (wild-pathname-p pathname)
1434        (error 'simple-file-error        (error 'simple-file-error
1435               :format-control "Bad place for a wild pathname."               :format-control (intl:gettext "Bad place for a wild pathname.")
1436               :pathname pathspec))               :pathname pathspec))
1437      (enumerate-search-list (pathname pathname)      (enumerate-search-list (pathname pathname)
1438         (let ((dir (pathname-directory pathname)))         (let ((dir (pathname-directory pathname)))
# Line 1474  optionally keeping some of the most rece Line 1447  optionally keeping some of the most rece
1447                             (unless (probe-file newpath)                             (unless (probe-file newpath)
1448                               (let ((namestring (namestring newpath)))                               (let ((namestring (namestring newpath)))
1449                                 (when verbose                                 (when verbose
1450                                   (format *standard-output* "~&Creating directory: ~A~%"                                   (format *standard-output* (intl:gettext "~&Creating directory: ~A~%")
1451                                           namestring))                                           namestring))
1452                                 (unix:unix-mkdir namestring mode)                                 (unix:unix-mkdir namestring mode)
1453                                 (unless (probe-file namestring)                                 (unless (probe-file namestring)
1454                                   (error 'simple-file-error                                   (error 'simple-file-error
1455                                          :pathname pathspec                                          :pathname pathspec
1456                                          :format-control "Can't create directory ~A."                                          :format-control (intl:gettext "Can't create directory ~A.")
1457                                          :format-arguments (list namestring)))                                          :format-arguments (list namestring)))
1458                                 (setf created-p t)))                                 (setf created-p t)))
1459                           (retry () :report "Try to create the directory again"                           (retry () :report "Try to create the directory again"

Legend:
Removed from v.1.104.4.4  
changed lines
  Added in v.1.114

  ViewVC Help
Powered by ViewVC 1.1.5