Line data Source code
1 : ;;; url-util.el --- Miscellaneous helper routines for URL library -*- lexical-binding: t -*-
2 :
3 : ;; Copyright (C) 1996-1999, 2001, 2004-2017 Free Software Foundation,
4 : ;; Inc.
5 :
6 : ;; Author: Bill Perry <wmperry@gnu.org>
7 : ;; Maintainer: emacs-devel@gnu.org
8 : ;; Keywords: comm, data, processes
9 :
10 : ;; This file is part of GNU Emacs.
11 : ;;
12 : ;; GNU Emacs is free software: you can redistribute it and/or modify
13 : ;; it under the terms of the GNU General Public License as published by
14 : ;; the Free Software Foundation, either version 3 of the License, or
15 : ;; (at your option) any later version.
16 :
17 : ;; GNU Emacs is distributed in the hope that it will be useful,
18 : ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 : ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20 : ;; GNU General Public License for more details.
21 :
22 : ;; You should have received a copy of the GNU General Public License
23 : ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
24 :
25 : ;;; Commentary:
26 :
27 : ;;; Code:
28 :
29 : (require 'url-parse)
30 : (require 'url-vars)
31 : (autoload 'timezone-parse-date "timezone")
32 : (autoload 'timezone-make-date-arpa-standard "timezone")
33 : (autoload 'mail-header-extract "mailheader")
34 :
35 : (defvar url-parse-args-syntax-table
36 : (copy-syntax-table emacs-lisp-mode-syntax-table)
37 : "A syntax table for parsing sgml attributes.")
38 :
39 : (modify-syntax-entry ?' "\"" url-parse-args-syntax-table)
40 : (modify-syntax-entry ?` "\"" url-parse-args-syntax-table)
41 : (modify-syntax-entry ?{ "(" url-parse-args-syntax-table)
42 : (modify-syntax-entry ?} ")" url-parse-args-syntax-table)
43 :
44 : ;;;###autoload
45 : (defcustom url-debug nil
46 : "What types of debug messages from the URL library to show.
47 : Debug messages are logged to the *URL-DEBUG* buffer.
48 :
49 : If t, all messages will be logged.
50 : If a number, all messages will be logged, as well shown via `message'.
51 : If a list, it is a list of the types of messages to be logged."
52 : :type '(choice (const :tag "none" nil)
53 : (const :tag "all" t)
54 : (checklist :tag "custom"
55 : (const :tag "HTTP" :value http)
56 : (const :tag "DAV" :value dav)
57 : (const :tag "General" :value retrieval)
58 : (const :tag "Filename handlers" :value handlers)
59 : (symbol :tag "Other")))
60 : :group 'url-hairy)
61 :
62 : ;;;###autoload
63 : (defun url-debug (tag &rest args)
64 0 : (if quit-flag
65 0 : (error "Interrupted!"))
66 0 : (if (or (eq url-debug t)
67 0 : (numberp url-debug)
68 0 : (and (listp url-debug) (memq tag url-debug)))
69 0 : (with-current-buffer (get-buffer-create "*URL-DEBUG*")
70 0 : (goto-char (point-max))
71 0 : (insert (symbol-name tag) " -> " (apply 'format args) "\n")
72 0 : (if (numberp url-debug)
73 0 : (apply 'message args)))))
74 :
75 : ;;;###autoload
76 : (defun url-parse-args (str &optional nodowncase)
77 : ;; Return an assoc list of attribute/value pairs from an RFC822-type string
78 0 : (let (
79 : name ; From name=
80 : value ; its value
81 : results ; Assoc list of results
82 : name-pos ; Start of XXXX= position
83 : val-pos ; Start of value position
84 : st
85 : nd
86 : )
87 0 : (save-excursion
88 0 : (save-restriction
89 0 : (set-buffer (get-buffer-create " *urlparse-temp*"))
90 0 : (set-syntax-table url-parse-args-syntax-table)
91 0 : (erase-buffer)
92 0 : (insert str)
93 0 : (setq st (point-min)
94 0 : nd (point-max))
95 0 : (set-syntax-table url-parse-args-syntax-table)
96 0 : (narrow-to-region st nd)
97 0 : (goto-char (point-min))
98 0 : (while (not (eobp))
99 0 : (skip-chars-forward "; \n\t")
100 0 : (setq name-pos (point))
101 0 : (skip-chars-forward "^ \n\t=;")
102 0 : (if (not nodowncase)
103 0 : (downcase-region name-pos (point)))
104 0 : (setq name (buffer-substring name-pos (point)))
105 0 : (skip-chars-forward " \t\n")
106 0 : (if (/= (or (char-after (point)) 0) ?=) ; There is no value
107 0 : (setq value nil)
108 0 : (skip-chars-forward " \t\n=")
109 0 : (setq val-pos (point)
110 : value
111 0 : (cond
112 0 : ((or (= (or (char-after val-pos) 0) ?\")
113 0 : (= (or (char-after val-pos) 0) ?'))
114 0 : (buffer-substring (1+ val-pos)
115 0 : (condition-case ()
116 0 : (prog2
117 0 : (forward-sexp 1)
118 0 : (1- (point))
119 0 : (skip-chars-forward "\""))
120 : (error
121 0 : (skip-chars-forward "^ \t\n")
122 0 : (point)))))
123 : (t
124 0 : (buffer-substring val-pos
125 0 : (progn
126 0 : (skip-chars-forward "^;")
127 0 : (skip-chars-backward " \t")
128 0 : (point)))))))
129 0 : (setq results (cons (cons name value) results))
130 0 : (skip-chars-forward "; \n\t"))
131 0 : results))))
132 :
133 : ;;;###autoload
134 : (defun url-insert-entities-in-string (string)
135 : "Convert HTML markup-start characters to entity references in STRING.
136 : Also replaces the \" character, so that the result may be safely used as
137 : an attribute value in a tag. Returns a new string with the result of the
138 : conversion. Replaces these characters as follows:
139 : & ==> &
140 : < ==> <
141 : > ==> >
142 : \" ==> ""
143 0 : (if (string-match "[&<>\"]" string)
144 0 : (with-current-buffer (get-buffer-create " *entity*")
145 0 : (erase-buffer)
146 0 : (buffer-disable-undo (current-buffer))
147 0 : (insert string)
148 0 : (goto-char (point-min))
149 0 : (while (progn
150 0 : (skip-chars-forward "^&<>\"")
151 0 : (not (eobp)))
152 0 : (insert (cdr (assq (char-after (point))
153 : '((?\" . """)
154 : (?& . "&")
155 : (?< . "<")
156 0 : (?> . ">")))))
157 0 : (delete-char 1))
158 0 : (buffer-string))
159 0 : string))
160 :
161 : ;;;###autoload
162 : (defun url-normalize-url (url)
163 : "Return a \"normalized\" version of URL.
164 : Strips out default port numbers, etc."
165 0 : (let (type data retval)
166 0 : (setq data (url-generic-parse-url url)
167 0 : type (url-type data))
168 0 : (if (member type '("www" "about" "mailto" "info"))
169 0 : (setq retval url)
170 : ;; FIXME all this does, and all this function seems to do in
171 : ;; most cases, is remove any trailing "#anchor" part of a url.
172 0 : (setf (url-target data) nil)
173 0 : (setq retval (url-recreate-url data)))
174 0 : retval))
175 :
176 : ;;;###autoload
177 : (defun url-lazy-message (&rest args)
178 : "Just like `message', but is a no-op if called more than once a second.
179 : Will not do anything if `url-show-status' is nil."
180 0 : (if (or (and url-current-object
181 0 : (url-silent url-current-object))
182 0 : (null url-show-status)
183 0 : (active-minibuffer-window)
184 0 : (= url-lazy-message-time
185 0 : (setq url-lazy-message-time (nth 1 (current-time)))))
186 : nil
187 0 : (apply 'message args)))
188 :
189 : ;;;###autoload
190 : (defun url-get-normalized-date (&optional specified-time)
191 : "Return a date string that most HTTP servers can understand."
192 0 : (let ((system-time-locale "C"))
193 0 : (format-time-string "%a, %d %b %Y %T GMT" specified-time t)))
194 :
195 : ;;;###autoload
196 : (defun url-eat-trailing-space (x)
197 : "Remove spaces/tabs at the end of a string."
198 0 : (let ((y (1- (length x)))
199 0 : (skip-chars (list ? ?\t ?\n)))
200 0 : (while (and (>= y 0) (memq (aref x y) skip-chars))
201 0 : (setq y (1- y)))
202 0 : (substring x 0 (1+ y))))
203 :
204 : ;;;###autoload
205 : (defun url-strip-leading-spaces (x)
206 : "Remove spaces at the front of a string."
207 0 : (let ((y (1- (length x)))
208 : (z 0)
209 0 : (skip-chars (list ? ?\t ?\n)))
210 0 : (while (and (<= z y) (memq (aref x z) skip-chars))
211 0 : (setq z (1+ z)))
212 0 : (substring x z nil)))
213 :
214 :
215 : (define-obsolete-function-alias 'url-pretty-length
216 : 'file-size-human-readable "24.4")
217 :
218 : ;;;###autoload
219 : (defun url-display-percentage (fmt perc &rest args)
220 0 : (when (and url-show-status
221 0 : (or (null url-current-object)
222 0 : (not (url-silent url-current-object))))
223 0 : (if (null fmt)
224 0 : (if (fboundp 'clear-progress-display)
225 0 : (clear-progress-display))
226 0 : (if (and (fboundp 'progress-display) perc)
227 0 : (apply 'progress-display fmt perc args)
228 0 : (apply 'message fmt args)))))
229 :
230 : ;;;###autoload
231 : (defun url-percentage (x y)
232 0 : (if (fboundp 'float)
233 0 : (round (* 100 (/ x (float y))))
234 0 : (/ (* x 100) y)))
235 :
236 : ;;;###autoload
237 : (defalias 'url-basepath 'url-file-directory)
238 :
239 : ;;;###autoload
240 : (defun url-file-directory (file)
241 : "Return the directory part of FILE, for a URL."
242 0 : (cond
243 0 : ((null file) "")
244 0 : ((string-match "\\?" file)
245 0 : (url-file-directory (substring file 0 (match-beginning 0))))
246 0 : ((string-match "\\(.*\\(/\\|%2[fF]\\)\\)" file)
247 0 : (match-string 1 file))))
248 :
249 : ;;;###autoload
250 : (defun url-file-nondirectory (file)
251 : "Return the nondirectory part of FILE, for a URL."
252 0 : (cond
253 0 : ((null file) "")
254 0 : ((string-match "\\?" file)
255 0 : (url-file-nondirectory (substring file 0 (match-beginning 0))))
256 0 : ((string-match ".*\\(?:/\\|%2[fF]\\)\\(.*\\)" file)
257 0 : (match-string 1 file))
258 0 : (t file)))
259 :
260 : ;;;###autoload
261 : (defun url-parse-query-string (query &optional downcase allow-newlines)
262 0 : (let (retval pairs cur key val)
263 0 : (setq pairs (split-string query "[;&]"))
264 0 : (while pairs
265 0 : (setq cur (car pairs)
266 0 : pairs (cdr pairs))
267 0 : (unless (string-match "=" cur)
268 0 : (setq cur (concat cur "=")))
269 :
270 0 : (when (string-match "=" cur)
271 0 : (setq key (url-unhex-string (substring cur 0 (match-beginning 0))
272 0 : allow-newlines))
273 0 : (setq val (url-unhex-string (substring cur (match-end 0) nil)
274 0 : allow-newlines))
275 0 : (if downcase
276 0 : (setq key (downcase key)))
277 0 : (setq cur (assoc key retval))
278 0 : (if cur
279 0 : (setcdr cur (cons val (cdr cur)))
280 0 : (setq retval (cons (list key val) retval)))))
281 0 : retval))
282 :
283 : ;;;###autoload
284 : (defun url-build-query-string (query &optional semicolons keep-empty)
285 : "Build a query-string.
286 :
287 : Given a QUERY in the form:
288 : ((key1 val1)
289 : (key2 val2)
290 : (key3 val1 val2)
291 : (key4)
292 : (key5 \"\"))
293 :
294 : \(This is the same format as produced by `url-parse-query-string')
295 :
296 : This will return a string
297 : \"key1=val1&key2=val2&key3=val1&key3=val2&key4&key5\". Keys may
298 : be strings or symbols; if they are symbols, the symbol name will
299 : be used.
300 :
301 : When SEMICOLONS is given, the separator will be \";\".
302 :
303 : When KEEP-EMPTY is given, empty values will show as \"key=\"
304 : instead of just \"key\" as in the example above."
305 0 : (mapconcat
306 : (lambda (key-vals)
307 0 : (let ((escaped
308 0 : (mapcar (lambda (sym)
309 0 : (url-hexify-string (format "%s" sym))) key-vals)))
310 0 : (mapconcat (lambda (val)
311 0 : (let ((vprint (format "%s" val))
312 0 : (eprint (format "%s" (car escaped))))
313 0 : (concat eprint
314 0 : (if (or keep-empty
315 0 : (and val (not (zerop (length vprint)))))
316 : "="
317 0 : "")
318 0 : vprint)))
319 0 : (or (cdr escaped) '("")) (if semicolons ";" "&"))))
320 0 : query (if semicolons ";" "&")))
321 :
322 : (defun url-unhex (x)
323 0 : (if (> x ?9)
324 0 : (if (>= x ?a)
325 0 : (+ 10 (- x ?a))
326 0 : (+ 10 (- x ?A)))
327 0 : (- x ?0)))
328 :
329 : ;; Fixme: Is this definition better, and does it ever matter?
330 :
331 : ;; (defun url-unhex-string (str &optional allow-newlines)
332 : ;; "Remove %XX, embedded spaces, etc in a url.
333 : ;; If optional second argument ALLOW-NEWLINES is non-nil, then allow the
334 : ;; decoding of carriage returns and line feeds in the string, which is normally
335 : ;; forbidden in URL encoding."
336 : ;; (setq str (or str ""))
337 : ;; (setq str (replace-regexp-in-string "%[[:xdigit:]]\\{2\\}"
338 : ;; (lambda (match)
339 : ;; (string (string-to-number
340 : ;; (substring match 1) 16)))
341 : ;; str t t))
342 : ;; (if allow-newlines
343 : ;; (replace-regexp-in-string "[\n\r]" (lambda (match)
344 : ;; (format "%%%.2X" (aref match 0)))
345 : ;; str t t)
346 : ;; str))
347 :
348 : ;;;###autoload
349 : (defun url-unhex-string (str &optional allow-newlines)
350 : "Remove %XX embedded spaces, etc in a URL.
351 : If optional second argument ALLOW-NEWLINES is non-nil, then allow the
352 : decoding of carriage returns and line feeds in the string, which is normally
353 : forbidden in URL encoding."
354 0 : (setq str (or str ""))
355 0 : (let ((tmp "")
356 : (case-fold-search t))
357 0 : (while (string-match "%[0-9a-f][0-9a-f]" str)
358 0 : (let* ((start (match-beginning 0))
359 0 : (ch1 (url-unhex (elt str (+ start 1))))
360 0 : (code (+ (* 16 ch1)
361 0 : (url-unhex (elt str (+ start 2))))))
362 0 : (setq tmp (concat
363 0 : tmp (substring str 0 start)
364 0 : (cond
365 0 : (allow-newlines
366 0 : (byte-to-string code))
367 0 : ((or (= code ?\n) (= code ?\r))
368 : " ")
369 0 : (t (byte-to-string code))))
370 0 : str (substring str (match-end 0)))))
371 0 : (concat tmp str)))
372 :
373 : (defconst url-unreserved-chars
374 : '(?a ?b ?c ?d ?e ?f ?g ?h ?i ?j ?k ?l ?m ?n ?o ?p ?q ?r ?s ?t ?u ?v ?w ?x ?y ?z
375 : ?A ?B ?C ?D ?E ?F ?G ?H ?I ?J ?K ?L ?M ?N ?O ?P ?Q ?R ?S ?T ?U ?V ?W ?X ?Y ?Z
376 : ?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9
377 : ?- ?_ ?. ?~)
378 : "List of characters that are unreserved in the URL spec.
379 : This is taken from RFC 3986 (section 2.3).")
380 :
381 : (defconst url-encoding-table
382 : (let ((vec (make-vector 256 nil)))
383 : (dotimes (byte 256)
384 : ;; RFC 3986 (Section 2.1): For consistency, URI producers and
385 : ;; normalizers should use uppercase hexadecimal digits for all
386 : ;; percent-encodings.
387 : (aset vec byte (format "%%%02X" byte)))
388 : vec)
389 : "Vector translating bytes to URI-encoded %-sequences.")
390 :
391 : (defun url--allowed-chars (char-list)
392 : "Return an \"allowed character\" mask (a 256-slot vector).
393 : The Nth element is non-nil if character N is in CHAR-LIST. The
394 : result can be passed as the second arg to `url-hexify-string'."
395 1 : (let ((vec (make-vector 256 nil)))
396 1 : (dolist (byte char-list)
397 78 : (ignore-errors (aset vec byte t)))
398 1 : vec))
399 :
400 : ;;;###autoload
401 : (defun url-hexify-string (string &optional allowed-chars)
402 : "URI-encode STRING and return the result.
403 : If STRING is multibyte, it is first converted to a utf-8 byte
404 : string. Each byte corresponding to an allowed character is left
405 : as-is, while all other bytes are converted to a three-character
406 : string: \"%\" followed by two upper-case hex digits.
407 :
408 : The allowed characters are specified by ALLOWED-CHARS. If this
409 : argument is nil, the list `url-unreserved-chars' determines the
410 : allowed characters. Otherwise, ALLOWED-CHARS should be a vector
411 : whose Nth element is non-nil if character N is allowed."
412 0 : (unless allowed-chars
413 0 : (setq allowed-chars (url--allowed-chars url-unreserved-chars)))
414 0 : (mapconcat (lambda (byte)
415 0 : (if (aref allowed-chars byte)
416 0 : (char-to-string byte)
417 0 : (aref url-encoding-table byte)))
418 0 : (if (multibyte-string-p string)
419 0 : (encode-coding-string string 'utf-8)
420 0 : string)
421 0 : ""))
422 :
423 : (defconst url-host-allowed-chars
424 : ;; Allow % to avoid re-encoding %-encoded sequences.
425 : (url--allowed-chars (append '(?% ?! ?$ ?& ?' ?\( ?\) ?* ?+ ?, ?\; ?=)
426 : url-unreserved-chars))
427 : "Allowed-character byte mask for the host segment of a URI.
428 : These characters are specified in RFC 3986, Appendix A.")
429 :
430 : (defconst url-path-allowed-chars
431 : (let ((vec (copy-sequence url-host-allowed-chars)))
432 : (aset vec ?/ t)
433 : (aset vec ?: t)
434 : (aset vec ?@ t)
435 : vec)
436 : "Allowed-character byte mask for the path segment of a URI.
437 : These characters are specified in RFC 3986, Appendix A.")
438 :
439 : (defconst url-query-allowed-chars
440 : (let ((vec (copy-sequence url-path-allowed-chars)))
441 : (aset vec ?? t)
442 : vec)
443 : "Allowed-character byte mask for the query segment of a URI.
444 : These characters are specified in RFC 3986, Appendix A.")
445 :
446 : ;;;###autoload
447 : (defun url-encode-url (url)
448 : "Return a properly URI-encoded version of URL.
449 : This function also performs URI normalization, e.g. converting
450 : the scheme to lowercase if it is uppercase. Apart from
451 : normalization, if URL is already URI-encoded, this function
452 : should return it unchanged."
453 0 : (let* ((obj (url-generic-parse-url url))
454 0 : (user (url-user obj))
455 0 : (pass (url-password obj))
456 0 : (path-and-query (url-path-and-query obj))
457 0 : (path (car path-and-query))
458 0 : (query (cdr path-and-query))
459 0 : (frag (url-target obj)))
460 0 : (if user
461 0 : (setf (url-user obj) (url-hexify-string user)))
462 0 : (if pass
463 0 : (setf (url-password obj) (url-hexify-string pass)))
464 0 : (if path
465 0 : (setq path (url-hexify-string path url-path-allowed-chars)))
466 0 : (if query
467 0 : (setq query (url-hexify-string query url-query-allowed-chars)))
468 0 : (setf (url-filename obj) (if query (concat path "?" query) path))
469 :
470 0 : (if frag
471 0 : (setf (url-target obj)
472 0 : (url-hexify-string frag url-query-allowed-chars)))
473 0 : (url-recreate-url obj)))
474 :
475 : ;;;###autoload
476 : (defun url-file-extension (fname &optional x)
477 : "Return the filename extension of FNAME.
478 : If optional argument X is t, then return the basename
479 : of the file with the extension stripped off."
480 0 : (if (and fname
481 0 : (setq fname (url-file-nondirectory fname))
482 0 : (string-match "\\.[^./]+$" fname))
483 0 : (if x (substring fname 0 (match-beginning 0))
484 0 : (substring fname (match-beginning 0) nil))
485 : ;;
486 : ;; If fname has no extension, and x then return fname itself instead of
487 : ;; nothing. When caching it allows the correct .hdr file to be produced
488 : ;; for filenames without extension.
489 : ;;
490 0 : (if x
491 0 : fname
492 0 : "")))
493 :
494 : ;;;###autoload
495 : (defun url-truncate-url-for-viewing (url &optional width)
496 : "Return a shortened version of URL that is WIDTH characters wide or less.
497 : WIDTH defaults to the current frame width."
498 0 : (let* ((fr-width (or width (frame-width)))
499 0 : (str-width (length url))
500 : (fname nil)
501 : (modified 0)
502 : (urlobj nil))
503 : ;; The first thing that can go are the search strings
504 0 : (if (and (>= str-width fr-width)
505 0 : (string-match "?" url))
506 0 : (setq url (concat (substring url 0 (match-beginning 0)) "?...")
507 0 : str-width (length url)))
508 0 : (if (< str-width fr-width)
509 : nil ; Hey, we are done!
510 0 : (setq urlobj (url-generic-parse-url url)
511 0 : fname (url-filename urlobj)
512 0 : fr-width (- fr-width 4))
513 0 : (while (and (>= str-width fr-width)
514 0 : (string-match "/" fname))
515 0 : (setq fname (substring fname (match-end 0) nil)
516 0 : modified (1+ modified))
517 0 : (setf (url-filename urlobj) fname)
518 0 : (setq url (url-recreate-url urlobj)
519 0 : str-width (length url)))
520 0 : (if (> modified 1)
521 0 : (setq fname (concat "/.../" fname))
522 0 : (setq fname (concat "/" fname)))
523 0 : (setf (url-filename urlobj) fname)
524 0 : (setq url (url-recreate-url urlobj)))
525 0 : url))
526 :
527 : ;;;###autoload
528 : (defun url-view-url (&optional no-show)
529 : "View the current document's URL.
530 : Optional argument NO-SHOW means just return the URL, don't show it in
531 : the minibuffer.
532 :
533 : This uses `url-current-object', set locally to the buffer."
534 : (interactive)
535 0 : (if (not url-current-object)
536 : nil
537 0 : (if no-show
538 0 : (url-recreate-url url-current-object)
539 0 : (message "%s" (url-recreate-url url-current-object)))))
540 :
541 : (defvar url-get-url-filename-chars "-%.?@a-zA-Z0-9()_/:~=&"
542 : "Valid characters in a URL.")
543 :
544 : (defun url-get-url-at-point (&optional pt)
545 : "Get the URL closest to point, but don't change position.
546 : Has a preference for looking backward when not directly on a symbol."
547 : ;; Not at all perfect - point must be right in the name.
548 0 : (save-excursion
549 0 : (if pt (goto-char pt))
550 0 : (let (start url)
551 0 : (save-excursion
552 : ;; first see if you're just past a filename
553 0 : (if (not (eobp))
554 0 : (if (looking-at "[] \t\n[{}()]") ; whitespace or some parens
555 0 : (progn
556 0 : (skip-chars-backward " \n\t\r({[]})")
557 0 : (if (not (bobp))
558 0 : (backward-char 1)))))
559 0 : (if (and (char-after (point))
560 0 : (string-match (concat "[" url-get-url-filename-chars "]")
561 0 : (char-to-string (char-after (point)))))
562 0 : (progn
563 0 : (skip-chars-backward url-get-url-filename-chars)
564 0 : (setq start (point))
565 0 : (skip-chars-forward url-get-url-filename-chars))
566 0 : (setq start (point)))
567 0 : (setq url (buffer-substring-no-properties start (point))))
568 0 : (if (and url (string-match "^(\\(.*\\))\\.?$" url))
569 0 : (setq url (match-string 1 url)))
570 0 : (if (and url (string-match "^URL:" url))
571 0 : (setq url (substring url 4 nil)))
572 0 : (if (and url (string-match "\\.$" url))
573 0 : (setq url (substring url 0 -1)))
574 0 : (if (and url (string-match "^www\\." url))
575 0 : (setq url (concat "http://" url)))
576 0 : (if (and url (not (string-match url-nonrelative-link url)))
577 0 : (setq url nil))
578 0 : url)))
579 :
580 : (defun url-generate-unique-filename (&optional fmt)
581 : "Generate a unique filename in `url-temporary-directory'."
582 : (declare (obsolete make-temp-file "23.1"))
583 : ;; This variable is obsolete, but so is this function.
584 0 : (let ((tempdir (with-no-warnings url-temporary-directory)))
585 0 : (if (not fmt)
586 0 : (let ((base (format "url-tmp.%d" (user-real-uid)))
587 : (fname "")
588 : (x 0))
589 0 : (setq fname (format "%s%d" base x))
590 0 : (while (file-exists-p
591 0 : (expand-file-name fname tempdir))
592 0 : (setq x (1+ x)
593 0 : fname (concat base (int-to-string x))))
594 0 : (expand-file-name fname tempdir))
595 0 : (let ((base (concat "url" (int-to-string (user-real-uid))))
596 : (fname "")
597 : (x 0))
598 0 : (setq fname (format fmt (concat base (int-to-string x))))
599 0 : (while (file-exists-p
600 0 : (expand-file-name fname tempdir))
601 0 : (setq x (1+ x)
602 0 : fname (format fmt (concat base (int-to-string x)))))
603 0 : (expand-file-name fname tempdir)))))
604 :
605 : (defun url-extract-mime-headers ()
606 : "Set `url-current-mime-headers' in current buffer."
607 0 : (save-excursion
608 0 : (goto-char (point-min))
609 0 : (unless url-current-mime-headers
610 0 : (set (make-local-variable 'url-current-mime-headers)
611 0 : (mail-header-extract)))))
612 :
613 : (defun url-make-private-file (file)
614 : "Make FILE only readable and writable by the current user.
615 : Creates FILE and its parent directories if they do not exist."
616 0 : (let ((dir (file-name-directory file)))
617 0 : (when dir
618 : ;; For historical reasons.
619 0 : (make-directory dir t)))
620 : ;; Based on doc-view-make-safe-dir.
621 0 : (condition-case nil
622 0 : (with-file-modes #o0600
623 0 : (with-temp-buffer
624 0 : (write-region (point-min) (point-max) file nil 'silent nil 'excl)))
625 : (file-already-exists
626 0 : (if (file-symlink-p file)
627 0 : (error "Danger: `%s' is a symbolic link" file))
628 0 : (set-file-modes file #o0600))))
629 :
630 : (provide 'url-util)
631 :
632 : ;;; url-util.el ends here
|