clients/gnome-trans-applet/dctrmon

   1 #!/usr/bin/guile \
   2 --debug -s
   3 !#
   4
   5 (use-modules (dolcon ui))
   6 (use-modules (ice-9 popen))
   7 (use-modules (ice-9 pretty-print))
   8
   9 (define (flush port)
  10   (force-output port))
  11
  12 (define idlist '())
  13 (define filter '())
  14 (define (filtered tag filter)
  15   (and (pair? filter)
  16        (or (equal? (car filter) (substring tag 0 (min (string-length (car filter)) (string-length tag))))
  17            (filtered tag (cdr filter)))))
  18 (catch 'system-error
  19        (lambda ()
  20          (let ((port (open-input-file (string-append (getenv "HOME") "/.dctrmon-defines"))) (form #f))
  21            (while (begin (set! form (read port)) (not (eof-object? form)))
  22                   (primitive-eval form))))
  23        (lambda args
  24          #f))
  25
  26
  27 (define krbcc (string-append "/tmp/krb5cc_dcmon_" (number->string (getuid)) "_XXXXXX"))
  28 (close-port (mkstemp! krbcc))
  29 (setenv "KRB5CCNAME" (string-append "FILE:" krbcc))
  30 (sigaction SIGCHLD SIG_DFL)
  31 (define pid (primitive-fork))
  32 (if (= pid 0)
  33     (begin (execlp "kinit" "kinit" "-f" "-r" "10d" "-k" "-t" (string-append (getenv "HOME") "/.myprinc.keytab") (string-append (passwd:name (getpwuid (getuid))) "/dcview"))
  34            (exit 1))
  35     (if (not (= (cdr (waitpid pid)) 0))
  36         (exit 1)))
  37 (dc-c&l #f (getenv "DCSERVER") #t)
  38 (delete-file krbcc)
  39
  40 (dc-ecmd-assert 200 "notify" "all" "on")
  41
  42 (display "C\n")
  43
  44 (let ((resp (dc-ecmd-assert '(200 201) "lstrans")))
  45   (if (and resp (= (cdr (assoc 'code (dc-extract resp))) 200))
  46       (for-each (lambda (o)
  47                   (if (= (cadr o) 2)
  48                       (catch 'bad-return
  49                              (lambda ()
  50                                (for-each (lambda (a)
  51                                            (if (and (equal? (car a) "tag") (filtered (cadr a) filter))
  52                                                (begin
  53                                                  (display (string-append "N\t" (cadr a) "\t" (number->string (list-ref o 6)) "\t" (number->string (list-ref o 7)) "\n"))
  54                                                  (set! idlist (append idlist (list (cons (car o) (cadr a))))))))
  55                                          (dc-intall (dc-ecmd-assert 200 "lstrarg" (car o)))))
  56                              (lambda args #f))))
  57                 (dc-intall resp))))
  58
  59 (flush (current-output-port))
  60
  61 (while #t
  62        (dc-select 10000)
  63        (while (let ((resp (dc-getresp)))
  64                 (if resp
  65                     (begin
  66                       (let* ((er (dc-extract resp)) (code (cdr (assoc 'code er))) (cmd (cdr (assoc 'cmd er))) (ir (dc-intresp resp)))
  67                         (if (equal? cmd ".notify")
  68                             (case code
  69                               ((610)
  70                                (let* ((id (car ir)) (ir2 (dc-intall (dc-ecmd-assert '(200 201) "lstrarg" id))) (tag (if (eq? (car ir2) '()) #f (assoc "tag" ir2))))
  71                                  (if (and tag (filtered (cadr tag) filter))
  72                                      (begin (display (string-append "N\t" (cadr tag) "\t-1\t-1\n"))
  73                                             (flush (current-output-port))
  74                                             (set! idlist (append idlist (list (cons (car ir) (cadr tag)))))))))
  75                               ((613)
  76                                (let ((id (car ir)))
  77                                  (if (assoc id idlist)
  78                                      (begin (display (string-append "S\t" (cdr (assoc id idlist)) "\t" (number->string (cadr ir)) "\n"))
  79                                             (flush (current-output-port))))))
  80                               ((615)
  81                                (let ((id (car ir)))
  82                                  (if (assoc id idlist)
  83                                      (begin (display (string-append "P\t" (cdr (assoc id idlist)) "\t" (number->string (cadr ir)) "\n"))
  84                                             (flush (current-output-port))))))
  85                               ((617)
  86                                (let ((id (car ir)))
  87                                  (if (assoc id idlist)
  88                                      (begin (display (string-append "D\t" (cdr (assoc id idlist)) "\n"))
  89                                             (flush (current-output-port)))))))))
  90                       #t)
  91                     #f)) #f))
  92
  93 (dc-disconnect)