Archived
1
0
Disbranĉigi 0

Added tests, fixed #'author for atom feeds

This commit is contained in:
Jaidyn Levesque 2019-07-10 12:23:28 -05:00
parent bac107fb3f
commit 5e6776a75c
5 changed files with 60 additions and 79 deletions

View File

@ -16,7 +16,7 @@ USAGE
———————————————————————————————————————— ————————————————————————————————————————
You can turn a feed's XML (string) into an RSSS:FEED object with #'rsss:parse. You can turn a feed's XML (string) into an RSSS:FEED object with #'rsss:parse.
Then, you can read it by means of it's slots. Then, you can read it by means of its slots.
Slots of both FEEDs and ENTRYs: Slots of both FEEDs and ENTRYs:
* name * name

View File

@ -52,10 +52,18 @@
(setf ,list (list ,item)) (setf ,list (list ,item))
(nconc ,list (list ,item)))) (nconc ,list (list ,item))))
(defmacro mapnil (function list)
"Map over a list with a function, but remove all NILs from the result list."
`(remove nil (mapcar ,function ,list)))
(defmacro mapfirst (function list)
"Map over a list with a function, and return the first non-NIL result."
`(car (mapnil ,function ,list)))
;; VARYING LIST → LIST ;; VARYING LIST → LIST
(defun equ-assoc (item list) (defun str-assoc (item list)
"Run #'assoc, but with #'equal as the test function." "Run #'assoc, but with #'string-equal as the test function."
(assoc item list :test #'equal)) (assoc item list :test #'string-equal))
;; VARYING → BOOLEAN ;; VARYING → BOOLEAN
(defun nilp (item) (defun nilp (item)
@ -97,20 +105,22 @@
;; ————————————————— ;; —————————————————
;; ATOM PARSING ;; ATOM PARSING
;; ————————————————— ;; —————————————————
(defmacro parse-atom-children (rsss parent-node child-node extra-cond) (defmacro parse-atom-children (rsss parent-node child-node
&optional (cond-1 '(T nil))
(cond-2 '(T nil)))
"Code common to parsing both overarching Atom XML and individual entries." "Code common to parsing both overarching Atom XML and individual entries."
`(mapcar `(mapcar
(lambda (,child-node) (lambda (,child-node)
(common-let ,child-node nil (common-let ,child-node nil
(cond ((equal "link" name) (cond ((string-equal "link" name)
(setf (uri ,rsss) (cadr (equ-assoc "href" attrs)))) (setf (uri ,rsss) (cadr (str-assoc "href" attrs))))
((equal "title" name) ((string-equal "title" name)
(setf (name ,rsss) (car chchild))) (setf (name ,rsss) (car chchild)))
((equal "updated" name) ((string-equal "updated" name)
(setf (date ,rsss) (car chchild))) (setf (date ,rsss) (car chchild)))
((equal "summary" name) ((string-equal "summary" name)
(setf (desc ,rsss) (car chchild))) (setf (desc ,rsss) (car chchild)))
,extra-cond))) ,cond-1 ,cond-2)))
;; nil)) ;; nil))
(xmls:node-children ,parent-node))) (xmls:node-children ,parent-node)))
@ -122,7 +132,7 @@
(let ((feed (make-instance 'feed))) (let ((feed (make-instance 'feed)))
(parse-atom-children (parse-atom-children
feed atom-node atom-child feed atom-node atom-child
((equal "entry" name) ((string-equal "entry" name)
(append-or-replace (entries feed) (parse-atom-entry atom-child)))) (append-or-replace (entries feed) (parse-atom-entry atom-child))))
feed)) feed))
@ -132,31 +142,47 @@
(let ((entry (make-instance 'entry))) (let ((entry (make-instance 'entry)))
(parse-atom-children (parse-atom-children
entry entry-node entry-child entry entry-node entry-child
((equal "content" name) ((string-equal "content" name)
(setf (text entry) (car chchild)))) (setf (text entry) (car chchild)))
((string-equal "author" name)
(setf (author entry)
(parse-atom-author-name entry-child))))
entry)) entry))
;; -----------------
;; XMLS:NODE → STRING
(defun parse-atom-author-name (author-node)
"Return the proper name of an author, given an Atom <author> node."
(common-let author-node nil
(if (stringp chchild) chchild
(mapfirst
(lambda (chchchild)
(if (string-equal "name" (xmls:node-name chchchild))
(car (xmls:node-children chchchild))))
chchild))))
;; ————————————————— ;; —————————————————
;; RSS1/RSS2 PARSING ;; RSS1/RSS2 PARSING
;; ————————————————— ;; —————————————————
(defmacro parse-rss-children (rsss parent-node child-node (defmacro parse-rss-children (rsss parent-node child-node
&optional (cond-1 `(T nil)) &optional (cond-1 '(T nil))
(cond-2 `(T nil)) (cond-2 '(T nil))
(cond-3 `(T nil)) (cond-3 '(T nil))
(cond-4 `(T nil))) (cond-4 '(T nil)))
"Some code common to parsing the children of rss nodes." "Some code common to parsing the children of rss nodes."
`(mapcar `(mapcar
(lambda (,child-node) (lambda (,child-node)
(common-let ,child-node nil (common-let ,child-node nil
(cond ((equal "title" name) (cond ((string-equal "title" name)
(setf (name ,rsss) (ie-car chchild))) (setf (name ,rsss) (ie-car chchild)))
((equal "pubDate" name) ((string-equal "pubDate" name)
(setf (date ,rsss) (ie-car chchild))) (setf (date ,rsss) (ie-car chchild)))
((equal "date" name) ((string-equal "date" name)
(setf (date ,rsss) (ie-car chchild))) (setf (date ,rsss) (ie-car chchild)))
((equal "link" name) ((string-equal "link" name)
(setf (uri ,rsss) (ie-car chchild))) (setf (uri ,rsss) (ie-car chchild)))
,cond-1 ,cond-2 ,cond-3 ,cond-4))) ,cond-1 ,cond-2 ,cond-3 ,cond-4)))
(xmls:node-children ,parent-node))) (xmls:node-children ,parent-node)))
@ -170,9 +196,9 @@
(mapcar (mapcar
(lambda (rss-child) (lambda (rss-child)
(let ((name (xmls:node-name rss-child))) (let ((name (xmls:node-name rss-child)))
(cond ((equal "channel" name) (cond ((string-equal "channel" name)
(parse-rss-channel feed rss-child)) (parse-rss-channel feed rss-child))
((equal "item" name) ((string-equal "item" name)
(append-or-replace (append-or-replace
(entries feed) (parse-rss-item rss-child)))))) (entries feed) (parse-rss-item rss-child))))))
(xmls:node-children rss-node)) (xmls:node-children rss-node))
@ -183,9 +209,9 @@
"Parse a channel node of an RSS feed; modifies the FEED object." "Parse a channel node of an RSS feed; modifies the FEED object."
(parse-rss-children (parse-rss-children
feed channel-node channel-child feed channel-node channel-child
((equal "description" name) ((string-equal "description" name)
(setf (desc feed) (ie-car chchild))) (setf (desc feed) (ie-car chchild)))
((equal "item" name) ((string-equal "item" name)
(append-or-replace (entries feed) (parse-rss-item channel-child)))) (append-or-replace (entries feed) (parse-rss-item channel-child))))
feed) feed)
@ -195,7 +221,7 @@
(let ((entry (make-instance 'entry))) (let ((entry (make-instance 'entry)))
(parse-rss-children (parse-rss-children
entry entry-node entry-child entry entry-node entry-child
((or (equal "content" name) (equal "encoded" name)) ((or (string-equal "content" name) (string-equal "encoded" name))
(setf (text entry) (ie-car chchild))) (setf (text entry) (ie-car chchild)))
;; about the following: people use <description> tags for both summaries ;; about the following: people use <description> tags for both summaries
;; and for actual post-bodies. (wtf :/) ;; and for actual post-bodies. (wtf :/)
@ -204,13 +230,13 @@
;; long… ;; long…
;; this is a hack that won't always be helpful or effective, it's the ;; this is a hack that won't always be helpful or effective, it's the
;; best trade-off I could think of. sorry ♥ ;; best trade-off I could think of. sorry ♥
((equal "description" name) ((string-equal "description" name)
(if (and (< 250 (length (ie-car chchild))) (not (text entry))) (if (and (< 250 (length (ie-car chchild))) (not (text entry)))
(setf (text entry) (ie-car chchild)) (setf (text entry) (ie-car chchild))
(setf (desc entry) (ie-car chchild)))) (setf (desc entry) (ie-car chchild))))
((equal "enclosure" name) ((string-equal "enclosure" name)
(setf (media entry) (cadr (assoc "url" attrs :test #'equal)))) (setf (media entry) (cadr (str-assoc "url" attrs))))
((or (equal "author" name) (equal "creator" name)) ((or (string-equal "author" name) (string-equal "creator" name))
(setf (author entry) (ie-car chchild)))) (setf (author entry) (ie-car chchild))))
entry)) entry))
@ -225,10 +251,10 @@
and :atom for (obviously!) Atom." and :atom for (obviously!) Atom."
(let ((name (xmls:node-name node)) (let ((name (xmls:node-name node))
(attrs (xmls:node-attrs node))) (attrs (xmls:node-attrs node)))
(cond ((and (equal "rss" name) (cond ((and (string-equal "rss" name)
(equal "2.0" (cadr (assoc "version" attrs :test #'equal)))) (equal "2.0" (cadr (assoc "version" attrs :test #'equal))))
:rss2) :rss2)
((equal "rss" name) ((or (string-equal "rss" name) (string-equal "rdf" name))
:rss1) :rss1)
((equal "feed" name) ((string-equal "feed" name)
:atom)))) :atom))))

View File

@ -1,12 +0,0 @@
================================================================================
TESTING FOR :RSSS
================================================================================
To test :rsss, make just change directories into the root of the repository;
then, load `t.lisp` from there, like so:
[0]> (load "t/t.lisp")
Then, you can run the tests:
[1]> (rsss-testing:do-all)

View File

@ -1,23 +0,0 @@
(defpackage :rsss
(:use :cl)
(:export
;; PUBLIC FUNCTIONS
:feed-value
:feed-values
:feed-value-listless
:feed-items
:title
:description
:pubdate
:link
;; PRIVATE FUNCTIONS
:getf-string
:getf-strings))
(in-package :rsss)

View File

@ -1,10 +0,0 @@
(ql:quickload :uiop)
(ql:quickload :rt)
(ql:quickload :xmls)
(load "t/package.lisp")
(load "src/main.lisp")
(load "t/main.lisp")
(rsss-testing:do-all)