/[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.43 by dtc, Fri May 16 17:03:56 1997 UTC revision 1.43.2.3 by pw, Tue May 23 16:36:27 2000 UTC
# Line 271  Line 271 
271              (unless (= tail-start tail-end)              (unless (= tail-start tail-end)
272                (setf pieces (butlast pieces))                (setf pieces (butlast pieces))
273                (extract-name-type-and-version namestr tail-start tail-end)))                (extract-name-type-and-version namestr tail-start tail-end)))
274            ;; PVE: Make sure there are no illegal characters in the name
275            ;; such as #\Null and #\/.
276            (when (and (stringp name)
277                       (find-if #'(lambda (x)
278                                    (or (char= x #\Null) (char= x #\/)))
279                                name))
280              (error 'parse-error))
281          ;; Now we have everything we want.  So return it.          ;; Now we have everything we want.  So return it.
282          (values nil ; no host for unix namestrings.          (values nil ; no host for unix namestrings.
283                  nil ; no devices for unix namestrings.                  nil ; no devices for unix namestrings.
# Line 405  Line 412 
412          (strings (if (eq version :wild)          (strings (if (eq version :wild)
413                       ".*"                       ".*"
414                       (format nil ".~D" version)))))                       (format nil ".~D" version)))))
415      (apply #'concatenate 'simple-string (strings))))      (and (strings) (apply #'concatenate 'simple-string (strings)))))
416    
417  (defun unparse-unix-namestring (pathname)  (defun unparse-unix-namestring (pathname)
418    (declare (type pathname pathname))    (declare (type pathname pathname))
# Line 631  Line 638 
638  ;;;  ;;;
639  (defun unix-namestring (pathname &optional (for-input t) executable-only)  (defun unix-namestring (pathname &optional (for-input t) executable-only)
640    "Convert PATHNAME into a string that can be used with UNIX system calls.    "Convert PATHNAME into a string that can be used with UNIX system calls.
641     Search-lists and wild-cards are expanded."     Search-lists and wild-cards are expanded. If optional argument
642       FOR-INPUT is true and PATHNAME doesn't exist, NIL is returned.
643       If optional argument EXECUTABLE-ONLY is true, NIL is returned
644       unless an executable version of PATHNAME exists."
645    ;; toy@rtp.ericsson.se: Let unix-namestring also handle logical    ;; toy@rtp.ericsson.se: Let unix-namestring also handle logical
646    ;; pathnames too.    ;; pathnames too.
647    (let ((path (let ((lpn (pathname pathname)))    (let ((path (let ((lpn (pathname pathname)))
# Line 649  Line 659 
659        (let ((names (names)))        (let ((names (names)))
660          (when names          (when names
661            (when (cdr names)            (when (cdr names)
662              (error "~S is ambiguous:~{~%  ~A~}" pathname names))              (error 'simple-file-error
663                       :format-control "~S is ambiguous:~{~%  ~A~}"
664                       :format-arguments (list pathname names)))
665            (return (car names))))))))            (return (car names))))))))
666    
667    
# Line 661  Line 673 
673  ;;;  ;;;
674  (defun truename (pathname)  (defun truename (pathname)
675    "Return the pathname for the actual file described by the pathname    "Return the pathname for the actual file described by the pathname
676    An error is signalled if no such file exists."    An error of type file-error is signalled if no such file exists,
677    (let ((result (probe-file pathname)))    or the pathname is wild."
678      (unless result    (if (wild-pathname-p pathname)
679        (error "The file ~S does not exist." (namestring pathname)))        (error 'simple-file-error
680      result))               :format-control "Bad place for a wild pathname."
681                 :pathname pathname)
682          (let ((result (probe-file pathname)))
683            (unless result
684              (error 'simple-file-error
685                     :pathname pathname
686                     :format-control "The file ~S does not exist."
687                     :format-arguments (list (namestring pathname))))
688            result)))
689    
690  ;;; Probe-File  --  Public  ;;; Probe-File  --  Public
691  ;;;  ;;;
# Line 673  Line 693 
693  ;;;  ;;;
694  (defun probe-file (pathname)  (defun probe-file (pathname)
695    "Return a pathname which is the truename of the file if it exists, NIL    "Return a pathname which is the truename of the file if it exists, NIL
696    otherwise."    otherwise. An error of type file-error is signaled if pathname is wild."
697    (let ((namestring (unix-namestring pathname t)))    (if (wild-pathname-p pathname)
698      (when (and namestring (unix:unix-file-kind namestring))        (error 'simple-file-error
699        (let ((truename (unix:unix-resolve-links               :pathname pathname
700                         (unix:unix-maybe-prepend-current-directory               :format-control "Bad place for a wild pathname.")
701                          namestring))))        (let ((namestring (unix-namestring pathname t)))
702          (when truename          (when (and namestring (unix:unix-file-kind namestring))
703            (let ((*ignore-wildcards* t))            (let ((truename (unix:unix-resolve-links
704              (pathname (unix:unix-simplify-pathname truename))))))))                             (unix:unix-maybe-prepend-current-directory
705                                namestring))))
706                (when truename
707                  (let ((*ignore-wildcards* t))
708                    (pathname (unix:unix-simplify-pathname truename)))))))))
709    
710    
711  ;;;; Other random operations.  ;;;; Other random operations.
# Line 696  Line 720 
720           (new-name (merge-pathnames new-name original))           (new-name (merge-pathnames new-name original))
721           (new-namestring (unix-namestring new-name nil)))           (new-namestring (unix-namestring new-name nil)))
722      (unless new-namestring      (unless new-namestring
723        (error "~S can't be created." new-name))        (error 'simple-file-error
724                 :pathname new-name
725                 :format-control "~S can't be created."
726                 :format-arguments (list new-name)))
727      (multiple-value-bind (res error)      (multiple-value-bind (res error)
728                           (unix:unix-rename original-namestring                           (unix:unix-rename original-namestring
729                                             new-namestring)                                             new-namestring)
730        (unless res        (unless res
731          (error "Failed to rename ~A to ~A: ~A"          (error 'simple-file-error
732                 original new-name (unix:get-unix-error-msg error)))                 :pathname new-name
733                   :format-control "Failed to rename ~A to ~A: ~A"
734                   :format-arguments (list original new-name
735                                           (unix:get-unix-error-msg error))))
736        (when (streamp file)        (when (streamp file)
737          (file-name file new-namestring))          (file-name file new-namestring))
738        (values new-name original (truename new-name)))))        (values new-name original (truename new-name)))))
# Line 717  Line 747 
747      (when (streamp file)      (when (streamp file)
748        (close file :abort t))        (close file :abort t))
749      (unless namestring      (unless namestring
750        (error "~S doesn't exist." file))        (error 'simple-file-error
751                 :pathname file
752                 :format-control "~S doesn't exist."
753                 :format-arguments (list file)))
754    
755      (multiple-value-bind (res err) (unix:unix-unlink namestring)      (multiple-value-bind (res err) (unix:unix-unlink namestring)
756        (unless res        (unless res
757          (error "Could not delete ~A: ~A."          (error 'simple-file-error
758                 namestring                 :pathname namestring
759                 (unix:get-unix-error-msg err)))))                 :format-control "Could not delete ~A: ~A."
760                   :format-arguments (list namestring
761                                           (unix:get-unix-error-msg err))))))
762    t)    t)
763    
764    
# Line 740  Line 775 
775  ;;; File-Write-Date  --  Public  ;;; File-Write-Date  --  Public
776  ;;;  ;;;
777  (defun file-write-date (file)  (defun file-write-date (file)
778    "Return file's creation date, or NIL if it doesn't exist."    "Return file's creation date, or NIL if it doesn't exist.
779    (let ((name (unix-namestring file t)))   An error of type file-error is signaled if file is a wild pathname"
780      (when name    (if (wild-pathname-p file)
781        (multiple-value-bind        (error 'simple-file-error
782            (res dev ino mode nlink uid gid rdev size atime mtime)               :pathname file
783            (unix:unix-stat name)               :format-control "Bad place for a wild pathname.")
784          (declare (ignore dev ino mode nlink uid gid rdev size atime))        (let ((name (unix-namestring file t)))
785          (when res          (when name
786            (+ unix-to-universal-time mtime))))))            (multiple-value-bind
787                  (res dev ino mode nlink uid gid rdev size atime mtime)
788                  (unix:unix-stat name)
789                (declare (ignore dev ino mode nlink uid gid rdev size atime))
790                (when res
791                  (+ unix-to-universal-time mtime)))))))
792    
793  ;;; File-Author  --  Public  ;;; File-Author  --  Public
794  ;;;  ;;;
795  (defun file-author (file)  (defun file-author (file)
796    "Returns the file author as a string, or nil if the author cannot be    "Returns the file author as a string, or nil if the author cannot be
797     determined.  Signals an error if file doesn't exist."   determined.  Signals an error of type file-error if file doesn't exist,
798    (let ((name (unix-namestring (pathname file) t)))   or file is a wild pathname."
799      (unless name    (if (wild-pathname-p file)
800        (error "~S doesn't exist." file))        (error 'simple-file-error
801      (multiple-value-bind (winp dev ino mode nlink uid)               :pathname file
802                           (unix:unix-stat name)               "Bad place for a wild pathname.")
803        (declare (ignore dev ino mode nlink))        (let ((name (unix-namestring (pathname file) t)))
804        (if winp (lookup-login-name uid)))))          (unless name
805              (error 'simple-file-error
806                     :pathname file
807                     :format-control "~S doesn't exist."
808                     :format-arguments (list file)))
809            (multiple-value-bind (winp dev ino mode nlink uid)
810                                 (unix:unix-stat name)
811              (declare (ignore dev ino mode nlink))
812              (if winp (lookup-login-name uid))))))
813    
814    
815  ;;;; DIRECTORY.  ;;;; DIRECTORY.
# Line 1100  Line 1147 
1147  ;;; File-writable -- exported from extensions.  ;;; File-writable -- exported from extensions.
1148  ;;;  ;;;
1149  ;;;   Determines whether the single argument (which should be a pathname)  ;;;   Determines whether the single argument (which should be a pathname)
1150  ;;;   can be written by the the current task.  ;;;   can be written by the current task.
1151  ;;;  ;;;
1152  (defun file-writable (name)  (defun file-writable (name)
1153    "File-writable accepts a pathname and returns T if the current    "File-writable accepts a pathname and returns T if the current
# Line 1172  Line 1219 
1219  ;;; Ensure-Directories-Exist  --  Public  ;;; Ensure-Directories-Exist  --  Public
1220  ;;;  ;;;
1221  (defun ensure-directories-exist (pathspec &key verbose (mode #o777))  (defun ensure-directories-exist (pathspec &key verbose (mode #o777))
1222      "Tests whether the directories containing the specified file
1223      actually exist, and attempts to create them if they do not.
1224      Portable programs should avoid using the :MODE keyword argument."
1225    (let* ((pathname (pathname pathspec))    (let* ((pathname (pathname pathspec))
1226           (pathname (if (logical-pathname-p pathname)           (pathname (if (logical-pathname-p pathname)
1227                         (translate-logical-pathname pathname)                         (translate-logical-pathname pathname)
1228                         pathname))                         pathname))
          (dir (pathname-directory pathname))  
1229           (created-p nil))           (created-p nil))
1230      (when (wild-pathname-p pathname)      (when (wild-pathname-p pathname)
1231        (error (make-condition 'file-error :pathname pathspec)))        (error 'simple-file-error
1232      (loop for i from 1 upto (length dir)               :format-control "Bad place for a wild pathname."
1233            do (let ((newpath (make-pathname :host (pathname-host pathname)               :pathname pathspec))
1234                                             :device (pathname-device pathname)      (enumerate-search-list (pathname pathname)
1235                                             :directory (subseq dir 0 i))))         (let ((dir (pathname-directory pathname)))
1236                 (unless (probe-file newpath)           (loop for i from 1 upto (length dir)
1237                   (let ((namestring (namestring newpath)))                 do (let ((newpath (make-pathname
1238                     (when verbose                                    :host (pathname-host pathname)
1239                       (format *standard-output* "~&Creating directory: ~A~%"                                    :device (pathname-device pathname)
1240                               namestring))                                    :directory (subseq dir 0 i))))
1241                     (unix:unix-mkdir namestring mode)                      (unless (probe-file newpath)
1242                     (unless (probe-file namestring)                        (let ((namestring (namestring newpath)))
1243                       (error (make-condition 'file-error :pathname pathspec)))                          (when verbose
1244                     (setf created-p t)))))                            (format *standard-output* "~&Creating directory: ~A~%"
1245      (values pathname created-p)))                                    namestring))
1246                            (unix:unix-mkdir namestring mode)
1247                            (unless (probe-file namestring)
1248                              (error 'simple-file-error
1249                                     :pathname pathspec
1250                                     :format-control "Can't create directory ~A."
1251                                     :format-arguments (list namestring)))
1252                            (setf created-p t)))))
1253             ;; Only the first path in a search-list is considered.
1254             (return (values pathname created-p))))))

Legend:
Removed from v.1.43  
changed lines
  Added in v.1.43.2.3

  ViewVC Help
Powered by ViewVC 1.1.5