1 (* -*- mode: tuareg -*- ******************************************************)
3 (* This is a light IRC client written in CAML *)
4 (* Written by and (c) Francois Fleuret, 2002 - 2005 *)
5 (* Contact <francois.fleuret@epfl.ch> for info and bug reports *)
7 (* This program is free software; you can redistribute it and/or modify *)
8 (* it under the terms of the GNU General Public License Version 2 as *)
9 (* published by the Free Software Foundation. See the file LICENSE for *)
12 (*****************************************************************************)
16 (* I removed all the dcc stuff between v0.25 and v0.5 because it was a
17 biiiig pile of crap. Feel free to write it ! *)
19 let version = "IRCML v0.5";;
21 let term_bold = ref "
\e[1m"
22 and term_underline = ref "
\e[4m"
23 and term_inverse = ref "
\e[7m"
24 and term_reset = ref "
\e[m";;
26 (*****************************************************************************)
28 (*****************************************************************************)
30 let keys h = Hashtbl.fold (fun key data accu -> key :: accu) h []
32 let verbose = ref false;;
34 (* Return the element after the given one, or the first of the list if
35 the given one is the last *)
39 let rec next_rec x = function
41 | h::t -> if h = x then List.hd t else next_rec x t
42 in try next_rec x l with Failure(e) -> List.hd l;;
44 let string_of_size size =
45 if size > 1048576 then (string_of_int (size / 1048576))^"Mb"
46 else if size > 1024 then (string_of_int (size / 1024))^"Kb"
47 else (string_of_int size) ^ "b";;
49 let duration_of_seconds duration =
50 (if duration >= 3600 then (string_of_int (duration/3600))^"h" else "") ^
51 (if (duration mod 3600) >= 60 then (string_of_int ((duration mod 3600)/60))^"min" else "") ^
52 (if (duration mod 60) > 0 then (string_of_int (duration mod 60))^"s" else "");;
54 (*****************************************************************************)
55 (* The global variables *)
56 (*****************************************************************************)
58 type user_status = { mutable operator: bool }
59 let string_of_user = fun u -> (if u.operator then "@" else "")
61 type channel = { name: string; people: (string, user_status) Hashtbl.t ; modes: (char, string) Hashtbl.t };;
67 and desired_nick = ref "b0z0"
68 and desired_server = ref "localhost"
69 and desired_port = ref 6667
71 and current_nick = ref ""
72 and (current_modes: (char, string) Hashtbl.t) = Hashtbl.create 10
73 and default_channel = ref ""
75 and login = ref "c4mlp0w4"
76 and name = ref ("Using " ^ version ^ ", the light IRC client in CAML")
78 and alive = ref true;;
80 (* Print something with a 'header character' à la sirc *)
81 (* '<' Leaving channel (part, kick, signoff, etc.) *)
82 (* '>' Joining a channel *)
85 (* 'X' Internal error, should never meet one *)
86 let printh h s = output_string Pervasives.stdout
89 "E" -> (!term_bold ^ "*" ^ h ^ "*" ^ " " ^ s ^ !term_reset ^ "\n")
90 | _ -> (!term_bold ^ "*" ^ h ^ "*" ^ !term_reset ^ " " ^ s ^ "\n")
93 (* Simply print something in the console *)
94 let print s = output_string Pervasives.stdout (s ^ "\n");;
96 type ssfe_cmd = Status of string | Tabulable of string;;
98 let current_status = ref "";;
103 Status(s) -> if not (s = !current_status) then (current_status := s; print ("`#ssfe#s" ^ s))
104 | Tabulable(s) -> print ("`#ssfe#t" ^ s)
107 (*****************************************************************************)
108 (* Command line parameter parsing *)
109 (*****************************************************************************)
111 Arg.parse [ ("-nick", Arg.String(fun n -> desired_nick := n), "Set the desired nick");
112 ("-server", Arg.String(fun s -> desired_server := s), "Set the desired server");
113 ("-port", Arg.Int(fun p -> desired_port := p), "Set the desired port");
114 ("-login", Arg.String(fun s -> login := s), "Set the login");
115 ("-name", Arg.String(fun s -> name := s), "Set the name") ]
116 (fun s -> ()) "Unknown option";;
118 (*****************************************************************************)
119 (* The connection with the server *)
120 (*****************************************************************************)
123 Established of Unix.file_descr
126 let last_server_msg = ref 0;;
128 let server_connection = ref Broken;;
130 (* This is the list of file descriptors active for reading. Each one
131 corresponds to a reader which will be called when something is
132 readable and a exception-handler, called if the connection is lost,
135 type fd_machine = { reader: unit -> unit; error_handler: string -> unit };;
137 let (fd_active: (Unix.file_descr, fd_machine) Hashtbl.t) = Hashtbl.create 10;;
139 (*****************************************************************************)
140 (* Handling of the channel list *)
141 (*****************************************************************************)
143 let (joined_channels: (string, channel) Hashtbl.t) = Hashtbl.create 10;;
145 let find_joined c = Hashtbl.find joined_channels (String.uppercase c)
146 and mem_joined c = Hashtbl.mem joined_channels (String.uppercase c)
147 and set_joined c x = Hashtbl.replace joined_channels (String.uppercase c) x
148 and remove_joined c = Hashtbl.remove joined_channels (String.uppercase c)
149 and same_channel c1 c2 = (String.uppercase c1) = (String.uppercase c2);;
151 let part_channel channel =
152 remove_joined channel;
153 if !default_channel = channel
154 then match (keys joined_channels) with
155 [] -> default_channel := ""; if not !ssfe then printh "I" "Not in a channel anymore"
156 | c::t -> default_channel := c; printh "I" ("Talking to " ^ !default_channel ^ " now");;
158 (*****************************************************************************)
159 (* Takes a string and returns an array of strings corresponding to the *)
160 (* tokens in the IRC protocole syntax. I.e. tokens are separated by white *)
161 (* spaces except the tail which is after a ':' *)
162 (*****************************************************************************)
164 let (irc_tokenize: string -> string array) = fun s ->
165 let l = (String.length s) in
166 let rec irc_tokenize s n =
167 if String.get s n == ':' then [String.sub s (n + 1) (l - n - 2)] else
169 let m = String.index_from s n ' ' in
170 let h = String.sub s n (m - n) in
171 h::irc_tokenize s (m+1)
173 Not_found -> if n < l then [String.sub s n (l - n - 1)] else []
175 (* Ignore the prefix if there is one *)
176 if (String.get s 0) == ':' then
177 let n = (String.index s ' ') in Array.of_list ((String.sub s 1 (n - 1))::(irc_tokenize s (n+1)))
178 else Array.of_list (""::(irc_tokenize s 0));;
180 (* Function to split the "nick!login@host" *)
182 let (split_prefix: string -> string * string * string) = fun prefix ->
183 let n1 = (String.index prefix '!') in
184 let n2 = (String.index_from prefix n1 '@') in
185 (String.sub prefix 0 n1,
186 String.sub prefix (n1 + 1) (n2 - (n1 + 1)),
187 String.sub prefix (n2 + 1) ((String.length prefix) - (n2 + 1)));;
189 (*****************************************************************************)
191 (*****************************************************************************)
193 let (cmd_aliases: (string, string) Hashtbl.t) = Hashtbl.create 100;;
195 List.iter (fun (a, b) -> Hashtbl.replace cmd_aliases a b) [
196 ("J", "JOIN"); ("M", "MSG"); ("K", "KICK"); ("L", "CHANINFO");
197 ("N", "NICK"); ("Q", "QUIT"); ("T", "TOPIC"); ("W", "WHOIS");
198 ("DC", "DISCONNECT"); ("S", "SERVER"); ("H", "HELP")
201 (*****************************************************************************)
202 (* The managers will be filled later *)
203 (*****************************************************************************)
205 let (protocole_managers: (string, string array -> unit) Hashtbl.t) = Hashtbl.create 100;;
206 let (cmd_managers: (string, string * ((unit -> string) -> (unit -> string) -> unit)) Hashtbl.t) = Hashtbl.create 100;;
207 let (ctcp_managers: (string, (unit -> string) -> (unit -> string) -> string -> string -> unit) Hashtbl.t) = Hashtbl.create 10;;
209 (*****************************************************************************)
210 (* The routines handling lines from the server or the user *)
211 (*****************************************************************************)
213 let print_unknown_protocole = fun tokens ->
214 let buffer = Buffer.create 100 in
215 Buffer.add_string buffer "Unknown protocole";
216 for i = 0 to ((Array.length tokens) - 1) do
217 Buffer.add_string buffer (" " ^ (string_of_int i) ^ ":(" ^ tokens.(i) ^ ")");
219 printh "X" (Buffer.contents buffer);;
221 let server_line_handler = fun line ->
222 if !verbose then (print_string ("SERVER [" ^ line ^ "]\n"); flush stdout);
223 last_server_msg := int_of_float (Unix.time ());
224 let tokens = (irc_tokenize line) in
226 let f = Hashtbl.find protocole_managers tokens.(1) in
227 try f tokens with Not_found -> printh "E" ("Protocole " ^ tokens.(1) ^ " raised Not_found!")
229 Not_found -> print_unknown_protocole tokens;;
231 let kill_server_connection error_message =
232 match !server_connection with
235 Hashtbl.remove fd_active fd;
236 server_connection := Broken;
237 printh "E" ("Connection lost (" ^ error_message ^ ")");
238 default_channel := "";
239 Hashtbl.clear joined_channels
243 let tell_server line =
244 match !server_connection with
248 if (Unix.write fd line 0 (String.length line)) <= 0 then kill_server_connection ("write error")
250 Unix.Unix_error(e, fname, fparam) -> kill_server_connection (fname ^ ": " ^ (Unix.error_message e))
252 | Broken -> printh "E" "No connection";;
254 let establish_connection () =
255 match !server_connection with
256 Established(_) -> printh "E" "Connection already established (try /DISCONNECT first)"
258 printh "I" ("Attempting connection to " ^ !desired_server ^
259 ":" ^ (string_of_int !desired_port) ^
260 " with nick " ^ !desired_nick);
262 let fd = Connection.connect !desired_server !desired_port in
264 match Unix.getsockname fd with
265 Unix.ADDR_INET(ai, _) -> my_host := Connection.dot_to_number (Unix.string_of_inet_addr ai)
266 | _ -> printh "E" "Internal error #0";
268 server_connection := Established(fd);
269 Hashtbl.replace fd_active fd { reader = linizer fd server_line_handler; error_handler = kill_server_connection };
270 tell_server ("USER " ^ !login ^ " caml rulez :" ^ !name ^ "\n");
271 tell_server ("NICK " ^ !desired_nick ^ "\n");
272 last_server_msg := int_of_float (Unix.time ());
273 printh "I" ("Connection established, waiting for server checkings.");
275 Network_error(e) -> printh "E" ("Can not connect to host: " ^ e);;
277 let stdin_line_handler = fun line ->
278 (*print_string ("STDIN [" ^ line ^ "]\n"); flush stdout;*)
279 if String.length line > 0 then
280 match String.get line 0 with
283 let (cl_token, cl_tail) = tokenizer line ' ' in
284 let cmd = String.uppercase (cl_token ()) in let cmd = String.sub cmd 1 ((String.length cmd) - 1) in
285 let cmd = try Hashtbl.find cmd_aliases cmd with Not_found -> cmd in
287 let (_, f) = (Hashtbl.find cmd_managers cmd) in
292 Not_found -> printh "E" ("Command " ^ cmd ^ " raised Not_found!")
295 Not_found -> printh "E" ("Unknown command '" ^ cmd ^ "'");
300 let (cl_token, cl_tail) = tokenizer line ' ' in
301 match cl_token () with
305 printh "I" "You are using ssfe";
307 term_underline := "
\1f";
308 term_inverse := "
\16";
315 if !default_channel = ""
316 then printh "E" "Not in a channel"
319 print ("<" ^ !current_nick ^ "> " ^ line);
320 tell_server ("PRIVMSG " ^ !default_channel ^ " :" ^ line ^ "\n")
323 let console_reader = linizer Unix.stdin stdin_line_handler
324 and console_error = fun error_message -> printh "E" ("Stdin error (" ^ error_message ^ ")"); exit 1 in
325 Hashtbl.replace fd_active Unix.stdin { reader = console_reader; error_handler = console_error };;
327 (*****************************************************************************)
328 (* Functions to handle scripts *)
329 (*****************************************************************************)
331 Hashtbl.add cmd_managers
334 "<module>: Loads the given bytecode object",
337 let module_name = token () in
338 printh "I" ("loading module " ^ module_name);
340 Dynlink.loadfile(module_name)
342 Dynlink.Error error -> printh "E" ("Module loading error (" ^ (Dynlink.error_message error) ^ ")");
343 | Sys_error error_message -> printh "E" ("Module loading error (" ^ error_message ^ ")");
345 Not_found -> printh "E" "Missing argument"
348 (*****************************************************************************)
349 (* Functions to handle the various user commands *)
350 (*****************************************************************************)
352 (* Each manager gets two (unit -> string), the first one to get tokens
353 one after another and the second one to get the tail when required *)
355 Hashtbl.add cmd_managers
364 (fun nick user -> print ("on " ^ name ^ " : [" ^ (string_of_user user) ^ "] " ^ nick))
370 Hashtbl.add cmd_managers
373 "[<cmd>]: Shows the help for the given command, or for all of them",
376 let cmd = String.uppercase (token ()) in
378 let (h, f) = (Hashtbl.find cmd_managers cmd) in
379 printh "H" ("/" ^ cmd ^ " " ^ h)
381 Not_found -> printh "H" ("Unknown command " ^ cmd)
383 Not_found -> Hashtbl.iter (fun cmd (help, f) -> (printh "H" ("/" ^ cmd ^ " " ^ help))) cmd_managers
386 Hashtbl.add cmd_managers
389 "[<action description>]: Describes an action in the default channel",
391 if !default_channel = ""
392 then printh "E" "Not in a channel"
393 else let msg = try (tail ()) with Not_found -> "" in
394 tell_server ("PRIVMSG " ^ !default_channel ^ " :
\ 1ACTION " ^ msg ^ "
\ 1\n");
395 print ("* " ^ !current_nick ^ " " ^ msg)
398 Hashtbl.add cmd_managers
401 "[<message>]: Sets yourself away",
403 try tell_server ("AWAY :" ^ (tail ()) ^ "\n")
404 with Not_found -> tell_server "AWAY\n";
407 Hashtbl.add cmd_managers
410 "<nick|#channel> <message>: Sends a message to a user, or a channel",
413 let dest = (token ()) and msg = (tail ()) in
414 tell_ssfe (Tabulable ("/msg " ^ dest ^ " "));
415 match String.get dest 0 with
418 print ("<" ^ !current_nick ^ (if same_channel !default_channel dest then "" else "/" ^ dest) ^ "> " ^ msg);
419 tell_server ("PRIVMSG " ^ dest ^ " :" ^ msg ^ "\n")
424 print (">" ^ dest ^ "< " ^ msg);
425 tell_server ("PRIVMSG " ^ dest ^ " :" ^ msg ^ "\n")
428 with Not_found -> printh "E" "Missing parameter"
431 Hashtbl.add cmd_managers
434 "<nick|#channel> <ctcp string>: Sends a CTCP (string quoted between ^A) to a user or a channel",
437 let dest = (token ()) and msg = (tail ()) in
438 tell_ssfe (Tabulable ("/msg " ^ dest ^ " "));
439 printh "I" ("Sending a CTCP " ^ msg ^ " to " ^ dest);
440 tell_server ("PRIVMSG " ^ dest ^ " :
\ 1" ^ msg ^ "
\ 1\n")
441 with Not_found -> printh "E" "Missing parameter"
444 Hashtbl.add cmd_managers
447 "<nick|#channel> <message>: Sends a notice to a user or a channel",
450 let dest = (token ()) and msg = (tail ()) in
451 print ("-> -" ^ dest ^ "- " ^ msg); tell_server ("PRIVMSG " ^ dest ^ " :" ^ msg ^ "\n")
452 with Not_found -> printh "E" "Missing parameter"
455 Hashtbl.add cmd_managers
458 "[<nick>]: Requests information about a user",
460 let nick = try token () with Not_found -> !current_nick in
462 then printh "E" "Missing argument"
463 else tell_server ("WHOIS " ^ nick ^ "\n")
466 Hashtbl.add cmd_managers
469 "[<nick>]: Requests information about a user on his server (get the idle)",
471 let nick = try token () with Not_found -> !current_nick in
473 then printh "E" "Missing argument"
474 else tell_server ("WHOIS " ^ nick ^ " " ^ nick ^ "\n")
477 Hashtbl.add cmd_managers
480 "[<server>[:<port>]]: Establishes a connection to a new server",
484 let (stoken, stail) = tokenizer (token ()) ':' in
485 desired_server := stoken ();
486 desired_port := int_of_string (stoken ())
489 | Failure(_) -> printh "E" "Syntax error"
491 establish_connection ()
494 Hashtbl.add cmd_managers
497 ": Selects the next joined channel as default",
500 default_channel := (find_joined (circular_succ (String.uppercase !default_channel) (keys joined_channels))).name;
501 if not !ssfe then printh "I" ("Talking to " ^ !default_channel ^ " now")
503 Not_found -> printh "E" "You have to join a channel first"
506 Hashtbl.add cmd_managers
509 "[<#channel> [<key>]]: Joins a channel or tells what is the default channel",
512 let channel = token () in let chan = match String.get channel 0 with '#' | '&' -> channel | _ -> "#" ^ channel in
513 let key = try " " ^ (token ()) with Not_found -> "" in
514 if mem_joined channel
515 then (default_channel := chan; if not !ssfe then printh "I" ("Talking to " ^ chan ^ " now"))
516 else tell_server ("JOIN " ^ chan ^ key ^ "\n")
518 if !default_channel = ""
519 then printh "I" "You are not in a channel"
520 else printh "I" ("You current channel is " ^ !default_channel)
523 Hashtbl.add cmd_managers
526 "[<topic>]: Sets or requests the topic in the current channel",
528 if !default_channel = ""
529 then printh "E" "Not in a channel"
531 try let topic = tail () in tell_server ("TOPIC " ^ !default_channel ^ " :" ^ topic ^ "\n")
532 with Not_found -> tell_server ("TOPIC " ^ !default_channel ^ "\n")
535 Hashtbl.add cmd_managers
538 "[<mode change>]: Changes mode or shows the mode of the current channel",
540 let chan = try token () with Not_found -> !default_channel in
542 then printh "E" "Need to specify a channel"
544 let chan = match String.get chan 0 with '#' | '&' -> chan | _ -> "#" ^ chan in
545 try tell_server ("MODE " ^ chan ^ " " ^ (tail ()) ^ "\n")
546 with Not_found -> tell_server ("MODE " ^ chan ^ "\n")
549 Hashtbl.add cmd_managers
552 "[<#channel>] <nick> [<comment>]: Kicks the given user from the given (or current) channel",
554 if !default_channel = ""
555 then printh "E" "Not in a channel"
558 let (channel, nick) = match String.get t 0 with '#' | '&' -> (t, token ()) | _ -> (!default_channel, t)
559 and comment = try tail () with Not_found -> "B1G d0Rk5 SuCk M00z b4LLz" in
560 tell_server ("KICK " ^ !default_channel ^ " " ^ nick ^ " :" ^ comment ^ "\n")
561 with Not_found -> printh "E" "Missing parameter"
564 Hashtbl.add cmd_managers
567 "[<#channel>]: Leaves the current or the specified channel",
569 let chan = try token () with Not_found -> !default_channel in
571 then printh "E" "Need to specify a channel"
572 else let chan = match String.get chan 0 with '#' | '&' -> chan | _ -> "#" ^ chan in
573 tell_server ("PART " ^ chan ^ "\n")
576 Hashtbl.add cmd_managers
579 "[<#channel>]: Gets the user list for the given channel",
581 let chan = try token () with Not_found -> !default_channel in
582 if chan = "" then printh "E" "Need to specify a channel"
584 let chan = match String.get chan 0 with '#' | '&' -> chan | _ -> "#" ^ chan in
585 tell_server ("LIST " ^ chan ^ "\n");
586 tell_server ("NAMES " ^ chan ^ "\n")
589 Hashtbl.add cmd_managers
592 "[<nick>]: Changes or requests the current nick",
594 try let nick = token () in tell_server ("NICK " ^ nick ^ "\n")
595 with Not_found -> printh "I" ("You current nick is " ^ !current_nick)
598 Hashtbl.add cmd_managers
601 "[<message>]: Signoffs on the current server with the given quit message",
603 let msg = try tail () with Not_found -> (version ^ ", the light IRC client in CAML") in
604 tell_server ("QUIT :" ^ msg ^ "\n");
607 Hashtbl.add cmd_managers
610 "[<message>]: Signoffs on the current server if connected, and terminates operations",
612 if !server_connection != Broken then begin
613 let msg = try tail () with Not_found -> (version ^ ", the light IRC client in CAML") in
614 tell_server ("QUIT :" ^ msg ^ "\n");
619 Hashtbl.add cmd_managers
622 "<line>: Sends the line to the server, as it is",
624 try tell_server (tail () ^ "\n")
625 with Not_found -> printh "E" "Missing parameter"
628 Hashtbl.add cmd_managers
631 ": Set the verbose mode (everything form the server will be printed)",
633 verbose := not !verbose;
634 if !verbose then printh "I" "Verbose mode on" else printh "I" "Verbose mode off"
637 (*****************************************************************************)
638 (* Function to handle the various CTCPs *)
639 (*****************************************************************************)
641 Hashtbl.add ctcp_managers
644 fun token tail from dest -> tell_server ("NOTICE " ^ from ^ " :" ^ version ^ ", the light IRC client in CAML\n")
647 Hashtbl.add ctcp_managers
650 fun token tail from dest -> try print ("* " ^ from ^ " " ^ (tail())) with Not_found -> print ("* " ^ from)
653 (*****************************************************************************)
654 (* Functions to handle the mode changes (that part of the protocole sucks) *)
655 (*****************************************************************************)
657 let rec flatten_modes = fun polarity mode_string mode_indice param_strings param_indice ->
658 if mode_indice < (String.length mode_string)
660 match (String.get mode_string mode_indice) with
661 '+' -> flatten_modes 1 mode_string (mode_indice+1) param_strings param_indice
662 | '-' -> flatten_modes (-1) mode_string (mode_indice+1) param_strings param_indice
663 | 'k' | 'o' | 'v' | 'b' as c ->
664 (c, polarity, param_strings.(param_indice))::(flatten_modes polarity mode_string (mode_indice+1) param_strings (param_indice+1))
665 | 'm' | 'i' | 's' | 't' | 'n' as c ->
666 (c, polarity, "")::(flatten_modes polarity mode_string (mode_indice+1) param_strings param_indice)
669 then ('l', polarity, param_strings.(param_indice))::(flatten_modes polarity mode_string (mode_indice+1) param_strings (param_indice+1))
670 else ('l', polarity, "")::(flatten_modes polarity mode_string (mode_indice+1) param_strings param_indice)
671 | other -> (other, polarity, "")::(flatten_modes polarity mode_string (mode_indice+1) param_strings param_indice)
676 let rec string_of_modelist = function
679 (if l > 0 then " +" else " -") ^
681 (if p = "" then "" else " " ^ p) ^
682 (string_of_modelist t)
684 let set_modes channel l =
685 let chan = find_joined channel in
689 | ('b', pol, pattern) -> ()
690 | ('v', pol, nick) -> ()
691 | ('o', pol, nick) -> (Hashtbl.find chan.people nick).operator <- (pol > 0)
692 | (c, 1, param) -> Hashtbl.replace chan.modes c param
693 | (c, -1, param) -> Hashtbl.remove chan.modes c
698 let get_status = fun () ->
699 " [" ^ version ^ "] " ^
700 (try string_of_user (Hashtbl.find (find_joined !default_channel).people !current_nick)
701 with Not_found -> "")
704 (if Hashtbl.mem current_modes 'i' then "i" else "") ^
705 (if Hashtbl.mem current_modes 'O' then "i" else "") ^
706 (if Hashtbl.mem current_modes 'o' then "i" else "") ^
707 (if Hashtbl.mem current_modes 'w' then "w" else "") ^
708 (if Hashtbl.mem current_modes 'a' then "a" else "") ^
710 if !default_channel = "" then ""
712 " on " ^ !default_channel ^
713 let modes = (find_joined !default_channel).modes in
715 (if Hashtbl.mem modes 'm' then "m" else "") ^
716 (if Hashtbl.mem modes 'i' then "i" else "") ^
717 (if Hashtbl.mem modes 's' then "s" else "") ^
718 (if Hashtbl.mem modes 'n' then "n" else "") ^
719 (if Hashtbl.mem modes 't' then "t" else "") ^
720 (try " key=" ^ (Hashtbl.find modes 'k') with Not_found -> "") ^
721 (try " limit=" ^ (Hashtbl.find modes 'l') with Not_found -> "") ^
725 (*****************************************************************************)
726 (* Function to handle the various commands received from the server *)
727 (*****************************************************************************)
729 (* This one just write a certain token as it is *)
731 let print_information i = fun tokens -> printh "I" tokens.(i);;
733 (* Here is the serious stuff ... each entry is a fun able to
734 interprete the tokens given as parameters *)
736 Hashtbl.add protocole_managers "001"
738 fun tokens -> current_nick := tokens.(2);
739 printh "I" ("You are now connected as " ^ tokens.(2))
742 Hashtbl.add protocole_managers "PING"
744 fun tokens -> tell_server ("PONG " ^ tokens.(2) ^ "\n")
747 Hashtbl.add protocole_managers "JOIN"
750 let (nick, login, host) = split_prefix tokens.(0) in
751 if nick = !current_nick
753 printh ">" ("You have joined " ^ tokens.(2));
754 set_joined tokens.(2) { name=tokens.(2); people= Hashtbl.create 10; modes = Hashtbl.create 10 };
755 default_channel := tokens.(2);
756 tell_server ("MODE " ^ tokens.(2) ^ "\n")
758 else printh ">" (nick ^ " (" ^ login ^ "@" ^ host ^ ") has joined " ^ tokens.(2));
759 Hashtbl.replace (find_joined tokens.(2)).people nick { operator = false }
762 Hashtbl.add protocole_managers "PART"
765 let (nick, login, host) = split_prefix tokens.(0) in
766 if nick = !current_nick
768 printh "<" ("You have left " ^ tokens.(2));
769 part_channel tokens.(2)
772 printh "<" (nick ^ " (" ^ login ^ "@" ^ host ^ ") has left " ^ tokens.(2));
773 Hashtbl.remove (find_joined tokens.(2)).people nick;
777 Hashtbl.add protocole_managers "QUIT"
779 fun tokens -> let (nick, login, host) = split_prefix tokens.(0) in
782 (fun name data s -> if Hashtbl.mem data.people nick then s ^ " " ^ data.name else s)
783 joined_channels "" in
784 printh "<" ("Signoff: " ^ nick ^ " (" ^ tokens.(2) ^ ") from" ^ channels);
785 Hashtbl.iter (fun name data -> Hashtbl.remove data.people nick) joined_channels;
788 Hashtbl.add protocole_managers "KICK"
791 let (nick, login, host) = split_prefix tokens.(0) in
792 if tokens.(3) = !current_nick
794 printh "<" ("You have been kicked from " ^ tokens.(2) ^ " by " ^ nick ^ " (" ^ tokens.(4)^ ")");
795 part_channel tokens.(2)
797 else printh "<" (tokens.(3) ^ " has been kicked from " ^ tokens.(2) ^ " by " ^ nick ^ " (" ^ tokens.(4) ^ ")");
798 Hashtbl.remove (find_joined tokens.(2)).people tokens.(3);
801 Hashtbl.add protocole_managers "NICK"
803 fun tokens -> let (nick, login, host) = split_prefix tokens.(0) in
804 if nick = !current_nick
806 printh "I" ("You are now known as " ^ tokens.(2));
807 current_nick := tokens.(2)
809 else printh "I" (nick ^ " is now known as " ^ tokens.(2));
812 let u = Hashtbl.find data.people nick in
814 Hashtbl.remove data.people nick;
815 Hashtbl.add data.people tokens.(2) u
819 Hashtbl.iter rename joined_channels;
822 Hashtbl.add protocole_managers "MODE"
825 let (nick, login, host) = try split_prefix tokens.(0) with Not_found -> (tokens.(0), "", "") in
826 let modes = flatten_modes 1 tokens.(3) 0 tokens 4 in
827 if match String.get tokens.(2) 0 with '#' | '&' -> true | _ -> false
830 set_modes (String.uppercase tokens.(2)) modes;
831 printh "I" ("Mode change by " ^ nick ^ " on channel " ^ tokens.(2) ^ (string_of_modelist modes))
836 (function (c, 1, x) -> Hashtbl.replace current_modes c x | (c, -1, x) -> Hashtbl.remove current_modes c | _ -> ())
838 printh "I" ("Mode change" ^ (string_of_modelist modes) ^ " by " ^ nick ^ " for user " ^ tokens.(2))
842 Hashtbl.add protocole_managers "TOPIC"
845 let (nick, login, host) = split_prefix tokens.(0) in
846 printh "I" (nick ^ " has changed the topic on " ^ tokens.(2) ^ " to \"" ^ tokens.(3) ^ "\"")
849 Hashtbl.add protocole_managers "ERROR"
851 fun tokens -> printh "E" tokens.(2)
854 Hashtbl.add protocole_managers "PRIVMSG"
857 let (nick, login, host) = split_prefix tokens.(0) in
859 let n1 = String.index tokens.(3) '
\ 1' in
860 let n2 = String.index_from tokens.(3) (n1 + 1) '
\ 1' in
861 let ctcp_line = (String.sub tokens.(3) (n1 + 1) (n2 - n1 - 1)) in
862 let (ctcp_token, ctcp_tail) = tokenizer ctcp_line ' ' in
863 let cmd = ctcp_token () in
865 (Hashtbl.find ctcp_managers cmd) ctcp_token ctcp_tail nick tokens.(2)
867 Not_found -> printh "E" ("Unknown CTCP [" ^ ctcp_line ^ "] from " ^ nick);
868 tell_server ("NOTICE " ^ nick ^ " :Unknown CTCP " ^ cmd ^ "'\n")
872 if (String.get tokens.(2) 0) = '#'
873 then print ("<" ^ nick ^ (if same_channel tokens.(2) !default_channel then "" else ("/" ^ tokens.(2))) ^ "> " ^
876 tell_ssfe (Tabulable ("/msg " ^ nick ^ " "));
877 print ("[" ^ nick ^ "] " ^ tokens.(3))
882 Hashtbl.add protocole_managers "NOTICE"
885 let (nick, login, host) = split_prefix tokens.(0) in
886 print ("-" ^ nick ^ (if tokens.(2) = !current_nick then "" else "/" ^ tokens.(2)) ^ "- " ^ tokens.(3))
889 Hashtbl.add protocole_managers "301"
891 fun tokens -> printh "I" (tokens.(3) ^ " is away (" ^ tokens.(4) ^ ")")
894 Hashtbl.add protocole_managers "311"
896 fun tokens -> printh "I" (tokens.(3) ^ " is " ^ tokens.(4) ^ "@" ^ tokens.(5) ^ " (" ^ tokens.(7) ^ ")")
899 Hashtbl.add protocole_managers "312"
901 fun tokens -> printh "I" ("on IRC via server " ^ tokens.(4) ^ " (" ^ tokens.(5) ^ ")")
904 Hashtbl.add protocole_managers "317"
907 let duration = int_of_string tokens.(4) in
908 printh "I" (tokens.(3) ^ " has been idle for " ^ (duration_of_seconds duration))
911 Hashtbl.add protocole_managers "319"
913 fun tokens -> printh "I" ("on channels: " ^ tokens.(4))
916 Hashtbl.add protocole_managers "324"
918 fun tokens -> set_modes tokens.(3) (flatten_modes 1 tokens.(4) 0 tokens 5)
921 Hashtbl.add protocole_managers "322"
923 fun tokens -> printh "I" ("There are " ^ tokens.(4) ^ " users on " ^ tokens.(3))
926 Hashtbl.add protocole_managers "331"
928 fun tokens -> printh "I" ("No topic is set on " ^ tokens.(3))
931 Hashtbl.add protocole_managers "333"
933 fun tokens -> printh "I" ("Topic for " ^ tokens.(3) ^ " set by " ^ tokens.(2))
938 fun s -> Hashtbl.add protocole_managers s (print_information 3)
940 [ "002"; "003"; "005"; "020"; "042";
941 "251"; "252"; "253"; "255"; "265"; "266";
945 Hashtbl.add protocole_managers "305"
947 fun tokens -> printh "I" tokens.(3); Hashtbl.remove current_modes 'a'
950 Hashtbl.add protocole_managers "306"
952 fun tokens -> printh "I" tokens.(3); Hashtbl.replace current_modes 'a' ""
955 Hashtbl.add protocole_managers "403" (print_information 4);
959 fun s -> Hashtbl.add protocole_managers s (fun tokens -> ())
963 Hashtbl.add protocole_managers "004"
965 fun tokens -> printh "I" (tokens.(3) ^ " " ^ tokens.(4) ^ " " ^ tokens.(5) ^ " " ^ tokens.(6))
968 Hashtbl.add protocole_managers "254"
970 fun tokens -> printh "I" ("There are " ^ tokens.(3) ^ " " ^ tokens.(4))
973 Hashtbl.add protocole_managers "332"
975 fun tokens -> printh "I" ("Topic for " ^ tokens.(3) ^ " is '" ^ tokens.(4) ^ "'")
978 Hashtbl.add protocole_managers "353"
981 printh "I" ("Users on " ^ tokens.(4) ^ ": " ^ tokens.(5));
982 let (n_token, n_tail) = tokenizer tokens.(5) ' '
983 and people_table = (find_joined tokens.(4)).people in
984 let rec add_nick = fun () ->
986 (let nick = n_token () in match String.get nick 0 with
987 '@' -> Hashtbl.replace people_table (String.sub nick 1 ((String.length nick) - 1)) { operator = true }
988 | _ -> Hashtbl.replace people_table nick { operator = false });
994 Hashtbl.add protocole_managers "366"
997 (*let users = Hashtbl.fold (fun nick status s -> " " ^ nick ^ s) (find_joined tokens.(3)).people "" in
998 printh "I" ("Users on " ^ tokens.(3) ^ ":" ^ users)*)
1001 Hashtbl.add protocole_managers "401"
1003 fun tokens -> printh "E" ("Can not find " ^ tokens.(3) ^ " on IRC")
1006 Hashtbl.add protocole_managers "433"
1010 then printh "E" ("Nickname " ^ tokens.(3) ^ " already in used, type /nick <nick> to choose another one")
1011 else printh "E" ("Nickname " ^ tokens.(3) ^ " already in used, you keep " ^ tokens.(2))
1014 Hashtbl.add protocole_managers "441"
1016 fun tokens -> printh "E" (tokens.(3) ^ " is not on channel " ^ tokens.(4))
1019 Hashtbl.add protocole_managers "461"
1021 fun tokens -> printh "E" ("Not enough parameters for " ^ tokens.(3))
1024 Hashtbl.add protocole_managers "472"
1026 fun tokens -> printh "E" ("Mode '" ^ tokens.(3) ^ "' " ^ tokens.(4))
1029 Hashtbl.add protocole_managers "474"
1031 fun tokens -> printh "E" ("Can not join " ^ tokens.(3) ^ " (banned)")
1034 Hashtbl.add protocole_managers "475"
1036 fun tokens -> printh "E" (tokens.(3) ^ ": " ^ tokens.(4))
1039 Hashtbl.add protocole_managers "482"
1041 fun tokens -> printh "E" ("You are not an operator on " ^ tokens.(3))
1044 (*****************************************************************************)
1045 (* The module initialization *)
1046 (*****************************************************************************)
1051 Dynlink.add_interfaces
1052 [ "Ircml"; "Buffer"; "List"; "Arg"; "String"; "Digest"; "Dynlink"; "Hashtbl"; "Sys";
1053 "Connection"; "Unix"; "Pervasives"; "Array" ]
1054 [ Sys.getcwd(); "/home/fleuret/local/lib/ocaml" ];
1057 Dynlink.Error error -> printh "E" ("Module loading error (" ^ (Dynlink.error_message error) ^ ")");;
1059 try ignore (Unix.tcgetattr Unix.stdout) with Unix.Unix_error _ -> print "`#ssfe#i";;
1061 (*****************************************************************************)
1063 (*****************************************************************************)
1065 print "-----------------------------------------------------------------------------";
1066 print (" " ^ version ^ ", the IRC client in OCAML");
1067 print " Written and (c) by <francois.fleuret@epfl.ch>";
1068 print "-----------------------------------------------------------------------------";
1070 establish_connection ();
1076 let (reading, _, _) = Unix.select (keys fd_active) [] [] 1.0 in
1081 let h = Hashtbl.find fd_active fd in
1082 try h.reader () with Network_error(e) -> h.error_handler e
1086 tell_ssfe (Status (get_status ()))
1090 printh "I" "You'll be back, ho yes ... you'll be back"