/[emacs]/emacs/lisp/gnus/nnslashdot.el
ViewVC logotype

Diff of /emacs/lisp/gnus/nnslashdot.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.2 by zsh, Sun Jan 21 05:33:42 2001 UTC revision 1.2.14.1 by zsh, Thu Feb 7 15:28:34 2002 UTC
# Line 1  Line 1 
1  ;;; nnslashdot.el --- interfacing with Slashdot  ;;; nnslashdot.el --- interfacing with Slashdot
2  ;; Copyright (C) 1999, 2000 Free Software Foundation, Inc.  ;; Copyright (C) 1999, 2000, 2001 Free Software Foundation, Inc.
3    
4  ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>  ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
5  ;; Keywords: news  ;; Keywords: news
# Line 57  Line 57 
57      "http://slashdot.org/article.pl?sid=%s&mode=nocomment"      "http://slashdot.org/article.pl?sid=%s&mode=nocomment"
58    "Where nnslashdot will fetch the article from.")    "Where nnslashdot will fetch the article from.")
59    
60    (defvoo nnslashdot-backslash-url "http://slashdot.org/slashdot.xml"
61      "Where nnslashdot will fetch the stories from.")
62    
63  (defvoo nnslashdot-threshold -1  (defvoo nnslashdot-threshold -1
64    "The article threshold.")    "The article threshold.")
65    
# Line 86  Line 89 
89    (nnslashdot-possibly-change-server group server)    (nnslashdot-possibly-change-server group server)
90    (condition-case why    (condition-case why
91        (unless gnus-nov-is-evil        (unless gnus-nov-is-evil
92          (if nnslashdot-threaded          (nnslashdot-retrieve-headers-1 articles group))
             (nnslashdot-threaded-retrieve-headers articles group)  
           (nnslashdot-sane-retrieve-headers articles group)))  
93      (search-failed (nnslashdot-lose why))))      (search-failed (nnslashdot-lose why))))
94    
95  (deffoo nnslashdot-threaded-retrieve-headers (articles group)  (deffoo nnslashdot-retrieve-headers-1 (articles group)
96    (let ((last (car (last articles)))    (let* ((last (car (last articles)))
97          (did nil)           (start (if nnslashdot-threaded 1 (pop articles)))
98          (start 1)           (entry (assoc group nnslashdot-groups))
99          (sid (caddr (assoc group nnslashdot-groups)))           (sid (nth 2 entry))
100          (first-comments t)           (first-comments t)
101          (startats '(1))           headers article subject score from date lines parent point cid
102          headers article subject score from date lines parent point s)           s startats changed)
103      (save-excursion      (save-excursion
104        (set-buffer nnslashdot-buffer)        (set-buffer nnslashdot-buffer)
105        (let ((case-fold-search t))        (let ((case-fold-search t))
# Line 107  Line 108 
108            (nnweb-insert (format nnslashdot-article-url            (nnweb-insert (format nnslashdot-article-url
109                                  (nnslashdot-sid-strip sid)) t)                                  (nnslashdot-sid-strip sid)) t)
110            (goto-char (point-min))            (goto-char (point-min))
111            (search-forward "Posted by ")            (re-search-forward "Posted by[ \t\r\n]+")
112            (when (looking-at "<a[^>]+>\\([^<]+\\)")            (when (looking-at "\\(<a[^>]+>\\)?[ \t\r\n]*\\([^<\r\n]+\\)")
113              (setq from (nnweb-decode-entities-string (match-string 1))))              (setq from (nnweb-decode-entities-string (match-string 2))))
114            (search-forward " on ")            (search-forward "on ")
115            (setq date (nnslashdot-date-to-date            (setq date (nnslashdot-date-to-date
116                        (buffer-substring (point) (1- (search-forward "<")))))                        (buffer-substring (point) (1- (search-forward "<")))))
117            (setq lines (/ (- (point)            (setq lines (/ (- (point)
# Line 123  Line 124 
124               1 group from date               1 group from date
125               (concat "<" (nnslashdot-sid-strip sid) "%1@slashdot>")               (concat "<" (nnslashdot-sid-strip sid) "%1@slashdot>")
126               "" 0 lines nil nil))               "" 0 lines nil nil))
127             headers))             headers)
128          (while (and (setq start (pop startats))            (setq start (if nnslashdot-threaded 2 (pop articles))))
129                      (< start last))          (while (and start (<= start last))
130            (setq point (goto-char (point-max)))            (setq point (goto-char (point-max)))
131            (nnweb-insert            (nnweb-insert
132             (format nnslashdot-comments-url             (format nnslashdot-comments-url
133                     (nnslashdot-sid-strip sid)                     (nnslashdot-sid-strip sid)
134                     nnslashdot-threshold 0 start)                     nnslashdot-threshold 0 (- start 2))
135             t)             t)
136            (when first-comments            (when (and nnslashdot-threaded first-comments)
137              (setq first-comments nil)              (setq first-comments nil)
138              (goto-char (point-max))              (goto-char (point-max))
139              (while (re-search-backward "startat=\\([0-9]+\\)" nil t)              (while (re-search-backward "startat=\\([0-9]+\\)" nil t)
# Line 140  Line 141 
141                (unless (memq s startats)                (unless (memq s startats)
142                  (push s startats)))                  (push s startats)))
143              (setq startats (sort startats '<)))              (setq startats (sort startats '<)))
144              (setq article (if (and article (< start article)) article start))
145            (goto-char point)            (goto-char point)
146            (while (re-search-forward            (while (re-search-forward
147                    "<a name=\"\\([0-9]+\\)\"><\\(b\\|H4\\)>\\([^<]+\\)</\\(b\\|H4\\)>.*score:\\([^)]+\\))"                    "<a name=\"\\([0-9]+\\)\"><\\(b\\|H4\\)>\\([^<]+\\)</\\(b\\|H4\\)>.*score:\\([^)]+\\))"
148                    nil t)                    nil t)
149              (setq article (string-to-number (match-string 1))              (setq cid (match-string 1)
150                    subject (match-string 3)                    subject (match-string 3)
151                    score (match-string 5))                    score (match-string 5))
152                (unless (assq article (nth 4 entry))
153                  (setcar (nthcdr 4 entry) (cons (cons article cid) (nth 4 entry)))
154                  (setq changed t))
155              (when (string-match "^Re: *" subject)              (when (string-match "^Re: *" subject)
156                (setq subject (concat "Re: " (substring subject (match-end 0)))))                (setq subject (concat "Re: " (substring subject (match-end 0)))))
157              (setq subject (nnweb-decode-entities-string subject))              (setq subject (nnweb-decode-entities-string subject))
158              (forward-line 1)              (search-forward "<BR>")
159              (if (looking-at              (if (looking-at
160                   "by <a[^>]+>\\([^<]+\\)</a>[ \t\n]*.*(\\([^)]+\\))")                   "by[ \t\n]+<a[^>]+>\\([^<]+\\)</a>[ \t\n]*(\\(<[^>]+>\\)*\\([^<>)]+\\))")
161                  (progn                  (progn
162                    (goto-char (- (match-end 0) 5))                    (goto-char (- (match-end 0) 5))
163                    (setq from (concat                    (setq from (concat
164                                (nnweb-decode-entities-string (match-string 1))                                (nnweb-decode-entities-string (match-string 1))
165                                " <" (match-string 2) ">")))                                " <" (match-string 3) ">")))
166                (setq from "")                (setq from "")
167                (when (looking-at "by \\(.+\\) on ")                (when (looking-at "by \\([^<>]*\\) on ")
168                  (goto-char (- (match-end 0) 5))                  (goto-char (- (match-end 0) 5))
169                  (setq from (nnweb-decode-entities-string (match-string 1)))))                  (setq from (nnweb-decode-entities-string (match-string 1)))))
170              (search-forward " on ")              (search-forward " on ")
171              (setq date              (setq date
172                    (nnslashdot-date-to-date                    (nnslashdot-date-to-date
173                     (buffer-substring (point) (progn (end-of-line) (point)))))                     (buffer-substring (point) (progn (skip-chars-forward "^()<>\n\r") (point)))))
174              (setq lines (/ (abs (- (search-forward "<td ")              (setq lines (/ (abs (- (search-forward "<td")
175                                     (search-forward "</td>")))                                     (search-forward "</td>")))
176                             70))                             70))
177              (forward-line 4)              (if (not
178              (setq parent                   (re-search-forward ".*cid=\\([0-9]+\\)\">Parent</A>" nil t))
179                    (if (looking-at ".*cid=\\([0-9]+\\)")                  (setq parent nil)
180                        (match-string 1)                (setq parent (match-string 1))
181                      nil))                (when (string= parent "0")
182              (setq did t)                  (setq parent nil)))
183              (push              (push
184               (cons               (cons
185                (1+ article)                article
186                (make-full-mail-header                (make-full-mail-header
187                 (1+ article)                 article
188                 (concat subject " (" score ")")                 (concat subject " (" score ")")
189                 from date                 from date
190                 (concat "<" (nnslashdot-sid-strip sid) "%"                 (concat "<" (nnslashdot-sid-strip sid) "%" cid "@slashdot>")
                        (number-to-string (1+ article))  
                        "@slashdot>")  
191                 (if parent                 (if parent
192                     (concat "<" (nnslashdot-sid-strip sid) "%"                     (concat "<" (nnslashdot-sid-strip sid) "%"
193                             (number-to-string (1+ (string-to-number parent)))                             parent "@slashdot>")
                            "@slashdot>")  
194                   "")                   "")
195                 0 lines nil nil))                 0 lines nil nil))
196               headers)))))               headers)
197                (while (and articles (<= (car articles) article))
198                  (pop articles))
199                (setq article (1+ article)))
200              (if nnslashdot-threaded
201                  (progn
202                    (setq start (pop startats))
203                    (if start (setq start (+ start 2))))
204                (setq start (pop articles))))))
205        (if changed (nnslashdot-write-groups))
206      (setq nnslashdot-headers (sort headers 'car-less-than-car))      (setq nnslashdot-headers (sort headers 'car-less-than-car))
207      (save-excursion      (save-excursion
208        (set-buffer nntp-server-buffer)        (set-buffer nntp-server-buffer)
# Line 201  Line 212 
212           (nnheader-insert-nov (cdr header)))))           (nnheader-insert-nov (cdr header)))))
213      'nov))      'nov))
214    
 (deffoo nnslashdot-sane-retrieve-headers (articles group)  
   (let ((last (car (last articles)))  
         (did nil)  
         (start (max (1- (car articles)) 1))  
         (sid (caddr (assoc group nnslashdot-groups)))  
         headers article subject score from date lines parent point)  
     (save-excursion  
       (set-buffer nnslashdot-buffer)  
       (erase-buffer)  
       (when (= start 1)  
         (nnweb-insert (format nnslashdot-article-url  
                               (nnslashdot-sid-strip sid)) t)  
         (goto-char (point-min))  
         (search-forward "Posted by ")  
         (when (looking-at "<a[^>]+>\\([^<]+\\)")  
           (setq from (nnweb-decode-entities-string (match-string 1))))  
         (search-forward " on ")  
         (setq date (nnslashdot-date-to-date  
                     (buffer-substring (point) (1- (search-forward "<")))))  
         (forward-line 2)  
         (setq lines (count-lines (point)  
                                  (re-search-forward  
                                   "A href=\"\\(http://slashdot.org\\)?/article")))  
         (push  
          (cons  
           1  
           (make-full-mail-header  
            1 group from date (concat "<" (nnslashdot-sid-strip sid)  
                                      "%1@slashdot>")  
            "" 0 lines nil nil))  
          headers))  
       (while (or (not article)  
                  (and did  
                       (< article last)))  
         (when article  
           (setq start (1+ article)))  
         (setq point (goto-char (point-max)))  
         (nnweb-insert  
          (format nnslashdot-comments-url (nnslashdot-sid-strip sid)  
                  nnslashdot-threshold 4 start)  
          t)  
         (goto-char point)  
         (while (re-search-forward  
                   "<a name=\"\\([0-9]+\\)\"><\\(b\\|H4\\)>\\([^<]+\\)</\\(b\\|H4\\)>.*score:\\([^)]+\\))"  
                 nil t)  
           (setq article (string-to-number (match-string 1))  
                 subject (match-string 3)  
                 score (match-string 5))  
           (when (string-match "^Re: *" subject)  
             (setq subject (concat "Re: " (substring subject (match-end 0)))))  
           (setq subject (nnweb-decode-entities-string subject))  
           (forward-line 1)  
           (if (looking-at  
                "by <a[^>]+>\\([^<]+\\)</a>[ \t\n]*.*(\\([^)]+\\))")  
               (progn  
                 (goto-char (- (match-end 0) 5))  
                 (setq from (concat  
                             (nnweb-decode-entities-string (match-string 1))  
                             " <" (match-string 2) ">")))  
             (setq from "")  
             (when (looking-at "by \\(.+\\) on ")  
               (goto-char (- (match-end 0) 5))  
               (setq from (nnweb-decode-entities-string (match-string 1)))))  
           (search-forward " on ")  
           (setq date  
                 (nnslashdot-date-to-date  
                  (buffer-substring (point) (progn (end-of-line) (point)))))  
           (setq lines (/ (abs (- (search-forward "<td ")  
                                  (search-forward "</td>")))  
                          70))  
           (forward-line 2)  
           (setq parent  
                 (if (looking-at ".*cid=\\([0-9]+\\)")  
                     (match-string 1)  
                   nil))  
           (setq did t)  
           (push  
            (cons  
             (1+ article)  
             (make-full-mail-header  
              (1+ article) (concat subject " (" score ")")  
              from date  
              (concat "<" (nnslashdot-sid-strip sid) "%"  
                      (number-to-string (1+ article))  
                      "@slashdot>")  
              (if parent  
                  (concat "<" (nnslashdot-sid-strip sid) "%"  
                          (number-to-string (1+ (string-to-number parent)))  
                          "@slashdot>")  
                "")  
              0 lines nil nil))  
            headers))))  
     (setq nnslashdot-headers  
           (sort headers (lambda (s1 s2) (< (car s1) (car s2)))))  
     (save-excursion  
       (set-buffer nntp-server-buffer)  
       (erase-buffer)  
       (mm-with-unibyte-current-buffer  
         (dolist (header nnslashdot-headers)  
           (nnheader-insert-nov (cdr header)))))  
     'nov))  
   
215  (deffoo nnslashdot-request-group (group &optional server dont-check)  (deffoo nnslashdot-request-group (group &optional server dont-check)
216    (nnslashdot-possibly-change-server nil server)    (nnslashdot-possibly-change-server nil server)
217    (let ((elem (assoc group nnslashdot-groups)))    (let ((elem (assoc group nnslashdot-groups)))
# Line 325  Line 234 
234    
235  (deffoo nnslashdot-request-article (article &optional group server buffer)  (deffoo nnslashdot-request-article (article &optional group server buffer)
236    (nnslashdot-possibly-change-server group server)    (nnslashdot-possibly-change-server group server)
237    (let (contents)    (let (contents cid)
238      (condition-case why      (condition-case why
239          (save-excursion          (save-excursion
240            (set-buffer nnslashdot-buffer)            (set-buffer nnslashdot-buffer)
# Line 333  Line 242 
242              (goto-char (point-min))              (goto-char (point-min))
243              (when (and (stringp article)              (when (and (stringp article)
244                         (string-match "%\\([0-9]+\\)@" article))                         (string-match "%\\([0-9]+\\)@" article))
245                (setq article (string-to-number (match-string 1 article))))                (setq cid (match-string 1 article))
246                  (let ((map (nth 4 (assoc group nnslashdot-groups))))
247                    (while map
248                      (if (equal (cdar map) cid)
249                          (setq article (caar map)
250                                map nil)
251                        (setq map (cdr map))))))
252              (when (numberp article)              (when (numberp article)
253                (if (= article 1)                (if (= article 1)
254                    (progn                    (progn
255                      (re-search-forward "Posted by *<[^>]+>[^>]*<[^>]+> *on ")                      (re-search-forward
256                         "Posted by")
257                      (search-forward "<BR>")                      (search-forward "<BR>")
258                      (setq contents                      (setq contents
259                            (buffer-substring                            (buffer-substring
260                             (point)                             (point)
261                             (progn                             (progn
262                               (re-search-forward                               (re-search-forward
263                                "<p>.*A href=\"\\(http://slashdot.org\\)?/article")                                "&lt;&nbsp;[ \t\r\n]*<A HREF=\"\\(\\(http:\\)?//slashdot\\.org\\)?/article")
264                               (match-beginning 0)))))                               (match-beginning 0)))))
265                  (search-forward (format "<a name=\"%d\">" (1- article)))                  (setq cid (cdr (assq article
266                                         (nth 4 (assoc group nnslashdot-groups)))))
267                    (search-forward (format "<a name=\"%s\">" cid))
268                  (setq contents                  (setq contents
269                        (buffer-substring                        (buffer-substring
270                         (re-search-forward "<td[^>]+>")                         (re-search-forward "<td[^>]*>")
271                         (search-forward "</td>")))))))                         (search-forward "</td>")))))))
272        (search-failed (nnslashdot-lose why)))        (search-failed (nnslashdot-lose why)))
273    
# Line 384  Line 302 
302    (let ((number 0)    (let ((number 0)
303          sid elem description articles gname)          sid elem description articles gname)
304      (condition-case why      (condition-case why
305          ;; First we do the Ultramode to get info on all the latest groups.          ;; First we do the Ultramode to get info on all the latest groups.
306          (progn          (progn
307            (mm-with-unibyte-buffer            (mm-with-unibyte-buffer
308              (nnweb-insert "http://slashdot.org/slashdot.xml" t)              (nnweb-insert nnslashdot-backslash-url t)
309              (goto-char (point-min))              (goto-char (point-min))
310              (while (search-forward "<story>" nil t)              (while (search-forward "<story>" nil t)
311                (narrow-to-region (point) (search-forward "</story>"))                (narrow-to-region (point) (search-forward "</story>"))
# Line 404  Line 322 
322                (setq gname (concat description " (" sid ")"))                (setq gname (concat description " (" sid ")"))
323                (if (setq elem (assoc gname nnslashdot-groups))                (if (setq elem (assoc gname nnslashdot-groups))
324                    (setcar (cdr elem) articles)                    (setcar (cdr elem) articles)
325                  (push (list gname articles sid) nnslashdot-groups))                  (push (list gname articles sid (current-time) nil)
326                          nnslashdot-groups))
327                (goto-char (point-max))                (goto-char (point-max))
328                (widen)))                (widen)))
329            ;; Then do the older groups.            ;; Then do the older groups.
# Line 425  Line 344 
344                    (setq gname (concat description " (" sid ")"))                    (setq gname (concat description " (" sid ")"))
345                    (if (setq elem (assoc gname nnslashdot-groups))                    (if (setq elem (assoc gname nnslashdot-groups))
346                        (setcar (cdr elem) articles)                        (setcar (cdr elem) articles)
347                      (push (list gname articles sid) nnslashdot-groups)))))                      (push (list gname articles sid (current-time) nil)
348                              nnslashdot-groups)))))
349              (incf number 30)))              (incf number 30)))
350        (search-failed (nnslashdot-lose why)))        (search-failed (nnslashdot-lose why)))
351      (nnslashdot-write-groups)      (nnslashdot-write-groups)
352      (nnslashdot-generate-active)      (nnslashdot-generate-active)
353      t))      t))
354      
355  (deffoo nnslashdot-request-newgroups (date &optional server)  (deffoo nnslashdot-request-newgroups (date &optional server)
356    (nnslashdot-possibly-change-server nil server)    (nnslashdot-possibly-change-server nil server)
357    (nnslashdot-generate-active)    (nnslashdot-generate-active)
# Line 496  Line 416 
416    (setq nnslashdot-headers nil    (setq nnslashdot-headers nil
417          nnslashdot-groups nil))          nnslashdot-groups nil))
418    
419    (deffoo nnslashdot-request-expire-articles
420        (articles group &optional server force)
421      (nnslashdot-possibly-change-server group server)
422      (let ((item (assoc group nnslashdot-groups)))
423        (when item
424          (if (fourth item)
425              (when (and (>= (length articles) (cadr item)) ;; All are expirable.
426                         (nnmail-expired-article-p
427                          group
428                          (fourth item)
429                          force))
430                (setq nnslashdot-groups (delq item nnslashdot-groups))
431                (nnslashdot-write-groups)
432                (setq articles nil)) ;; all expired.
433            (setcdr (cddr item) (list (current-time)))
434            (nnslashdot-write-groups))))
435      articles)
436    
437  (nnoo-define-skeleton nnslashdot)  (nnoo-define-skeleton nnslashdot)
438    
439  ;;; Internal functions  ;;; Internal functions
# Line 508  Line 446 
446    (unless nnslashdot-groups    (unless nnslashdot-groups
447      (nnslashdot-read-groups)))      (nnslashdot-read-groups)))
448    
449    (defun nnslashdot-make-tuple (tuple n)
450      (prog1
451          tuple
452        (while (> n 1)
453          (unless (cdr tuple)
454            (setcdr tuple (list nil)))
455          (setq tuple (cdr tuple)
456                n (1- n)))))
457    
458  (defun nnslashdot-read-groups ()  (defun nnslashdot-read-groups ()
459    (let ((file (expand-file-name "groups" nnslashdot-directory)))    (let ((file (expand-file-name "groups" nnslashdot-directory)))
460      (when (file-exists-p file)      (when (file-exists-p file)
461        (mm-with-unibyte-buffer        (mm-with-unibyte-buffer
462          (insert-file-contents file)          (insert-file-contents file)
463          (goto-char (point-min))          (goto-char (point-min))
464          (setq nnslashdot-groups (read (current-buffer)))))))          (setq nnslashdot-groups (read (current-buffer))))
465          (if (and nnslashdot-groups (< (length (car nnslashdot-groups)) 5))
466              (let ((groups nnslashdot-groups))
467                (while groups
468                  (nnslashdot-make-tuple (car groups) 5)
469                  (setq groups (cdr groups))))))))
470    
471  (defun nnslashdot-write-groups ()  (defun nnslashdot-write-groups ()
472    (with-temp-file (expand-file-name "groups" nnslashdot-directory)    (with-temp-file (expand-file-name "groups" nnslashdot-directory)
473      (prin1 nnslashdot-groups (current-buffer))))      (gnus-prin1 nnslashdot-groups)))
474        
475  (defun nnslashdot-init (server)  (defun nnslashdot-init (server)
476    "Initialize buffers and such."    "Initialize buffers and such."
477    (unless (file-exists-p nnslashdot-directory)    (unless (file-exists-p nnslashdot-directory)
# Line 528  Line 480 
480      (setq nnslashdot-buffer      (setq nnslashdot-buffer
481            (save-excursion            (save-excursion
482              (nnheader-set-temp-buffer              (nnheader-set-temp-buffer
483               (format " *nnslashdot %s*" server))))))               (format " *nnslashdot %s*" server))))
484        (push nnslashdot-buffer gnus-buffers)))
485    
486  (defun nnslashdot-date-to-date (sdate)  (defun nnslashdot-date-to-date (sdate)
487    (condition-case err    (condition-case err
# Line 552  Line 505 
505  (defun nnslashdot-lose (why)  (defun nnslashdot-lose (why)
506    (error "Slashdot HTML has changed; please get a new version of nnslashdot"))    (error "Slashdot HTML has changed; please get a new version of nnslashdot"))
507    
 ;(defun nnslashdot-sid-strip (sid)  
 ;  (if (string-match "^00/" sid)  
 ;      (substring sid (match-end 0))  
 ;    sid))  
   
508  (defalias 'nnslashdot-sid-strip 'identity)  (defalias 'nnslashdot-sid-strip 'identity)
509    
510  (provide 'nnslashdot)  (provide 'nnslashdot)

Legend:
Removed from v.1.2  
changed lines
  Added in v.1.2.14.1

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26