2011/04/17

Common Lisp の feed パーサライブリありませんか?

あまりよさそうなのが見つからなかったので、てきとうに作ってみた。これも The Lisp Curse かな。

最初 (cxml-xmls:make-xmls-builder) 使ってみたら、とても遅かったので (stp:make-builder) を使うことにした。

(eval-when (:compile-toplevel :load-toplevel :execute)
(ql:quickload "drakma")
(ql:quickload "cxml")
(ql:quickload "cxml-stp")
(ql:quickload "xpath")
(ql:quickload "series"))

(series::install :implicit-map t)

(setf drakma:*drakma-default-external-format* :utf-8)

(iterate ((x (scan '(("application" . "xml")
("text" . "xml")))))
(pushnew x drakma:*text-content-types* :test #'equal))

(defclass feed ()
((title :initarg :title)
(link :initarg :link)
(description :initarg :description)
(creator :initarg :creator)
(items :initform () :initarg :items)))

(defclass feed-entry ()
((title :initarg :title)
(link :initarg :link)
(content :initarg :content)
(creator :initarg :creator)
(pub-date :initarg :pub-date)
(category :initarg :category)))

(defun %xv (path context)
(xpath:string-value (xpath:evaluate path context)))

(defun read-url (url)
(delete #\Return (drakma:http-request url)))

(defun fetch-rss (url)
(let ((response (read-url url)))
(parse-rss response)))

;;(fetch-rss "http://cadr.g.hatena.ne.jp/g000001/rss2")

(defun parse-rss (text)
(xpath:with-namespaces (("dc" "http://purl.org/dc/elements/1.1/")
("content" "http://purl.org/rss/1.0/modules/content/"))
(let* ((doc (cxml:parse text (stp:make-builder)))
(feed (make-instance 'feed
:title (%xv "rss/channel/title" doc)
:link (%xv "rss/channel/link" doc)
:description (%xv "rss/channel/description" doc)
:creator (%xv "rss/channel/dc:creator" doc))))
(with-slots (items) feed
(xpath:do-node-set (node (xpath:evaluate "//item" doc))
(push (make-instance 'feed-entry
:title (%xv "title" node)
:link (%xv "link" node)
:content (%xv "description" node)
:creator (%xv "dc:creator" node)
:pub-date (%xv "pubDate" node)
:category (%xv "category" node))
items))
(setf items (nreverse items)))
feed)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; atom

(defun fetch-atom (url)
(let ((response (read-url url)))
(parse-atom response)))

;;(fetch-atom "http://blog.livedoor.jp/chiblits/atom.xml")
;;(fetch-atom "http://feeds.feedburner.com/blogspot/rztf")

(defun parse-atom (text)
(let ((doc (cxml:parse text (stp:make-builder))))
(let ((namespace (collect-first
(choose-if (lambda (namespace)
(xpath:with-namespaces ((nil namespace))
(string/= (%xv "feed/title" doc) "")))
(scan '("http://www.w3.org/2005/Atom" "http://purl.org/atom/ns#"))))))
(xpath:with-namespaces ((nil namespace))
(let ((feed (make-instance 'feed
:title (%xv "feed/title" doc)
:link (%xv "feed/link[@rel=\"alternate\"]/@href" doc)
:description (%xv "feed/tagline" doc)
:creator (%xv "feed/author/name" doc))))
(with-slots (items) feed
(xpath:do-node-set (node (xpath:evaluate "//entry" doc))
(push (make-instance 'feed-entry
:title (%xv "title" node)
:link (%xv "link/@href" node)
:content (%xv "content" node)
:creator (%xv "author/name" node)
:pub-date (%xv "issued|published" node)
:category (%xv "category/@term" node))
items))
(setf items (nreverse items)))
feed)))))

0 件のコメント: