;;; pure-irc-send.el --- sending message to IRC process

;; Copyright (C) 2000 by Project Pure.

;; Author: SHIMADA Mitsunobu <simm@irc.fan.gr.jp>
;; Keywords: PURE, IRC, send

;; $Id: pure-irc-send.el,v 1.3 2000/10/18 14:46:49 simm Exp $

;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; Commentary:

;; PURE means "Primitive Universal Relay-chat Environment"

;;; Code:

(require 'pure-bl)
(require 'pure-cs)

(defvar pure-irc-send-default-interval
  (if (or (fboundp 'run-at-time) (fboundp 'add-timeout)) 2 nil)
  "Default value of pure-irc-send-interval, buffer-local variable.")

(defvar pure-irc-send-default-ctcp-interval
  (if (or (fboundp 'run-at-time) (fboundp 'add-timeout)) 5 nil)
  "Default value of pure-irc-send-ctcp-interval, buffer-local variable.")

(defconst pure-irc-send-local-variables
  '([pure-irc-send-timer nil
     "Timer object, to execute unlock sending."]
    [pure-irc-send-interval pure-irc-send-default-interval
     "Interval time, to send message to server."]
    [pure-irc-send-ctcp-timer nil
     "Timer object, to execute unlock CTCP reply."]
    [pure-irc-send-ctcp-interval pure-irc-send-default-ctcp-interval
     "Interval time, to send CTCP reply message."])
  "List of buffer-local variables.")

(defvar pure-irc-send-server-alist nil
  "Server association list. Each element is '(process . buffer) structure.")

(cond
 ((featurep 'xemacs)
  (defun pure-irc-send-set-timer (time func proc)
    "Set timer object according to the kind of Emacsen."
    (add-timeout time func (cons proc (current-buffer))))
  (defun pure-irc-send-reset-timer (id)
    "Reset timer object according to the kind of Emacsen."
    (and (itimerp id) (disable-timeout id))))
 ((fboundp 'run-at-time)
  (defun pure-irc-send-set-timer (time func proc)
    "Set timer object according to the kind of Emacsen."
    (run-at-time time nil func (cons proc (current-buffer))))
  (defun pure-irc-send-reset-timer (id)
    "Reset timer object according to the kind of Emacsen."
    (and (timerp id) (cancel-timer id)))))

(defun pure-irc-send-init ()
  "Initialize PURE-IRC-SEND module, make permanentally-buffer-local variables."
  (pure-bl-make-permanent pure-irc-send-local-variables t))

(defun pure-irc-send-create-buffer (proc &optional name)
  "Create buffer for PURE-IRC-SEND.
This function returns (process . buffer)-formatted cons cell."
  (or (assoc proc pure-irc-send-server-alist)
      (let* ((buf (generate-new-buffer (format " *pure-irc-send:%s*" (or name "nil"))))
	     (cell (cons proc buf)))
	(save-excursion
	  (set-buffer buf)
	  (setq pure-irc-send-timer nil pure-irc-send-ctcp-timer nil))
	(setq pure-irc-send-server-alist (cons cell pure-irc-send-server-alist))
	cell)))

(defun pure-irc-send-delete-buffer (proc)
  "Delete buffer for PURE-IRC-SEND."
  (let ((cell (assoc proc pure-irc-send-server-alist)))
    (if cell
	(save-excursion
	  (set-buffer (cdr cell))
	  (pure-irc-send-reset-timer pure-irc-send-ctcp-timer)
	  (pure-irc-send-reset-timer pure-irc-send-timer)
	  (kill-buffer (cdr cell))
	  (setq pure-irc-send-server-alist (delete cell pure-irc-send-server-alist))))))

(defun pure-irc-send-register (proc coding &rest args)
  "Register string `str' into process `proc'."
  (let (beg end (buf (cdr (assoc proc pure-irc-send-server-alist))))
    (or buf
        (setq buf (cdr (pure-irc-send-create-buffer proc))))
    (save-excursion
      (set-buffer buf)
      (goto-char (point-max))
      (setq beg (point))
      (insert (apply 'format args))
      ;; new-line code must be "\n"
      (if (= ?\n (char-before (point)))
	  nil
	(insert "\n"))
      (forward-char -1)
      (if (= ?\r (char-before (point)))
	  (delete-char -1))
      (setq end (point))
      ;; encode region
      (if coding
	  (pure-cs-encode-region beg end coding))
      ;; detect CTCP REPLY message
      (goto-char beg)
      (if (looking-at "NOTICE[ \t][^ \t\n]+[ \t]:\001")
	  (put-text-property beg end 'pure 'CTCP))
      ;; send message into process
      (or pure-irc-send-timer
	  (pure-irc-send-control proc)))))

(defun pure-irc-send-control (proc)
  "Message controller for PURE-IRC-SEND.
This function is called by enqueuing function or canceler function,
current buffer must be PURE-IRC-SEND buffer associated with `proc'.
This function calls `pure-irc-send-message' to send message to process."
  (setq pure-irc-send-timer t)
  (goto-char (point-min))
  (while (and (eq t pure-irc-send-timer)
	      (not (eobp)))
    (cond ((not (get-text-property (point) 'pure))
	   ;; non CTCP REPLY message
	   (pure-irc-send-message proc))
	  ((not pure-irc-send-ctcp-timer)
	   ;; CTCP ready
	   (pure-irc-send-message proc)
	   (if pure-irc-send-ctcp-interval
	       (setq pure-irc-send-ctcp-timer
		     (pure-irc-send-set-timer
		      pure-irc-send-ctcp-interval 'pure-irc-send-cancel-ctcp-timer proc))))
	  (t
	   (forward-line 1))))
  (if (eq t pure-irc-send-timer)
      (setq pure-irc-send-timer nil)))

(defun pure-irc-send-message (proc)
  "Send message to process `proc'.
Current buffer must be PURE-IRC-SEND buffer associated with `proc'."
  (let (beg end)
    (setq beg (point))
    (forward-line 1)
    (setq end (point))
    (process-send-region proc beg end)
    (delete-region beg end)
    (if pure-irc-send-interval
	(setq pure-irc-send-timer
	      (pure-irc-send-set-timer
	       pure-irc-send-interval 'pure-irc-send-cancel-timer proc)))))

(defun pure-irc-send-cancel-timer (cell)
  "Cancel timer object to lock sending."
  (if (buffer-live-p (cdr cell))
      (save-excursion
	(set-buffer (cdr cell))
	(pure-irc-send-reset-timer pure-irc-send-timer)
	(pure-irc-send-control (car cell)))))

(defun pure-irc-send-cancel-ctcp-timer (cell)
  "Cancel timer object to lock CTCP REPLY sending."
  (if (buffer-live-p (cdr cell))
      (save-excursion
	(set-buffer (cdr cell))
	(pure-irc-send-reset-timer pure-irc-send-ctcp-timer)
	(setq pure-irc-send-ctcp-timer nil)
	(or pure-irc-send-timer
	    (pure-irc-send-control (car cell))))))

(defun pure-irc-send-pong (proc &optional msg)
  "Send PONG immediately."
  (process-send-string proc (format "PONG :%s\n" (or msg "*****"))))

;; That's all
(provide 'pure-irc-send)

;;; pure-irc-send.el ends here