LCOV - code coverage report
Current view: top level - lisp/url - url-util.el (source / functions) Hit Total Coverage
Test: tramp-tests-after.info Lines: 4 303 1.3 %
Date: 2017-08-30 10:12:24 Functions: 1 30 3.3 %

          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             :     &  ==>  &amp;
     140             :     <  ==>  &lt;
     141             :     >  ==>  &gt;
     142             :     \"  ==>  &quot;"
     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             :                              '((?\" . "&quot;")
     154             :                                (?& . "&amp;")
     155             :                                (?< . "&lt;")
     156           0 :                                (?> . "&gt;")))))
     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

Generated by: LCOV version 1.12