Mercurial > emacs
view lisp/url/url-expand.el @ 70022:34e6282ccc27
(customize-package-emacs-version-alist)
(mh-e, mh-alias, mh-folder, mh-folder-selection)
(mh-identity, mh-inc, mh-junk, mh-letter, mh-ranges)
(mh-scan-line-formats, mh-search, mh-sending-mail, )
(mh-sequences, mh-show, mh-speedbar, mh-thread, mh-tool-bar)
(mh-hooks, mh-faces, mh-alias-completion-ignore-case-flag)
(mh-alias-expand-aliases-flag, mh-alias-flash-on-comma)
(mh-alias-insert-file, mh-alias-insertion-location)
(mh-alias-local-users, mh-alias-local-users-prefix)
(mh-alias-passwd-gecos-comma-separator-flag)
(mh-new-messages-folders, mh-ticked-messages-folders)
(mh-large-folder, mh-recenter-summary-flag)
(mh-recursive-folders-flag, mh-sortm-args)
(mh-default-folder-for-message-function, )
(mh-default-folder-list, mh-default-folder-must-exist-flag)
(mh-default-folder-prefix, mh-identity-list)
(mh-auto-fields-list, mh-auto-fields-prompt-flag)
(mh-identity-default, mh-identity-handlers, mh-inc-prog)
(mh-inc-spool-list, mh-junk-background, mh-junk-disposition)
(mh-junk-program, mh-compose-insertion)
(mh-compose-skipped-header-fields)
(mh-compose-space-does-completion-flag)
(mh-delete-yanked-msg-window-flag)
(mh-extract-from-attribution-verb, mh-ins-buf-prefix)
(mh-letter-complete-function, mh-letter-fill-column)
(mh-mml-method-default, mh-signature-file-name)
(mh-signature-separator-flag, mh-x-face-file, )
(mh-yank-behavior, mh-interpret-number-as-range-flag)
(mh-adaptive-cmd-note-flag, mh-scan-format-file, mh-scan-prog)
(mh-search-program, mh-compose-forward-as-mime-flag)
(mh-compose-letter-function, mh-compose-prompt-flag)
(mh-forward-subject-format, mh-insert-x-mailer-flag)
(mh-redist-full-contents-flag, mh-reply-default-reply-to)
(mh-reply-show-message-flag, )
(mh-refile-preserves-sequences-flag, mh-tick-seq)
(mh-update-sequences-after-mh-show-flag)
(mh-bury-show-buffer-flag, mh-clean-message-header-flag)
(mh-decode-mime-flag, )
(mh-display-buttons-for-alternatives-flag)
(mh-display-buttons-for-inline-parts-flag)
(mh-do-not-confirm-flag, mh-fetch-x-image-url)
(mh-graphical-smileys-flag, mh-graphical-emphasis-flag)
(mh-highlight-citation-style, mh-invisible-header-fields)
(mh-invisible-header-fields-default, mh-lpr-command-format)
(mh-max-inline-image-height, mh-max-inline-image-width)
(mh-mhl-format-file, mh-mime-save-parts-default-directory)
(mh-print-background-flag, mh-show-maximum-size)
(mh-show-use-xface-flag, mh-store-default-directory)
(mh-summary-height, mh-speed-update-interval)
(mh-show-threads-flag, mh-tool-bar-search-function)
(mh-defcustom, mh-after-commands-processed-hook)
(mh-alias-reloaded-hook, mh-before-commands-processed-hook)
(mh-before-quit-hook, mh-before-send-letter-hook)
(mh-delete-msg-hook, mh-find-path-hook, mh-folder-mode-hook)
(mh-forward-hook, mh-inc-folder-hook, )
(mh-insert-signature-hook, )
(mh-kill-folder-suppress-prompt-hooks, mh-letter-mode-hook)
(mh-mh-to-mime-hook, mh-search-mode-hook, mh-quit-hook)
(mh-refile-msg-hook, mh-show-hook, mh-show-mode-hook)
(mh-unseen-updated-hook, mh-folder-address, mh-folder-body)
(mh-folder-cur-msg-number, mh-folder-date, mh-folder-deleted)
(mh-folder-followup, mh-folder-msg-number, mh-folder-refiled)
(mh-folder-sent-to-me-hint, mh-folder-sent-to-me-sender)
(mh-folder-subject, mh-folder-tick, mh-folder-to)
(mh-letter-header-field, mh-search-folder, mh-show-cc)
(mh-show-date, mh-show-from, mh-show-header, mh-show-pgg-bad)
(mh-show-pgg-good, mh-show-pgg-unknown, mh-show-signature)
(mh-show-subject, mh-show-to, mh-show-xface, )
(mh-speedbar-folder, mh-speedbar-folder-with-unseen-messages)
(mh-speedbar-selected-folder)
(mh-speedbar-selected-folder-with-unseen-messages): Use dotted
notation in :package-version keyword.
author | Bill Wohler <wohler@newt.com> |
---|---|
date | Fri, 14 Apr 2006 00:47:00 +0000 |
parents | e8a3fb527b77 |
children | e3694f1cb928 d04d8ccb3c41 |
line wrap: on
line source
;;; url-expand.el --- expand-file-name for URLs ;; Copyright (C) 1999, 2004, 2005, 2006 Free Software Foundation, Inc. ;; Keywords: comm, data, processes ;; This file is part of GNU Emacs. ;; 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. ;; 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. ;;; Code: (require 'url-methods) (require 'url-util) (require 'url-parse) (defun url-expander-remove-relative-links (name) ;; Strip . and .. from pathnames (let ((new (if (not (string-match "^/" name)) (concat "/" name) name))) ;; If it ends with a '/.' or '/..', tack on a trailing '/' sot hat ;; the tests that follow are not too complicated in terms of ;; looking for '..' or '../', etc. (if (string-match "/\\.+$" new) (setq new (concat new "/"))) ;; Remove '/./' first (while (string-match "/\\(\\./\\)" new) (setq new (concat (substring new 0 (match-beginning 1)) (substring new (match-end 1))))) ;; Then remove '/../' (while (string-match "/\\([^/]*/\\.\\./\\)" new) (setq new (concat (substring new 0 (match-beginning 1)) (substring new (match-end 1))))) ;; Remove cruft at the beginning of the string, so people that put ;; in extraneous '..' because they are morons won't lose. (while (string-match "^/\\.\\.\\(/\\)" new) (setq new (substring new (match-beginning 1) nil))) new)) (defun url-expand-file-name (url &optional default) "Convert URL to a fully specified URL, and canonicalize it. Second arg DEFAULT is a URL to start with if URL is relative. If DEFAULT is nil or missing, the current buffer's URL is used. Path components that are `.' are removed, and path components followed by `..' are removed, along with the `..' itself." (if (and url (not (string-match "^#" url))) ;; Need to nuke newlines and spaces in the URL, or we open ;; ourselves up to potential security holes. (setq url (mapconcat (function (lambda (x) (if (memq x '(? ?\n ?\r)) "" (char-to-string x)))) url ""))) ;; Need to figure out how/where to expand the fragment relative to (setq default (cond ((vectorp default) ;; Default URL has already been parsed default) (default ;; They gave us a default URL in non-parsed format (url-generic-parse-url default)) (url-current-object ;; We are in a URL-based buffer, use the pre-parsed object url-current-object) ((string-match url-nonrelative-link url) ;; The URL they gave us is absolute, go for it. nil) (t ;; Hmmm - this shouldn't ever happen. (error "url-expand-file-name confused - no default?")))) (cond ((= (length url) 0) ; nil or empty string (url-recreate-url default)) ((string-match "^#" url) ; Offset link, use it raw url) ((string-match url-nonrelative-link url) ; Fully-qualified URL, return it immediately url) (t (let* ((urlobj (url-generic-parse-url url)) (inhibit-file-name-handlers t) (expander (url-scheme-get-property (url-type default) 'expand-file-name))) (if (string-match "^//" url) (setq urlobj (url-generic-parse-url (concat (url-type default) ":" url)))) (funcall expander urlobj default) (url-recreate-url urlobj))))) (defun url-identity-expander (urlobj defobj) (url-set-type urlobj (or (url-type urlobj) (url-type defobj)))) (defun url-default-expander (urlobj defobj) ;; The default expansion routine - urlobj is modified by side effect! (if (url-type urlobj) ;; Well, they told us the scheme, let's just go with it. nil (url-set-type urlobj (or (url-type urlobj) (url-type defobj))) (url-set-port urlobj (or (url-port urlobj) (and (string= (url-type urlobj) (url-type defobj)) (url-port defobj)))) (if (not (string= "file" (url-type urlobj))) (url-set-host urlobj (or (url-host urlobj) (url-host defobj)))) (if (string= "ftp" (url-type urlobj)) (url-set-user urlobj (or (url-user urlobj) (url-user defobj)))) (if (string= (url-filename urlobj) "") (url-set-filename urlobj "/")) (if (string-match "^/" (url-filename urlobj)) nil (let ((query nil) (file nil) (sepchar nil)) (if (string-match "[?#]" (url-filename urlobj)) (setq query (substring (url-filename urlobj) (match-end 0)) file (substring (url-filename urlobj) 0 (match-beginning 0)) sepchar (substring (url-filename urlobj) (match-beginning 0) (match-end 0))) (setq file (url-filename urlobj))) (setq file (url-expander-remove-relative-links (concat (url-basepath (url-filename defobj)) file))) (url-set-filename urlobj (if query (concat file sepchar query) file)))))) (provide 'url-expand) ;;; arch-tag: 7b5f744b-b721-49da-be47-484631680a5a ;;; url-expand.el ends here