;;; url-util.el --- Miscellaneous helper routines for URL library
;; Copyright (C) 1996, 1997, 1998, 1999, 2001, 2004,
-;; 2005 Free Software Foundation, Inc.
+;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
;; Author: Bill Perry <wmperry@gnu.org>
;; Keywords: comm, data, processes
;; This file is part of GNU Emacs.
;;
-;; GNU Emacs is free software; you can redistribute it and/or modify
+;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
-;;
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
-;;
+
;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
-;; Boston, MA 02110-1301, USA.
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; Code:
(require 'url-parse)
+(eval-when-compile (require 'cl))
(autoload 'timezone-parse-date "timezone")
(autoload 'timezone-make-date-arpa-standard "timezone")
(autoload 'mail-header-extract "mailheader")
(defun url-normalize-url (url)
"Return a 'normalized' version of URL.
Strips out default port numbers, etc."
- (let (type data grok retval)
+ (let (type data retval)
(setq data (url-generic-parse-url url)
type (url-type data))
(if (member type '("www" "about" "mailto" "info"))
(setq retval url)
- (url-set-target data nil)
+ (setf (url-target data) nil)
(setq retval (url-recreate-url data)))
retval))
;;;###autoload
(defun url-get-normalized-date (&optional specified-time)
- "Return a 'real' date string that most HTTP servers can understand."
- (require 'timezone)
- (let* ((raw (if specified-time (current-time-string specified-time)
- (current-time-string)))
- (gmt (timezone-make-date-arpa-standard raw
- (nth 1 (current-time-zone))
- "GMT"))
- (parsed (timezone-parse-date gmt))
- (day (cdr-safe (assoc (substring raw 0 3) url-weekday-alist)))
- (year nil)
- (month (car
- (rassoc
- (string-to-number (aref parsed 1)) url-monthabbrev-alist)))
- )
- (setq day (or (car-safe (rassoc day url-weekday-alist))
- (substring raw 0 3))
- year (aref parsed 0))
- ;; This is needed for plexus servers, or the server will hang trying to
- ;; parse the if-modified-since header. Hopefully, I can take this out
- ;; soon.
- (if (and year (> (length year) 2))
- (setq year (substring year -2 nil)))
-
- (concat day ", " (aref parsed 2) "-" month "-" year " "
- (aref parsed 3) " " (or (aref parsed 4)
- (concat "[" (nth 1 (current-time-zone))
- "]")))))
+ "Return a 'real' date string that most HTTP servers can understand."
+ (let ((system-time-locale "C"))
+ (format-time-string "%a, %d %b %Y %T GMT"
+ (or specified-time (current-time)) t)))
;;;###autoload
(defun url-eat-trailing-space (x)
;;;###autoload
(defun url-display-percentage (fmt perc &rest args)
- (if (null fmt)
- (if (fboundp 'clear-progress-display)
- (clear-progress-display))
- (if (and (fboundp 'progress-display) perc)
- (apply 'progress-display fmt perc args)
- (apply 'message fmt args))))
+ (when url-show-status
+ (if (null fmt)
+ (if (fboundp 'clear-progress-display)
+ (clear-progress-display))
+ (if (and (fboundp 'progress-display) perc)
+ (apply 'progress-display fmt perc args)
+ (apply 'message fmt args)))))
;;;###autoload
(defun url-percentage (x y)
(/ (* x 100) y)))
;;;###autoload
-(defun url-basepath (file &optional x)
- "Return the base pathname of FILE, or the actual filename if X is true."
+(defun url-file-directory (file)
+ "Return the directory part of FILE, for a URL."
(cond
((null file) "")
((string-match (eval-when-compile (regexp-quote "?")) file)
- (if x
- (file-name-nondirectory (substring file 0 (match-beginning 0)))
- (file-name-directory (substring file 0 (match-beginning 0)))))
- (x (file-name-nondirectory file))
+ (file-name-directory (substring file 0 (match-beginning 0))))
(t (file-name-directory file))))
;;;###autoload
-(defun url-parse-query-string (query &optional downcase)
+(defun url-file-nondirectory (file)
+ "Return the nondirectory part of FILE, for a URL."
+ (cond
+ ((null file) "")
+ ((string-match (eval-when-compile (regexp-quote "?")) file)
+ (file-name-nondirectory (substring file 0 (match-beginning 0))))
+ (t (file-name-nondirectory file))))
+
+;;;###autoload
+(defun url-parse-query-string (query &optional downcase allow-newlines)
(let (retval pairs cur key val)
(setq pairs (split-string query "&"))
(while pairs
pairs (cdr pairs))
(if (not (string-match "=" cur))
nil ; Grace
- (setq key (url-unhex-string (substring cur 0 (match-beginning 0)))
- val (url-unhex-string (substring cur (match-end 0) nil)))
+ (setq key (url-unhex-string (substring cur 0 (match-beginning 0))
+ allow-newlines))
+ (setq val (url-unhex-string (substring cur (match-end 0) nil)
+ allow-newlines))
(if downcase
(setq key (downcase key)))
(setq cur (assoc key retval))
This is taken from RFC 2396.")
;;;###autoload
-(defun url-hexify-string (str)
- "Escape characters in a string."
- (mapconcat
- (lambda (char)
- ;; Fixme: use a char table instead.
- (if (not (memq char url-unreserved-chars))
- (if (> char 255)
- (error "Hexifying multibyte character %s" str)
- (format "%%%02X" char))
- (char-to-string char)))
- str ""))
+(defun url-hexify-string (string)
+ "Return a new string that is STRING URI-encoded.
+First, STRING is converted to utf-8, if necessary. Then, for each
+character in the utf-8 string, those found in `url-unreserved-chars'
+are left as-is, all others are represented as a three-character
+string: \"%\" followed by two lowercase hex digits."
+ ;; To go faster and avoid a lot of consing, we could do:
+ ;;
+ ;; (defconst url-hexify-table
+ ;; (let ((map (make-vector 256 nil)))
+ ;; (dotimes (byte 256) (aset map byte
+ ;; (if (memq byte url-unreserved-chars)
+ ;; (char-to-string byte)
+ ;; (format "%%%02x" byte))))
+ ;; map))
+ ;;
+ ;; (mapconcat (curry 'aref url-hexify-table) ...)
+ (mapconcat (lambda (byte)
+ (if (memq byte url-unreserved-chars)
+ (char-to-string byte)
+ (format "%%%02x" byte)))
+ (if (multibyte-string-p string)
+ (encode-coding-string string 'utf-8)
+ string)
+ ""))
;;;###autoload
(defun url-file-extension (fname &optional x)
If optional variable X is t,
then return the basename of the file with the extension stripped off."
(if (and fname
- (setq fname (url-basepath fname t))
+ (setq fname (url-file-nondirectory fname))
(string-match "\\.[^./]+$" fname))
(if x (substring fname 0 (match-beginning 0))
(substring fname (match-beginning 0) nil))
WIDTH defaults to the current frame width."
(let* ((fr-width (or width (frame-width)))
(str-width (length url))
- (tail (file-name-nondirectory url))
(fname nil)
(modified 0)
(urlobj nil))
(if (and (>= str-width fr-width)
(string-match "?" url))
(setq url (concat (substring url 0 (match-beginning 0)) "?...")
- str-width (length url)
- tail (file-name-nondirectory url)))
+ str-width (length url)))
(if (< str-width fr-width)
nil ; Hey, we are done!
(setq urlobj (url-generic-parse-url url)
(string-match "/" fname))
(setq fname (substring fname (match-end 0) nil)
modified (1+ modified))
- (url-set-filename urlobj fname)
+ (setf (url-filename urlobj) fname)
(setq url (url-recreate-url urlobj)
str-width (length url)))
(if (> modified 1)
(setq fname (concat "/.../" fname))
(setq fname (concat "/" fname)))
- (url-set-filename urlobj fname)
+ (setf (url-filename urlobj) fname)
(setq url (url-recreate-url urlobj)))
url))
(set (make-local-variable 'url-current-mime-headers)
(mail-header-extract)))))
+(defun url-make-private-file (file)
+ "Make FILE only readable and writable by the current user.
+Creates FILE and its parent directories if they do not exist."
+ (let ((dir (file-name-directory file)))
+ (when dir
+ ;; For historical reasons.
+ (make-directory dir t)))
+ ;; Based on doc-view-make-safe-dir.
+ (condition-case nil
+ (let ((umask (default-file-modes)))
+ (unwind-protect
+ (progn
+ (set-default-file-modes #o0600)
+ (with-temp-buffer
+ (write-region (point-min) (point-max)
+ file nil 'silent nil 'excl)))
+ (set-default-file-modes umask)))
+ (file-already-exists
+ (if (file-symlink-p file)
+ (error "Danger: `%s' is a symbolic link" file))
+ (set-file-modes file #o0600))))
+
(provide 'url-util)
;; arch-tag: 24352abc-5a5a-412e-90cd-313b26bed5c9