Browse code

Added tests, fixed #'author for atom feeds

Jaidyn Levesque authored on 2019-07-10 17:23:28
Showing 5 changed files
... ...
@@ -16,7 +16,7 @@ USAGE
16 16
 ————————————————————————————————————————
17 17
 You can turn a feed's XML (string) into an RSSS:FEED object with #'rsss:parse.
18 18
 
19
-Then, you can read it by means of it's slots.
19
+Then, you can read it by means of its slots.
20 20
 
21 21
 Slots of both FEEDs and ENTRYs:
22 22
 * name
... ...
@@ -52,10 +52,18 @@
52 52
     (setf ,list  (list ,item))
53 53
     (nconc ,list (list ,item))))
54 54
 
55
+(defmacro mapnil (function list)
56
+  "Map over a list with a function, but remove all NILs from the result list."
57
+  `(remove nil (mapcar ,function ,list)))
58
+
59
+(defmacro mapfirst (function list)
60
+  "Map over a list with a function, and return the first non-NIL result."
61
+  `(car (mapnil ,function ,list)))
62
+
55 63
 ;; VARYING LIST → LIST
56
-(defun equ-assoc (item list)
57
-  "Run #'assoc, but with #'equal as the test function."
58
-  (assoc item list :test #'equal))
64
+(defun str-assoc (item list)
65
+  "Run #'assoc, but with #'string-equal as the test function."
66
+  (assoc item list :test #'string-equal))
59 67
 
60 68
 ;; VARYING → BOOLEAN
61 69
 (defun nilp (item)
... ...
@@ -97,20 +105,22 @@
97 105
 ;; —————————————————
98 106
 ;; ATOM PARSING
99 107
 ;; —————————————————
100
-(defmacro parse-atom-children (rsss parent-node child-node extra-cond)
108
+(defmacro parse-atom-children (rsss parent-node child-node
109
+				    &optional (cond-1 '(T nil))
110
+				              (cond-2 '(T nil)))
101 111
   "Code common to parsing both overarching Atom XML and individual entries."
102 112
    `(mapcar
103 113
       (lambda (,child-node)
104 114
 	(common-let ,child-node nil
105
-	  (cond ((equal "link"  name)
106
-		 (setf (uri ,rsss)       (cadr (equ-assoc "href" attrs))))
107
-		((equal "title" name)
115
+	  (cond ((string-equal "link" name)
116
+		 (setf (uri ,rsss)       (cadr (str-assoc "href" attrs))))
117
+		((string-equal "title" name)
108 118
 		 (setf (name ,rsss)      (car chchild)))
109
-		((equal "updated" name)
119
+		((string-equal "updated" name)
110 120
 		 (setf (date ,rsss)      (car chchild)))
111
-		((equal "summary" name)
121
+		((string-equal "summary" name)
112 122
 		 (setf (desc ,rsss)      (car chchild)))
113
-		,extra-cond)))
123
+		,cond-1 ,cond-2)))
114 124
 ;;	  nil))
115 125
       (xmls:node-children ,parent-node)))
116 126
 
... ...
@@ -122,7 +132,7 @@
122 132
   (let ((feed (make-instance 'feed)))
123 133
     (parse-atom-children
124 134
       feed atom-node atom-child
125
-      ((equal "entry" name)
135
+      ((string-equal "entry" name)
126 136
        (append-or-replace (entries feed) (parse-atom-entry atom-child))))
127 137
     feed))
128 138
 
... ...
@@ -132,31 +142,47 @@
132 142
   (let ((entry (make-instance 'entry)))
133 143
     (parse-atom-children
134 144
       entry entry-node entry-child
135
-      ((equal "content" name)
136
-       (setf (text entry) (car chchild))))
145
+      ((string-equal "content" name)
146
+       (setf (text entry) (car chchild)))
147
+      ((string-equal "author" name)
148
+       (setf (author entry)
149
+	     (parse-atom-author-name entry-child))))
137 150
     entry))
138 151
 
152
+;; -----------------
153
+
154
+;; XMLS:NODE → STRING
155
+(defun parse-atom-author-name (author-node)
156
+  "Return the proper name of an author, given an Atom <author> node."
157
+  (common-let author-node nil
158
+    (if (stringp chchild)  chchild
159
+      (mapfirst
160
+	(lambda (chchchild)
161
+	  (if (string-equal "name" (xmls:node-name chchchild))
162
+	    (car (xmls:node-children chchchild))))
163
+	chchild))))
164
+ 
139 165
 
140 166
 
141 167
 ;; —————————————————
142 168
 ;; RSS1/RSS2 PARSING
143 169
 ;; —————————————————
144 170
 (defmacro parse-rss-children (rsss parent-node child-node
145
-				    &optional (cond-1 `(T nil))
146
-					      (cond-2 `(T nil))
147
-					      (cond-3 `(T nil))
148
-					      (cond-4 `(T nil)))
171
+				    &optional (cond-1 '(T nil))
172
+					      (cond-2 '(T nil))
173
+					      (cond-3 '(T nil))
174
+					      (cond-4 '(T nil)))
149 175
   "Some code common to parsing the children of rss nodes."
150 176
   `(mapcar
151 177
      (lambda (,child-node)
152 178
        (common-let ,child-node nil
153
-         (cond ((equal "title" name)
179
+         (cond ((string-equal "title" name)
154 180
 		(setf (name ,rsss) (ie-car chchild)))
155
-	       ((equal "pubDate" name)
181
+	       ((string-equal "pubDate" name)
156 182
 		(setf (date ,rsss) (ie-car chchild)))
157
-	       ((equal "date" name)
183
+	       ((string-equal "date" name)
158 184
 		(setf (date ,rsss) (ie-car chchild)))
159
-	       ((equal "link" name)
185
+	       ((string-equal "link" name)
160 186
 		(setf (uri ,rsss)  (ie-car chchild)))
161 187
 	       ,cond-1 ,cond-2 ,cond-3 ,cond-4)))
162 188
      (xmls:node-children ,parent-node)))
... ...
@@ -170,9 +196,9 @@
170 196
     (mapcar 
171 197
       (lambda (rss-child)
172 198
 	(let ((name (xmls:node-name rss-child)))
173
-	  (cond ((equal "channel" name)
199
+	  (cond ((string-equal "channel" name)
174 200
 		 (parse-rss-channel feed rss-child))
175
-		((equal "item"    name)
201
+		((string-equal "item"    name)
176 202
 		 (append-or-replace
177 203
 		   (entries feed) (parse-rss-item rss-child))))))
178 204
       (xmls:node-children rss-node))
... ...
@@ -183,9 +209,9 @@
183 209
   "Parse a channel node of an RSS feed; modifies the FEED object."
184 210
   (parse-rss-children
185 211
     feed channel-node channel-child
186
-    ((equal "description" name)
212
+    ((string-equal "description" name)
187 213
      (setf (desc feed) (ie-car chchild)))
188
-    ((equal "item" name)
214
+    ((string-equal "item" name)
189 215
      (append-or-replace (entries feed) (parse-rss-item channel-child))))
190 216
   feed)
191 217
 
... ...
@@ -195,7 +221,7 @@
195 221
   (let ((entry (make-instance 'entry)))
196 222
     (parse-rss-children
197 223
       entry entry-node entry-child
198
-      ((or (equal "content" name) (equal "encoded" name))
224
+      ((or (string-equal "content" name) (string-equal "encoded" name))
199 225
        (setf (text entry)   (ie-car chchild)))
200 226
       ;; about the following: people use <description> tags for both summaries
201 227
       ;; and for actual post-bodies. (wtf :/)
... ...
@@ -204,13 +230,13 @@
204 230
       ;; long…
205 231
       ;; this is a hack that won't always be helpful or effective, it's the
206 232
       ;; best trade-off I could think of. sorry ♥
207
-      ((equal "description" name)
233
+      ((string-equal "description" name)
208 234
        (if (and (< 250 (length (ie-car chchild))) (not (text entry)))
209 235
 	 (setf (text entry) (ie-car chchild))
210 236
 	 (setf (desc entry) (ie-car chchild))))
211
-      ((equal "enclosure" name)
212
-       (setf (media entry)  (cadr (assoc "url" attrs :test #'equal))))
213
-      ((or (equal "author" name) (equal "creator" name))
237
+      ((string-equal "enclosure" name)
238
+       (setf (media entry)  (cadr (str-assoc "url" attrs))))
239
+      ((or (string-equal "author" name) (string-equal "creator" name))
214 240
        (setf (author entry) (ie-car chchild))))
215 241
     entry))
216 242
 
... ...
@@ -225,10 +251,10 @@
225 251
   and :atom for (obviously!) Atom."
226 252
   (let ((name    (xmls:node-name node))
227 253
 	(attrs   (xmls:node-attrs node)))
228
-    (cond ((and (equal "rss" name)
254
+    (cond ((and (string-equal "rss" name)
229 255
 		(equal "2.0" (cadr (assoc "version" attrs :test #'equal))))
230 256
 	   :rss2)
231
-	  ((equal "rss" name)
257
+	  ((or (string-equal "rss" name) (string-equal "rdf" name))
232 258
 	   :rss1)
233
-	  ((equal "feed" name)
259
+	  ((string-equal "feed" name)
234 260
 	   :atom))))
235 261
deleted file mode 100644
... ...
@@ -1,12 +0,0 @@
1
-================================================================================
2
-TESTING FOR :RSSS
3
-================================================================================
4
-
5
-To test :rsss, make just change directories into the root of the repository;
6
-then, load `t.lisp` from there, like so:
7
-
8
-	[0]> (load "t/t.lisp")
9
-
10
-Then, you can run the tests:
11
-
12
-	[1]> (rsss-testing:do-all)
13 0
deleted file mode 100644
... ...
@@ -1,23 +0,0 @@
1
-(defpackage :rsss
2
-  (:use :cl)
3
-  (:export 
4
-
5
-    ;; PUBLIC FUNCTIONS
6
-    :feed-value
7
-    :feed-values
8
-    :feed-value-listless
9
-
10
-    :feed-items
11
-
12
-    :title
13
-    :description
14
-    :pubdate
15
-    :link
16
-
17
-
18
-    ;; PRIVATE FUNCTIONS
19
-    :getf-string
20
-    :getf-strings))
21
-    
22
-
23
-(in-package :rsss)
24 0
deleted file mode 100644
... ...
@@ -1,10 +0,0 @@
1
-(ql:quickload :uiop)
2
-(ql:quickload :rt)
3
-(ql:quickload :xmls)
4
-
5
-(load "t/package.lisp")
6
-
7
-(load "src/main.lisp")
8
-(load "t/main.lisp")
9
-
10
-(rsss-testing:do-all)