;;; url-util.el --- Miscellaneous helper routines for URL library
-;; Copyright (C) 1996, 1997, 1998, 1999, 2001, 2004,
-;; 2005, 2006, 2007 Free Software Foundation, Inc.
+;; Copyright (C) 1996, 1997, 1998, 1999, 2001, 2004, 2005, 2006, 2007,
+;; 2008, 2009, 2010 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 3, 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")
> ==> >
\" ==> ""
(if (string-match "[&<>\"]" string)
- (save-excursion
- (set-buffer (get-buffer-create " *entity*"))
+ (with-current-buffer (get-buffer-create " *entity*")
(erase-buffer)
(buffer-disable-undo (current-buffer))
(insert string)
type (url-type data))
(if (member type '("www" "about" "mailto" "info"))
(setq retval url)
+ ;; FIXME all this does, and all this function seems to do in
+ ;; most cases, is remove any trailing "#anchor" part of a url.
(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
- (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)
(round (* 100 (/ x (float y))))
(/ (* x 100) y)))
+;;;###autoload
+(defalias 'url-basepath 'url-file-directory)
+
;;;###autoload
(defun url-file-directory (file)
"Return the directory part of FILE, for a URL."
;;;###autoload
(defun url-unhex-string (str &optional allow-newlines)
- "Remove %XX embedded spaces, etc in a url.
+ "Remove %XX embedded spaces, etc in a URL.
If optional second argument ALLOW-NEWLINES is non-nil, then allow the
decoding of carriage returns and line feeds in the string, which is normally
forbidden in URL encoding."
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
;;;###autoload
(defun url-file-extension (fname &optional x)
"Return the filename extension of FNAME.
-If optional variable X is t,
-then return the basename of the file with the extension stripped off."
+If optional argument X is t, then return the basename
+of the file with the extension stripped off."
(if (and fname
(setq fname (url-file-nondirectory fname))
(string-match "\\.[^./]+$" fname))
;;;###autoload
(defun url-truncate-url-for-viewing (url &optional width)
- "Return a shortened version of URL that is WIDTH characters or less wide.
+ "Return a shortened version of URL that is WIDTH characters wide or less.
WIDTH defaults to the current frame width."
(let* ((fr-width (or width (frame-width)))
(str-width (length url))
(eval-and-compile
(defvar url-get-url-filename-chars "-%.?@a-zA-Z0-9()_/:~=&"
- "Valid characters in a URL")
+ "Valid characters in a URL.")
)
(defun url-get-url-at-point (&optional pt)
(defun url-generate-unique-filename (&optional fmt)
"Generate a unique filename in `url-temporary-directory'."
- (if (not fmt)
- (let ((base (format "url-tmp.%d" (user-real-uid)))
+ ;; This variable is obsolete, but so is this function.
+ (let ((tempdir (with-no-warnings url-temporary-directory)))
+ (if (not fmt)
+ (let ((base (format "url-tmp.%d" (user-real-uid)))
+ (fname "")
+ (x 0))
+ (setq fname (format "%s%d" base x))
+ (while (file-exists-p
+ (expand-file-name fname tempdir))
+ (setq x (1+ x)
+ fname (concat base (int-to-string x))))
+ (expand-file-name fname tempdir))
+ (let ((base (concat "url" (int-to-string (user-real-uid))))
(fname "")
(x 0))
- (setq fname (format "%s%d" base x))
+ (setq fname (format fmt (concat base (int-to-string x))))
(while (file-exists-p
- (expand-file-name fname url-temporary-directory))
+ (expand-file-name fname tempdir))
(setq x (1+ x)
- fname (concat base (int-to-string x))))
- (expand-file-name fname url-temporary-directory))
- (let ((base (concat "url" (int-to-string (user-real-uid))))
- (fname "")
- (x 0))
- (setq fname (format fmt (concat base (int-to-string x))))
- (while (file-exists-p
- (expand-file-name fname url-temporary-directory))
- (setq x (1+ x)
- fname (format fmt (concat base (int-to-string x)))))
- (expand-file-name fname url-temporary-directory))))
+ fname (format fmt (concat base (int-to-string x)))))
+ (expand-file-name fname tempdir)))))
+(make-obsolete 'url-generate-unique-filename 'make-temp-file "23.1")
(defun url-extract-mime-headers ()
"Set `url-current-mime-headers' in current buffer."
(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