1;;; sb-tigris.el --- shimbun backend for tigris.org ML
2
3;; Copyright (C) 2005, 2007, 2009, 2017, 2019
4;; Tsuyoshi CHO <Tsuyoshi.CHO@Gmail.com>
5
6;; Author: Tsuyoshi CHO <Tsuyoshi.CHO@Gmail.com>
7;; Keywords: news
8
9;; This file is a part of shimbun.
10
11;; This program is free software; you can redistribute it and/or modify
12;; it under the terms of the GNU General Public License as published by
13;; the Free Software Foundation; either version 2, or (at your option)
14;; any later version.
15
16;; This program is distributed in the hope that it will be useful,
17;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
19;; GNU General Public License for more details.
20
21;; You should have received a copy of the GNU General Public License
22;; along with this program; see the file COPYING.  If not, write to
23;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
24;; Boston, MA 02110-1301, USA.
25
26;;; Code:
27
28(eval-when-compile (require 'cl-lib)) ;; cl-incf
29(require 'shimbun)
30
31(luna-define-class shimbun-tigris (shimbun) ())
32
33(defvar shimbun-tigris-server-name "tigris.org")
34(defvar shimbun-tigris-url-regexp "http://%s.tigris.org/servlets/SummarizeList?listName=%s")
35(defcustom shimbun-tigris-group-alist
36  '(("subversion"  . ("announce" "dev" "issues" "svn" "svn-breakage" "users"
37		      "l10n-es" "l10n-fr"))
38    ("rapidsvn"    . ("users" "issues" "announce" "dev" "cvs"))
39    ("tortoisesvn" . ("dev" "announce" "patches"))
40    ("scarab"      . ("announce" "dev" "users" "cvs" "issues"))
41    ("xmlbasedsrs" . ("dev" "cvs" "announce" "users"))
42    ("argouml"     . ("announce" "issues" "cvs" "users" "dev" "modules-dev"
43		      "mda" "user-group-sweden" "users-espanol"))
44    ("eyebrowse"   . ("announce" "dev" "users" "cvs" "issues"))
45    ("binarycloud" . ("users" "issues" "cvs" "dev"))
46    ("phpcreate"   . ("dev" "announce" "issues" "users"))
47    ("lptools"     . ("dev" "cvs" "announce" "issues" "users"))
48    ("maxq"        . ("users" "dev" "issues"))
49    ("aut"         . ("dev" "cvs" "announce" "issues" "users"))
50    ("current"     . ("dev" "cvs" "announce" "issues" "users"))
51    ("readyset"    . ("dev" "cvs" "issues" "announce"))
52    ("gef"         . ("issues" "dev" "users" "cvs" "announce"))
53    ("axion"       . ("dev" "cvs" "announce" "issues" "users"))
54    ("style"       . ("dev" "cvs" "announce" "issues" "users"))
55    ("sstree"      . ("issues" "dev" "cvs"))
56    ("readings"    . ("discuss" "issues" "announce" "cvs" "suggest"))
57    ("spin"        . ("dev" "cvs" "announce" "issues" "users"))
58    ("elmuth"      . ("users" "dev" "cvs" "announce" "issues"))
59    ("ankhsvn"     . ("issues" "users" "announce" "cvs" "svn-commit"
60		      "Draco-build"))
61    )
62  "List of mailing lists serverd by Tigris.org."
63  :group 'shimbun
64  :type '(repeat
65	  (cons
66	   :format "%v" :indent 0
67	   (string :format "Project Name: %v")
68	   (repeat
69	    :format "%v%i\n" :indent 12
70	    (string :format "ML: %v"))))
71  )
72
73(defmacro shimbun-tigris-get-project (shimbun)
74  `(nth 0 (split-string
75	   (shimbun-current-group-internal ,shimbun)
76	   "\\.")))
77
78(defmacro shimbun-tigris-get-ml-name (shimbun)
79  `(nth 1 (split-string
80	   (shimbun-current-group-internal ,shimbun)
81	   "\\.")))
82
83(luna-define-method shimbun-groups ((shimbun shimbun-tigris))
84  "return groups : project.ml-name"
85  (let (groups)
86    (dolist (project shimbun-tigris-group-alist)
87      (let ((mls (cdr project)))
88	(dolist (ml-name mls)
89	  (push (concat (car project) "." ml-name) groups))))
90    groups))
91
92(luna-define-method shimbun-index-url ((shimbun shimbun-tigris))
93  (shimbun-expand-url
94   (format shimbun-tigris-url-regexp
95	   (shimbun-tigris-get-project shimbun)
96	   (shimbun-tigris-get-ml-name shimbun)
97	   )))
98
99(defun shimbun-tigris-remove-amp (url)
100  "Remove URL &amp; -> &"
101  (save-match-data
102    (while (string-match "&amp;" url)
103      (setq url (replace-match "&" nil nil url))))
104  url)
105
106(luna-define-method shimbun-get-headers ((shimbun shimbun-tigris)
107					 &optional range)
108  (save-excursion
109    (let ((case-fold-search t)
110	  (pages (shimbun-header-index-pages range))
111	  (link-regexp
112	   (format "http://%s.tigris.org/servlets/BrowseList\\?listName=%s&\\(amp;\\)?by=date&\\(amp;\\)?.*"
113		   (shimbun-tigris-get-project shimbun)
114		   (shimbun-tigris-get-ml-name shimbun)))
115	  indexes headers)
116      (goto-char (point-min))
117      (search-forward "inclsummarizeby") ;; top of links
118      (while (re-search-forward "<a +href=\"\\([^\"]+\\)\"" nil t)
119	(let ((url (match-string 1)))
120	  (when (and url
121		     (string-match link-regexp url))
122	    (push (concat (shimbun-tigris-remove-amp url) "&paged=false") indexes))))
123      (setq indexes (nreverse indexes))
124      (catch 'stop
125	(let ((count 0) url)
126	  (while (and indexes
127		      (if pages (<= (cl-incf count) pages) t))
128	    (erase-buffer)
129	    (setq url (pop indexes))
130	    (shimbun-retrieve-url url)
131	    (goto-char (point-min))
132	    (while (re-search-forward "<tr[^>]*>\\s *\
133<td[^>]*>\\([^<]+\\)</td>\\s *\
134<td[^>]*>\\s *<a *href=\"\\([^\"]+\\)\"[^>]*>\\([^<]+\\)</a>\\s *</td>\\s *\
135<td[^>]*>\\([^<]+\\)</td>\\s *\
136</tr>" nil t)
137	      (let* ((from (match-string-no-properties 1))
138		     (url (shimbun-tigris-remove-amp (match-string-no-properties 2)))
139		     (title (match-string-no-properties 3))
140		     (date (match-string-no-properties 4))
141		     (count 0)
142		     id)
143		(when (string-match ".*msgNo=\\([0-9]+\\).*" url)
144		  (setq count (string-to-number (match-string 1 url))))
145		(setq id (format "<%d%%%s.%s.%s>"
146				 count
147				 (shimbun-tigris-get-ml-name shimbun)
148				 (shimbun-tigris-get-project shimbun)
149				 shimbun-tigris-server-name
150				 ))
151		(if (and (stringp date)
152			 (string-match "\\([0-9]*\\)-\\([0-9]*\\)-\\([0-9]*\\)" date))
153		    (setq date (shimbun-make-date-string
154				(string-to-number (match-string 1 date))
155				(string-to-number (match-string 2 date))
156				(string-to-number (match-string 3 date))))
157		  (setq date nil))
158		;; change to raw page
159		(setq url (shimbun-expand-url
160			   (concat url "&raw=true")))
161		(when (shimbun-search-id shimbun id)
162		  (throw 'stop nil))
163		(push (shimbun-create-header
164		       count title
165		       from
166		       date
167		       id "" 0 0 url)
168		      headers))))))
169      headers)))
170
171(luna-define-method shimbun-make-contents ((shimbun shimbun-tigris)
172					   header)
173  (let ((case-fold-search t)
174	(beg nil)
175	(end nil))
176    (when (search-forward "<PRE>")
177      (forward-line 1)
178      (beginning-of-line)
179      (setq beg (point))
180      (delete-region (point-min) beg))
181    (when (search-forward "</PRE>")
182      (forward-line -1)
183      (end-of-line)
184      (setq end (point))
185      (delete-region end (point-max)))
186    ;; replace "&lt;" -> "<"
187    (goto-char (point-min))
188    (while (search-forward "&lt;" nil t)
189      (replace-match "<"))
190    ;; header edit if deleted
191    (goto-char (point-min))
192    (when (and beg end)
193      (when (re-search-forward "^$" nil t) ;; end of header
194	(goto-char (match-end 0))
195	(when (re-search-backward "^Message-ID" nil t)
196	  (replace-match "X-Original-Message-ID"))) ;; replace msg-id to x-ori-msg-id
197      (goto-char (point-min))
198      (insert (concat "Message-ID: " (shimbun-header-id header) "\n")) ;; add msg-id
199      (insert (concat "Xref: " (shimbun-header-xref header) "\n")) ;; add Xref
200      ))
201  (buffer-string))
202
203(provide 'sb-tigris)
204
205;;; sb-tigris.el ends here
206