code.delx.au - gnu-emacs-elpa/blob - chess-irc.el

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;;
   3 ;; This transport uses an IRC bot to send/receive moves.
   4 ;;
   5
   6 (require 'chess-network)
   7
   8 (defgroup chess-irc nil
   9   "Use an IRC bot for sending/receiving moves."
  10   :group 'chess-engine)
  11
  12 (defcustom chess-irc-server "irc.openprojects.net"
  13   "The IRC host to connect your chess-irc engine to."
  14   :type 'string
  15   :group 'chess-irc)
  16
  17 (defcustom chess-irc-port 6667
  18   "The port of the IRC host specified by `chess-irc-server'."
  19   :type 'string
  20   :group 'chess-irc)
  21
  22 (defcustom chess-irc-nick (user-login-name)
  23   "The nick you wish to use for sending/receiving IRC chess moves."
  24   :type 'string
  25   :group 'chess-irc)
  26
  27 ;;; Code:
  28
  29 (chess-message-catalog 'english
  30   '((opponent-says  . "Your opponent says: %s")
  31     (irc-connecting . "Connecting to IRC server '%s:%d'...")
  32     (irc-logging-in . "Connected, now logging in as '%s'...")
  33     (irc-waiting    . "Now waiting for 'name USER' via /msg, or `M-x chess-irc-engage'")
  34     (irc-challenge  . "IRC nick of user to challenge: ")))
  35
  36 (defvar chess-irc-regexp-alist
  37   (append chess-network-regexp-alist
  38           (list (cons ".+"
  39                       (function
  40                        (lambda ()
  41                          (chess-message 'opponent-says
  42                                         (match-string 0))))))))
  43
  44 (defvar chess-irc-process)
  45 (defvar chess-irc-engine)
  46 (defvar chess-irc-opponent)
  47 (defvar chess-irc-working nil)
  48 (defvar chess-irc-last-pos nil)
  49 (defvar chess-irc-use-ctcp nil)
  50
  51 (make-variable-buffer-local 'chess-irc-process)
  52 (make-variable-buffer-local 'chess-irc-engine)
  53 (make-variable-buffer-local 'chess-irc-opponent)
  54 (make-variable-buffer-local 'chess-irc-working)
  55 (make-variable-buffer-local 'chess-irc-last-pos)
  56 (make-variable-buffer-local 'chess-irc-use-ctcp)
  57
  58 (defun chess-irc-handler (game event &rest args)
  59   "This is an example of a generic transport engine."
  60   (unless chess-engine-handling-event
  61     (cond
  62      ((eq event 'initialize)
  63       (chess-message 'irc-connecting chess-irc-server chess-irc-port)
  64       (let ((engine (current-buffer)) proc)
  65         (with-current-buffer (generate-new-buffer " *chess-irc*")
  66           (setq chess-irc-engine engine
  67                 proc (open-network-stream "*chess-irc*" (current-buffer)
  68                                           chess-irc-server chess-irc-port))
  69           (chess-message 'irc-logging-in chess-irc-nick)
  70           (when (and proc (processp proc)
  71                      (eq (process-status proc) 'open))
  72             (process-send-string proc (format "USER %s 0 * :%s\n"
  73                                               (user-login-name)
  74                                               chess-full-name))
  75             (process-send-string proc (format "NICK %s\n" chess-irc-nick))
  76             (set-process-filter proc 'chess-irc-filter)
  77             (set-process-buffer proc (current-buffer))
  78             (set-marker (process-mark proc) (point))
  79             (chess-message 'irc-waiting)))
  80         (setq chess-irc-process proc))
  81       t)
  82
  83      ((eq event 'match)
  84       (setq chess-irc-opponent (read-string (chess-string 'irc-challenge)))
  85       (chess-network-handler 'match chess-irc-opponent))
  86
  87      ((eq event 'destroy)
  88       (chess-engine-send nil "quit")
  89       (process-send-string chess-irc-process "QUIT :Goodbye\n")
  90       (kill-buffer (process-buffer chess-irc-process)))
  91
  92      ((eq event 'send)
  93       (process-send-string chess-irc-process
  94                            (if chess-irc-use-ctcp
  95                                (format "PRIVMSG %s :\C-aCHESS %s\C-a\n"
  96                                        chess-irc-opponent (car args))
  97                              (format "PRIVMSG %s :%s\n"
  98                                      chess-irc-opponent (car args)))))
  99      (t
 100       (apply 'chess-network-handler game event args)))))
 101
 102 ;; This filter translates IRC syntax into basic chess-network protocol
 103 (defun chess-irc-filter (proc string)
 104   (let ((buf (process-buffer proc)))
 105     (when (buffer-live-p buf)
 106       (with-current-buffer buf
 107         (let ((moving (= (point) (process-mark proc))))
 108           (save-excursion
 109             ;; Insert the text, advancing the marker.
 110             (goto-char (process-mark proc))
 111             (while (string-match "\r" string)
 112               (setq string (replace-match "" t t string)))
 113             (insert string)
 114             (set-marker (process-mark proc) (point)))
 115           (if moving (goto-char (process-mark proc))))
 116         (unless chess-irc-working
 117           (setq chess-irc-working t)
 118           (unwind-protect
 119               (progn
 120                 (if chess-irc-last-pos
 121                     (goto-char chess-irc-last-pos)
 122                   (goto-char (point-min)))
 123                 (beginning-of-line)
 124                 (while (not (eobp))
 125                   (cond
 126                    ((looking-at
 127                      ":\\([^ \t\n!]+\\)!\\S-+ PRIVMSG \\(\\S-+\\) :\\(\C-aCHESS \\)?\\(.+\\)\C-a?\n")
 128                     (let ((sender (match-string 1))
 129                           (target (match-string 2))
 130                           (ctcp (match-string 3))
 131                           (msg (match-string 4)))
 132                     (with-current-buffer chess-irc-engine
 133                       (when (and (string= chess-irc-nick target)
 134                                  (or (null chess-irc-opponent)
 135                                      (string= chess-irc-opponent sender)))
 136                         (unless chess-irc-opponent
 137                           (setq chess-irc-opponent sender))
 138                         (if (and (not chess-irc-use-ctcp)
 139                                  ctcp (> (length ctcp) 0))
 140                           (setq chess-irc-use-ctcp t))
 141                         (chess-engine-submit nil (concat msg "\n")))))))
 142                   (forward-line)))
 143             (setq chess-irc-last-pos (point)
 144                   chess-irc-working nil)))))))
 145
 146 (provide 'chess-irc)
 147
 148 ;;; chess-irc.el ends here