(defpackage :irc (:use :cl)
  (:export #:start-irc))

(in-package :irc)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (require :clm))

(defvar *irc-motif-connection*)

(defstruct connection
  (realname "Unknown User")
  (username "dent")
  nick
  host
  (port 6667)
  (userinfo ":")
  pane
  chat-log
  input-box
  socket
  stream
  handler
  (buffer (make-array 512 :element-type 'character :fill-pointer 0))
  (last-command nil)
  (state :new)
  (channels nil)
  (current-channel nil))

(defvar *active-connections* nil)

(defun make-new-connection (ashell &rest initargs)
  (let ((connection (apply #'make-connection initargs)))
    (make-connection-shell ashell connection)
    (setf (connection-socket connection)
	  (ext:connect-to-inet-socket (connection-host connection)
				      (connection-port connection)))
    (setf (connection-stream connection)
	  (system:make-fd-stream (connection-socket connection)
				 :input t :output t :buffering :none
				 :timeout 300))
    (setf (connection-state connection) :hand-shake)
    (setf (connection-handler connection)
	  (system:add-fd-handler (connection-socket connection) :input
				 #'(lambda (fd)
				     (declare (ignore fd))
				     (handle-connection-input connection))))
    (push connection *active-connections*)
    ;; Now start hand-shake
    (send-command connection :nick (connection-nick connection))
    (send-command connection :user (connection-username connection)
		  "0" "*" (connection-realname connection))
    connection))

(defun close-connection (connection &key (reason "Closing Connection") abortp)
  (block closing
    (handler-bind ((end-of-file #'(lambda (c)
				    (when (eq (stream-error-stream c)
					      (connection-stream connection))
				      (return-from closing t)))))
      (system:remove-fd-handler (connection-handler connection))
      (unless abortp (send-command connection :quit reason))
      (system:serve-all-events 1)
      (when (open-stream-p (connection-stream connection))
	(ignore-errors (close (connection-stream connection) :abort abortp)))))
  ;; Cleanup
  (setf (connection-handler connection) nil
	(connection-stream connection) nil
	(connection-state connection) :closed)
  (when (connection-pane connection)
    (xt:with-motif-connection (*irc-motif-connection*)
      (xt:destroy-widget (connection-pane connection))))
  (setq *active-connections*
	(remove connection *active-connections*))
  t)

(defun handle-connection-input (connection)
  (do* ((stream (connection-stream connection))
	(buffer (connection-buffer connection))
	(char (and (open-stream-p stream) (read-char-no-hang stream))
	      (and (open-stream-p stream) (read-char-no-hang stream))))
       ((null char))
    (case char
      (#\Linefeed
       (let ((length (fill-pointer buffer)))
	 (when (and (> length 0)
		    (char= (aref buffer (1- length)) #\Return))
	   (decf length))
	 #+DEBUG
	 (format *trace-output* "~&Recv> \"")
	 #+DEBUG
	 (write-string buffer *trace-output* :end length)
	 #+DEBUG
	 (format *trace-output* "\"~%")
	 (multiple-value-call #'process-message connection
			      (parse-message buffer 0 length))
	 (setf (fill-pointer buffer) 0)))
      (t
       (vector-push char buffer)))))

(defun parse-message (buffer start end)
  (assert (> end start))
  (do ((source nil) (command nil) (args nil)
       (chunk-start start)
       (pos start (1+ pos)))
      ((> pos end)
       (unless command
	 (error "Strange stuff"))
       (values source command (nreverse args)))
    (flet ((process-chunk ()
	     (assert (<= chunk-start pos))
	     (cond
	       ((null command)
		(setq command
		      (cond
			((and (= (- pos chunk-start) 3)
			      (digit-char-p (aref buffer chunk-start) 10)
			      (parse-integer buffer
					     :start chunk-start :end pos)))
			((> pos chunk-start)
			 (intern
			  (nstring-upcase (subseq buffer chunk-start pos))
			  :keyword))
			(t
			 (error "Empty command")))))
	       (t
		(when (char= (aref buffer chunk-start) #\:)
		  (incf chunk-start))
		(push (subseq buffer chunk-start pos) args)))))
      (cond
	((= pos end)
	 (process-chunk))
	((not (char= (aref buffer pos) #\Space))
	 t)
	((and (= chunk-start start)
	      (char= (aref buffer chunk-start) #\:))
	 (setq source (subseq buffer (1+ chunk-start) pos))
	 (setq chunk-start (1+ pos)))
	((char= (aref buffer chunk-start) #\:)
	 ;; Ignore spaces in the trailer
	 t)
	(t
	 (process-chunk)
	 (setq chunk-start (1+ pos)))))))

(defmacro command-case ((command arguments) &rest clauses)
  (loop with cmd-var = (gensym)
	with args-var = (gensym)
	for ((spec . lambda-list) . body) in clauses
	collect
	`(,spec
	  (destructuring-bind ,lambda-list ,args-var
	    ,@body))
	into result
	finally
	(return
	  `(let ((,cmd-var ,command) (,args-var ,arguments))
	     (case ,cmd-var
	       ,@result)))))

(defun parse-source (source what)
  (ecase what
    (:nick
     (subseq source 0 (position #\! source)))
    (:address
     (let ((nick-end (position #\! source)))
       (if nick-end
	   (subseq source (1+ nick-end))
	   source)))
    (:user
     (let* ((nick-end (position #\! source))
	    (user-start (or nick-end 0))
	    (user-end (position #\@ source :start user-start)))
       (subseq source user-start user-end)))
    (:domain
     (let* ((user-end (position #\@ source)))
       (if user-end
	   (subseq source (1+ user-end))
	   nil)))))

(defun write-chat-log (connection control-string &rest arguments)
  (multiple-value-bind (s m h) (decode-universal-time (get-universal-time))
    (let ((chat-log (connection-chat-log connection))
	  (string (format nil "~2,'0D:~2,'0D:~2,'0D ~?" h m s
			  control-string arguments)))
      (xt:with-motif-connection (*irc-motif-connection*)
	(xt:list-add-item chat-log string 0)
	(xt:list-set-bottom-pos chat-log 0)))))

(defun process-message (connection source command arguments)
  (command-case (command arguments)
    ((:ping &rest servers)
     (apply #'send-command connection :pong servers))
    ((:error message)
     (write-chat-log connection "~11<ERROR:~> ~A" message))
    (((:privmsg :notice) target text)
     (let ((source (parse-source source :nick))
	   (real-text
	    (process-message-text connection source command target text)))
       (cond
	 ((zerop (length real-text))
	  ;; Ignore empty messages, regardless of their origin
	  t)
	 ((string= target (connection-nick connection))
	  (write-chat-log connection "~11<*~A*~> ~A" source real-text))
	 ((string-equal target (connection-current-channel connection))
	  (write-chat-log connection "~11<<~A>~> ~A" source real-text))
	 (t
	  (write-chat-log connection "~10<<~A~>:~A> ~A"
			  source target real-text)))))
    ((:nick newnick)
     (write-chat-log connection "~11<***~> ~A is now known as ~A"
		     (parse-source source :nick) newnick))
    ((:join channel)
     (write-chat-log connection "~11<***~> ~A (~A) joined ~A"
		     (parse-source source :nick) (parse-source source :address)
		     channel))
    ((:part channel &optional msg)
     (write-chat-log connection "~11<***~> ~A has left ~A~@[ (~A)~]"
		     (parse-source source :nick) channel msg))
    ((:quit &optional msg)
     (write-chat-log connection "~11<***~> ~A has signed off~@[ (~A)~]"
		     (parse-source source :nick) msg))
    ((001 nick msg)
     (when (eq (connection-state connection) :hand-shake)
       (write-chat-log connection "~11<***~> Connected as ~A: ~A" nick msg)
       (setf (connection-state connection) :normal)
       (xt:with-motif-connection (*irc-motif-connection*)
	 (xt:set-sensitive (connection-input-box connection) t))))
    ((t &rest args)
     (if (numberp command)
	 (write-chat-log connection "~11<~3,'0D~>~{ ~A~}" command args)
	 (write-chat-log connection "~11<???~> ~A ~A~{ ~S~}"
			 source command args)))))

(defun low-level-dequote-message (text)
  (if (find #\^P text)
      (with-output-to-string (out)
	(with-input-from-string (in text)
	  (do ((char (read-char in nil nil) (read-char in nil nil))
	       (escape-p nil))
	      ((null char))
	    (cond
	      (escape-p
	       (case char
		 (#\0 (write-char #\Null out))
		 (#\n (write-char #\Newline out))
		 (#\r (write-char #\Return out))
		 (#\^P (write-char #\^P out))
		 (t
		  ;; Ignore illegal quouting...
		  nil))
	       (setq escape-p nil))
	      ((char= char #\^P)
	       (setq escape-p t))
	      (t
	       (write-char char out))))))
      text))

(defun process-message-text (connection source command target text)
  (let ((message (low-level-dequote-message text)))
    (if (find #\^A message)
	(strip-extended-messages connection source command target message)
	message)))

(defun strip-extended-messages (connection source command target text)
  (with-output-to-string (result-stream)
    (with-input-from-string (in text)
      (do ((char (read-char in nil nil) (read-char in nil nil))
	   (extended-message-stream (make-string-output-stream))
	   (current-output-stream result-stream)
	   (extended-escape-p nil))
	  ((null char)
	   (when (eq current-output-stream extended-message-stream)
	     (process-extended-message
	      connection source command target
	      (get-output-stream-string extended-message-stream)))
	   (close extended-message-stream))
	(cond
	  (extended-escape-p
	   (case char
	     (#\a (write-char #\^A current-output-stream))
	     (#\\ (write-char #\\ current-output-stream))
	     (t
	      ;; Ignore...
	      t))
	   (setq extended-escape-p nil))
	  ((and (char= char #\^A)
		(eq current-output-stream result-stream))
	   (setq current-output-stream extended-message-stream))
	  ((and (char= char #\^A)
		(eq current-output-stream extended-message-stream))
	   (process-extended-message
	    connection source command target
	    (get-output-stream-string extended-message-stream))
	   (setq current-output-stream result-stream))
	  ((char= char #\\)
	   (setq extended-escape-p t))
	  (t
	   (write-char char current-output-stream)))))))

(defun process-extended-message (connection source command target message)
  (let* ((tag-end (position #\Space message))
	 (tag (if (null tag-end) message (subseq message 0 tag-end)))
	 (arg-start (min (length message) (1+ (or tag-end (length message))))))
    (macrolet ((with-safe-reply ((nick-var) &body body)
		 `(when (and (eq command :privmsg)
			 (string-equal target (connection-nick connection)))
		    (let ((,nick-var (parse-source source :nick)))
		      (when ,nick-var
			(send-command connection :notice ,nick-var
				      (create-message-text ,@body)))))))
      (cond
	((string= tag "ACTION")
	 (write-chat-log connection "~11<*~> ~A ~A"
			 (parse-source source :nick)
			 (subseq message arg-start)))
	((string= tag "CLIENTINFO")
	 (if (= arg-start (length message))
	     (with-safe-reply (nick)
	       (cons
		"CLIENTINFO"
		(format nil ":~{~A~^ ~}"
			'("ACTION"
			  "CLIENTINFO" "USERINFO" "VERSION" "ERRMSG"))))
	     (let ((argument (subseq message arg-start)))
	       (cond
		 ((string= argument "ACTION")
		  (with-safe-reply (nick)
		    (cons
		     "CLIENTINFO"
		     ":ACTION takes one argument, the sender's action.")))
		 ((string= argument "CLIENTINFO")
		  (with-safe-reply (nick)
		    (cons
		     "CLIENTINFO"
		     (concatenate
		      'string
		      ":CLIENTINFO with 0 arguments lists all available CTCP "
		      "commands, with 1 argument it gives information on that "
		      "CTCP command."))))
		 ((string= argument "USERINFO")
		  (with-safe-reply (nick)
		    (cons "CLIENTINFO" "Returns the user's userinfo string.")))
		 ((string= argument "VERSION")
		  (with-safe-reply (nick)
		    (cons
		     "CLIENTINFO"
		     "Returns version info on the user's client software.")))
		 ((string= argument "ERRMSG")
		  (with-safe-reply (nick)
		    (cons
		     "CLIENTINFO"
		     (concatenate
		      'string
		      "Is returned on encountering an unknown CTCP command. "
		      "If received, it works like an echo command."))))
		 (t
		  (with-safe-reply (nick)
		    (cons
		     "ERRMSG"
		     (format nil "~A :Unknown command/tag." message))))))))
	((string= tag "USERINFO")
	 (with-safe-reply (nick)
	   (cons "USERINFO" (connection-userinfo connection))))
	((string= tag "VERSION")
	 (with-safe-reply (nick)
	   (cons "VERSION"
		 (format nil "SillyIRC:1.0:~A ~A"
			 (lisp-implementation-type)
			 (lisp-implementation-version)))))
	(t
	 (with-safe-reply (nick)
	   (cons "ERRMSG"
		 (format nil "~A :Tag is unknown" message))))))))

(defun create-message-text (&rest parts)
  (with-output-to-string (out)
    (dolist (part parts)
      (etypecase part
	(string
	 (low-level-quote-message (ctcp-quote-message part) out))
	(cons
	 (write-char #\^A out)
	 (low-level-quote-message (ctcp-quote-message (car part)) out)
	 (when (cdr part)
	   (write-char #\Space out)
	   (low-level-quote-message (ctcp-quote-message (cdr part)) out))
	 (write-char #\^A out))))))

(defun low-level-quote-message (text &optional stream)
  (flet ((doit (out)
	   (loop for char across text
		 do
		 (case char
		   (#\Null (write-char #\^P out) (write-char #\0 out))
		   (#\Newline (write-char #\^P out) (write-char #\n out))
		   (#\Return (write-char #\^P out) (write-char #\r out))
		   (#\^P (write-char #\^P out) (write-char #\^P out))
		   (t (write-char char out))))))
    (if stream
	(doit stream)
	(with-output-to-string (out) (doit out)))))

(defun ctcp-quote-message (text &optional stream)
  (flet ((doit (out)
	   (loop for char across text
		 do
		 (case char
		   (#\^A (write-char #\\ out) (write-char #\a out))
		   (#\\ (write-char #\\ out) (write-char #\\ out))
		   (t (write-char char out))))))
    (if stream
	(doit stream)
	(with-output-to-string (out) (doit out)))))
	     
;; write directly to server
(defun send-command (connection command &rest args)
  #+DEBUG
  (format *trace-output* "~&send> ~S~{ ~S~}~%" command args)
  (let ((stream (connection-stream connection)))
    (setf (connection-last-command connection) command)
    (if (numberp command)
	(format stream "~3,'0D" command)
	(write-string (symbol-name command) stream))
    (do* ((rest args (rest rest))
	  (arg (first rest) (first rest)))
	 ((null arg)
	  (write-char #\Return stream)
	  (write-char #\Linefeed stream))
      (write-char #\Space stream)
      (cond
	((null (rest rest))
	 (write-char #\: stream)
	 (write-string arg stream))
	(t
	 (assert (null (find #\Space arg)))
	 (write-string arg stream))))
    (finish-output stream)))

(define-condition command-error ()
  ())

(define-condition simple-command-error (command-error simple-condition)
  ())

(define-condition syntax-error (command-error)
  ((string :initarg :string :reader syntax-error-string)))

(define-condition argument-count-error (syntax-error)
  ((expected :initarg :expected :reader argument-count-error-expected)
   (optional :initarg :optional :initform 0
	     :reader argument-count-error-optional)
   (encountered :initarg :encountered
		:reader argument-count-error-encountered)
   (trailerp :initarg :trailerp :reader argument-count-error-trailerp))
  (:report (lambda (c s)
	     (format s "Command expected ~D argument~:P~
                        ~@[ and upto ~D optional argument~:P~] ~
                        ~:[~;(the last being a trailer argument) ~]~
                        but got ~:[~;only ~]~D!"
		     (argument-count-error-expected c)
		     (unless (zerop (argument-count-error-optional c))
		       (argument-count-error-optional c))
		     (argument-count-error-trailerp c)
		     (< (argument-count-error-encountered c)
			(argument-count-error-expected c))
		     (argument-count-error-encountered c)))))

(define-condition unknown-command-error (syntax-error)
  ((command :initarg :command :reader unknown-command-error-command))
  (:report (lambda (c s)
	     (format s "Command ~S is unknown!"
		     (unknown-command-error-command c)))))

(defun parse-command-args (line cmd-end required &key (optional 0) trailerp)
  (do* ((end (length line))
	(start (or cmd-end end))
	(i (+ required optional) (1- i))
	(result nil))
       ((= start end)
	(unless (<= 0 i optional)
	  (error 'argument-count-error
		 :expected required :optional optional :trailerp trailerp
		 :encountered (- (+ required optional) i)))
	(nreverse result))
    (loop while (char= #\Space (char line start))
      do (incf start))
    (loop with chunk-end = (if (and trailerp (= i 1)) end start)
	  until (or (= chunk-end end) (char= #\Space (char line chunk-end)))
	  do (incf chunk-end)
	  finally
	  (push (subseq line start chunk-end) result)
	  (setq start chunk-end))))

(defun simple-command-error (control &rest args)
  (error 'simple-command-error :format-control control :format-arguments args))

(defun process-command (connection line)
  (cond
    ((or (null line) (zerop (length line)))
     ;; Ignore
     t)
    ((char= (aref line 0) #\/)
     (handler-bind ((command-error
		     (lambda (c)
		       (write-chat-log connection "~11<***~> Error: ~A" c)
		       (return-from process-command nil))))
       (let* ((cmd-end (position #\Space line))
	      (command (subseq line 1 cmd-end)))
	 (cond
	   ((string-equal command "msg")
	    (destructuring-bind (target message)
		(parse-command-args line cmd-end 2 :trailerp t)
	      (write-chat-log connection "~10<<~A~>:~A> ~A"
			      (connection-nick connection)
			      target
			      message)
	      (send-command connection :privmsg target message)))
	   ((string-equal command "me")
	    (destructuring-bind (message)
		(parse-command-args line cmd-end 1 :trailerp t)
	      (write-chat-log connection "~11<*~> ~A ~A"
			      (connection-nick connection)
			      message)
	      (send-command connection :privmsg
			    (connection-current-channel connection)
			    (create-message-text
			     (cons "ACTION" message)))))
	   ((string-equal command "select")
	    (destructuring-bind (channel)
		(parse-command-args line cmd-end 1)
	      (unless (member channel (connection-channels connection)
			      :test #'string-equal)
		(simple-command-error "Unknown channel: ~A" channel))
	      (setf (connection-current-channel connection) channel)))
	   ((string-equal command "join")
	    (destructuring-bind (channel) (parse-command-args line cmd-end 1)
	      (when (member channel (connection-channels connection)
			    :test #'string-equal)
		(simple-command-error "Already joined channel ~A." channel))
	      (push channel (connection-channels connection))
	      (setf (connection-current-channel connection) channel)
	      (send-command connection :join channel)))
	   ((string-equal command "part")
	    (destructuring-bind (channel &optional message)
		(parse-command-args line cmd-end 1 :optional 1 :trailerp t)
	      (unless (member channel (connection-channels connection)
			      :test #'string-equal)
		(simple-command-error "You haven't joined channel ~A."
				      channel))
	      (setf (connection-channels connection)
		    (delete channel (connection-channels connection)
			    :test #'string-equal))
	      (when (string-equal (connection-current-channel connection)
				  channel)
		(setf (connection-current-channel connection)
		      (first (connection-channels connection))))
	      (if message
		  (send-command connection :part channel message)
		  (send-command connection :part channel))))
	   ((string-equal command "whois")
	    (destructuring-bind (nicks &optional target)
		(parse-command-args line cmd-end 1 :optional 1)
	      (if target
		  (send-command connection :whois target nicks)
		  (send-command connection :whois nicks))))
	   ((string-equal command "away")
	    (destructuring-bind (&optional message)
		(parse-command-args line cmd-end 0 :optional 1 :trailerp t)
	      (if message
		  (send-command connection :away message)
		  (send-command connection :away))))
	   ((string-equal command "ison")
	    (destructuring-bind (&rest nicks)
		(parse-command-args line cmd-end 0 :optional 15)
	      (apply #'send-command connection :ison nicks)))
	   ((string-equal command "bye")
	    (destructuring-bind (&optional message)
		(parse-command-args line cmd-end 0 :optional 1 :trailerp t)
	      (if message
		  (close-connection connection :reason message)
		  (close-connection connection))))
	   ((string-equal command "eval")
	    (unless (null cmd-end)
	      (ignore-errors
		(eval 
		 (read-from-string line t t :start cmd-end)))))
	   ((string-equal command "quote")
	    (multiple-value-bind (source command args)
		(let ((rest
		       (first
			(parse-command-args line cmd-end 1 :trailerp t))))
		  (parse-message rest 0 (length rest)))
	      (declare (ignore source))
	      (apply #'send-command connection command args)))
	   (t
	    (error 'unknown-command-error :command command))))))
    (t
     (write-chat-log connection "~11<<~A>~> ~A"
		     (connection-nick connection) line)
     (send-command connection :privmsg
		   (connection-current-channel connection)
		   line))))

(defun make-connection-shell (ashell connection)
  (let* ((title (format nil "SillyIRC ~A@~A"
			(connection-nick connection)
			(connection-host connection)))
	 (pane
	  (xt:create-popup-shell "connectionShell" :top-level-shell ashell
				 :title title
				 :icon-name title))
	 (form (xt:create-form pane "cform"))
	 (input-box (xt:create-text form "inputBox"
				    :max-length 400
				    :columns 120
				    :bottom-attachment :attach-form
				    :left-attachment :attach-form
				    :right-attachment :attach-form))
	 (hsep (xt:create-separator form "separator"
				    :orientation :horizontal
				    :bottom-attachment :attach-widget
				    :bottom-widget input-box
				    :left-attachment :attach-form
				    :right-attachment :attach-form))
	 (chat-log (xt:create-scrolled-list form "chatLog"
					    :visible-item-count 20
					    :bottom-attachment :attach-widget
					    :bottom-widget hsep
					    :top-attachment :attach-form
					    :left-attachment :attach-form
					    :right-attachment :attach-form)))
    (xt:manage-child form)
    (xt:manage-child input-box)
    (xt:manage-child hsep)
    (xt:manage-child chat-log)
    (xt:set-sensitive input-box nil)
    (xt:add-callback input-box :activate-callback
		     #'(lambda (widget c-d)
			 (declare (ignore c-d))
			 (let ((line
				(string-trim '(#\Space #\Tab)
					     (xt:text-get-string widget))))
			   (xt:text-clear-selection widget)
			   (xt:text-set-string widget "")
			   (process-command connection line))))
    (xt:add-callback pane :destroy-callback
		     #'(lambda (w c-d)
			 (declare (ignore w c-d))
			 (close-connection connection)))
    (setf (connection-pane connection) pane
	  (connection-chat-log connection) chat-log
	  (connection-input-box connection) input-box)
    (xt:popup pane :grab-none)
    pane))

(defun make-control-shell (ashell)
  (let* ((pane
	  (xt:create-popup-shell "controlShell" :top-level-shell ashell
				 :title "SillyIRC Control"
				 :icon-name "SillyIRC Control"))
	 (form (xt:create-form pane "form"))
	 (fields-rc (xt:create-row-column form "fieldsRC"
					  :top-attachment :attach-form
					  :left-attachment :attach-form
					  :right-attachment :attach-form
					  :orientation :horizontal
					  :packing :pack-column
					  :num-columns 1))
	 (left-rc (xt:create-row-column fields-rc "leftRC"
					:packing :pack-column
					:num-columns 1))
	 (right-rc (xt:create-row-column fields-rc "rightRC"
					 :packing :pack-column
					 :num-columns 1))
	 (server-label (xt:create-label left-rc "serverLabel"
					:label-string "Server:"))
	 (server-text (xt:create-text left-rc "serverText"))
	 (port-label (xt:create-label right-rc "portLabel"
				      :label-string "Port:"))
	 (port-text (xt:create-text right-rc "portText" :value "6667"))
	 (realname-label (xt:create-label left-rc "realnameLabel"
					  :label-string "Realname:"))
	 (realname-text (xt:create-text left-rc "realnameText"))
	 (userinfo-label (xt:create-label right-rc "userinfoLabel"
					  :label-string "Userinfo:"))
	 (userinfo-text (xt:create-text right-rc "userinfoText"))
	 (nick-label (xt:create-label left-rc "nickLabel"
				      :label-string "Nick:"))
	 (nick-text (xt:create-text left-rc "nickText"))
	 (hsep (xt:create-separator form "separator"
				    :orientation :horizontal
				    :top-attachment :attach-widget
				    :top-widget fields-rc
				    :left-attachment :attach-form
				    :right-attachment :attach-form))
	 (connect (xt:create-push-button form "connectButton"
					 :label-string "Connect"
					 :top-attachment :attach-widget
					 :top-widget hsep
					 :bottom-attachment :attach-form
					 :left-attachment :attach-form
					 :right-attachment :attach-form)))
    (xt:manage-child form)
    (xt:manage-child fields-rc)
    (xt:manage-child left-rc)
    (xt:manage-children server-label server-text 
			realname-label realname-text
			nick-label nick-text)
    (xt:manage-child right-rc)
    (xt:manage-children port-label port-text
			userinfo-label userinfo-text)
    (xt:manage-children	hsep connect)
    (xt:add-callback connect :activate-callback
		     #'(lambda (w c-d)
			 (declare (ignore w c-d))
			 (make-new-connection
			  ashell
			  :host (first (xt:get-values server-text :value))
			  :port (or (ignore-errors
				      (parse-integer
				       (first
					(xt:get-values port-text :value))))
				    6667)
			  :nick (first (xt:get-values nick-text :value))
			  :realname
			  (first (xt:get-values realname-text :value))
			  :userinfo
			  (concatenate
			   'string ":"
			   (first (xt:get-values userinfo-text :value))))))
    (xt:add-callback pane :destroy-callback
		     #'(lambda (w c-d)
			 (declare (ignore w c-d))
			 (mapc #'close-connection *active-connections*)
			 (xt:quit-application)))
    pane))

(defun make-top-level ()
  (let* ((ashell (xt:create-application-shell))
	 (cshell (make-control-shell ashell)))
    (setq *irc-motif-connection* xti:*motif-connection*)
    (xt:popup cshell :grab-none)))

(defun start-irc ()
  (xt:run-motif-application #'make-top-level
			    :application-class "SILLYIRC"
			    :application-name "sillyirc"))

(setf (getf ext:*herald-items* :sillyirc)
      `("    IRC client SillyIRC 1.0"))