File: main.lisp

package info (click to toggle)
cl-rss 0.1.1-4
  • links: PTS
  • area: main
  • in suites: lenny
  • size: 40 kB
  • ctags: 16
  • sloc: lisp: 80; makefile: 44; sh: 28
file content (101 lines) | stat: -rw-r--r-- 3,232 bytes parent folder | download | duplicates (3)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
;;;; Name:          main.lisp
;;;; Purpose:       Main RSS functions
;;;; Programmer:    Kevin M. Rosenberg
;;;; Date Started:  Sep 2003
;;;;
;;;; $Id: rss.asd 7061 2003-09-07 06:34:45Z kevin $
;;;; *************************************************************************

(in-package #:rss)

(defclass rss-0.9x-channel ()
  ((title :accessor title :initform nil)
   (link :accessor link :initform nil)
   (description :accessor description)
   (items :accessor items :initform nil)))

(defclass rss-0.9x-item ()
  ((title :accessor title :initform nil )
   (link :accessor link :initform nil)))

(defvar *sites*
    '("http://www.cliki.net/recent-changes.rdf"))

(defun show-sites (&optional (sites *sites*))
  (dolist (site sites)
    (awhen (rss-site site)
	   (display-site it))))

(defun display-site (site &key (stream *standard-output*))
  (format stream "Site: ~A~%" (title site))
  (dolist (item (items site))
    (format stream "  ~A~%" (title item))))

(defun rss-site (uri)
  (multiple-value-bind (body response headers true-uri)
      (net.aserve.client:do-http-request uri)
    (declare (ignore true-uri headers))
    (when (eql 200 response)
      (with-input-from-string (strm body)
	(parse-rss-0.9x-stream strm)))))
  
(defun parse-rss-0.9x-file (file)
  (with-open-file (stream file :direction :input)
    (parse-rss-0.9x-stream stream)))

(defun is-rss-version-supported (attributes)
  (awhen (position "version" attributes :key #'car :test #'string=)
	 (let ((version (second (nth it attributes))))
	   (= 4 (length version))
	   (string= "0.9" (subseq version 0 3)))))

(defun parse-rss-0.9x-stream (stream)
  (let* ((*package* (find-package 'kmrcl))
	 (tree (remove-from-tree-if 
		(lambda (x) (and (stringp x) (is-string-whitespace x)))
		(xmls:parse stream :compress-whitespace t))))
    (unless (and (string= "rss" (first tree))
		 (is-rss-version-supported (second tree)))
      (return-from parse-rss-0.9x-stream nil))
    (let* ((content (third tree))
	   (pos 0)
	   (len (length content))
	   (rss (make-instance 'rss-0.9x-channel)))
      (when (string= "channel" (nth pos content))
	(incf pos)
	(while (and (< pos len) 
		    (or (string= "title" (car (nth pos content)))
			(string= "link" (car (nth pos content)))
			(string= "description" (car (nth pos content)))))
	  (let ((slot (nth pos content)))
	    (cond
	     ((string= "title" (car slot))
	      (setf (title rss) (second slot)))
	     ((string= "link" (car slot))
	      (setf (link rss) (second slot)))
	     ((string= "description" (car slot))
	      (setf (description rss) (second slot)))))
	  (incf pos)))
      (while (< pos len)
	(when (string= "item" (car (nth pos content)))
	  (let ((item (make-instance 'rss-0.9x-item)))
	    (dolist (pair (cdr (nth pos content)))
	      (cond
	       ((string= "title" (car pair))
		(setf (title item) (second pair)))
	       ((string= "link" (car pair))
		(setf (link item) (second pair)))))
	    (push item (items rss))))
	(incf pos))
      (setf (items rss) (nreverse (items rss)))
      rss)))