home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / w3 / url-http.el.z / url-http.el
Encoding:
Text File  |  1998-05-21  |  20.9 KB  |  606 lines
  1. ;;; url-http.el --- HTTP Uniform Resource Locator retrieval code
  2. ;; Author: wmperry
  3. ;; Created: 1998/01/06 14:22:36
  4. ;; Version: 1.22
  5. ;; Keywords: comm, data, processes
  6.  
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8. ;;; Copyright (c) 1993-1996 by William M. Perry <wmperry@cs.indiana.edu>
  9. ;;; Copyright (c) 1996, 1997 Free Software Foundation, Inc.
  10. ;;;
  11. ;;; This file is not part of GNU Emacs, but the same permissions apply.
  12. ;;;
  13. ;;; GNU Emacs is free software; you can redistribute it and/or modify
  14. ;;; it under the terms of the GNU General Public License as published by
  15. ;;; the Free Software Foundation; either version 2, or (at your option)
  16. ;;; any later version.
  17. ;;;
  18. ;;; GNU Emacs is distributed in the hope that it will be useful,
  19. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21. ;;; GNU General Public License for more details.
  22. ;;;
  23. ;;; You should have received a copy of the GNU General Public License
  24. ;;; along with GNU Emacs; see the file COPYING.  If not, write to the
  25. ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  26. ;;; Boston, MA 02111-1307, USA.
  27. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  28.  
  29. (require 'url-vars)
  30. (require 'url-parse)
  31. (require 'url-cookie)
  32. (require 'timezone)
  33.  
  34. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  35. ;;; Support for HTTP/1.0 MIME messages
  36. ;;; ----------------------------------
  37. ;;; These functions are the guts of the HTTP/0.9 and HTTP/1.0 transfer
  38. ;;; protocol, handling access authorization, format negotiation, the
  39. ;;; whole nine yards.
  40. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  41. (defun url-parse-viewer-types ()
  42.   "Create a string usable for an Accept: header from mm-mime-data"
  43.   (let ((tmp mm-mime-data)
  44.     label mjr mnr cur-mnr (str ""))
  45.     (while tmp
  46.       (setq mnr (cdr (car tmp))
  47.         mjr (car (car tmp))
  48.         tmp (cdr tmp))
  49.       (while mnr
  50.     (setq cur-mnr (car mnr)
  51.           label (concat mjr "/" (if (string= ".*" (car cur-mnr))
  52.                     "*"
  53.                       (car cur-mnr))))
  54.     (cond
  55.      ((string-match (regexp-quote label) str) nil)
  56.      ((> (+ (% (length str) 60)
  57.         (length (concat ", " mjr "/" (car cur-mnr)))) 60)
  58.       (setq str (format "%s\r\nAccept: %s" str label)))
  59.      (t
  60.       (setq str (format "%s, %s" str label))))
  61.     (setq mnr (cdr mnr))))
  62.     (substring str 2 nil)))
  63.  
  64. (defun url-create-multipart-request (file-list)
  65.   "Create a multi-part MIME request for all files in FILE-LIST"
  66.   (let ((separator (current-time-string))
  67.     (content "message/http-request")           
  68.     (ref-url nil))
  69.     (setq separator
  70.       (concat "separator-"
  71.           (mapconcat
  72.            (function
  73.             (lambda (char)
  74.               (if (memq char url-mime-separator-chars)
  75.               (char-to-string char) ""))) separator "")))
  76.     (cons separator
  77.       (concat
  78.        (mapconcat
  79.         (function
  80.          (lambda (file)
  81.            (concat "--" separator "\nContent-type: " content "\n\n"
  82.                (url-create-mime-request file ref-url)))) file-list
  83.                "\n")
  84.        "--" separator))))
  85.  
  86. (defun url-create-message-id ()
  87.   "Generate a string suitable for the Message-ID field of a request"
  88.   (concat "<" (url-create-unique-id) "@" (system-name) ">"))
  89.  
  90. (defun url-create-unique-id ()
  91.   ;; Generate unique ID from user name and current time.
  92.   (let* ((date (current-time-string))
  93.      (name (user-login-name))
  94.      (dateinfo (and date (timezone-parse-date date)))
  95.      (timeinfo (and date (timezone-parse-time (aref dateinfo 3)))))
  96.     (if (and dateinfo timeinfo)
  97.     (concat (upcase name) "."
  98.         (aref dateinfo 0)    ; Year
  99.         (aref dateinfo 1)    ; Month
  100.         (aref dateinfo 2)    ; Day
  101.         (aref timeinfo 0)    ; Hour
  102.         (aref timeinfo 1)    ; Minute 
  103.         (aref timeinfo 2)    ; Second
  104.         )
  105.       (error "Cannot understand current-time-string: %s." date))
  106.     ))
  107.  
  108. (defun url-http-user-agent-string ()
  109.   (if (or (eq url-privacy-level 'paranoid)
  110.       (and (listp url-privacy-level)
  111.            (memq 'agent url-privacy-level)))
  112.       ""
  113.     (format "User-Agent: %s/%s URL/%s%s\r\n"
  114.         url-package-name url-package-version
  115.         url-version
  116.         (cond
  117.          ((and url-os-type url-system-type)
  118.           (concat " (" url-os-type "; " url-system-type ")"))
  119.          ((or url-os-type url-system-type)
  120.           (concat " (" (or url-system-type url-os-type) ")"))
  121.          (t "")))))
  122.  
  123. (defun url-create-mime-request (fname ref-url)
  124.   "Create a MIME request for fname, referred to by REF-URL."
  125.   (let* ((extra-headers)
  126.      (request nil)
  127.      (url (url-view-url t))
  128.      (no-cache (cdr-safe (assoc "Pragma" url-request-extra-headers)))
  129.      (proxy-auth (if (or (cdr-safe (assoc "Proxy-Authorization"
  130.                           url-request-extra-headers))
  131.                  (not (boundp 'proxy-info))
  132.                  (not url-using-proxy))
  133.              nil
  134.                (let ((url-basic-auth-storage
  135.                   url-proxy-basic-authentication))
  136.              (url-get-authentication url-using-proxy nil 'any nil))))
  137.      (proxy-obj (if (and (boundp 'proxy-info) proxy-info)
  138.             (url-generic-parse-url proxy-info)))
  139.      (real-fname (if proxy-obj (url-filename proxy-obj) fname))
  140.      (host (or (and proxy-obj (url-host proxy-obj))
  141.            (url-host url-current-object)))
  142.      (auth (if (cdr-safe (assoc "Authorization" url-request-extra-headers))
  143.            nil
  144.          (url-get-authentication (or
  145.                       (and (boundp 'proxy-info)
  146.                            proxy-info)
  147.                       url) nil 'any nil))))
  148.     (setq no-cache (and no-cache (string-match "no-cache" no-cache)))
  149.     (if auth
  150.     (setq auth (concat "Authorization: " auth "\r\n")))
  151.     (if proxy-auth
  152.     (setq proxy-auth (concat "Proxy-Authorization: " proxy-auth "\r\n")))
  153.  
  154.     (if (and ref-url (stringp ref-url) (or (string= ref-url "file:nil")
  155.                        (string= ref-url "")))
  156.     (setq ref-url nil))
  157.  
  158.     (if (or (memq url-privacy-level '(low high paranoid))
  159.         (and (listp url-privacy-level)
  160.          (memq 'lastloc url-privacy-level)))
  161.     (setq ref-url nil))
  162.  
  163.     (setq extra-headers (mapconcat
  164.              (function (lambda (x)
  165.                      (concat (car x) ": " (cdr x))))
  166.              url-request-extra-headers "\r\n"))
  167.     (if (not (equal extra-headers ""))
  168.     (setq extra-headers (concat extra-headers "\r\n")))
  169.     (setq request
  170.       (format
  171.        (concat
  172.         "%s %s HTTP/1.0\r\n"    ; The request
  173.         "MIME-Version: 1.0\r\n"    ; Version of MIME we speaketh
  174.         "Extension: %s\r\n"        ; HTTP extensions we support
  175.         "Host: %s\r\n"        ; Who we want to talk to
  176.         "%s"            ; Who its from
  177.         "Accept-encoding: %s\r\n"    ; Encodings we understand
  178.         "Accept-language: %s\r\n"     ; Languages we understand
  179.         "Accept: %s\r\n"        ; Types we understand
  180.         "%s"            ; User agent
  181.         "%s"            ; Authorization
  182.         "%s"            ; Cookies
  183.         "%s"            ; Proxy Authorization
  184.         "%s"            ; If-modified-since
  185.         "%s"            ; Where we came from
  186.         "%s"            ; Any extra headers
  187.         "%s"            ; Any data
  188.         "\r\n")            ; End request
  189.        (or url-request-method "GET")
  190.        fname
  191.        (or url-extensions-header "none")
  192.        (or host "UNKNOWN.HOST.NAME")
  193.        (if url-personal-mail-address
  194.            (concat "From: " url-personal-mail-address "\r\n")
  195.          "")
  196.        url-mime-encoding-string
  197.        url-mime-language-string
  198.        url-mime-accept-string
  199.        (url-http-user-agent-string)
  200.        (or auth "")
  201.        (url-cookie-generate-header-lines
  202.         host real-fname (equal "https" (url-type url-current-object)))
  203.        (or proxy-auth "")
  204.        (if (and (not no-cache)
  205.             (member url-request-method '("GET" nil)))
  206.            (let ((tm (url-is-cached url)))
  207.          (if tm
  208.              (concat "If-modified-since: "
  209.                  (url-get-normalized-date tm) "\r\n")
  210.            ""))
  211.          "")
  212.        (if ref-url (concat "Referer: " ref-url "\r\n") "")
  213.        extra-headers
  214.        (if url-request-data
  215.            (format "Content-length: %d\r\n\r\n%s"
  216.                (length url-request-data) url-request-data)
  217.          "")))
  218.     request))
  219.  
  220. (defun url-setup-reload-timer (url must-be-viewing &optional time)
  221.   ;; Set up a timer to load URL at optional TIME.  If TIME is unspecified,
  222.   ;; default to 5 seconds.  Only loads document if MUST-BE-VIEWING is the
  223.   ;; current URL when the timer expires."
  224.   (if (or (not time)
  225.       (<= time 0))
  226.       (setq time 5))
  227.   (let ((func
  228.      (` (lambda ()
  229.           (if (equal (url-view-url t) (, must-be-viewing))
  230.           (let ((w3-reuse-buffers 'no))
  231.             (if (equal (, url) (url-view-url t))
  232.             (kill-buffer (current-buffer)))
  233.             (w3-fetch (, url))))))))
  234.     (cond
  235.      ((featurep 'itimer)
  236.       (start-itimer "reloader" func time))
  237.      ((fboundp 'run-at-time)
  238.       (run-at-time time nil func))
  239.      (t
  240.       (url-warn 'url "Cannot set up timer for automatic reload, sorry!")))))
  241.  
  242. (defun url-handle-refresh-header (reload)
  243.   (if (and reload
  244.        url-honor-refresh-requests
  245.        (or (eq url-honor-refresh-requests t)
  246.            (funcall url-confirmation-func "Honor refresh request? ")))
  247.       (let ((uri (url-view-url t)))
  248.     (if (string-match ";" reload)
  249.         (progn
  250.           (setq uri (substring reload (match-end 0) nil)
  251.             reload (substring reload 0 (match-beginning 0)))
  252.           (if (string-match
  253.            "ur[li][ \t]*=[ \t]*\"*\\([^ \t\"]+\\)\"*"
  254.            uri)
  255.           (setq uri (url-match uri 1)))
  256.           (setq uri (url-expand-file-name uri (url-view-url t)))))
  257.     (url-setup-reload-timer uri (url-view-url t)
  258.                 (string-to-int (or reload "5"))))))
  259.  
  260. (defun url-parse-mime-headers (&optional no-delete switch-buff)
  261.   ;; Parse mime headers and remove them from the html
  262.   (and switch-buff (set-buffer url-working-buffer))
  263.   (let* ((st (point-min))
  264.      (nd (progn
  265.            (goto-char (point-min))
  266.            (skip-chars-forward " \t\n")
  267.            (if (re-search-forward "^\r*$" nil t)
  268.            (1+ (point))
  269.          (point-max))))
  270.      save-pos
  271.      status
  272.      class
  273.      hname
  274.      hvalu
  275.      result
  276.      )
  277.     (narrow-to-region st (min nd (point-max)))
  278.     (goto-char (point-min))
  279.     (skip-chars-forward " \t\n")    ; Get past any blank crap
  280.     (skip-chars-forward "^ \t")    ; Skip over the HTTP/xxx
  281.     (setq status (read (current-buffer)); Quicker than buffer-substring, etc.
  282.       result (cons (cons "status" status) result))
  283.     (end-of-line)
  284.     (while (not (eobp))
  285.       (skip-chars-forward " \t\n\r")
  286.       (setq save-pos (point))
  287.       (skip-chars-forward "^:\n\r")
  288.       (downcase-region save-pos (point))
  289.       (setq hname (buffer-substring save-pos (point)))
  290.       (skip-chars-forward ": \t ")
  291.       (setq save-pos (point))
  292.       (skip-chars-forward "^\n\r")
  293.       (setq hvalu (buffer-substring save-pos (point))
  294.         result (cons (cons hname hvalu) result))
  295.       (if (string= hname "set-cookie")
  296.       (url-cookie-handle-set-cookie hvalu)))
  297.     (or no-delete (delete-region st (min nd (point))))
  298.     (setq url-current-mime-type (cdr (assoc "content-type" result))
  299.       url-current-mime-encoding (cdr (assoc "content-encoding" result))
  300.       url-current-mime-viewer (mm-mime-info url-current-mime-type nil t)
  301.       url-current-mime-headers result
  302.       url-current-can-be-cached
  303.       (not (string-match "no-cache"
  304.                  (or (cdr-safe (assoc "pragma" result)) ""))))
  305.     (url-handle-refresh-header (cdr-safe (assoc "refresh" result)))
  306.     (if (and url-request-method
  307.          (not (string= url-request-method "GET")))
  308.     (setq url-current-can-be-cached nil))
  309.     (let ((expires (cdr-safe (assoc "expires" result))))
  310.       (if (and expires url-current-can-be-cached (featurep 'timezone))
  311.       (progn
  312.         (if (string-match
  313.          (concat "^[^,]+, +\\(..\\)-\\(...\\)-\\(..\\) +"
  314.              "\\(..:..:..\\) +\\[*\\([^\]]+\\)\\]*$")
  315.                   expires)
  316.         (setq expires (concat (url-match expires 1) " "
  317.                       (url-match expires 2) " "
  318.                       (url-match expires 3) " "
  319.                       (url-match expires 4) " ["
  320.                       (url-match expires 5) "]")))
  321.         (setq expires
  322.           (let ((d1 (mapcar
  323.                  (function
  324.                   (lambda (s) (and s (string-to-int s))))
  325.                  (timezone-parse-date
  326.                   (current-time-string))))
  327.             (d2 (mapcar
  328.                  (function (lambda (s) (and s (string-to-int s))))
  329.                  (timezone-parse-date expires))))
  330.             (- (timezone-absolute-from-gregorian 
  331.             (nth 1 d1) (nth 2 d1) (car d1))
  332.                (timezone-absolute-from-gregorian 
  333.             (nth 1 d2) (nth 2 d2) (car d2))))
  334.           url-current-can-be-cached (/= 0 expires)))))
  335.     (setq class (/ status 100))
  336.     (cond
  337.      ;; Classes of response codes
  338.      ;;
  339.      ;; 5xx = Server Error
  340.      ;; 4xx = Client Error
  341.      ;; 3xx = Redirection
  342.      ;; 2xx = Successful
  343.      ;; 1xx = Informational
  344.      ;;
  345.      ((= class 2)            ; Successful in some form or another
  346.       (cond
  347.        ((or (= status 206)        ; Partial content
  348.         (= status 205))        ; Reset content
  349.     (setq url-current-can-be-cached nil))
  350.        ((= status 204)            ; No response - leave old document
  351.     (kill-buffer url-working-buffer))
  352.        (t nil))                ; All others indicate success
  353.       )
  354.      ((= class 3)            ; Redirection of some type
  355.       (cond
  356.        ((or (= status 301)        ; Moved - retry with Location: header
  357.         (= status 302)        ; Found - retry with Location: header
  358.         (= status 303))        ; Method - retry with location/method
  359.     (let ((x (url-view-url t))
  360.           (redir (or (cdr (assoc "uri" result))
  361.              (cdr (assoc "location" result))))
  362.           (redirmeth (upcase (or (cdr (assoc "method" result))
  363.                      url-request-method
  364.                      "get"))))
  365.       (if (and redir (string-match "\\([^ \t]+\\)[ \t]" redir))
  366.           (setq redir (url-match redir 1)))
  367.       (if (and redir (string-match "^<\\(.*\\)>$" redir))
  368.           (setq redir (url-match redir 1)))
  369.  
  370.       ;; As per Roy Fielding, 303 maps _any_ method to a 'GET'
  371.       (if (= 303 status)
  372.           (setq redirmeth "GET"))
  373.  
  374.       ;; As per Roy Fielding, 301, 302 use the same method as the
  375.       ;; original request, but if != GET, user interaction is
  376.       ;; required.
  377.       (if (and (not (string= "GET" redirmeth))
  378.            (not (funcall
  379.              url-confirmation-func
  380.              (concat
  381.               "Honor redirection with non-GET method "
  382.               "(possible security risks)? "))))
  383.           (progn
  384.         (url-warn 'url
  385.               (format
  386.                "The URL %s tried to issue a redirect to %s using a method other than
  387. GET, which can open up various security holes.  Please see the
  388. HTTP/1.0 specification for more details." x redir) 'error)
  389.         (if (funcall url-confirmation-func
  390.                  "Continue (with method of GET)? ")
  391.             (setq redirmeth "GET")
  392.           (error "Transaction aborted."))))
  393.  
  394.       (if (not (equal x redir))
  395.           (let ((url-request-method redirmeth))
  396.         (url-maybe-relative redir))
  397.         (progn
  398.           (goto-char (point-max))
  399.           (insert "<hr>Error!  This URL tried to redirect me to itself!<P>"
  400.               "Please notify the server maintainer.")))))
  401.        ((= status 304)            ; Cached document is newer
  402.     (message "Extracting from cache...")
  403.     (url-cache-extract (url-cache-create-filename (url-view-url t))))
  404.        ((= status 305)            ; Use proxy in Location: header
  405.     nil)))
  406.      ((= class 4)            ; Client error
  407.       (cond
  408.        ((and (= status 401)        ; Unauthorized access, retry w/auth.
  409.          (< url-current-passwd-count url-max-password-attempts))
  410.     (setq url-current-passwd-count (1+ url-current-passwd-count))
  411.     (let* ((y (or (cdr (assoc "www-authenticate" result)) "basic"))
  412.            (url (url-view-url t))
  413.            (type (downcase (if (string-match "[ \t]" y)
  414.                    (substring y 0 (match-beginning 0))
  415.                  y))))
  416.       (cond
  417.        ((url-auth-registered type)
  418.         (let ((args y)
  419.           (ctr (1- (length y)))
  420.           auth
  421.           (url-request-extra-headers url-request-extra-headers))
  422.           (while (/= 0 ctr)
  423.         (if (= ?, (aref args ctr))
  424.             (aset args ctr ?\;))
  425.         (setq ctr (1- ctr)))
  426.           (setq args (mm-parse-args y)
  427.             auth (url-get-authentication url
  428.                          (cdr-safe
  429.                           (assoc "realm" args))
  430.                          type t args))
  431.           (if auth
  432.           (setq url-request-extra-headers
  433.             (cons (cons "Authorization" auth)
  434.                   url-request-extra-headers)))
  435.           (url-retrieve url t)))
  436.        (t
  437.         (widen)
  438.         (goto-char (point-max))
  439.         (setq url-current-can-be-cached nil)
  440.         (insert "<hr>Sorry, but I do not know how to handle " y
  441.             " authentication.  If you'd like to write it,"
  442.             " send it to " url-bug-address ".<hr>")))))
  443.        ((= status 407)            ; Proxy authentication required
  444.     (let* ((y (or (cdr (assoc "proxy-authenticate" result)) "basic"))
  445.            (url (url-view-url t))
  446.            (urlobj (url-generic-parse-url url))
  447.            (url-basic-auth-storage url-proxy-basic-authentication)
  448.            (url-using-proxy (url-find-proxy-for-url urlobj
  449.                             (url-host urlobj)))
  450.            (type (downcase (if (string-match "[ \t]" y)
  451.                    (substring y 0 (match-beginning 0))
  452.                  y))))
  453.       (cond
  454.        ((url-auth-registered type)
  455.         (let ((args y)
  456.           (ctr (1- (length y)))
  457.           auth
  458.           (url-request-extra-headers url-request-extra-headers))
  459.           (while (/= 0 ctr)
  460.         (if (= ?, (aref args ctr))
  461.             (aset args ctr ?\;))
  462.         (setq ctr (1- ctr)))
  463.           (setq args (mm-parse-args y)
  464.             auth (url-get-authentication (or url-using-proxy url)
  465.                          (cdr-safe
  466.                           (assoc "realm" args))
  467.                          type t args))
  468.           (if auth
  469.           (setq url-request-extra-headers
  470.             (cons (cons "Proxy-Authorization" auth)
  471.                   url-request-extra-headers)))
  472.           (setq url-proxy-basic-authentication url-basic-auth-storage)
  473.           (url-retrieve url t)))
  474.        (t
  475.         (widen)
  476.         (goto-char (point-max))
  477.         (setq url-current-can-be-cached nil)
  478.         (insert "<hr>Sorry, but I do not know how to handle " y
  479.             " authentication.  If you'd like to write it,"
  480.             " send it to " url-bug-address ".<hr>")))))
  481.        ;;((= status 400) nil)        ; Bad request - syntax
  482.        ;;((= status 401) nil)        ; Tried too many times
  483.        ;;((= status 402) nil)        ; Payment required, retry w/Chargeto:
  484.        ;;((= status 403) nil)        ; Access is forbidden
  485.        ;;((= status 404) nil)        ; Not found...
  486.        ;;((= status 405) nil)        ; Method not allowed
  487.        ;;((= status 406) nil)        ; None acceptable
  488.        ;;((= status 408) nil)        ; Request timeout
  489.        ;;((= status 409) nil)        ; Conflict
  490.        ;;((= status 410) nil)        ; Document is gone
  491.        ;;((= status 411) nil)        ; Length required
  492.        ;;((= status 412) nil)        ; Unless true
  493.        (t                ; All others mena something hosed
  494.     (setq url-current-can-be-cached nil))))
  495.      ((= class 5)
  496. ;;;      (= status 504)            ; Gateway timeout
  497. ;;;      (= status 503)            ; Service unavailable
  498. ;;;      (= status 502)            ; Bad gateway
  499. ;;;      (= status 501)            ; Facility not supported
  500. ;;;      (= status 500)            ; Internal server error
  501.       (setq url-current-can-be-cached nil))
  502.      ((= class 1)
  503.       (cond
  504.        ((or (= status 100)        ; Continue
  505.         (= status 101))        ; Switching protocols
  506.     nil)))
  507.      (t
  508.       (setq url-current-can-be-cached nil)))
  509.     (widen)
  510.     status))
  511.  
  512. (defun url-mime-response-p (&optional switch-buff)
  513.   ;; Determine if the current buffer is a MIME response
  514.   (and switch-buff (set-buffer url-working-buffer))
  515.   (goto-char (point-min))
  516.   (skip-chars-forward " \t\n")
  517.   (and (looking-at "^HTTP/.+")))
  518.  
  519. (defsubst url-recreate-with-attributes (obj)
  520.   (if (url-attributes obj)
  521.       (concat (url-filename obj) ";"
  522.           (mapconcat
  523.            (function
  524.         (lambda (x)
  525.           (if (cdr x)
  526.               (concat (car x) "=" (cdr x))
  527.             (car x)))) (url-attributes obj) ";"))
  528.     (url-filename obj)))
  529.  
  530. (defun url-http (url &optional proxy-info)
  531.   ;; Retrieve URL via http.
  532.   (let* ((urlobj (url-generic-parse-url url))
  533.      (ref-url (or url-current-referer (url-view-url t))))
  534.     (url-clear-tmp-buffer)
  535.     (let* ((server (url-host urlobj))
  536.        (port   (url-port urlobj))
  537.        (file   (or proxy-info (url-recreate-with-attributes urlobj)))
  538.        (dest   (url-target urlobj))
  539.        request)
  540.       (if (equal port "") (setq port "80"))
  541.       (if (equal file "") (setq file "/"))
  542.       (if (not server)
  543.       (progn
  544.         (url-warn
  545.          'url
  546.          (eval-when-compile
  547.            (concat
  548.         "Malformed URL got passed into url-retrieve.\n"
  549.         "Either `url-expand-file-name' is broken in some\n"
  550.         "way, or an incorrect URL was manually entered (more likely)."
  551.         )))
  552.         (error "Malformed URL: `%s'" url)))
  553.       (if (or (not (member port url-bad-port-list))
  554.           (funcall url-confirmation-func
  555.                (concat
  556.             "Warning!  Trying to connect to port "
  557.             port
  558.             " - continue? ")))
  559.       (progn
  560.         (setq request (url-create-mime-request file ref-url))
  561.         (url-lazy-message "Contacting %s:%s" server port)
  562.         (let ((process
  563.            (url-open-stream "WWW" url-working-buffer server
  564.                    (string-to-int port))))
  565.           (if (not (processp process))
  566.           (url-sentinel url-working-buffer nil)
  567.         (progn
  568.           (url-process-put process 'url (or proxy-info url))
  569.           (set-process-sentinel process 'ignore)
  570.           (process-kill-without-query process)
  571.           (process-send-string process request)
  572.           (url-lazy-message "Request sent, waiting for response...")
  573.           (setq url-current-content-length nil)
  574.           (make-local-variable 'after-change-functions)
  575.           (add-hook 'after-change-functions 'url-after-change-function)
  576.           (if url-be-asynchronous
  577.               (set-process-sentinel process 'url-sentinel)
  578.             (unwind-protect
  579.             (save-excursion
  580.               (set-buffer url-working-buffer)
  581.               (while (memq (url-process-status process)
  582.                        '(run open))
  583.                 (url-accept-process-output process)))
  584.               (condition-case ()
  585.               (url-kill-process process)
  586.             (error nil))))
  587.           (if url-be-asynchronous
  588.               nil
  589.             (message "Retrieval complete.")
  590.             (remove-hook 'after-change-functions
  591.                  'url-after-change-function))))))
  592.     (progn
  593.       (ding)
  594.       (url-warn 'security "Aborting connection to bad port..."))))))
  595.  
  596. (defun url-https (url)
  597.   ;; Retrieve a URL via SSL
  598.   (condition-case ()
  599.       (require 'ssl)
  600.     (error (error "Not configured for SSL, please read the info pages.")))
  601.   (let ((url-this-is-ssl t)
  602.     (url-gateway-method 'ssl))
  603.     (url-http url)))
  604.  
  605. (provide 'url-http)
  606.