/[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.46 by dtc, Sun Mar 1 21:46:05 1998 UTC revision 1.47 by pw, Mon Apr 20 11:32:51 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 '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 '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 '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 '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 '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 '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 '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 '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 '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 '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 1181  Line 1216 
1216                         pathname))                         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 'file-error
1220                 :format-control "Bad place for a wild pathname."
1221                 :pathname pathspec))
1222      (enumerate-search-list (pathname pathname)      (enumerate-search-list (pathname pathname)
1223         (let ((dir (pathname-directory pathname)))         (let ((dir (pathname-directory pathname)))
1224           (loop for i from 1 upto (length dir)           (loop for i from 1 upto (length dir)
# Line 1196  Line 1233 
1233                                    namestring))                                    namestring))
1234                          (unix:unix-mkdir namestring mode)                          (unix:unix-mkdir namestring mode)
1235                          (unless (probe-file namestring)                          (unless (probe-file namestring)
1236                            (error (make-condition 'file-error                            (error 'file-error
1237                                                   :pathname pathspec)))                                   :pathname pathspec
1238                                     :format-control "Can't create directory ~A."
1239                                     :format-arguments (list namestring))))
1240                          (setf created-p t)))))                          (setf created-p t)))))
1241           ;; Only the first path in a search-list is considered.           ;; Only the first path in a search-list is considered.
1242           (return (values pathname created-p))))))           (return (values pathname created-p))))))

Legend:
Removed from v.1.46  
changed lines
  Added in v.1.47

  ViewVC Help
Powered by ViewVC 1.1.5