1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
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)
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))
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))
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)
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)
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
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)))