[clisp-list] Re: heads up - on-line docs, pre-test etc

[Sam S. <sd...@gn...>]

> * Yaroslav Kavenchuk <xnirapuhx@wragl.ol> [2005-11-22 13:50:04 +0200]:
>
>> Ah oops, I am behind proxy server - as it to specify?
>
> I see clhs.lisp: by analogy to the url-connection from asdf-install
> (public domain) it is necessary for open-http define *proxy-port*
> *proxy-host* *proxy-user* *proxy-password* or parse proxy-string
> "proxy-user:proxy-password@proxy-host:proxy-port" from *proxy* or
> environment variable HTTP_PROXY.

please try the appended patch.

-- 
Sam Steingold (http://www.podval.org/~sds) running w2k
http://www.honestreporting.com http://www.savegushkatif.org
http://ffii.org/ http://www.jihadwatch.org/ http://www.camera.org
Hard work has a future payoff.  Laziness pays off NOW.


--- clhs.lisp	19 Nov 2005 23:44:29 -0500	1.31
+++ clhs.lisp	22 Nov 2005 10:51:52 -0500	
@@ -85,6 +85,24 @@
  --> <URL:~a>~%" 'browse-url url)))))
 
 ;;; see also clocc/cllib/net.lisp
+(defvar *proxy* nil
+  "A list of 4 elements (user password host port), parsed from $HTTP_PROXY
+proxy-user:proxy-password@proxy-host:proxy-port")
+(defun proxy (&optional (proxy-string (getenv "HTTP_PROXY") proxy-p))
+  "When the argument is supplied or *PROXY* is NIL, parse the argument,
+set *PROXY*, and return it; otherwise just return *PROXY*."
+  (when (or proxy-p (null *proxy*))
+    (check-type proxy-string string)
+    (let* ((at (position #\@ proxy-string))
+           (colon1 (and at (position #\: proxy-string :end at)))
+           (colon2 (position #\: proxy-string :start (or at 0))))
+      (setq *proxy*
+            (list (and at (subseq proxy-string 0 (or colon1 at)))
+                  (and at colon1 (subseq proxy-string (1+ colon1) at))
+                  (subseq proxy-string (if at (1+ at) 0) colon2)
+                  (and colon2 (parse-integer proxy-string
+                                             :start (1+ colon2)))))))
+  *proxy*)
 
 (defmacro with-http-input ((var url) &body body)
   (if (symbolp var)
@@ -96,20 +114,26 @@
                 (MULTIPLE-VALUE-PROG1 (PROGN ,@body-rest)
                   (when ,(first var) (CLOSE ,(first var))))
              (when ,(first var) (CLOSE ,(first var) :ABORT T)))))))
-(defun open-http (url &key (if-does-not-exist :error))
+(defun open-http (url &key (if-does-not-exist :error) (default-port 80))
   (unless (string-equal #1="http://" url
                         :end2 (min (length url) #2=#.(length #1#)))
     (error "~S: ~S is not an HTTP URL" 'open-http url))
   (format t "~&;; connecting to ~S..." url) (force-output)
-  (let* ((host-end (position #\/ url :start #2#)) status code
-         (host (subseq url #2# host-end)) content-length
-         (path (if host-end (subseq url host-end) "/"))
+  (let* ((host-port-end (position #\/ url :start #2#)) status code
+         (port-start (position #\: url :start #2# :end host-port-end))
+         (host (subseq url #2# (or port-start host-port-end))) content-length
+         (port (if port-start
+                   (parse-integer url :start (1+ port-start)
+                                  :end host-port-end)
+                   default-port))
+         (path (if host-port-end (subseq url host-port-end) "/"))
          (sock (handler-bind ((error (lambda (c)
                                        (unless (eq if-does-not-exist :error)
-                                         (format t "cannot connect to ~S: ~A~%"
-                                                 host c)
+                                         (format
+                                          t "cannot connect to ~S:~D: ~A~%"
+                                          host port c)
                                          (return-from open-http nil)))))
-                 (socket:socket-connect 80 host :external-format :dos))))
+                 (socket:socket-connect port host :external-format :dos))))
     (format t "connected...") (force-output)
     (format sock "GET ~A HTTP/1.0~%User-agent: ~A~%Host: ~A~%Accept: */*~%Connection: close~2%" path (lisp-implementation-type) host) ; request
     (write-string (setq status (read-line sock))) (force-output)