]> code.delx.au - gnu-emacs-elpa/blob - packages/debbugs/debbugs.el
Move asynchronous calls in debbugs to SOAP function level.
[gnu-emacs-elpa] / packages / debbugs / debbugs.el
1 ;;; debbugs.el --- SOAP library to access debbugs servers
2
3 ;; Copyright (C) 2011-2015 Free Software Foundation, Inc.
4
5 ;; Author: Michael Albinus <michael.albinus@gmx.de>
6 ;; Keywords: comm, hypermedia
7 ;; Package: debbugs
8 ;; Version: 0.8
9
10 ;; This file is not part of GNU Emacs.
11
12 ;; This program is free software: you can redistribute it and/or modify
13 ;; it under the terms of the GNU General Public License as published by
14 ;; the Free Software Foundation, either version 3 of the License, or
15 ;; (at your option) any later version.
16
17 ;; This program is distributed in the hope that it will be useful,
18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20 ;; GNU General Public License for more details.
21
22 ;; You should have received a copy of the GNU General Public License
23 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
24
25 ;;; Commentary:
26
27 ;; This package provides basic functions to access a Debbugs SOAP
28 ;; server (see <http://wiki.debian.org/DebbugsSoapInterface>).
29
30 ;; The function "get_versions" is not implemented (yet). "search_est"
31 ;; is an extension on <http://debbugs.gnu.org>.
32
33 ;;; Code:
34
35 ;(setq soap-debug t message-log-max t)
36 (require 'soap-client)
37 (eval-when-compile (require 'cl))
38
39 (declare-function soap-invoke-async "soap-client")
40 (declare-function async-start "async")
41 (declare-function async-get "async")
42
43 (defgroup debbugs nil
44 "Debbugs library"
45 :group 'hypermedia)
46
47 (defcustom debbugs-servers
48 '(("gnu.org"
49 :wsdl "http://debbugs.gnu.org/cgi/soap.cgi?WSDL"
50 :bugreport-url "http://debbugs.gnu.org/cgi/bugreport.cgi")
51 ("debian.org"
52 :wsdl "http://bugs.debian.org/cgi-bin/soap.cgi?WSDL"
53 :bugreport-url "http://bugs.debian.org/cgi-bin/bugreport.cgi"))
54 "*List of Debbugs server specifiers.
55 Each entry is a list that contains a string identifying the port
56 name and the server parameters in keyword-value form. Allowed
57 keywords are:
58
59 `:wsdl' -- Location of WSDL. The value is a string with URL that
60 should return the WSDL specification of Debbugs/SOAP service.
61
62 `:bugreport-url' -- URL of the server script that returns mboxes
63 with bug logs.
64
65 The list initially contains two predefined and configured Debbugs
66 servers: \"gnu.org\" and \"debian.org\"."
67 :group 'debbugs
68 :link '(custom-manual "(debbugs)Debbugs server specifiers")
69 :type '(choice
70 (const nil)
71 (repeat
72 (cons :tag "Server"
73 (string :tag "Port name")
74 (checklist :tag "Options" :greedy t
75 (group :inline t
76 (const :format "" :value :wsdl)
77 (string :tag "WSDL"))
78 (group :inline t
79 (const :format "" :value :bugreport-url)
80 (string :tag "Bugreport URL")))))))
81
82 (defcustom debbugs-port "gnu.org"
83 "The port instance to be applied from `debbugs-wsdl'.
84 This corresponds to the Debbugs server to be accessed, either
85 \"gnu.org\", or \"debian.org\", or user defined port name."
86 ;; Maybe we should create an own group?
87 :group 'debbugs
88 :type '(choice :tag "Debbugs server" (const "gnu.org") (const "debian.org")
89 (string :tag "user defined port name")))
90
91 ;; It would be nice if we could retrieve it from the debbugs server.
92 ;; Not supported yet.
93 (defconst debbugs-wsdl
94 (soap-load-wsdl
95 (expand-file-name
96 "Debbugs.wsdl"
97 (if load-in-progress
98 (file-name-directory load-file-name)
99 default-directory)))
100 "The WSDL object to be used describing the SOAP interface.")
101
102 ;; Please do not increase this value, otherwise we would run into
103 ;; performance problems on the server. Maybe we need to change this a
104 ;; server specific value.
105 (defconst debbugs-max-hits-per-request 500
106 "The max number of bugs or results per soap invocation.")
107
108 (defvar debbugs-soap-invoke-async-object nil
109 "The object manipulated by `debbugs-soap-invoke-async'.")
110
111 (defun debbugs-soap-invoke-async (operation-name &rest parameters)
112 "Invoke the SOAP connection asynchronously.
113 If possible, it uses `soap-invoke-async' from soapclient 3.0.
114 Otherwise, `async-start' from the async package is used."
115 (if nil;(fboundp 'soap-invoke-async)
116 ;; This is soap-client 3.0. Does not work for large requests.
117 (apply
118 'soap-invoke-async
119 (lambda (response &rest args)
120 (message "lambda\n%s" response)
121 (setq debbugs-soap-invoke-async-object
122 (append debbugs-soap-invoke-async-object (car response)))
123 (message "lambda1\n%s" debbugs-soap-invoke-async-object))
124 nil
125 debbugs-wsdl debbugs-port operation-name parameters)
126 ;; Fallback.
127 (async-start
128 `(lambda ()
129 (load ,(locate-library "soap-client"))
130 (apply
131 'soap-invoke
132 (soap-load-wsdl
133 ,(expand-file-name
134 "Debbugs.wsdl"
135 (file-name-directory (locate-library "debbugs"))))
136 ,debbugs-port ,operation-name ',parameters)))))
137
138 (defun debbugs-get-bugs (&rest query)
139 "Return a list of bug numbers which match QUERY.
140
141 QUERY is a sequence of keyword-value pairs where the values are
142 strings, i.e. :KEYWORD \"VALUE\" [:KEYWORD \"VALUE\"]*
143
144 The keyword-value pair is a subquery. The keywords are allowed to
145 have multiple occurrence within the query at any place. The
146 subqueries with the same keyword form the logical subquery, which
147 returns the union of bugs of every subquery it contains.
148
149 The result of the QUERY is an intersection of results of all
150 subqueries.
151
152 Valid keywords are:
153
154 :package -- The value is the name of the package a bug belongs
155 to, like \"emacs\", \"coreutils\", \"gnus\", or \"tramp\".
156
157 :src -- This is used to retrieve bugs that belong to source
158 with given name.
159
160 :severity -- This is the severity of the bug. The exact set of
161 allowed values depends on the Debbugs port. Examples are
162 \"normal\", \"minor\", \"wishlist\" etc.
163
164 :tag -- An arbitrary string the bug is annotated with.
165 Usually, this is used to mark the status of the bug, like
166 \"fixed\", \"moreinfo\", \"notabug\", \"patch\",
167 \"unreproducible\" or \"wontfix\". The exact set of tags
168 depends on the Debbugs port.
169
170 :owner -- This is used to identify bugs by the owner's email
171 address. The special email address \"me\" is used as pattern,
172 replaced with `user-mail-address'.
173
174 :submitter -- With this keyword it is possible to filter bugs
175 by the submitter's email address. The special email address
176 \"me\" is used as pattern, replaced with `user-mail-address'.
177
178 :maint -- This is used to find bugs of the packages which are
179 maintained by the person with the given email address. The
180 special email address \"me\" is used as pattern, replaced with
181 `user-mail-address'.
182
183 :correspondent -- This allows to find bug reports where the
184 person with the given email address has participated. The
185 special email address \"me\" is used as pattern, replaced with
186 `user-mail-address'.
187
188 :affects -- With this keyword it is possible to find bugs which
189 affect the package with the given name. The bugs are chosen by
190 the value of field `affects' in bug's status. The returned bugs
191 do not necessary belong to this package.
192
193 :status -- Status of bug. Valid values are \"done\",
194 \"forwarded\" and \"open\".
195
196 :archive -- A keyword to filter for bugs which are already
197 archived, or not. Valid values are \"0\" (not archived),
198 \"1\" (archived) or \"both\". If this keyword is not given in
199 the query, `:archive \"0\"' is assumed by default.
200
201 Example. Get all opened and forwarded release critical bugs for
202 the packages which are maintained by \"me\" and which have a
203 patch:
204
205 \(debbugs-get-bugs :maint \"me\" :tag \"patch\"
206 :severity \"critical\"
207 :status \"open\"
208 :severity \"grave\"
209 :status \"forwarded\"
210 :severity \"serious\")"
211
212 (let (vec kw key val)
213 ;; Check query.
214 (while (and (consp query) (<= 2 (length query)))
215 (setq kw (pop query)
216 val (pop query))
217 (unless (and (keywordp kw) (stringp val))
218 (error "Wrong query: %s %s" kw val))
219 (setq key (substring (symbol-name kw) 1))
220 (case kw
221 ((:package :severity :tag :src :affects)
222 ;; Value shall be one word.
223 (if (string-match "\\`\\S-+\\'" val)
224 (setq vec (vconcat vec (list key val)))
225 (error "Wrong %s: %s" key val)))
226 ((:owner :submitter :maint :correspondent)
227 ;; Value is an email address.
228 (if (string-match "\\`\\S-+\\'" val)
229 (progn
230 (when (string-equal "me" val)
231 (setq val user-mail-address))
232 (when (string-match "<\\(.+\\)>" val)
233 (setq val (match-string 1 val)))
234 (setq vec (vconcat vec (list key val))))
235 (error "Wrong %s: %s" key val)))
236 (:status
237 ;; Possible values: "done", "forwarded" and "open"
238 (if (string-match "\\`\\(done\\|forwarded\\|open\\)\\'" val)
239 (setq vec (vconcat vec (list key val)))
240 (error "Wrong %s: %s" key val)))
241 (:archive
242 ;; Value is `0' or `1' or `both'.
243 (if (string-match "\\`\\(0\\|1\\|both\\)\\'" val)
244 (setq vec (vconcat vec (list key val)))
245 (error "Wrong %s: %s" key val)))
246 (t (error "Unknown key: %s" kw))))
247
248 (unless (null query)
249 (error "Unknown key: %s" (car query)))
250 (sort (car (soap-invoke debbugs-wsdl debbugs-port "get_bugs" vec)) '<)))
251
252 (defun debbugs-newest-bugs (amount)
253 "Return the list of bug numbers, according to AMOUNT (a number) latest bugs."
254 (sort (car (soap-invoke debbugs-wsdl debbugs-port "newest_bugs" amount)) '<))
255
256 (defun debbugs-get-status (&rest bug-numbers)
257 "Return a list of status entries for the bugs identified by BUG-NUMBERS.
258
259 Every returned entry is an association list with the following attributes:
260
261 `bug_num': The bug number.
262
263 `package': A list of package names the bug belongs to.
264
265 `severity': The severity of the bug report. This can be
266 \"important\", \"grave\", \"normal\", \"minor\" or \"wishlist\".
267
268 `tags': The status of the bug report, a list of strings. This
269 can be \"fixed\", \"notabug\", \"wontfix\", \"unreproducible\",
270 \"moreinfo\" or \"patch\".
271
272 `pending': The string \"pending\", \"forwarded\" or \"done\".
273
274 `subject': Subject/Title of the bugreport.
275
276 `originator': Submitter of the bugreport.
277
278 `mergedwith': A list of bug numbers this bug was merged with.
279 If it is a single bug, then this attribute contains just a
280 number.
281
282 `source': Source package name of the bug report.
283
284 `date': Date of bug creation.
285
286 `log_modified', `last_modified': Date of last update.
287
288 `found_date', `fixed_date': Date of bug report / bug fix
289 \(empty for now).
290
291 `done': The email address of the worker who has closed the bug (if done).
292
293 `archived': `t' if the bug is archived, `nil' otherwise.
294
295 `unarchived': The date the bug has been unarchived, if ever.
296
297 `found_versions', `fixed_versions': List of version strings.
298
299 `forwarded': A URL or an email address.
300
301 `blocks': A list of bug numbers this bug blocks.
302
303 `blockedby': A list of bug numbers this bug is blocked by.
304
305 `msgid': The message id of the initial bug report.
306
307 `owner': Who is responsible for fixing.
308
309 `location': Always the string \"db-h\" or \"archive\".
310
311 `affects': A list of package names.
312
313 `summary': Arbitrary text.
314
315 Example:
316
317 \(debbugs-get-status 10)
318
319 => ;; Attributes with empty values are not shown
320 \(\(\(bug_num . 10)
321 \(source . \"unknown\")
322 \(date . 1203606305.0)
323 \(msgid . \"<87zltuz7eh.fsf@freemail.hu>\")
324 \(severity . \"wishlist\")
325 \(owner . \"Magnus Henoch <mange@freemail.hu>\")
326 \(log_modified . 1261079402.0)
327 \(location . \"db-h\")
328 \(subject . \"url-gw should support HTTP CONNECT proxies\")
329 \(originator . \"Magnus Henoch <mange@freemail.hu>\")
330 \(last_modified . 1271200046.0)
331 \(pending . \"pending\")
332 \(package \"emacs\")))"
333 (when bug-numbers
334 (if (<= (length bug-numbers) debbugs-max-hits-per-request)
335 ;; Do it directly.
336 (setq debbugs-soap-invoke-async-object
337 (car (soap-invoke
338 debbugs-wsdl debbugs-port "get_status"
339 (apply 'vector bug-numbers))))
340
341 ;; Retrieve bugs asynchronously.
342 (let ((bug-ids bug-numbers)
343 results)
344 (setq debbugs-soap-invoke-async-object nil)
345 (while bug-ids
346 (setq results
347 (append
348 results
349 (list
350 (debbugs-soap-invoke-async
351 "get_status"
352 (apply
353 'vector
354 (butlast
355 bug-ids (- (length bug-ids)
356 debbugs-max-hits-per-request))))))
357
358 bug-ids
359 (last bug-ids (- (length bug-ids)
360 debbugs-max-hits-per-request))))
361
362 (dolist (res results)
363 (if (bufferp res)
364 ;; This is soap-client 3.0.
365 (while (buffer-live-p res)
366 (sit-for 0.1))
367 ;; Fallback.
368 (dolist (status (async-get res))
369 (setq debbugs-soap-invoke-async-object
370 (append debbugs-soap-invoke-async-object status)))))))
371
372 (mapcar
373 (lambda (x)
374 (let (y)
375 ;; "archived" is the number 1 or 0.
376 (setq y (assoc 'archived (cdr (assoc 'value x))))
377 (setcdr y (= (cdr y) 1))
378 ;; "found_versions" and "fixed_versions" are lists,
379 ;; containing strings or numbers.
380 (dolist (attribute '(found_versions fixed_versions))
381 (setq y (assoc attribute (cdr (assoc 'value x))))
382 (setcdr y (mapcar
383 (lambda (z) (if (numberp z) (number-to-string z) z))
384 (cdr y))))
385 ;; "mergedwith", "blocks" and "blockedby are strings,
386 ;; containing blank separated bug numbers.
387 (dolist (attribute '(mergedwith blocks blockedby))
388 (setq y (assoc attribute (cdr (assoc 'value x))))
389 (when (stringp (cdr y))
390 (setcdr y (mapcar
391 'string-to-number (split-string (cdr y) " " t)))))
392 ;; "package" is a string, containing comma separated
393 ;; package names. "keywords" and "tags" are strings,
394 ;; containing blank separated package names.
395 (dolist (attribute '(package keywords tags))
396 (setq y (assoc attribute (cdr (assoc 'value x))))
397 (when (stringp (cdr y))
398 (setcdr y (split-string (cdr y) ",\\| " t))))
399 (cdr (assoc 'value x))))
400 debbugs-soap-invoke-async-object)))
401
402 (defun debbugs-get-usertag (&rest query)
403 "Return a list of bug numbers which match QUERY.
404
405 QUERY is a sequence of keyword-value pairs where the values are
406 strings, i.e. :KEYWORD \"VALUE\" [:KEYWORD \"VALUE\"]*
407
408 Valid keywords are:
409
410 :user -- The value is the name of the package a bug belongs to,
411 like \"emacs\", \"coreutils\", \"gnus\", or \"tramp\". It can
412 also be an email address of a user who has applied a user tag.
413 The special email address \"me\" is used as pattern, replaced
414 with `user-mail-address'. There must be at least one such
415 entry; it is recommended to have exactly one.
416
417 :tag -- A string applied as user tag. Often, it is a
418 subproduct identification, like \"cedet\" or \"tramp\" for the
419 package \"emacs\".
420
421 If there is no :tag entry, no bug numbers will be returned but a list of
422 existing user tags for :user.
423
424 Example:
425
426 \(debbugs-get-usertag :user \"emacs\")
427
428 => (\"www\" \"solaris\" \"ls-lisp\" \"cygwin\")
429
430 \(debbugs-get-usertag :user \"emacs\" :tag \"www\" :tag \"cygwin\")
431
432 => (807 1223 5637)"
433
434 (let (user tags kw key val object result)
435 ;; Check query.
436 (while (and (consp query) (<= 2 (length query)))
437 (setq kw (pop query)
438 val (pop query))
439 (unless (and (keywordp kw) (stringp val))
440 (error "Wrong query: %s %s" kw val))
441 (setq key (substring (symbol-name kw) 1))
442 (case kw
443 ((:user)
444 ;; Value shall be one word. Extract email address, if existing.
445 (if (string-match "\\`\\S-+\\'" val)
446 (progn
447 (when (string-equal "me" val)
448 (setq val user-mail-address))
449 (when (string-match "<\\(.+\\)>" val)
450 (setq val (match-string 1 val)))
451 (pushnew val user :test #'equal))
452 (error "Wrong %s: %s" key val)))
453 ((:tag)
454 ;; Value shall be one word.
455 (if (string-match "\\`\\S-+\\'" val)
456 (pushnew val tags :test #'equal)
457 (error "Wrong %s: %s" key val)))
458 (t (error "Unknown key: %s" kw))))
459
460 (unless (null query)
461 (error "Unknown key: %s" (car query)))
462 (unless (= (length user) 1)
463 (error "There must be exactly one :user entry"))
464
465 (setq
466 object
467 (car (soap-invoke debbugs-wsdl debbugs-port "get_usertag" (car user))))
468
469 (if (null tags)
470 ;; Return the list of existing tags.
471 (mapcar (lambda (x) (symbol-name (car x))) object)
472
473 ;; Return bug numbers.
474 (dolist (elt object result)
475 (when (member (symbol-name (car elt)) tags)
476 (setq result (append (cdr elt) result)))))))
477
478 (defun debbugs-get-bug-log (bug-number)
479 "Return a list of messages related to BUG-NUMBER.
480
481 Every message is an association list with the following attributes:
482
483 `msg_num': The number of the message inside the bug log. The
484 numbers are ascending, newer messages have a higher number.
485
486 `header': The message header lines, as arrived at the bug tracker.
487
488 `body': The message body.
489
490 `attachments' A list of possible attachments, or `nil'. Not
491 implemented yet server side."
492 (car (soap-invoke debbugs-wsdl debbugs-port "get_bug_log" bug-number)))
493
494 (defun debbugs-search-est (&rest query)
495 "Return the result of a full text search according to QUERY.
496
497 QUERY is a sequence of lists of keyword-value pairs where the
498 values are strings or numbers, i.e. :KEYWORD \"VALUE\" [:KEYWORD
499 VALUE]*
500
501 Every sublist of the QUERY forms a hyperestraier condition. A
502 detailed description of hyperestraier conditions can be found at
503 URL `http://fallabs.com/hyperestraier/uguide-en.html#searchcond'.
504
505 The following conditions are possible:
506
507 \[:phrase SEARCH-PHRASE :skip NUMBER :max NUMBER\]
508
509 The string SEARCH-PHRASE forms the search on the database. It
510 contains words to be searched for, combined by operators like
511 AND, ANDNOT and OR. If there is no operator between the words,
512 AND is used by default. The phrase keyword and value can also
513 be omitted, this is useful in combination with other conditions.
514
515 :skip and :max are optional. They specify, how many hits are
516 skipped, and how many maximal hits are returned. This can be
517 used for paged results. Per default, :skip is 0 and :max is 10.
518
519 There must be exactly one such condition.
520
521 \[ATTRIBUTE VALUE+ :operation OPERATION :order ORDER\]
522
523 ATTRIBUTE is one of the following keywords:
524
525 :status -- Status of bug. Valid values are \"done\",
526 \"forwarded\" and \"open\".
527
528 :subject, :@title -- The subject of a message or the title of
529 the bug, a string.
530
531 :date, :@cdate -- The submission or modification dates of a
532 message, a number.
533
534 :submitter, :@author -- The email address of the submitter of a
535 bug or the author of a message belonging to this bug, a string.
536 The special email address \"me\" is used as pattern, replaced
537 with `user-mail-address'.
538
539 :package -- The value is the name of the package a bug belongs
540 to, like \"emacs\", \"coreutils\", \"gnus\", or \"tramp\".
541
542 :tags -- An arbitrary string the bug is annotated with.
543
544 :severity -- This is the severity of the bug. The exact set of
545 allowed values depends on the Debbugs port. Examples are
546 \"normal\", \"minor\", \"wishlist\" etc.
547
548 :operator defines the comparison operator to be applied to
549 ATTRIBUTE. For string attributes this could be \"STREQ\" \(is
550 equal to the string), \"STRNE\" \(is not equal to the string),
551 \"STRINC\" \(includes the string), \"STRBW\" \(begins with the
552 string), \"STREW\" \(ends with the string), \"STRAND\"
553 \(includes all tokens in the string), \"STROR\" \(includes at
554 least one token in the string), \"STROREQ\" \(is equal to at
555 least one token in the string) or \"STRRX\" \(matches regular
556 expressions of the string). For operators with tokens, several
557 values for ATTRIBUTE shall be used.
558
559 Numbers can be compared by the operators \"NUMEQ\" \(is equal
560 to the number), \"NUMNE\" \(is not equal to the number),
561 \"NUMGT\" \(is greater than the number), \"NUMGE\" \(is greater
562 than or equal to the number), \"NUMLT\" \(is less than the
563 number), \"NUMLE\" \(is less than or equal to the number) or
564 \"NUMBT\" \(is between the two numbers). In the last case,
565 there must be two values for ATTRIBUTE.
566
567 If an operator is leaded by \"!\", the meaning is inverted. If
568 a string operator is leaded by \"I\", the case of the value is
569 ignored.
570
571 The optional :order can be specified only in one condition. It
572 means, that ATTRIBUTE is used for sorting the results. The
573 following order operators exist: \"STRA\" \(ascending by
574 string), \"STRD\" \(descending by string), \"NUMA\" \(ascending
575 by number) or \"NUMD\" \(descending by number).
576
577 A special case is an :order, where there is no corresponding
578 attribute value and no operator. In this case, ATTRIBUTE is
579 not used for the search.
580
581 The result of the QUERY is a list of association lists with the
582 same attributes as in the conditions. Additional attributes are
583
584 `id': The bug number.
585
586 `msg_num': The number of the message inside the bug log.
587
588 `snippet': The surrounding text found by the search. For the
589 syntax of the snippet, consult the hyperestraier user guide.
590
591 Examples:
592
593 \(debbugs-search-est
594 '\(:phrase \"armstrong AND debbugs\" :skip 10 :max 2)
595 '\(:severity \"normal\" :operator \"STRINC\")
596 '\(:date :order \"NUMA\"))
597
598 => \(\(\(msg_num . 21)
599 \(date . 1229208302)
600 \(@author . \"Glenn Morris <rgm@gnu.org>\")
601 \(@title . \"Re: bug#1567: Mailing an archived bug\")
602 \(id . 1567)
603 \(severity . \"normal\")
604 \(@cdate . \"Wed, 17 Dec 2008 14:34:50 -0500\")
605 \(snippet . \"...\")
606 \(subject . \"Mailing an archived bug\")
607 \(package . \"debbugs.gnu.org\"))
608 ...)
609
610 ;; Show all messages from me between 2011-08-01 and 2011-08-31.
611 \(debbugs-search-est
612 '\(:max 20)
613 '\(:@author \"me\" :operator \"ISTRINC\")
614 `\(:date
615 ,\(floor \(float-time \(encode-time 0 0 0 1 8 2011)))
616 ,\(floor \(float-time \(encode-time 0 0 0 31 8 2011)))
617 :operator \"NUMBT\"))"
618
619 (let (args result)
620 ;; Compile search arguments.
621 (dolist (elt query)
622 (let (vec kw key val
623 phrase-cond attr-cond)
624
625 ;; Phrase is mandatory, even if empty.
626 (when (and (or (member :skip elt) (member :max elt))
627 (not (member :phrase elt)))
628 (setq vec (vector "phrase" "")))
629
630 ;; Parse condition.
631 (while (consp elt)
632 (setq kw (pop elt))
633 (unless (keywordp kw)
634 (error "Wrong keyword: %s" kw))
635 (setq key (substring (symbol-name kw) 1))
636 (cl-case kw
637 ;; Phrase condition.
638 (:phrase
639 ;; It shouldn't happen in an attribute condition.
640 (if attr-cond
641 (error "Wrong keyword: %s" kw))
642 (setq phrase-cond t val (pop elt))
643 ;; Value is a string.
644 (if (stringp val)
645 (setq vec (vconcat vec (list key val)))
646 (error "Wrong %s: %s" key val)))
647
648 ((:skip :max)
649 ;; It shouldn't happen in an attribute condition.
650 (if attr-cond
651 (error "Wrong keyword: %s" kw))
652 (setq phrase-cond t val (pop elt))
653 ;; Value is a number.
654 (if (numberp val)
655 (setq vec (vconcat vec (list key (number-to-string val))))
656 (error "Wrong %s: %s" key val)))
657
658 ;; Attribute condition.
659 ((:submitter :@author)
660 ;; It shouldn't happen in a phrase condition.
661 (if phrase-cond
662 (error "Wrong keyword: %s" kw))
663 (if (not (stringp (car elt)))
664 (setq vec (vconcat vec (list key "")))
665 ;; Value is an email address.
666 (while (and (stringp (car elt))
667 (string-match "\\`\\S-+\\'" (car elt)))
668 (when (string-equal "me" (car elt))
669 (setcar elt user-mail-address))
670 (when (string-match "<\\(.+\\)>" (car elt))
671 (setcar elt (match-string 1 (car elt))))
672 (let ((x (pop elt)))
673 (unless (member x val)
674 (setq val (append val (list x))))))
675 (setq vec
676 (vconcat vec (list key (mapconcat 'identity val " "))))))
677
678 (:status
679 ;; It shouldn't happen in a phrase condition.
680 (if phrase-cond
681 (error "Wrong keyword: %s" kw))
682 (setq attr-cond t)
683 (if (not (stringp (car elt)))
684 (setq vec (vconcat vec (list key "")))
685 ;; Possible values: "done", "forwarded" and "open"
686 (while (and (stringp (car elt))
687 (string-match
688 "\\`\\(done\\|forwarded\\|open\\)\\'" (car elt)))
689 (let ((x (pop elt)))
690 (unless (member x val)
691 (setq val (append val (list x))))))
692 (setq vec
693 (vconcat vec (list key (mapconcat 'identity val " "))))))
694
695 ((:subject :package :tags :severity :@title)
696 ;; It shouldn't happen in a phrase condition.
697 (if phrase-cond
698 (error "Wrong keyword: %s" kw))
699 (setq attr-cond t)
700 (if (not (stringp (car elt)))
701 (setq vec (vconcat vec (list key "")))
702 ;; Just a string.
703 (while (stringp (car elt))
704 (let ((x (pop elt)))
705 (unless (member x val)
706 (setq val (append val (list x))))))
707 (setq vec
708 (vconcat vec (list key (mapconcat 'identity val " "))))))
709
710 ((:date :@cdate)
711 ;; It shouldn't happen in a phrase condition.
712 (if phrase-cond
713 (error "Wrong keyword: %s" kw))
714 (setq attr-cond t)
715 (if (not (numberp (car elt)))
716 (setq vec (vconcat vec (list key "")))
717 ;; Just a number.
718 (while (numberp (car elt))
719 (let ((x (pop elt)))
720 (unless (member x val)
721 (setq val (append val (list x))))))
722 (setq vec
723 (vconcat
724 vec (list key (mapconcat 'number-to-string val " "))))))
725
726 ((:operator :order)
727 ;; It shouldn't happen in a phrase condition.
728 (if phrase-cond
729 (error "Wrong keyword: %s" kw))
730 (setq attr-cond t val (pop elt))
731 ;; Value is a number.
732 (if (stringp val)
733 (setq vec (vconcat vec (list key val)))
734 (error "Wrong %s: %s" key val)))
735
736 (t (error "Unknown key: %s" kw))))
737
738 (setq args (vconcat args (list vec)))))
739
740 (setq result
741 (car (soap-invoke debbugs-wsdl debbugs-port "search_est" args)))
742 ;; The result contains lists (key value). We transform it into
743 ;; cons cells (key . value).
744 (dolist (elt1 result result)
745 (dolist (elt2 elt1)
746 (setcdr elt2 (cadr elt2))))))
747
748 (defun debbugs-get-attribute (bug-or-message attribute)
749 "Return the value of key ATTRIBUTE.
750
751 BUG-OR-MESSAGE must be list element returned by either
752 `debbugs-get-status' or `debbugs-get-bug-log'.
753
754 Example: Return the originator of last submitted bug.
755
756 \(debbugs-get-attribute
757 \(car \(apply 'debbugs-get-status \(debbugs-newest-bugs 1))) 'originator)"
758 (cdr (assoc attribute bug-or-message)))
759
760 (defun debbugs-get-message-numbers (messages)
761 "Return the message numbers of MESSAGES.
762 MESSAGES must be the result of a `debbugs-get-bug-log' call."
763 (mapcar (lambda (x) (debbugs-get-attribute x 'msg_num)) messages))
764
765 (defun debbugs-get-message (messages message-number)
766 "Return the message MESSAGE-NUMBER of MESSAGES.
767 MESSAGES must be the result of a `debbugs-get-bug-log' call.
768
769 The returned message is a list of strings. The first element are
770 the header lines of the message, the second element is the body
771 of the message. Further elements of the list, if any, are
772 attachments of the message.
773
774 If there is no message with MESSAGE-NUMBER, the function returns `nil'.
775
776 Example: Return the first message of last submitted bug.
777
778 \(let \(\(messages \(apply 'debbugs-get-bug-log \(debbugs-newest-bugs 1))))
779 \(debbugs-get-message messages
780 \(car \(debbugs-get-message-numbers messages))))"
781 (while (and messages
782 (/= (debbugs-get-attribute (car messages) 'msg_num)
783 message-number))
784 (setq messages (cdr messages)))
785 (when messages
786 (append (list (debbugs-get-attribute (car messages) 'header)
787 (debbugs-get-attribute (car messages) 'body))
788 (debbugs-get-attribute (car messages) 'attachments))))
789
790 (defun debbugs-get-mbox (bug-number mbox-type &optional filename)
791 "Download mbox with messages of bug BUG-NUMBER from Debbugs server.
792 BUG-NUMBER is a number of bug. It must be of integer type.
793
794 MBOX-TYPE specifies a type of mbox and can be one of the
795 following symbols:
796
797 `mboxfolder': Download mbox folder.
798
799 `mboxmaint': Download maintainer's mbox.
800
801 `mboxstat', `mboxstatus': Download status mbox. The use of
802 either symbol depends on actual Debbugs server configuration.
803 For gnu.org, use the former; for debian.org - the latter.
804
805 FILENAME, if non-`nil', is the name of file to store mbox. If
806 FILENAME is `nil', the downloaded mbox is inserted into the
807 current buffer."
808 (let (url (mt "") bn)
809 (unless (setq url (plist-get
810 (cdr (assoc debbugs-port debbugs-servers))
811 :bugreport-url))
812 (error "URL of bugreport script for port %s is not specified"
813 debbugs-port))
814 (setq bn (format "bug=%s;" (number-to-string bug-number)))
815 (unless (eq mbox-type 'mboxfolder)
816 (if (memq mbox-type '(mboxmaint mboxstat mboxstatus))
817 (setq mt (concat (symbol-name mbox-type) "=yes;"))
818 (error "Unknown mbox type: %s" mbox-type)))
819 (setq url (concat url (format "?%s%smbox=yes" bn mt)))
820 (if filename
821 (url-copy-file url filename t)
822 (url-insert-file-contents url))))
823
824 (provide 'debbugs)
825
826 ;;; TODO:
827
828 ;; * Make `debbugs-soap-invoke-async' work with `soap-invoke-async'.
829 ;; * SOAP interface extensions (wishlist).
830 ;; - Server-side sorting.
831 ;; - Regexp and/or wildcards search.
832 ;; - Returning message attachments.
833
834 ;;; debbugs.el ends here