Mercurial > hg > xemacs-beta

comparison lisp/w3/url-file.el @ 98:0d2f883870bc r20-1b1

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-1b1
author cvs
date Mon, 13 Aug 2007 09:13:56 +0200
parents 364816949b59
children a145efe76779
comparison
equal deleted inserted replaced
97:498bf5da1c90 98:0d2f883870bc
1 ;;; url-file.el --- File retrieval code 1 ;;; url-file.el --- File retrieval code
2 ;; Author: wmperry 2 ;; Author: wmperry
3 ;; Created: 1997/01/24 14:32:50 3 ;; Created: 1997/02/10 16:16:46
4 ;; Version: 1.9 4 ;; Version: 1.13
5 ;; Keywords: comm, data, processes 5 ;; Keywords: comm, data, processes
6 6
7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8 ;;; Copyright (c) 1993-1996 by William M. Perry (wmperry@cs.indiana.edu) 8 ;;; Copyright (c) 1993-1996 by William M. Perry (wmperry@cs.indiana.edu)
9 ;;; Copyright (c) 1996, 1997 Free Software Foundation, Inc. 9 ;;; Copyright (c) 1996, 1997 Free Software Foundation, Inc.
42 (jam-zcat-filename-list nil) 42 (jam-zcat-filename-list nil)
43 (file-coding-system-for-read mule-no-coding-system) 43 (file-coding-system-for-read mule-no-coding-system)
44 (coding-system-for-read mule-no-coding-system)) 44 (coding-system-for-read mule-no-coding-system))
45 (setq compressed 45 (setq compressed
46 (cond 46 (cond
47 ((file-exists-p fname) nil) 47 ((file-exists-p fname)
48 (if (string-match "\\.\\(z\\|gz\\|Z\\)$" fname)
49 (case (intern (match-string 1 fname))
50 ((z gz)
51 (setq url-current-mime-headers (cons
52 (cons
53 "content-transfer-encoding"
54 "gzip")
55 url-current-mime-headers)))
56 (Z
57 (setq url-current-mime-headers (cons
58 (cons
59 "content-transfer-encoding"
60 "compress")
61 url-current-mime-headers))))
62 nil))
48 ((file-exists-p (concat fname ".Z")) 63 ((file-exists-p (concat fname ".Z"))
49 (setq fname (concat fname ".Z"))) 64 (setq fname (concat fname ".Z")
65 url-current-mime-headers (cons (cons
66 "content-transfer-encoding"
67 "compress")
68 url-current-mime-headers)))
50 ((file-exists-p (concat fname ".gz")) 69 ((file-exists-p (concat fname ".gz"))
51 (setq fname (concat fname ".gz"))) 70 (setq fname (concat fname ".gz")
71 url-current-mime-headers (cons (cons
72 "content-transfer-encoding"
73 "gzip")
74 url-current-mime-headers)))
52 ((file-exists-p (concat fname ".z")) 75 ((file-exists-p (concat fname ".z"))
53 (setq fname (concat fname ".z"))) 76 (setq fname (concat fname ".z")
77 url-current-mime-headers (cons (cons
78 "content-transfer-encoding"
79 "gzip")
80 url-current-mime-headers)))
54 (t 81 (t
55 (error "File not found %s" fname)))) 82 (error "File not found %s" fname))))
56 (if (or (not compressed) url-inhibit-uncompression) 83 (apply 'insert-file-contents fname args)
57 (apply 'insert-file-contents fname args) 84 (set-buffer-modified-p nil)))
58 (let* ((extn (url-file-extension fname)) 85
59 (code (cdr-safe (assoc extn url-uncompressor-alist))) 86 (defvar url-dired-minor-mode-map
60 (decoder (cdr-safe (assoc code mm-content-transfer-encodings)))) 87 (let ((map (make-sparse-keymap)))
61 (cond 88 (define-key map "\C-m" 'url-dired-find-file)
62 ((null decoder) 89 (if url-running-xemacs
63 (apply 'insert-file-contents fname args)) 90 (define-key map [button2] 'url-dired-find-file-mouse)
64 ((stringp decoder) 91 (define-key map [mouse-2] 'url-dired-find-file-mouse))
65 (apply 'insert-file-contents fname args) 92 map)
66 (message "Decoding...") 93 "Keymap used when browsing directories.")
67 (call-process-region (point-min) (point-max) decoder t t nil) 94
68 (message "Decoding... done.")) 95 (defvar url-dired-minor-mode nil
69 ((listp decoder) 96 "Whether we are in url-dired-minor-mode")
70 (apply 'call-process-region (point-min) (point-max) 97
71 (car decoder) t t t (cdr decoder))) 98 (make-variable-buffer-local 'url-dired-minor-mode)
72 ((and (symbolp decoder) (fboundp decoder)) 99
73 (apply 'insert-file-contents fname args) 100 (defun url-dired-find-file ()
74 (message "Decoding...") 101 "In dired, visit the file or directory named on this line, using Emacs-W3."
75 (funcall decoder (point-min) (point-max)) 102 (interactive)
76 (message "Decoding... done.")) 103 (w3-open-local (dired-get-filename)))
77 (t 104
78 (error "Malformed entry for %s in `mm-content-transfer-encodings'" 105 (defun url-dired-find-file-mouse (event)
79 code)))))) 106 "In dired, visit the file or directory name you click on, using Emacs-W3."
80 (set-buffer-modified-p nil)) 107 (interactive "@e")
108 (if (event-point event)
109 (progn
110 (goto-char (event-point event))
111 (url-dired-find-file))))
112
113 (defun url-dired-minor-mode (&optional arg)
114 "Minor mode for directory browsing with Emacs-W3."
115 (interactive "P")
116 (cond
117 ((null arg)
118 (setq url-dired-minor-mode (not url-dired-minor-mode)))
119 ((equal 0 arg)
120 (setq url-dired-minor-mode nil))
121 (t
122 (setq url-dired-minor-mode t))))
123
124 (add-minor-mode 'url-dired-minor-mode " URL" url-dired-minor-mode-map)
81 125
82 (defun url-format-directory (dir) 126 (defun url-format-directory (dir)
83 ;; Format the files in DIR into hypertext 127 ;; Format the files in DIR into hypertext
84 (let ((files (directory-files dir nil)) file 128 (if (and url-directory-index-file
85 div attr mod-time size typ title) 129 (file-exists-p (expand-file-name url-directory-index-file dir))
86 (if (and url-directory-index-file 130 (file-readable-p (expand-file-name url-directory-index-file dir)))
87 (file-exists-p (expand-file-name url-directory-index-file dir))
88 (file-readable-p (expand-file-name url-directory-index-file dir)))
89 (save-excursion
90 (set-buffer url-working-buffer)
91 (erase-buffer)
92 (insert-file-contents-literally
93 (expand-file-name url-directory-index-file dir)))
94 (save-excursion 131 (save-excursion
95 (if (string-match "/\\([^/]+\\)/$" dir)
96 (setq title (concat ".../" (url-match dir 1) "/"))
97 (setq title "/"))
98 (setq div (1- (length files)))
99 (set-buffer url-working-buffer) 132 (set-buffer url-working-buffer)
100 (erase-buffer) 133 (erase-buffer)
101 (insert "<html>\n" 134 (insert-file-contents-literally
102 " <head>\n" 135 (expand-file-name url-directory-index-file dir)))
103 " <title>" title "</title>\n" 136 (kill-buffer (current-buffer))
104 " </head>\n" 137 (find-file dir)
105 " <body>\n" 138 (url-dired-minor-mode t)))
106 " <div>\n" 139 ; (let ((files (directory-files dir nil)) file
107 " <h1 align=center> Index of " title "</h1>\n" 140 ; div attr mod-time size typ title desc)
108 " <pre>\n" 141 ; (save-excursion
109 " Name Last modified Size\n</pre>" 142 ; (if (string-match "/\\([^/]+\\)/$" dir)
110 "<hr>\n <pre>\n") 143 ; (setq title (concat ".../" (url-match dir 1) "/"))
111 (while files 144 ; (setq title "/"))
112 (url-lazy-message "Building directory list... (%d%%)" 145 ; (setq div (1- (length files)))
113 (/ (* 100 (- div (length files))) div)) 146 ; (set-buffer url-working-buffer)
114 (setq file (expand-file-name (car files) dir) 147 ; (erase-buffer)
115 attr (file-attributes file) 148 ; (insert "<html>\n"
116 file (car files) 149 ; " <head>\n"
117 mod-time (nth 5 attr) 150 ; " <title>" title "</title>\n"
118 size (nth 7 attr) 151 ; " </head>\n"
119 typ (or (mm-extension-to-mime (url-file-extension file)) "")) 152 ; " <body>\n"
120 (setq file (url-hexify-string file)) 153 ; " <h1 align=center> Index of " title "</h1>\n"
121 (if (equal '(0 0) mod-time) ; Set to null if unknown or 154 ; " <table border=0>\n"
122 (setq mod-time "Unknown ") 155 ; " <tr><th>Name<th>Last Modified<th>Size</tr>\n"
123 (setq mod-time (current-time-string mod-time))) 156 ; " <tr><td colspan=3><hr></tr>\n")
124 (if (or (equal size 0) (equal size -1) (null size)) 157 ; (while files
125 (setq size " -") 158 ; (url-lazy-message "Building directory list... (%d%%)"
126 (setq size 159 ; (/ (* 100 (- div (length files))) div))
127 (cond 160 ; (setq file (expand-file-name (car files) dir)
128 ((< size 1024) (concat " " "1K")) 161 ; attr (file-attributes file)
129 ((< size 1048576) (concat " " 162 ; file (car files)
130 (int-to-string 163 ; mod-time (nth 5 attr)
131 (max 1 (/ size 1024))) "K")) 164 ; size (nth 7 attr)
132 (t 165 ; typ (or (mm-extension-to-mime (url-file-extension file)) ""))
133 (let* ((megs (max 1 (/ size 1048576))) 166 ; (setq file (url-hexify-string file))
134 (kilo (/ (- size (* megs 1048576)) 1024))) 167 ; (if (equal '(0 0) mod-time) ; Set to null if unknown or
135 (concat " " (int-to-string megs) 168 ; (setq mod-time "Unknown")
136 (if (> kilo 0) 169 ; (setq mod-time (current-time-string mod-time)))
137 (concat "." (int-to-string kilo)) 170 ; (if (or (equal size 0) (equal size -1) (null size))
138 "") "M")))))) 171 ; (setq size "-")
139 (cond 172 ; (setq size
140 ((or (equal "." (car files)) 173 ; (cond
141 (equal "/.." (car files))) 174 ; ((< size 1024) "1K")
142 nil) 175 ; ((< size 1048576) (concat (int-to-string
143 ((equal ".." (car files)) 176 ; (max 1 (/ size 1024))) "K"))
144 (if (not (= ?/ (aref file (1- (length file))))) 177 ; (t
145 (setq file (concat file "/")))) 178 ; (let* ((megs (max 1 (/ size 1048576)))
146 ((stringp (nth 0 attr)) ; Symbolic link handling 179 ; (kilo (/ (- size (* megs 1048576)) 1024)))
147 (insert "[LNK] <a href=\"./" file "\">" (car files) "</a>" 180 ; (concat (int-to-string megs)
148 (make-string (max 0 (- 25 (length (car files)))) ? ) 181 ; (if (> kilo 0)
149 mod-time size "\n")) 182 ; (concat "." (int-to-string kilo))
150 ((nth 0 attr) ; Directory handling 183 ; "") "M"))))))
151 (insert "[DIR] <a href=\"./" file "/\">" (car files) "</a>" 184 ; (cond
152 (make-string (max 0 (- 25 (length (car files)))) ? ) 185 ; ((or (equal "." (car files))
153 mod-time size "\n")) 186 ; (equal "/.." (car files)))
154 ((string-match "image" typ) 187 ; (setq desc nil))
155 (insert "[IMG] <a href=\"./" file "\">" (car files) "</a>" 188 ; ((equal ".." (car files))
156 (make-string (max 0 (- 25 (length (car files)))) ? ) 189 ; (if (not (= ?/ (aref file (1- (length file)))))
157 mod-time size "\n")) 190 ; (setq file (concat file "/"))))
158 ((string-match "application" typ) 191 ; ((stringp (nth 0 attr)) ; Symbolic link handling
159 (insert "[APP] <a href=\"./" file "\">" (car files) "</a>" 192 ; (setq desc "[LNK]"))
160 (make-string (max 0 (- 25 (length (car files)))) ? ) 193 ; ((nth 0 attr) ; Directory handling
161 mod-time size "\n")) 194 ; (setq desc "[DIR]"))
162 ((string-match "text" typ) 195 ; ((string-match "image" typ)
163 (insert "[TXT] <a href=\"./" file "\">" (car files) "</a>" 196 ; (setq desc "[IMG]"))
164 (make-string (max 0 (- 25 (length (car files)))) ? ) 197 ; ((string-match "application" typ)
165 mod-time size "\n")) 198 ; (setq desc "[APP]"))
166 (t 199 ; ((string-match "text" typ)
167 (insert "[UNK] <a href=\"./" file "\">" (car files) "</a>" 200 ; (setq desc "[TXT]"))
168 (make-string (max 0 (- 25 (length (car files)))) ? ) 201 ; ((auto-save-file-name-p (car files))
169 mod-time size "\n"))) 202 ; (setq desc "[BAK]"))
170 (setq files (cdr files))) 203 ; (t
171 (insert " </pre>\n" 204 ; (setq desc "[UNK]")))
172 " </div>\n" 205 ; (if desc
173 " </body>\n" 206 ; (insert "<tr><td>" desc " <a href=\"./" file "\">" (car files)
174 "</html>\n" 207 ; "</a><td>" mod-time "<td><p align=right>" size
175 "<!-- Automatically generated by URL v" url-version 208 ; "</tr>\n"))
176 " -->\n"))))) 209 ; (setq files (cdr files)))
210 ; (insert " </table>\n"
211 ; " </body>\n"
212 ; "</html>\n"
213 ; "<!-- Automatically generated by URL v" url-version
214 ; " -->\n")))
177 215
178 (defun url-host-is-local-p (host) 216 (defun url-host-is-local-p (host)
179 "Return t iff HOST references our local machine." 217 "Return t iff HOST references our local machine."
180 (let ((case-fold-search t)) 218 (let ((case-fold-search t))
181 (or 219 (or
220 (efs-set-passwd site user pass)) 258 (efs-set-passwd site user pass))
221 (t 259 (t
222 nil))) 260 nil)))
223 (cond 261 (cond
224 ((file-directory-p filename) 262 ((file-directory-p filename)
225 (if url-use-hypertext-dired 263 (if (string-match "/$" filename)
226 (progn 264 nil
227 (if (string-match "/$" filename) 265 (setq filename (concat filename "/")))
228 nil 266 (if (string-match "/$" file)
229 (setq filename (concat filename "/"))) 267 nil
230 (if (string-match "/$" file) 268 (setq file (concat file "/")))
231 nil 269 (url-set-filename urlobj file)
232 (setq file (concat file "/"))) 270 (url-format-directory filename))
233 (url-set-filename urlobj file)
234 (url-format-directory filename))
235 (progn
236 (if (get-buffer url-working-buffer)
237 (kill-buffer url-working-buffer))
238 (find-file filename))))
239 ((and (boundp 'w3-dump-to-disk) (symbol-value 'w3-dump-to-disk)) 271 ((and (boundp 'w3-dump-to-disk) (symbol-value 'w3-dump-to-disk))
240 (cond 272 (cond
241 ((file-exists-p filename) nil) 273 ((file-exists-p filename) nil)
242 ((file-exists-p (concat filename ".Z")) 274 ((file-exists-p (concat filename ".Z"))
243 (setq filename (concat filename ".Z"))) 275 (setq filename (concat filename ".Z")))