source: tags/0.9.0/parse-message.lisp

Last change on this file was 219, checked in by Erik Huelsmann, 12 years ago

Fix long-standing complaint that cl-irc hits the debugger on unknown
(and, as Matthew Emerson puts it, irrelevant) response codes.

  • parse-message.lisp: (find-reply-name): Simply return the reply name. (create-irc-message): If there's no reply name, raise an error.
  • protocol.lisp: (read-irc-message, read-message, read-message-loop): restructure

condition handling for END-OF-FILE and NO-SUCH-REPLY to eliminate
"trickery" (returning values which mean different things than what
they are)

  • variable.lisp: (*unknown-reply-hook*): New variable for function to catch unhandled

replies. Defaults to ignore unhandled replies.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision URL
File size: 9.7 KB
Line 
1;;;; $Id: parse-message.lisp 219 2012-09-23 09:50:06Z ehuelsmann $
2;;;; $URL: tags/0.9.0/parse-message.lisp $
3
4;;;; See the LICENSE file for licensing information.
5
6(in-package :irc)
7
8(defun find-reply-name (reply-number &key (reply-names *reply-names*))
9  "Numeric replies in the IRC RFCs have more meaningful names.  Given
10a numeric reply (`reply-number') this function will either return the
11symbol representing the reply or raise a continuable error
12(`no-such-reply') which gives you the opportunity to ignore the
13situation."
14  (let ((name (assoc reply-number reply-names)))
15    (when name
16      (cadr name))))
17
18(defun return-source (string &key (start 0))
19  "Assuming `string' is a valid IRC message this function returns the
20source part of the message.  Returns nil if the source part is not
21present."
22  (cut-between string #\: '(#\! #\Space) :start start))
23
24(defun return-user (string &key (start 0))
25  "Assuming `string' is a valid IRC message this function returns the
26user part of the message.  Returns nil if the user part is not
27present."
28  (cut-between string #\! '(#\@ #\Space) :start start))
29
30(defun return-host (string &key (start 0))
31  "Assuming `string' is a valid IRC message this function returns the
32host part of the message.  Returns nil if the host part is not
33present."
34  (cut-between string #\@ '(#\Space) :start start))
35
36(defun return-command (string &key (start 0))
37  "Assuming `string' is a valid IRC message this function returns the
38command part of the message.  Returns nil if the command part is not
39present."
40  (if (eql (char string start) #\Space)
41      (cut-between string #\Space '(#\Space) :start start)
42      (cut-between string nil '(#\Space) :start start :cut-extra nil)))
43
44(defun return-arguments (string &key (start 0))
45  "Assuming `string' is a valid IRC message this function returns the
46arguments part of the message as a list.  Returns nil if the arguments
47part is not present."
48  (multiple-value-bind (end-position return-argument)
49      (cut-before string " :" '(#\Return) :start start :cut-to-end t)
50    (values end-position (tokenize-string return-argument
51                                          :delimiters '(#\Space)))))
52
53(defun return-trailing-argument (string &key (start 0))
54  "Assuming `string' is a valid IRC message this function returns the
55trailing-argument part of the message.  Returns nil if the
56trailing-argument part is not present."
57  (when (< start (length string))
58    (cut-between string #\: '(#\Return) :start start :cut-to-end t)))
59
60(defun combine-arguments-and-trailing (string &key (start 0))
61  (multiple-value-bind
62      (start return-string)
63      (return-arguments string :start start)
64    (multiple-value-bind
65        (return-index trailing)
66        (return-trailing-argument string :start start)
67      (values return-index
68              (append return-string (when (and trailing (string/= "" trailing))
69                                      (list trailing)))))))
70
71(defun parse-raw-message (string &key (start 0))
72  "Assuming `string' is a valid IRC message, parse the message and
73return the values in the following order:
74
75  - source
76  - user
77  - host
78  - command
79  - arguments
80  - trailing-argument
81
82Any values not present will be represented as nil."
83  (let ((index start)
84        (returns nil))
85    (dolist (function '(return-source
86                        return-user
87                        return-host
88                        return-command
89                        combine-arguments-and-trailing))
90      (multiple-value-bind (return-index return-string)
91          (funcall function string :start index)
92        (setf index return-index)
93        (push return-string returns)))
94    (apply #'values (reverse returns))))
95
96(defun irc-error-reply-p (string)
97  "Returns t if `string' is a string-representation of an IRC error
98reply message, nil otherwise."
99  (unless (zerop (length string))
100    (if (and (every #'digit-char-p string)
101             (member (char string 0) '(#\4 #\5)))
102        t
103        nil)))
104
105(defun numeric-reply-p (string)
106  "Returns t if `string' is a string-representation of an IRC number
107reply, nil otherwise."
108  (every #'digit-char-p string))
109
110(defun ctcp-type-p (string type)
111  "Is the `string' actually a representation of the CTCP `type'?"
112  (if (string-equal (substring string 1 (min (length string)
113                                             (1+ (length (symbol-name type)))))
114                    type)
115      type
116      nil))
117
118(defun dcc-type-p (string type)
119  "Is the `string' actually a representation of the DCC `type'?"
120  (let* ((args (tokenize-string (string-trim (list +soh+) string)))
121         (dcc (string-upcase (first args)))
122         (sess-type (string-upcase (second args))))
123    (when (string= dcc "DCC")
124      (let ((r
125             ;; the list below was found on Wikipedia and in kvirc docs
126             (second (assoc sess-type '(("CHAT" :dcc-chat-request)
127                                        ("SEND" :dcc-send-request)
128                                        ("XMIT" :dcc-xmit-request)
129                                        ("SCHAT" :dcc-schat-request)
130                                        ("SSEND" :dcc-ssend-request)
131                                        ("REVERSE" :dcc-reverse-request)
132                                        ("RSEND" :dcc-rsend-request)
133                                        ("TSEND" :dcc-tsend-request)
134                                        ("STSEND" :dcc-stsend-request)
135                                        ("TSSEND" :dcc-stsend-request)
136                                        ("RESUME" :dcc-resume-request)
137                                        ("ACCEPT" :dcc-accept-request)
138                                        ;; GET
139                                        ;; TGET
140                                        ;; STGET
141                                        ;; TSGET
142                                        ;; RECV
143                                        ;; SRECV
144                                        ;; TRECV
145                                        ;; STRECV
146                                        ;; TSRECV
147                                        ;; RSEND
148                                        ;; SRSEND
149                                        ;; TRSEND
150                                        ;; STRSEND
151                                        ;; TSRSEND
152                                        ;; VOICE
153                                        ) :test #'string=))))
154        (when (eq r type)
155          type)))))
156
157(defun ctcp-message-type (string)
158  "If `string' is a CTCP message, return the type of the message or
159nil if this is a) not a CTCP message or b) a CTCP message we don't
160know about."
161  (if (or (not (stringp string))
162          (zerop (length string))
163          (not (eql (char string 0) +soh+)))
164      nil
165      (case (char string 1)
166        (#\A (ctcp-type-p string :action))
167        (#\C (ctcp-type-p string :clientinfo))
168        (#\D
169         (or (dcc-type-p string :dcc-chat-request)
170             (dcc-type-p string :dcc-send-request)))
171        (#\F (ctcp-type-p string :finger))
172        (#\P (ctcp-type-p string :ping))
173        (#\S (ctcp-type-p string :source))
174        (#\T (ctcp-type-p string :time))
175        (#\U (ctcp-type-p string :userinfo))
176        (#\V (ctcp-type-p string :version))
177        (otherwise nil))))
178
179(defun create-irc-message (string)
180  "If `string' is a valid IRC message parse it and return an object of
181the correct type with its slots prefilled according to the information
182in the message."
183  (multiple-value-bind (source user host command arguments)
184      (parse-raw-message string)
185    (let* ((class 'irc-message)
186           (trailing-argument (car (last arguments)))
187           (ctcp (ctcp-message-type trailing-argument)))
188      (when command
189        (cond
190          ;;((irc-error-reply-p command)
191           ;; Disable for now, as it prevents adding hooks for some useful
192           ;; error types
193           ;;(progn
194           ;;  (setf command (find-reply-name (parse-integer command)))
195           ;;  (setf class 'irc-error-reply)))
196          ((numeric-reply-p command)
197           (let* ((reply-number (parse-integer command))
198                  (reply-name (find-reply-name reply-number)))
199             (unless reply-name
200               (error "Ignore unknown reply."
201                      'no-such-reply :reply-number reply-number))
202             (setf command reply-name)
203             (setf class (find-irc-message-class command))))
204          (t
205           (setf command (intern (string-upcase command)
206                                 (find-package :keyword)))
207           (setf class (find-irc-message-class command)))))
208      (when ctcp
209        (setf class (find-ctcp-message-class ctcp)))
210      (let ((instance (make-instance class
211                                     :source (or source "")
212                                     :user (or user "")
213                                     :host (or host "")
214                                     :command (if command
215                                                  (string command)
216                                                  "")
217                                     :arguments arguments
218                                     :connection nil
219                                     :received-time (get-universal-time)
220                                     :raw-message-string (or string ""))))
221        (when ctcp
222          (setf (ctcp-command instance) ctcp))
223        instance))))
224
225(defun create-dcc-message (string)
226  (let* ((class 'dcc-privmsg-message)
227         (ctcp (ctcp-message-type string)))
228    (when ctcp
229      (setf class (find-dcc-ctcp-message class ctcp)))
230    (let ((instance (make-instance class
231                                   :arguments (list string)
232                                   :connection nil
233                                   :received-time (get-universal-time)
234                                   :raw-message-string string)))
235      (when ctcp
236        (setf (ctcp-command instance) ctcp))
237      instance)))
Note: See TracBrowser for help on using the repository browser.