/[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.2 by dtc, Sun Jul 19 01:06:05 1998 UTC
# Line 661  Line 661 
661  ;;;  ;;;
662  (defun truename (pathname)  (defun truename (pathname)
663    "Return the pathname for the actual file described by the pathname    "Return the pathname for the actual file described by the pathname
664    An error is signalled if no such file exists."    An error of type file-error is signalled if no such file exists,
665    (let ((result (probe-file pathname)))    or the pathname is wild."
666      (unless result    (if (wild-pathname-p pathname)
667        (error "The file ~S does not exist." (namestring pathname)))        (error 'simple-file-error
668      result))               :format-control "Bad place for a wild pathname."
669                 :pathname pathname)
670          (let ((result (probe-file pathname)))
671            (unless result
672              (error 'simple-file-error
673                     :pathname pathname
674                     :format-control "The file ~S does not exist."
675                     :format-arguments (list (namestring pathname))))
676            result)))
677    
678  ;;; Probe-File  --  Public  ;;; Probe-File  --  Public
679  ;;;  ;;;
# Line 673  Line 681 
681  ;;;  ;;;
682  (defun probe-file (pathname)  (defun probe-file (pathname)
683    "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
684    otherwise."    otherwise. An error of type file-error is signaled if pathname is wild."
685    (let ((namestring (unix-namestring pathname t)))    (if (wild-pathname-p pathname)
686      (when (and namestring (unix:unix-file-kind namestring))        (error 'simple-file-error
687        (let ((truename (unix:unix-resolve-links               :pathname pathname
688                         (unix:unix-maybe-prepend-current-directory               :format-control "Bad place for a wild pathname.")
689                          namestring))))        (let ((namestring (unix-namestring pathname t)))
690          (when truename          (when (and namestring (unix:unix-file-kind namestring))
691            (let ((*ignore-wildcards* t))            (let ((truename (unix:unix-resolve-links
692              (pathname (unix:unix-simplify-pathname truename))))))))                             (unix:unix-maybe-prepend-current-directory
693                                namestring))))
694                (when truename
695                  (let ((*ignore-wildcards* t))
696                    (pathname (unix:unix-simplify-pathname truename)))))))))
697    
698    
699  ;;;; Other random operations.  ;;;; Other random operations.
# Line 696  Line 708 
708           (new-name (merge-pathnames new-name original))           (new-name (merge-pathnames new-name original))
709           (new-namestring (unix-namestring new-name nil)))           (new-namestring (unix-namestring new-name nil)))
710      (unless new-namestring      (unless new-namestring
711        (error "~S can't be created." new-name))        (error 'simple-file-error
712                 :pathname new-name
713                 :format-control "~S can't be created."
714                 :format-arguments (list new-name)))
715      (multiple-value-bind (res error)      (multiple-value-bind (res error)
716                           (unix:unix-rename original-namestring                           (unix:unix-rename original-namestring
717                                             new-namestring)                                             new-namestring)
718        (unless res        (unless res
719          (error "Failed to rename ~A to ~A: ~A"          (error 'simple-file-error
720                 original new-name (unix:get-unix-error-msg error)))                 :pathname new-name
721                   :format-control "Failed to rename ~A to ~A: ~A"
722                   :format-arguments (list original new-name
723                                           (unix:get-unix-error-msg error))))
724        (when (streamp file)        (when (streamp file)
725          (file-name file new-namestring))          (file-name file new-namestring))
726        (values new-name original (truename new-name)))))        (values new-name original (truename new-name)))))
# Line 717  Line 735 
735      (when (streamp file)      (when (streamp file)
736        (close file :abort t))        (close file :abort t))
737      (unless namestring      (unless namestring
738        (error "~S doesn't exist." file))        (error 'simple-file-error
739                 :pathname file
740                 :format-control "~S doesn't exist."
741                 :format-arguments (list file)))
742    
743      (multiple-value-bind (res err) (unix:unix-unlink namestring)      (multiple-value-bind (res err) (unix:unix-unlink namestring)
744        (unless res        (unless res
745          (error "Could not delete ~A: ~A."          (error 'simple-file-error
746                 namestring                 :pathname namestring
747                 (unix:get-unix-error-msg err)))))                 :format-control "Could not delete ~A: ~A."
748                   :format-arguments (list namestring
749                                           (unix:get-unix-error-msg err))))))
750    t)    t)
751    
752    
# Line 740  Line 763 
763  ;;; File-Write-Date  --  Public  ;;; File-Write-Date  --  Public
764  ;;;  ;;;
765  (defun file-write-date (file)  (defun file-write-date (file)
766    "Return file's creation date, or NIL if it doesn't exist."    "Return file's creation date, or NIL if it doesn't exist.
767    (let ((name (unix-namestring file t)))   An error of type file-error is signaled if file is a wild pathname"
768      (when name    (if (wild-pathname-p file)
769        (multiple-value-bind        (error 'simple-file-error
770            (res dev ino mode nlink uid gid rdev size atime mtime)               :pathname file
771            (unix:unix-stat name)               :format-control "Bad place for a wild pathname.")
772          (declare (ignore dev ino mode nlink uid gid rdev size atime))        (let ((name (unix-namestring file t)))
773          (when res          (when name
774            (+ unix-to-universal-time mtime))))))            (multiple-value-bind
775                  (res dev ino mode nlink uid gid rdev size atime mtime)
776                  (unix:unix-stat name)
777                (declare (ignore dev ino mode nlink uid gid rdev size atime))
778                (when res
779                  (+ unix-to-universal-time mtime)))))))
780    
781  ;;; File-Author  --  Public  ;;; File-Author  --  Public
782  ;;;  ;;;
783  (defun file-author (file)  (defun file-author (file)
784    "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
785     determined.  Signals an error if file doesn't exist."   determined.  Signals an error of type file-error if file doesn't exist,
786    (let ((name (unix-namestring (pathname file) t)))   or file is a wild pathname."
787      (unless name    (if (wild-pathname-p file)
788        (error "~S doesn't exist." file))        (error 'simple-file-error
789      (multiple-value-bind (winp dev ino mode nlink uid)               :pathname file
790                           (unix:unix-stat name)               "Bad place for a wild pathname.")
791        (declare (ignore dev ino mode nlink))        (let ((name (unix-namestring (pathname file) t)))
792        (if winp (lookup-login-name uid)))))          (unless name
793              (error 'simple-file-error
794                     :pathname file
795                     :format-control "~S doesn't exist."
796                     :format-arguments (list file)))
797            (multiple-value-bind (winp dev ino mode nlink uid)
798                                 (unix:unix-stat name)
799              (declare (ignore dev ino mode nlink))
800              (if winp (lookup-login-name uid))))))
801    
802    
803  ;;;; DIRECTORY.  ;;;; DIRECTORY.
# Line 1100  Line 1135 
1135  ;;; File-writable -- exported from extensions.  ;;; File-writable -- exported from extensions.
1136  ;;;  ;;;
1137  ;;;   Determines whether the single argument (which should be a pathname)  ;;;   Determines whether the single argument (which should be a pathname)
1138  ;;;   can be written by the the current task.  ;;;   can be written by the current task.
1139  ;;;  ;;;
1140  (defun file-writable (name)  (defun file-writable (name)
1141    "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 1207 
1207  ;;; Ensure-Directories-Exist  --  Public  ;;; Ensure-Directories-Exist  --  Public
1208  ;;;  ;;;
1209  (defun ensure-directories-exist (pathspec &key verbose (mode #o777))  (defun ensure-directories-exist (pathspec &key verbose (mode #o777))
1210      "Tests whether the directories containing the specified file
1211      actually exist, and attempts to create them if they do not.
1212      Portable programs should avoid using the :MODE keyword argument."
1213    (let* ((pathname (pathname pathspec))    (let* ((pathname (pathname pathspec))
1214           (pathname (if (logical-pathname-p pathname)           (pathname (if (logical-pathname-p pathname)
1215                         (translate-logical-pathname pathname)                         (translate-logical-pathname pathname)
1216                         pathname))                         pathname))
          (dir (pathname-directory pathname))  
1217           (created-p nil))           (created-p nil))
1218      (when (wild-pathname-p pathname)      (when (wild-pathname-p pathname)
1219        (error (make-condition 'file-error :pathname pathspec)))        (error 'simple-file-error
1220      (loop for i from 1 upto (length dir)               :format-control "Bad place for a wild pathname."
1221            do (let ((newpath (make-pathname :host (pathname-host pathname)               :pathname pathspec))
1222                                             :device (pathname-device pathname)      (enumerate-search-list (pathname pathname)
1223                                             :directory (subseq dir 0 i))))         (let ((dir (pathname-directory pathname)))
1224                 (unless (probe-file newpath)           (loop for i from 1 upto (length dir)
1225                   (let ((namestring (namestring newpath)))                 do (let ((newpath (make-pathname
1226                     (when verbose                                    :host (pathname-host pathname)
1227                       (format *standard-output* "~&Creating directory: ~A~%"                                    :device (pathname-device pathname)
1228                               namestring))                                    :directory (subseq dir 0 i))))
1229                     (unix:unix-mkdir namestring mode)                      (unless (probe-file newpath)
1230                     (unless (probe-file namestring)                        (let ((namestring (namestring newpath)))
1231                       (error (make-condition 'file-error :pathname pathspec)))                          (when verbose
1232                     (setf created-p t)))))                            (format *standard-output* "~&Creating directory: ~A~%"
1233      (values pathname created-p)))                                    namestring))
1234                            (unix:unix-mkdir namestring mode)
1235                            (unless (probe-file namestring)
1236                              (error 'simple-file-error
1237                                     :pathname pathspec
1238                                     :format-control "Can't create directory ~A."
1239                                     :format-arguments (list namestring)))
1240                            (setf created-p t)))))
1241             ;; Only the first path in a search-list is considered.
1242             (return (values pathname created-p))))))

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

  ViewVC Help
Powered by ViewVC 1.1.5