;;; -*-Scheme-*-
;;;
-;;; $Id: dos.scm,v 1.34 1996/02/28 16:42:39 adams Exp $
+;;; $Id: dos.scm,v 1.35 1996/04/24 02:38:58 cph Exp $
;;;
-;;; Copyright (c) 1992-95 Massachusetts Institute of Technology
+;;; Copyright (c) 1992-96 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
string?)
(define (insert-directory! file switches mark type)
- switches ; ignored
;; Insert directory listing for FILE at MARK.
+ ;; SWITCHES are examined for the presence of "t".
;; TYPE can have one of three values:
;; 'WILDCARD means treat FILE as shell wildcard.
;; 'DIRECTORY means FILE is a directory and a full listing is expected.
;; 'FILE means FILE itself should be listed, and not its contents.
- ;; SWITCHES are ignored.
- (generate-dired-listing! (if (eq? type 'DIRECTORY)
- (pathname-as-directory file)
- file)
- mark))
-
-(define (generate-dired-listing! pathname point)
- (let ((files (directory-read pathname)))
- (for-each (lambda (file) (generate-dired-entry! file point))
- files)))
-
-(define (generate-dired-entry! file point)
- (define (file-attributes/ls-time-string attr)
- (let ((time-string
- (file-time->string (file-attributes/modification-time attr))))
- ;; Move the year from end to start, carrying leading space.
- (let ((index (fix:- (string-length time-string) 5)))
- (string-append (string-tail time-string index)
- " "
- (string-head time-string index)))))
-
- (let ((name (file-namestring file))
- (attr (or (file-attributes file) (dummy-file-attributes))))
- (let ((entry (string-append
- (string-pad-right ; Mode string
- (file-attributes/mode-string attr) 12 #\Space)
- (string-pad-left ; Length
- (number->string (file-attributes/length attr)) 10 #\Space)
- (string-pad-right ; Mod time
- (file-attributes/ls-time-string attr) 26 #\Space)
- name)))
- (let ((point (mark-left-inserting-copy point)))
- (insert-string entry point)
- (insert-newline point)
- (mark-temporary! point)))))
-
-(define-integrable (dummy-file-attributes)
- '#(#f 0 0 0 0 0 0 0 "----------" 0))
\ No newline at end of file
+ (let ((mark (mark-left-inserting-copy mark))
+ (now (get-universal-time)))
+ (call-with-current-continuation
+ (lambda (k)
+ (bind-condition-handler (list condition-type:file-error)
+ (lambda (condition)
+ (insert-string (condition/report-string condition) mark)
+ (insert-newline mark)
+ (k unspecific))
+ (lambda ()
+ (for-each
+ (lambda (entry)
+ (insert-string
+ (dos/dired-line-string (car entry) (cdr entry) now)
+ mark)
+ (insert-newline mark))
+ (let ((make-entry
+ (lambda (pathname)
+ (let ((attributes (file-attributes pathname)))
+ (if attributes
+ (list (cons (file-namestring pathname)
+ attributes))
+ '())))))
+ (if (eq? 'FILE type)
+ (make-entry file)
+ (sort (append-map make-entry (directory-read file))
+ (if (string-find-next-char switches #\t)
+ (lambda (x y)
+ (> (file-attributes/modification-time (cdr x))
+ (file-attributes/modification-time (cdr y))))
+ (lambda (x y)
+ (string-ci<? (car x) (car y))))))))))))
+ (mark-temporary! mark)))
+
+(define (dos/dired-line-string name attr now)
+ (string-append
+ (string-pad-right (file-attributes/mode-string attr)
+ 12 #\Space)
+ " "
+ (string-pad-left (number->string (file-attributes/length attr))
+ 10 #\Space)
+ " "
+ (file-time->ls-string (file-attributes/modification-time attr) now)
+ " "
+ name))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Id: os2.scm,v 1.28 1996/04/24 02:30:14 cph Exp $
+;;; $Id: os2.scm,v 1.29 1996/04/24 02:38:48 cph Exp $
;;;
-;;; Copyright (c) 1994-95 Massachusetts Institute of Technology
+;;; Copyright (c) 1994-96 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;; 'WILDCARD means treat FILE as shell wildcard.
;; 'DIRECTORY means FILE is a directory and a full listing is expected.
;; 'FILE means FILE itself should be listed, and not its contents.
- (let ((mark (mark-left-inserting-copy mark)))
- (call-with-current-continuation
- (lambda (k)
- (bind-condition-handler (list condition-type:file-error)
- (lambda (condition)
- (insert-string (condition/report-string condition) mark)
- (insert-newline mark)
- (k unspecific))
- (lambda ()
- (for-each
- (let ((now (os2/file-time->nmonths (current-file-time))))
- (lambda (entry)
- (insert-string
- (os2/dired-line-string (car entry) (cdr entry) now)
- mark)
- (insert-newline mark)))
- (if (eq? 'FILE type)
- (let ((attributes (file-attributes file)))
- (if attributes
- (list (cons (file-namestring file) attributes))
- '()))
- (sort (os2/read-dired-files file
- (string-find-next-char switches
- #\a))
- (if (string-find-next-char switches #\t)
- (lambda (x y)
- (> (file-attributes/modification-time (cdr x))
- (file-attributes/modification-time (cdr y))))
- (lambda (x y)
- (string-ci<? (car x) (car y)))))))))))
+ (let ((mark (mark-left-inserting-copy mark))
+ (now (get-universal-time)))
+ (catch-file-errors (lambda (c)
+ (insert-string (condition/report-string c) mark)
+ (insert-newline mark))
+ (lambda ()
+ (for-each
+ (lambda (entry)
+ (insert-string (os2/dired-line-string (car entry) (cdr entry) now)
+ mark)
+ (insert-newline mark))
+ (if (eq? 'FILE type)
+ (let ((attributes (file-attributes file)))
+ (if attributes
+ (list (cons (file-namestring file) attributes))
+ '()))
+ (sort (os2/read-dired-files file
+ (string-find-next-char switches #\a))
+ (if (string-find-next-char switches #\t)
+ (lambda (x y)
+ (> (file-attributes/modification-time (cdr x))
+ (file-attributes/modification-time (cdr y))))
+ (lambda (x y)
+ (string-ci<? (car x) (car y)))))))))
(mark-temporary! mark)))
-\f
+
(define (os2/dired-line-string name attr now)
(string-append
(file-attributes/mode-string attr)
" "
(string-pad-left (number->string (file-attributes/length attr)) 10 #\space)
" "
- (os/ls-file-time-string (file-attributes/modification-time attr) now)
+ (file-time->ls-string (file-attributes/modification-time attr) now)
" "
name))
(cons (cons (file-namestring (car pathnames)) attr) result)
result))))))
\f
-;;;; Time
-
-(define (os/ls-file-time-string time #!optional now)
- (let ((now
- (if (or (default-object? now) (not now))
- (os2/file-time->nmonths (current-file-time))
- now))
- (dt (decode-file-time time))
- (ns (lambda (n m c) (string-pad-left (number->string n) m c))))
- (string-append (month/short-string (decoded-time/month dt))
- " "
- (ns (decoded-time/day dt) 2 #\space)
- " "
- (if (<= -6 (- (os2/file-time->nmonths time) now) 0)
- (string-append (ns (decoded-time/hour dt) 2 #\0)
- ":"
- (ns (decoded-time/minute dt) 2 #\0))
- (string-append " "
- (number->string
- (decoded-time/year dt)))))))
-
-(define (os2/file-time->nmonths time)
- (let ((time (quotient time #x200000)))
- (+ (* (quotient time 16) 12)
- (remainder time 16))))
-\f
;;;; Compressed Files
(define (os/read-file-methods)
;;; -*-Scheme-*-
;;;
-;;; $Id: unix.scm,v 1.67 1996/04/24 02:29:50 cph Exp $
+;;; $Id: unix.scm,v 1.68 1996/04/24 02:38:37 cph Exp $
;;;
;;; Copyright (c) 1989-96 Massachusetts Institute of Technology
;;;
(or ((ucode-primitive full-hostname 0))
((ucode-primitive hostname 0))))
-(define (os/ls-file-time-string time)
- (let ((dt (decode-file-time time))
- (ns (lambda (n m c) (string-pad-left (number->string n) m c))))
- (string-append (month/short-string (decoded-time/month dt))
- " "
- (ns (decoded-time/day dt) 2 #\space)
- " "
- (if (<= (- (get-universal-time) time) (* 60 60 24 180))
- (string-append (ns (decoded-time/hour dt) 2 #\0)
- ":"
- (ns (decoded-time/minute dt) 2 #\0))
- (string-append " "
- (number->string
- (decoded-time/year dt)))))))
-
(define (os/newsrc-file-name server)
(let ((homedir (user-homedir-pathname)))
(let ((specific
;;; -*-Scheme-*-
;;;
-;;; $Id: utils.scm,v 1.38 1994/08/24 19:57:15 adams Exp $
+;;; $Id: utils.scm,v 1.39 1996/04/24 02:38:19 cph Exp $
;;;
-;;; Copyright (c) 1986, 1989-94 Massachusetts Institute of Technology
+;;; Copyright (c) 1986, 1989-96 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
(for-each write-string strings)
(loop))
-(define (catch-file-errors if-error thunk)
- (call-with-protected-continuation
- (lambda (continuation)
- (bind-condition-handler (list condition-type:file-error
- condition-type:port-error)
- (lambda (condition)
- condition
- (continuation (if-error)))
- thunk))))
-
(define (delete-directory-no-errors filename)
(catch-file-errors (lambda () #f)
(lambda () (delete-directory filename) #t)))
(begin (procedure i)
(loop (1+ i)))))
(loop 0))
-
+\f
(define make-strong-eq-hash-table
(strong-hash-table/constructor eq-hash-mod eq? #t))
(and (not (null? alist))
(if (eq? (weak-car (car alist)) item)
(car alist)
- (loop (cdr alist))))))
\ No newline at end of file
+ (loop (cdr alist))))))
+
+(define (file-time->ls-string time #!optional now)
+ ;; Returns a time string like that used by unix `ls -l'.
+ (let ((time (file-time->universal-time time))
+ (now
+ (if (or (default-object? now) (not now))
+ (get-universal-time)
+ now)))
+ (let ((dt (decode-universal-time time))
+ (d2 (lambda (n c) (string-pad-left (number->string n) 2 c))))
+ (string-append (month/short-string (decoded-time/month dt))
+ " "
+ (d2 (decoded-time/day dt) #\space)
+ " "
+ (if (<= 0 (- now time) (* 180 24 60 60))
+ (string-append (d2 (decoded-time/hour dt) #\0)
+ ":"
+ (d2 (decoded-time/minute dt) #\0))
+ (string-append " "
+ (number->string
+ (decoded-time/year dt))))))))
+
+(define (catch-file-errors if-error thunk)
+ (call-with-protected-continuation
+ (lambda (continuation)
+ (bind-condition-handler (list condition-type:file-error
+ condition-type:port-error)
+ (if (procedure-arity-valid? if-error 0)
+ (lambda (condition) condition (continuation (if-error)))
+ (lambda (condition) (continuation (if-error condition))))
+ thunk))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Id: vc.scm,v 1.21 1995/04/30 06:54:43 cph Exp $
+;;; $Id: vc.scm,v 1.22 1996/04/24 02:38:08 cph Exp $
;;;
-;;; Copyright (c) 1994-95 Massachusetts Institute of Technology
+;;; Copyright (c) 1994-96 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
".")
#t)
(begin
- (pop-up-vc-command-buffer #f)
+ (pop-up-vc-command-buffer #t)
#f)))))
(define-command vc-version-other-window
" "
(pad-on-left-to (number->string (file-attributes/length attr)) 8)
" "
- (os/ls-file-time-string (file-attributes/modification-time attr))
+ (file-time->ls-string (file-attributes/modification-time attr))
" "
(file-namestring file)
"\n")
projects / mit-scheme.git / commitdiff