/[cmucl]/src/hemlock/dired.lisp
ViewVC logotype

Diff of /src/hemlock/dired.lisp

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

revision 1.1.1.3 by ram, Fri Feb 8 16:33:47 1991 UTC revision 1.1.1.3.1.1 by wlott, Wed Feb 5 16:31:07 1992 UTC
# Line 113  Line 113 
113    (cond    (cond
114     ((not directoryp)     ((not directoryp)
115      (let* ((ses-name1 (ext:unix-namestring spec1 t))      (let* ((ses-name1 (ext:unix-namestring spec1 t))
116             (exists1p (mach:unix-file-kind ses-name1))             (exists1p (unix:unix-file-kind ses-name1))
117             (ses-name2 (ext:unix-namestring spec2 nil))             (ses-name2 (ext:unix-namestring spec2 nil))
118             (pname1 (pathname ses-name1))             (pname1 (pathname ses-name1))
119             (pname2 (pathname ses-name2))             (pname2 (pathname ses-name2))
# Line 300  Line 300 
300    (cond    (cond
301     ((not directoryp)     ((not directoryp)
302      (let* ((ses-name1 (ext:unix-namestring spec1 t))      (let* ((ses-name1 (ext:unix-namestring spec1 t))
303             (exists1p (mach:unix-file-kind ses-name1))             (exists1p (unix:unix-file-kind ses-name1))
304             (ses-name2 (ext:unix-namestring spec2 nil))             (ses-name2 (ext:unix-namestring spec2 nil))
305             (pname1 (pathname ses-name1))             (pname1 (pathname ses-name1))
306             (pname2 (pathname ses-name2))             (pname2 (pathname ses-name2))
# Line 554  Line 554 
554  (defun make-directory (name)  (defun make-directory (name)
555    "Creates directory name.  If name exists, then an error is signaled."    "Creates directory name.  If name exists, then an error is signaled."
556    (let ((ses-name (ext:unix-namestring name nil)))    (let ((ses-name (ext:unix-namestring name nil)))
557      (when (mach:unix-file-kind ses-name)      (when (unix:unix-file-kind ses-name)
558        (funcall *error-function* "Name already exists -- ~S" ses-name))        (funcall *error-function* "Name already exists -- ~S" ses-name))
559      (enter-directory ses-name))      (enter-directory ses-name))
560    t)    t)
# Line 565  Line 565 
565    
566  (defun open-file (ses-name)  (defun open-file (ses-name)
567    (multiple-value-bind (fd err)    (multiple-value-bind (fd err)
568                         (mach:unix-open ses-name mach:o_rdonly 0)                         (unix:unix-open ses-name unix:o_rdonly 0)
569      (unless fd      (unless fd
570        (funcall *error-function* "Opening ~S failed: ~A." ses-name err))        (funcall *error-function* "Opening ~S failed: ~A." ses-name err))
571      fd))      fd))
572    
573  (defun close-file (fd)  (defun close-file (fd)
574    (mach:unix-close fd))    (unix:unix-close fd))
575    
576  (defun read-file (fd ses-name)  (defun read-file (fd ses-name)
577    (multiple-value-bind (winp dev-or-err ino mode nlink uid gid rdev size)    (multiple-value-bind (winp dev-or-err ino mode nlink uid gid rdev size)
578                         (mach:unix-fstat fd)                         (unix:unix-fstat fd)
579      (declare (ignore ino nlink uid gid rdev))      (declare (ignore ino nlink uid gid rdev))
580      (unless winp (funcall *error-function*      (unless winp (funcall *error-function*
581                            "Opening ~S failed: ~A."  ses-name dev-or-err))                            "Opening ~S failed: ~A."  ses-name dev-or-err))
582      (let ((storage (system:allocate-system-memory size)))      (let ((storage (system:allocate-system-memory size)))
583        (multiple-value-bind (read-bytes err)        (multiple-value-bind (read-bytes err)
584                             (mach:unix-read fd storage size)                             (unix:unix-read fd storage size)
585          (when (or (null read-bytes) (not (= size read-bytes)))          (when (or (null read-bytes) (not (= size read-bytes)))
586            (system:deallocate-system-memory storage size)            (system:deallocate-system-memory storage size)
587            (funcall *error-function*            (funcall *error-function*
# Line 589  Line 589 
589        (values storage size mode))))        (values storage size mode))))
590    
591  (defun write-file (ses-name data byte-count mode)  (defun write-file (ses-name data byte-count mode)
592    (multiple-value-bind (fd err) (mach:unix-creat ses-name #o644)    (multiple-value-bind (fd err) (unix:unix-creat ses-name #o644)
593      (unless fd      (unless fd
594        (funcall *error-function* "Couldn't create file ~S: ~A"        (funcall *error-function* "Couldn't create file ~S: ~A"
595                 ses-name (mach:get-unix-error-msg err)))                 ses-name (unix:get-unix-error-msg err)))
596      (multiple-value-bind (winp err) (mach:unix-write fd data 0 byte-count)      (multiple-value-bind (winp err) (unix:unix-write fd data 0 byte-count)
597        (unless winp        (unless winp
598          (funcall *error-function* "Writing file ~S failed: ~A"          (funcall *error-function* "Writing file ~S failed: ~A"
599                 ses-name                 ses-name
600                 (mach:get-unix-error-msg err))))                 (unix:get-unix-error-msg err))))
601      (mach:unix-fchmod fd (logand mode #o777))      (unix:unix-fchmod fd (logand mode #o777))
602      (mach:unix-close fd)))      (unix:unix-close fd)))
603    
604  (defvar *utimes-buffer* (make-list 4 :initial-element 0))  (defvar *utimes-buffer* (make-list 4 :initial-element 0))
605    
606  (defun set-write-date (ses-name secs)  (defun set-write-date (ses-name secs)
607    (multiple-value-bind (winp dev-or-err ino mode nlink uid gid rdev size atime)    (multiple-value-bind (winp dev-or-err ino mode nlink uid gid rdev size atime)
608                         (mach:unix-stat ses-name)                         (unix:unix-stat ses-name)
609      (declare (ignore ino mode nlink uid gid rdev size))      (declare (ignore ino mode nlink uid gid rdev size))
610      (unless winp (funcall *error-function*      (unless winp (funcall *error-function*
611                            "Couldn't stat file ~S failed: ~A."  ses-name                            "Couldn't stat file ~S failed: ~A."  ses-name
612                            dev-or-err))                            dev-or-err))
613      (setf (car *utimes-buffer*) atime)      (setf (car *utimes-buffer*) atime)
614      (setf (caddr *utimes-buffer*) secs))      (setf (caddr *utimes-buffer*) secs))
615    (multiple-value-bind (winp err) (mach:unix-utimes ses-name *utimes-buffer*)    (multiple-value-bind (winp err) (unix:unix-utimes ses-name *utimes-buffer*)
616      (unless winp      (unless winp
617        (funcall *error-function* "Couldn't set write date of file ~S: ~A"        (funcall *error-function* "Couldn't set write date of file ~S: ~A"
618                 ses-name                 ses-name
619                 (mach:get-unix-error-msg err)))))                 (unix:get-unix-error-msg err)))))
620    
621  (defun get-write-date (ses-name)  (defun get-write-date (ses-name)
622    (multiple-value-bind (winp dev-or-err ino mode nlink uid gid rdev size    (multiple-value-bind (winp dev-or-err ino mode nlink uid gid rdev size
623                          atime mtime)                          atime mtime)
624                         (mach:unix-stat ses-name)                         (unix:unix-stat ses-name)
625      (declare (ignore ino mode nlink uid gid rdev size atime))      (declare (ignore ino mode nlink uid gid rdev size atime))
626      (unless winp (funcall *error-function* "Couldn't stat file ~S failed: ~A."      (unless winp (funcall *error-function* "Couldn't stat file ~S failed: ~A."
627                            ses-name dev-or-err))                            ses-name dev-or-err))
# Line 634  Line 634 
634  ;;; have this problem.  ;;; have this problem.
635  ;;;  ;;;
636  (defun sub-rename-file (ses-name1 ses-name2)  (defun sub-rename-file (ses-name1 ses-name2)
637    (multiple-value-bind (res err) (mach:unix-rename ses-name1 ses-name2)    (multiple-value-bind (res err) (unix:unix-rename ses-name1 ses-name2)
638      (unless res      (unless res
639        (funcall *error-function* "Failed to rename ~A to ~A: ~A."        (funcall *error-function* "Failed to rename ~A to ~A: ~A."
640                 ses-name1 ses-name2 (mach:get-unix-error-msg err)))))                 ses-name1 ses-name2 (unix:get-unix-error-msg err)))))
641    
642  (defun directory-existsp (ses-name)  (defun directory-existsp (ses-name)
643    (eq (mach:unix-file-kind ses-name) :directory))    (eq (unix:unix-file-kind ses-name) :directory))
644    
645  (defun enter-directory (ses-name)  (defun enter-directory (ses-name)
646    (declare (simple-string ses-name))    (declare (simple-string ses-name))
# Line 649  Line 649 
649                        length-1)                        length-1)
650                     (subseq ses-name 0 (1- (length ses-name)))                     (subseq ses-name 0 (1- (length ses-name)))
651                     ses-name)))                     ses-name)))
652      (multiple-value-bind (winp err) (mach:unix-mkdir name #o755)      (multiple-value-bind (winp err) (unix:unix-mkdir name #o755)
653        (unless winp        (unless winp
654          (funcall *error-function* "Couldn't make directory ~S: ~A"          (funcall *error-function* "Couldn't make directory ~S: ~A"
655                   name                   name
656                   (mach:get-unix-error-msg err))))))                   (unix:get-unix-error-msg err))))))
657    
658  (defun delete-directory (ses-name)  (defun delete-directory (ses-name)
659    (declare (simple-string ses-name))    (declare (simple-string ses-name))
660    (multiple-value-bind (winp err)    (multiple-value-bind (winp err)
661                         (mach:unix-rmdir (subseq ses-name 0                         (unix:unix-rmdir (subseq ses-name 0
662                                                  (1- (length ses-name))))                                                  (1- (length ses-name))))
663      (unless winp      (unless winp
664        (funcall *error-function* "Couldn't delete directory ~S: ~A"        (funcall *error-function* "Couldn't delete directory ~S: ~A"
665                 ses-name                 ses-name
666                 (mach:get-unix-error-msg err)))))                 (unix:get-unix-error-msg err)))))
667    
668    
669    

Legend:
Removed from v.1.1.1.3  
changed lines
  Added in v.1.1.1.3.1.1

  ViewVC Help
Powered by ViewVC 1.1.5