[Cl-irc-cvs] CVS update: cl-irc/example/cliki.lisp
Brian Mastenbrook
bmastenbrook at common-lisp.net
Thu Aug 12 16:24:55 UTC 2004
Update of /project/cl-irc/cvsroot/cl-irc/example
In directory common-lisp.net:/home/bmastenbrook/cl-irc/example
Modified Files:
cliki.lisp
Log Message:
shortening!
Date: Thu Aug 12 09:24:54 2004
Author: bmastenbrook
Index: cl-irc/example/cliki.lisp
diff -u cl-irc/example/cliki.lisp:1.25 cl-irc/example/cliki.lisp:1.26
--- cl-irc/example/cliki.lisp:1.25 Thu Aug 12 08:50:46 2004
+++ cl-irc/example/cliki.lisp Thu Aug 12 09:24:54 2004
@@ -1,4 +1,4 @@
- ;;;; $Id: cliki.lisp,v 1.25 2004/08/12 15:50:46 bmastenbrook Exp $
+ ;;;; $Id: cliki.lisp,v 1.26 2004/08/12 16:24:54 bmastenbrook Exp $
;;;; $Source: /project/cl-irc/cvsroot/cl-irc/example/cliki.lisp,v $
;;;; cliki.lisp - CLiki as an infobot; only works on SBCL.
@@ -233,8 +233,9 @@
(defun url-port (url)
(assert (string-equal url "http://" :end1 7))
- (let ((port-start (position #\: url :start 7)))
- (if port-start (parse-integer url :start (1+ port-start) :junk-allowed t) 80)))
+ (let ((path-start (position #\/ url :start 7)))
+ (let ((port-start (position #\: url :start 7 :end path-start)))
+ (if port-start (parse-integer url :start (1+ port-start) :junk-allowed t) 80))))
(defun url-host (url)
(assert (string-equal url "http://" :end1 7))
@@ -249,6 +250,7 @@
(stream (socket-connect host port)))
;; we are exceedingly unportable about proper line-endings here.
;; Anyone wishing to run this under non-SBCL should take especial care
+
(format stream "GET ~A HTTP/1.0~%Host: ~A~%User-Agent: CLiki Bot~%~%" url host)
(force-output stream)
(list
@@ -296,50 +298,75 @@
(if interrupt-thread
(ccl:process-kill interrupt-thread)))))
+(defun http-get (url)
+ (host-with-timeout
+ 5
+ (destructuring-bind (response headers stream)
+ (block got
+ (loop
+ (destructuring-bind (response headers stream) (url-connection url)
+ (unless (member response '(301 302))
+ (return-from got (list response headers stream)))
+ (close stream)
+ (setf stream nil)
+ (setf url (cdr (assoc :location headers))))))
+ (if (not (eql response 200))
+ nil
+ stream))))
+
(defun cliki-first-sentence (term)
(let* ((cliki-url (format nil "http://www.cliki.net/~A"
(encode-for-url term)))
(url (concatenate 'string cliki-url "?source")))
(block cliki-return
(handler-case
- (host-with-timeout 5
- (destructuring-bind (response headers stream)
- (block got
- (loop
- (destructuring-bind (response headers stream) (url-connection url)
- (unless (member response '(301 302))
- (return-from got (list response headers stream)))
- (close stream)
- (setf url (cdr (assoc :location headers))))))
- (unwind-protect
- (if (not (eql response 200))
- nil
- ;;(format nil "The term ~A was not found in CLiki." term)
- (let ((first-line ""))
- (loop for i from 1 to 5 do ;; scan the first 5 lines
- (progn
- (multiple-value-bind (next-line missing-newline-p)
- (read-line stream nil)
- (if next-line
- (setf first-line (concatenate 'string first-line (string #\newline) next-line))
- (return-from cliki-return (format nil "The end of the page was reached before a definition was found in ~A" cliki-url))))
- (setf first-line (regex-replace-all "\\r" first-line " "))
- (setf first-line (regex-replace-all "\\n" first-line " "))
- (setf first-line (regex-replace-all "_\\(([^)]*)\\)" first-line "\\1"))
- (setf first-line (regex-replace-all "#H\\(([^)]*)\\)" first-line "\\1"))
- (setf first-line (regex-replace-all "\\*\\(([^)]*)\\)" first-line "\\1"))
- (setf first-line (regex-replace-all "<[^>]+>" first-line ""))
- (setf first-line (regex-replace-all "^(([^.]|\\.\\S)+)\\.\\s+.*$" first-line "\\1."))
- (setf first-line (regex-replace-all "(\\s)\\s+" first-line "\\1"))
- (setf first-line (regex-replace-all "^\\s*(.+\\S)\\s*$" first-line "\\1"))
- (when (scan "^([^.]|\\.\\S)+[.?!]$" first-line)
- (setf first-line (concatenate 'string first-line " " cliki-url))
- (return-from cliki-return first-line))))
- (format nil "No definition was found in the first 5 lines of ~A" cliki-url)))
- (if stream (close stream)))))
+ (let ((stream (http-get url)))
+ (unwind-protect
+ (if (not stream)
+ nil
+ ;;(format nil "The term ~A was not found in CLiki." term)
+ (let ((first-line ""))
+ (loop for i from 1 to 5 do ;; scan the first 5 lines
+ (progn
+ (multiple-value-bind (next-line missing-newline-p)
+ (read-line stream nil)
+ (if next-line
+ (setf first-line (concatenate 'string first-line (string #\newline) next-line))
+ (return-from cliki-return (format nil "The end of the page was reached before a definition was found in ~A" cliki-url))))
+ (setf first-line (regex-replace-all "\\r" first-line " "))
+ (setf first-line (regex-replace-all "\\n" first-line " "))
+ (setf first-line (regex-replace-all "_\\(([^)]*)\\)" first-line "\\1"))
+ (setf first-line (regex-replace-all "#H\\(([^)]*)\\)" first-line "\\1"))
+ (setf first-line (regex-replace-all "\\*\\(([^)]*)\\)" first-line "\\1"))
+ (setf first-line (regex-replace-all "<[^>]+>" first-line ""))
+ (setf first-line (regex-replace-all "^(([^.]|\\.\\S)+)\\.\\s+.*$" first-line "\\1."))
+ (setf first-line (regex-replace-all "(\\s)\\s+" first-line "\\1"))
+ (setf first-line (regex-replace-all "^\\s*(.+\\S)\\s*$" first-line "\\1"))
+ (when (scan "^([^.]|\\.\\S)+[.?!]$" first-line)
+ (setf first-line (concatenate 'string first-line " " cliki-url))
+ (return-from cliki-return first-line))))
+ (format nil "No definition was found in the first 5 lines of ~A" cliki-url)))
+ (if stream (close stream))))
(condition (c &rest whatever) (return-from cliki-return (regex-replace-all "\\n" (format nil "An error was encountered in lookup: ~A." c) " ")))))
))
+(defun shorten (url)
+ (handler-case
+ (let ((stream (http-get (format nil "http://shorl.com/create.php?url=~A" url))))
+ (finish-output t)
+ (unwind-protect
+ (when stream
+ (prog1
+ (loop for line = (read-line stream nil nil)
+ while line
+ if (scan "http://shorl\\.com/[a-z]+" line)
+ return (regex-replace-all "^.*(http://shorl\\.com/[a-z]+).*$" line "\\1"))
+ (close stream)
+ (setf stream nil)))
+ (if stream (close stream))))
+ (condition (c)
+ (return-from shorten (regex-replace-all "\\n" (format nil "An error was encountered in shorten: ~A." c) " ")))))
+
(defvar *cliki-connection*)
(defvar *cliki-nickname*)
@@ -645,6 +672,9 @@
(let ((str (nth-value 1 (scan-to-strings "^(?i)advice\\W+(\\d+)$" first-pass))))
(and str
(lookup-advice (elt str 0))))
+ (let ((str (nth-value 1 (scan-to-strings "^(?i)shorten\\s+(\\w+://.+\\S)\\s*$" term-with-question))))
+ (and str
+ (shorten (elt str 0))))
(if (should-do-lookup first-pass (or channel sender ""))
(aif (or (small-definition-lookup first-pass)
(cliki-first-sentence first-pass)
More information about the cl-irc-cvs
mailing list