1 ;;; ***********************************************************
  2 ;;; *                                                         *
  3 ;;; * Copyright, (C) Honeywell Information Systems Inc., 1982 *
  4 ;;; *                                                         *
  5 ;;; * Copyright (c) 1978 by Massachusetts Institute of        *
  6 ;;; * Technology and Honeywell Information Systems, Inc.      *
  7 ;;; *                                                         *
  8 ;;; ***********************************************************
  9 ;;;
 10 ;;;
 11 ;;;       Directory editor
 12 ;;;       Archy, '78, extracted from e_macops_ 8/16/79 by BSG
 13 ;;;       Modified: 12/8/83 - B. Margolin - don't allow d/u when on
 14 ;;;                 blank line at the end.  Also modernized some code
 15 ;;;                 (defun->defcom, lambda->let, comout-get-output).
 16 ;;;
 17 
 18 (%include e-macros)
 19 (declare (special dired-segs-to-delete dired-buffer-to-go-back-to dired-dir)
 20          (*expr absolute_pathname_ convert_status_code_ error_table_
 21                 expand_pathname_ go-to-hpos minibuffer-remark))
 22 
 23 (declare (defpl1 cu_$level_get "" (return fixed bin)))
 24 (defprop trim e_lap_$trim expr)
 25 (declare (defpl1 hcs_$get_user_effmode
 26                    "" (char (*))(char (*))(char (*))(fixed bin)(return fixed bin)(return fixed bin (35.))))
 27 
 28 (defcom edit-dir
 29         &numeric-argument (&pass)
 30         &arguments ((dir &default &eval (if numarg (minibuf-response "Directory: " NL)
 31                                       else "")))
 32         (setq dir (absolute_pathname_ dir))
 33         (if (not (zerop (cadr dir)))
 34             (display-com-error (cadr dir) "")
 35             else
 36             (setq dir (trim (car dir))))
 37         (let ((access-ok (dired-access-check dir)))
 38              (if (not access-ok)
 39                  (display-error-noabort "Warning: Modify access on " dir " lacking.")))
 40         (go-to-or-create-buffer 'Dir/ Edit)
 41         (setq buffer-modified-flag t)
 42         (comout-get-output "list -pn" dir
 43                            "-mode -name -primary -length -no_header")
 44         (setq fpathname dir)                      ;for user
 45         (do-forever (go-to-beginning-of-line)
 46                     (insert-string TAB)
 47                     (if (lastlinep)(stop-doing))
 48                     (next-line))
 49         (go-to-beginning-of-buffer)
 50         (dired-mode)
 51         (setq dired-segs-to-delete nil)
 52         (setq dired-buffer-to-go-back-to previous-buffer)
 53         (setq dired-dir dir)
 54         (setq read-only-flag t buffer-modified-flag nil)
 55         (select-buffer-find-window current-buffer 'cursize))
 56 
 57 (defun dired-mode ()
 58        (setq current-buffer-mode 'DIRED)
 59        (register-local-var 'dired-segs-to-delete)
 60        (register-local-var 'dired-buffer-to-go-back-to)
 61        (register-local-var 'dired-dir)
 62        (set-key 'D 'dired-mark-for-deletion)
 63        (set-key 'd 'dired-mark-for-deletion)
 64        (set-key 'n 'next-line-command)
 65        (set-key 'p 'prev-line-command)
 66        (set-key 'N 'next-line-command)
 67        (set-key 'P 'prev-line-command)
 68        (set-key 'R 'dired-rename)
 69        (set-key 'r 'dired-rename)
 70        (set-key 'U 'dired-unmark-for-deletion)
 71        (set-key 'u 'dired-unmark-for-deletion)
 72        (set-key 'E 'dired-examine-file)
 73        (set-key 'e 'dired-examine-file)
 74        (set-key 'Q 'dired-quit)
 75        (set-key 'q 'dired-quit)
 76        (set-key '^X^Q 'dired-quit)
 77        (set-key '^XB 'dired-quit-and-go-buffer))
 78 
 79 (defcom dired-mark-for-deletion
 80         (if (lastlinep) (command-quit))           ;Last line is empty
 81         (go-to-beginning-of-line)
 82         (if-at "D"
 83                else (without-modifying (insert-string "D"))
 84                     (setq dired-segs-to-delete (cons (dired-get-filename)
 85                                                      dired-segs-to-delete)))
 86         (next-line))
 87 
 88 (defcom dired-unmark-for-deletion
 89         (if (lastlinep) (command-quit))           ;Last line is empty
 90         (go-to-beginning-of-line)
 91         (if-at "D" (without-modifying (delete-char))
 92                    (setq dired-segs-to-delete (delete
 93                                                 (dired-get-filename)
 94                                                 dired-segs-to-delete)))
 95         (next-line))
 96 
 97 (defcom dired-examine-file
 98         (let ((dname dired-dir)
 99               (ename (dired-get-filename)))
100              (find-buffer-in-window '|Dired Examine|)
101              (set-key '^X^Q 'dired-exit-examine-buffer)
102              (read-in-file (catenate dname ">" ename))
103              (minibuffer-remark "Use ^X^Q to return to DIRED")))
104 
105 (defcom dired-exit-examine-buffer
106         (set-buffer-self-destruct current-buffer)
107         (find-buffer-in-window '|Dir Edit|))
108 
109 (defcom dired-quit
110         (cond ((null dired-segs-to-delete)
111                (set-buffer-self-destruct current-buffer)
112                (select-buffer-window dired-buffer-to-go-back-to nil)
113                (setq previous-buffer current-buffer))
114               (t (dired-m-access-check)           ;aborts if access lacking
115                  (init-local-displays)
116                  (local-display-generator-nnl "Files to delete:")
117                  (local-display-generator-nnl "")
118                  (mapc 'local-display-generator-nnl dired-segs-to-delete)
119                  (local-display-generator "---------------")
120                  (if (yesp "Deleting the above listed files, OK? ")
121                      (dired-delete-files dired-segs-to-delete)
122                      (set-buffer-self-destruct current-buffer)
123                      (select-buffer-window dired-buffer-to-go-back-to nil)
124                      (setq previous-buffer current-buffer)
125                      else (go-to-beginning-of-buffer)))))
126 
127 (defcom dired-quit-and-go-buffer
128         &arguments ((buffer &symbol &prompt "Select Buffer: "
129                             &default  &eval dired-buffer-to-go-back-to))
130         (set-buffer-self-destruct current-buffer)
131         (let ((prevbuf dired-buffer-to-go-back-to))
132              (select-buffer-window buffer nil)
133              (setq previous-buffer prevbuf)))
134 
135 (defun dired-get-filename ()
136         (go-to-end-of-line)
137         (skip-back-whitespace)
138         (with-mark m (go-to-beginning-of-line)
139                      (go-to-hpos 20.)
140                      (prog1 (point-mark-to-string m)
141                             (go-to-beginning-of-line))))
142 
143 (declare (defpl1 delete_$path "" (char (*))(char (*))(bit (6))(char (*))
144                  (return fixed bin (35.))))
145 
146 
147 (defun dired-delete-files (seg-list)              ;bsg 5/3/79 for delete_
148        (let  ((err-list nil)
149               (code))
150              (mapc '(lambda (file)
151                             (setq code (delete_$path dired-dir file
152                                                      (lsh 44 30.) "emacs"))
153                             (or (= 0 code)(setq err-list
154                                                 (cons (cons file code)
155                                                       err-list))))
156                    seg-list)
157              (if (not (null err-list))
158                  (init-local-displays)
159                  (mapc 'local-display-generator-nnl
160                        '("Errors encountered during deletions:"
161                           "These files not deleted:"
162                           ""))
163                  (mapc '(lambda (x)(local-display-generator-nnl
164                                      (catenate
165                                        (e_lap_$trim
166                                          (cadr (convert_status_code_ (cdr x))))
167                                        " "
168                                        (car x))))
169                        err-list)
170                  (end-local-displays))))
171 
172 (defun dired-access-check (dir)
173        (let ((epr (expand_pathname_ dir)))
174             (let ((hcssr (hcs_$get_user_effmode (car epr)(cadr epr) ""
175                                                 (cu_$level_get))))
176                  (if (not (zerop (cadr hcssr)))
177                      (if (= (cadr hcssr)(error_table_ 'incorrect_access))
178                          (rplaca hcssr 77)
179                          (display-error-noabort "Warning: cannot check access on " dir ".")
180                          else
181                          (display-com-error (cadr hcssr) dir)))
182                  (let ((mode (car hcssr)))
183                       (if (zerop (boole 1 mode 10))
184                           (display-error "dired: Status permission on " dir " lacking."))
185                       (not (zerop (boole 1 2 mode)))))))
186 
187 ;; 11/24/79 BSG
188 
189 (declare (defpl1 hcs_$chname_file "" (char (*))(char (*))(char (*))(char (*))(return fixed bin (35.))))
190 
191 (defcom dired-rename
192         &prologue dired-m-access-check
193         &arguments ((new &string &prompt
194                          &eval (catenate "New name for " (dired-get-filename) ": ")))
195         (let ((old (dired-get-filename)))
196              (let ((code (hcs_$chname_file dired-dir old old new)))
197                   (or (zerop code)
198                       (display-com-error code new))
199                   (go-to-hpos 20.)
200                   (without-modifying (without-saving (kill-to-end-of-line))
201                                      (insert-string new)
202                                      (go-to-beginning-of-line)))))
203 
204 (defun dired-m-access-check ()
205        (if (not (dired-access-check dired-dir))
206            (display-error "Modify access lacking on " dired-dir)))