From 41ed4cf0af1eab1c7b14246f8e1e09fd7b8f3ac9 Mon Sep 17 00:00:00 2001 From: Francois Fleuret Date: Sun, 16 Mar 2008 20:57:29 +0100 Subject: [PATCH] automatic commit --- INSTALL | 13 + LICENSE | 340 +++++++++++++++ Makefile | 35 ++ connection.ml | 142 +++++++ connection.mli | 28 ++ ircml.ml | 1090 ++++++++++++++++++++++++++++++++++++++++++++++++ 6 files changed, 1648 insertions(+) create mode 100644 INSTALL create mode 100644 LICENSE create mode 100644 Makefile create mode 100644 connection.ml create mode 100644 connection.mli create mode 100644 ircml.ml diff --git a/INSTALL b/INSTALL new file mode 100644 index 0000000..f27587b --- /dev/null +++ b/INSTALL @@ -0,0 +1,13 @@ + +1) To make the ircml executable + +> make + +2) To make the ssfe front-end (if it's not already installed on your +machine), type + +> gcc -o ssfe -lncurses ssfe.c + +3) To run ircml + +> ./ssfe ./ircml -nick minick -server my.irc.server diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..d60c31a --- /dev/null +++ b/LICENSE @@ -0,0 +1,340 @@ + GNU GENERAL PUBLIC LICENSE + Version 2, June 1991 + + Copyright (C) 1989, 1991 Free Software Foundation, Inc. + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +License is intended to guarantee your freedom to share and change free +software--to make sure the software is free for all its users. This +General Public License applies to most of the Free Software +Foundation's software and to any other program whose authors commit to +using it. (Some other Free Software Foundation software is covered by +the GNU Library General Public License instead.) You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +this service if you wish), that you receive source code or can get it +if you want it, that you can change the software or use pieces of it +in new free programs; and that you know you can do these things. + + To protect your rights, we need to make restrictions that forbid +anyone to deny you these rights or to ask you to surrender the rights. +These restrictions translate to certain responsibilities for you if you +distribute copies of the software, or if you modify it. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must give the recipients all the rights that +you have. You must make sure that they, too, receive or can get the +source code. And you must show them these terms so they know their +rights. + + We protect your rights with two steps: (1) copyright the software, and +(2) offer you this license which gives you legal permission to copy, +distribute and/or modify the software. + + Also, for each author's protection and ours, we want to make certain +that everyone understands that there is no warranty for this free +software. If the software is modified by someone else and passed on, we +want its recipients to know that what they have is not the original, so +that any problems introduced by others will not reflect on the original +authors' reputations. + + Finally, any free program is threatened constantly by software +patents. We wish to avoid the danger that redistributors of a free +program will individually obtain patent licenses, in effect making the +program proprietary. To prevent this, we have made it clear that any +patent must be licensed for everyone's free use or not licensed at all. + + The precise terms and conditions for copying, distribution and +modification follow. + + GNU GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License applies to any program or other work which contains +a notice placed by the copyright holder saying it may be distributed +under the terms of this General Public License. The "Program", below, +refers to any such program or work, and a "work based on the Program" +means either the Program or any derivative work under copyright law: +that is to say, a work containing the Program or a portion of it, +either verbatim or with modifications and/or translated into another +language. (Hereinafter, translation is included without limitation in +the term "modification".) Each licensee is addressed as "you". + +Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running the Program is not restricted, and the output from the Program +is covered only if its contents constitute a work based on the +Program (independent of having been made by running the Program). +Whether that is true depends on what the Program does. + + 1. You may copy and distribute verbatim copies of the Program's +source code as you receive it, in any medium, provided that you +conspicuously and appropriately publish on each copy an appropriate +copyright notice and disclaimer of warranty; keep intact all the +notices that refer to this License and to the absence of any warranty; +and give any other recipients of the Program a copy of this License +along with the Program. + +You may charge a fee for the physical act of transferring a copy, and +you may at your option offer warranty protection in exchange for a fee. + + 2. You may modify your copy or copies of the Program or any portion +of it, thus forming a work based on the Program, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) You must cause the modified files to carry prominent notices + stating that you changed the files and the date of any change. + + b) You must cause any work that you distribute or publish, that in + whole or in part contains or is derived from the Program or any + part thereof, to be licensed as a whole at no charge to all third + parties under the terms of this License. + + c) If the modified program normally reads commands interactively + when run, you must cause it, when started running for such + interactive use in the most ordinary way, to print or display an + announcement including an appropriate copyright notice and a + notice that there is no warranty (or else, saying that you provide + a warranty) and that users may redistribute the program under + these conditions, and telling the user how to view a copy of this + License. (Exception: if the Program itself is interactive but + does not normally print such an announcement, your work based on + the Program is not required to print an announcement.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Program, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Program, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Program. + +In addition, mere aggregation of another work not based on the Program +with the Program (or with a work based on the Program) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may copy and distribute the Program (or a work based on it, +under Section 2) in object code or executable form under the terms of +Sections 1 and 2 above provided that you also do one of the following: + + a) Accompany it with the complete corresponding machine-readable + source code, which must be distributed under the terms of Sections + 1 and 2 above on a medium customarily used for software interchange; or, + + b) Accompany it with a written offer, valid for at least three + years, to give any third party, for a charge no more than your + cost of physically performing source distribution, a complete + machine-readable copy of the corresponding source code, to be + distributed under the terms of Sections 1 and 2 above on a medium + customarily used for software interchange; or, + + c) Accompany it with the information you received as to the offer + to distribute corresponding source code. (This alternative is + allowed only for noncommercial distribution and only if you + received the program in object code or executable form with such + an offer, in accord with Subsection b above.) + +The source code for a work means the preferred form of the work for +making modifications to it. For an executable work, complete source +code means all the source code for all modules it contains, plus any +associated interface definition files, plus the scripts used to +control compilation and installation of the executable. However, as a +special exception, the source code distributed need not include +anything that is normally distributed (in either source or binary +form) with the major components (compiler, kernel, and so on) of the +operating system on which the executable runs, unless that component +itself accompanies the executable. + +If distribution of executable or object code is made by offering +access to copy from a designated place, then offering equivalent +access to copy the source code from the same place counts as +distribution of the source code, even though third parties are not +compelled to copy the source along with the object code. + + 4. You may not copy, modify, sublicense, or distribute the Program +except as expressly provided under this License. Any attempt +otherwise to copy, modify, sublicense or distribute the Program is +void, and will automatically terminate your rights under this License. +However, parties who have received copies, or rights, from you under +this License will not have their licenses terminated so long as such +parties remain in full compliance. + + 5. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Program or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Program (or any work based on the +Program), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Program or works based on it. + + 6. Each time you redistribute the Program (or any work based on the +Program), the recipient automatically receives a license from the +original licensor to copy, distribute or modify the Program subject to +these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties to +this License. + + 7. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Program at all. For example, if a patent +license would not permit royalty-free redistribution of the Program by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Program. + +If any portion of this section is held invalid or unenforceable under +any particular circumstance, the balance of the section is intended to +apply and the section as a whole is intended to apply in other +circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system, which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 8. If the distribution and/or use of the Program is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Program under this License +may add an explicit geographical distribution limitation excluding +those countries, so that distribution is permitted only in or among +countries not thus excluded. In such case, this License incorporates +the limitation as if written in the body of this License. + + 9. The Free Software Foundation may publish revised and/or new versions +of the General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + +Each version is given a distinguishing version number. If the Program +specifies a version number of this License which applies to it and "any +later version", you have the option of following the terms and conditions +either of that version or of any later version published by the Free +Software Foundation. If the Program does not specify a version number of +this License, you may choose any version ever published by the Free Software +Foundation. + + 10. If you wish to incorporate parts of the Program into other free +programs whose distribution conditions are different, write to the author +to ask for permission. For software which is copyrighted by the Free +Software Foundation, write to the Free Software Foundation; we sometimes +make exceptions for this. Our decision will be guided by the two goals +of preserving the free status of all derivatives of our free software and +of promoting the sharing and reuse of software generally. + + NO WARRANTY + + 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY +FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN +OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES +PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED +OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS +TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE +PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, +REPAIR OR CORRECTION. + + 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR +REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, +INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING +OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED +TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY +YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER +PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGES. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +convey the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This program 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 of the License, or + (at your option) any later version. + + This program 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 this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + + +Also add information on how to contact you by electronic and paper mail. + +If the program is interactive, make it output a short notice like this +when it starts in an interactive mode: + + Gnomovision version 69, Copyright (C) year name of author + Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, the commands you use may +be called something other than `show w' and `show c'; they could even be +mouse-clicks or menu items--whatever suits your program. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the program, if +necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the program + `Gnomovision' (which makes passes at compilers) written by James Hacker. + + , 1 April 1989 + Ty Coon, President of Vice + +This General Public License does not permit incorporating your program into +proprietary programs. If your program is a subroutine library, you may +consider it more useful to permit linking proprietary applications with the +library. If this is what you want to do, use the GNU Library General +Public License instead of this License. diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..546f147 --- /dev/null +++ b/Makefile @@ -0,0 +1,35 @@ + +############################################################################## +# This program is free software; you can redistribute it and/or # +# modify it under the terms of the GNU General Public License # +# version 2 as published by the Free Software Foundation. # +# # +# This program 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. # +# # +# Written and (c) by François Fleuret # +# Contact for comments & bug reports # +############################################################################## + +ARCHIVE_NAME = ircml_`date +%d-%m-%y` + +OCAMLC=ocamlc + +all: ircml + +%.cmi: %.mli + ${OCAMLC} -g -c $^ + +%.cmo: %.ml + ${OCAMLC} -g -c $^ + +ircml: connection.cmi connection.cmo ircml.ml + ${OCAMLC} -g -o ircml unix.cma dynlink.cma connection.cmo ircml.ml + +clean: + \rm *.cm? ircml + +archive: + cd ..; tar zcvf $(ARCHIVE_NAME).tgz ircml/*.ml ircml/*.mli ircml/*.c ircml/Makefile ircml/LICENSE ircml/INSTALL diff --git a/connection.ml b/connection.ml new file mode 100644 index 0000000..156401e --- /dev/null +++ b/connection.ml @@ -0,0 +1,142 @@ +(* -*- mode: tuareg -*- ******************************************************) +(* *) +(* Written by and (c) Francois Fleuret, 2002 *) +(* Contact for info and bug reports *) +(* *) +(* This program 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. See the file LICENSE for more details. *) +(* *) +(*****************************************************************************) + +let buffer_length = 4096 + +exception Network_error of string + +let bytes_of_int n = + let s = "0000" in + String.set s 3 (char_of_int (n land 255)); + String.set s 2 (char_of_int ((n lsr 8) land 255)); + String.set s 1 (char_of_int ((n lsr 16) land 255)); + String.set s 0 (char_of_int ((n lsr 24) land 255)); + s;; + +let int_of_bytes s = + try + int_of_char (String.get s 3) + + 256 * (int_of_char (String.get s 2) + + 256 * (int_of_char (String.get s 1) + + 256 * int_of_char (String.get s 0))) + with + _ -> -1;; + +(* What a shame that I have to do this ... *) + +let dot_to_number s = + let rec decode_rec k = + try + let l = String.index_from s k '.' in (int_of_string (String.sub s k (l-k)))::(decode_rec (l+1)) + with + Not_found -> [ int_of_string (String.sub s k ((String.length s) - k)) ] + in + let k = List.fold_left (fun x y -> Int64.add (Int64.mul (Int64.of_int 256) x) (Int64.of_int y)) Int64.zero (decode_rec 0) + in Int64.to_string k;; + +let connect (hostname: string) (port: int) = + try + let s = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in + Unix.connect s (Unix.ADDR_INET(((Unix.gethostbyname hostname).Unix.h_addr_list).(0), port)); + s + with + Not_found -> raise (Network_error("Unknown host " ^ hostname)) + | Unix.Unix_error(e, fname, fparam) -> raise (Network_error(fname ^ ": " ^ Unix.error_message(e))) + +let listen port = + try + let s = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in + Unix.bind s (Unix.ADDR_INET(Unix.inet_addr_any, port)); + Unix.listen s 4; + s + with + Unix.Unix_error(e, fname, fparam) -> raise (Network_error(fname ^ ": " ^ Unix.error_message(e))) + +type rstream = { rdescr: Unix.file_descr; buffer: string; mutable pos: int } + +let read_lines (rc: rstream) (reader: string -> unit) = + try + (* We read as much available characters as we can to fill up the + buffer *) + let s = Unix.read rc.rdescr rc.buffer rc.pos (buffer_length - rc.pos) in + if s <= 0 + then raise (Network_error((string_of_int s) ^ " character(s) read")) + else rc.pos <- rc.pos + s; + (* the 'read' function applies the reader to the new lines we got, + starting at character 'current' *) + let rec read current = + try + (* if we are already after the end, finish *) + if(current >= rc.pos) then raise Not_found; + (* Look for a \n in the remaining part of the buffer *) + let cr = (String.index_from rc.buffer current '\n') in + (* If it is afte`r the 'fresh' data, it means we do not have \n + remaining, raise a Not_found *) + if (cr >= rc.pos) then raise Not_found; + (* We have found a \n, applies the reader to the line it ends *) + reader (String.sub rc.buffer current (cr - current)); + read (cr+1) + with + (* No more lines in the buffer *) + Not_found -> + (* moves the remaining characters to the beginning of the buffer *) + if(current < rc.pos) then String.blit rc.buffer current rc.buffer 0 (rc.pos - current); + (* refreshes the index where to put next incoming characters *) + rc.pos <- (rc.pos - current); + in read 0 + with + Unix.Unix_error(e, fname, fparam) -> raise (Network_error (fname ^ ": " ^ (Unix.error_message e))) + +let linizer = fun (d: Unix.file_descr) (reader: string -> unit) () -> + read_lines { rdescr = d; buffer = String.create buffer_length; pos = 0 } reader;; + +let read_binary (fd: Unix.file_descr) (reader: string -> unit) = + try + let buffer = String.create buffer_length in + let s = Unix.read fd buffer 0 buffer_length in + if s <= 0 + then raise (Network_error((string_of_int s) ^ " character(s) read")); + reader (String.sub buffer 0 s) + with + Unix.Unix_error(e, fname, fparam) -> raise (Network_error (fname ^ ": " ^ (Unix.error_message e)));; + +let binarizer = fun (d: Unix.file_descr) (reader: string -> unit) () -> read_binary d reader;; + +(******************************************************************************) +(* A tokenizer takes a string and a separator and returns two functions *) +(* unit -> string, the first returning the tokens one after another, and the *) +(* second returning the remaining part of the string. *) +(******************************************************************************) + +let (tokenizer: string -> char -> (unit -> string) * (unit -> string)) = fun line c -> + +let index = ref 0 in + +let token () = let n = !index in +try + let m = (String.index_from line n c) in + index := m + 1; + while !index < (String.length line) && (String.get line !index = c) do index := !index+1; done; + String.sub (line) n (m - n) +with + Not_found -> if !index < (String.length line) + then begin + index := (String.length line); + String.sub (line) n (!index - n) + end + else raise Not_found + +and tail () = + if !index < (String.length line) + then let n = !index in (index := (String.length line); String.sub (line) n (!index - n)) + else raise Not_found + +in (token, tail);; diff --git a/connection.mli b/connection.mli new file mode 100644 index 0000000..5da8eda --- /dev/null +++ b/connection.mli @@ -0,0 +1,28 @@ +(* -*- mode: tuareg -*- ******************************************************) +(* *) +(* Written by and (c) Francois Fleuret, 2002 *) +(* Contact for info and bug reports *) +(* *) +(* This program 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. See the file LICENSE for more details. *) +(* *) +(*****************************************************************************) + +exception Network_error of string + +val bytes_of_int : int -> string +val int_of_bytes : string -> int +val dot_to_number : string -> string +val connect : string -> int -> Unix.file_descr +val listen : int -> Unix.file_descr + +(* (linizer fd reader) is a function that, when called, applies the + reader to each available line (individually) from fd *) +val linizer : Unix.file_descr -> (string -> unit) -> (unit -> unit) + +(* Same, but instead of being applied to each line individually, it + will be applied to all available bytes at all *) +val binarizer : Unix.file_descr -> (string -> unit) -> (unit -> unit) + +val tokenizer: string -> char -> (unit -> string) * (unit -> string) diff --git a/ircml.ml b/ircml.ml new file mode 100644 index 0000000..d0ab137 --- /dev/null +++ b/ircml.ml @@ -0,0 +1,1090 @@ +(* -*- mode: tuareg -*- ******************************************************) +(* *) +(* This is a light IRC client written in CAML *) +(* Written by and (c) Francois Fleuret, 2002 - 2005 *) +(* Contact for info and bug reports *) +(* *) +(* This program is free software; you can redistribute it and/or modify *) +(* it under the terms of the GNU General Public License Version 2 as *) +(* published by the Free Software Foundation. See the file LICENSE for *) +(* more details. *) +(* *) +(*****************************************************************************) + +open Connection;; + +(* I removed all the dcc stuff between v0.25 and v0.5 because it was a + biiiig pile of crap. Feel free to write it ! *) + +let version = "IRCML v0.5";; + +let term_bold = ref "" +and term_underline = ref "" +and term_inverse = ref "" +and term_reset = ref "";; + +(*****************************************************************************) +(* Various stuff *) +(*****************************************************************************) + +let keys h = Hashtbl.fold (fun key data accu -> key :: accu) h [] + +let verbose = ref false;; + +(* Return the element after the given one, or the first of the list if + the given one is the last *) + +let circular_succ = + fun x l -> + let rec next_rec x = function + [] -> raise Not_found + | h::t -> if h = x then List.hd t else next_rec x t + in try next_rec x l with Failure(e) -> List.hd l;; + +let string_of_size size = + if size > 1048576 then (string_of_int (size / 1048576))^"Mb" + else if size > 1024 then (string_of_int (size / 1024))^"Kb" + else (string_of_int size) ^ "b";; + +let duration_of_seconds duration = + (if duration >= 3600 then (string_of_int (duration/3600))^"h" else "") ^ + (if (duration mod 3600) >= 60 then (string_of_int ((duration mod 3600)/60))^"min" else "") ^ + (if (duration mod 60) > 0 then (string_of_int (duration mod 60))^"s" else "");; + +(*****************************************************************************) +(* The global variables *) +(*****************************************************************************) + +type user_status = { mutable operator: bool } +let string_of_user = fun u -> (if u.operator then "@" else "") + +type channel = { name: string; people: (string, user_status) Hashtbl.t ; modes: (char, string) Hashtbl.t };; + +let ssfe = ref false + +and my_host = ref "" + +and desired_nick = ref "b0z0" +and desired_server = ref "localhost" +and desired_port = ref 6667 + +and current_nick = ref "" +and (current_modes: (char, string) Hashtbl.t) = Hashtbl.create 10 +and default_channel = ref "" + +and login = ref "c4mlp0w4" +and name = ref ("Using " ^ version ^ ", the light IRC client in CAML") + +and alive = ref true;; + +(* Print something with a 'header character' à la sirc *) +(* '<' Leaving channel (part, kick, signoff, etc.) *) +(* '>' Joining a channel *) +(* 'E' Error *) +(* 'I' Information *) +(* 'X' Internal error, should never meet one *) +let printh h s = output_string Pervasives.stdout + begin + match h with + "E" -> (!term_bold ^ "*" ^ h ^ "*" ^ " " ^ s ^ !term_reset ^ "\n") + | _ -> (!term_bold ^ "*" ^ h ^ "*" ^ !term_reset ^ " " ^ s ^ "\n") + end;; + +(* Simply print something in the console *) +let print s = output_string Pervasives.stdout (s ^ "\n");; + +type ssfe_cmd = Status of string | Tabulable of string;; + +let current_status = ref "";; + +let tell_ssfe x = + if !ssfe then begin + match x with + Status(s) -> if not (s = !current_status) then (current_status := s; print ("`#ssfe#s" ^ s)) + | Tabulable(s) -> print ("`#ssfe#t" ^ s) + end;; + +(*****************************************************************************) +(* Command line parameter parsing *) +(*****************************************************************************) + +Arg.parse [ ("-nick", Arg.String(fun n -> desired_nick := n), "Set the desired nick"); + ("-server", Arg.String(fun s -> desired_server := s), "Set the desired server"); + ("-port", Arg.Int(fun p -> desired_port := p), "Set the desired port"); + ("-login", Arg.String(fun s -> login := s), "Set the login"); + ("-name", Arg.String(fun s -> name := s), "Set the name") ] + (fun s -> ()) "Unknown option";; + +(*****************************************************************************) +(* The connection with the server *) +(*****************************************************************************) + +type connection = + Established of Unix.file_descr + | Broken;; + +let last_server_msg = ref 0;; + +let server_connection = ref Broken;; + +(* This is the list of file descriptors active for reading. Each one + corresponds to a reader which will be called when something is + readable and a exception-handler, called if the connection is lost, + with the reason *) + +type fd_machine = { reader: unit -> unit; error_handler: string -> unit };; + +let (fd_active: (Unix.file_descr, fd_machine) Hashtbl.t) = Hashtbl.create 10;; + +(*****************************************************************************) +(* Handling of the channel list *) +(*****************************************************************************) + +let (joined_channels: (string, channel) Hashtbl.t) = Hashtbl.create 10;; + +let find_joined c = Hashtbl.find joined_channels (String.uppercase c) +and mem_joined c = Hashtbl.mem joined_channels (String.uppercase c) +and set_joined c x = Hashtbl.replace joined_channels (String.uppercase c) x +and remove_joined c = Hashtbl.remove joined_channels (String.uppercase c) +and same_channel c1 c2 = (String.uppercase c1) = (String.uppercase c2);; + +let part_channel channel = + remove_joined channel; + if !default_channel = channel + then match (keys joined_channels) with + [] -> default_channel := ""; if not !ssfe then printh "I" "Not in a channel anymore" + | c::t -> default_channel := c; printh "I" ("Talking to " ^ !default_channel ^ " now");; + +(*****************************************************************************) +(* Takes a string and returns an array of strings corresponding to the *) +(* tokens in the IRC protocole syntax. I.e. tokens are separated by white *) +(* spaces except the tail which is after a ':' *) +(*****************************************************************************) + +let (irc_tokenize: string -> string array) = fun s -> + let l = (String.length s) in + let rec irc_tokenize s n = + if String.get s n == ':' then [String.sub s (n + 1) (l - n - 2)] else + try + let m = String.index_from s n ' ' in + let h = String.sub s n (m - n) in + h::irc_tokenize s (m+1) + with + Not_found -> if n < l then [String.sub s n (l - n - 1)] else [] + in + (* Ignore the prefix if there is one *) + if (String.get s 0) == ':' then + let n = (String.index s ' ') in Array.of_list ((String.sub s 1 (n - 1))::(irc_tokenize s (n+1))) + else Array.of_list (""::(irc_tokenize s 0));; + +(* Function to split the "nick!login@host" *) + +let (split_prefix: string -> string * string * string) = fun prefix -> + let n1 = (String.index prefix '!') in + let n2 = (String.index_from prefix n1 '@') in + (String.sub prefix 0 n1, + String.sub prefix (n1 + 1) (n2 - (n1 + 1)), + String.sub prefix (n2 + 1) ((String.length prefix) - (n2 + 1)));; + +(*****************************************************************************) +(* The aliases *) +(*****************************************************************************) + +let (cmd_aliases: (string, string) Hashtbl.t) = Hashtbl.create 100;; + +List.iter (fun (a, b) -> Hashtbl.replace cmd_aliases a b) [ + ("J", "JOIN"); ("M", "MSG"); ("K", "KICK"); ("L", "CHANINFO"); + ("N", "NICK"); ("Q", "QUIT"); ("T", "TOPIC"); ("W", "WHOIS"); + ("DC", "DISCONNECT"); ("S", "SERVER"); ("H", "HELP") +];; + +(*****************************************************************************) +(* The managers will be filled later *) +(*****************************************************************************) + +let (protocole_managers: (string, string array -> unit) Hashtbl.t) = Hashtbl.create 100;; +let (cmd_managers: (string, string * ((unit -> string) -> (unit -> string) -> unit)) Hashtbl.t) = Hashtbl.create 100;; +let (ctcp_managers: (string, (unit -> string) -> (unit -> string) -> string -> string -> unit) Hashtbl.t) = Hashtbl.create 10;; + +(*****************************************************************************) +(* The routines handling lines from the server or the user *) +(*****************************************************************************) + +let print_unknown_protocole = fun tokens -> + let buffer = Buffer.create 100 in + Buffer.add_string buffer "Unknown protocole"; + for i = 0 to ((Array.length tokens) - 1) do + Buffer.add_string buffer (" " ^ (string_of_int i) ^ ":(" ^ tokens.(i) ^ ")"); + done; + printh "X" (Buffer.contents buffer);; + +let server_line_handler = fun line -> + if !verbose then (print_string ("SERVER [" ^ line ^ "]\n"); flush stdout); + last_server_msg := int_of_float (Unix.time ()); + let tokens = (irc_tokenize line) in + try + let f = Hashtbl.find protocole_managers tokens.(1) in + try f tokens with Not_found -> printh "E" ("Protocole " ^ tokens.(1) ^ " raised Not_found!") + with + Not_found -> print_unknown_protocole tokens;; + +let kill_server_connection error_message = + match !server_connection with + Established(fd) -> + begin + Hashtbl.remove fd_active fd; + server_connection := Broken; + printh "E" ("Connection lost (" ^ error_message ^ ")"); + default_channel := ""; + Hashtbl.clear joined_channels + end + | Broken -> exit 1;; + +let tell_server line = + match !server_connection with + Established(fd) -> + begin + try + if (Unix.write fd line 0 (String.length line)) <= 0 then kill_server_connection ("write error") + with + Unix.Unix_error(e, fname, fparam) -> kill_server_connection (fname ^ ": " ^ (Unix.error_message e)) + end + | Broken -> printh "E" "No connection";; + +let establish_connection () = + match !server_connection with + Established(_) -> printh "E" "Connection already established (try /DISCONNECT first)" + | Broken -> + printh "I" ("Attempting connection to " ^ !desired_server ^ + ":" ^ (string_of_int !desired_port) ^ + " with nick " ^ !desired_nick); + try + let fd = Connection.connect !desired_server !desired_port in + begin + match Unix.getsockname fd with + Unix.ADDR_INET(ai, _) -> my_host := Connection.dot_to_number (Unix.string_of_inet_addr ai) + | _ -> printh "E" "Internal error #0"; + end; + server_connection := Established(fd); + Hashtbl.replace fd_active fd { reader = linizer fd server_line_handler; error_handler = kill_server_connection }; + tell_server ("USER " ^ !login ^ " caml rulez :" ^ !name ^ "\n"); + tell_server ("NICK " ^ !desired_nick ^ "\n"); + last_server_msg := int_of_float (Unix.time ()); + printh "I" ("Connection established, waiting for server checkings."); + with + Network_error(e) -> printh "E" ("Can not connect to host: " ^ e);; + +let stdin_line_handler = fun line -> + (*print_string ("STDIN [" ^ line ^ "]\n"); flush stdout;*) + if String.length line > 0 then + match String.get line 0 with + '/' -> + begin + let (cl_token, cl_tail) = tokenizer line ' ' in + let cmd = String.uppercase (cl_token ()) in let cmd = String.sub cmd 1 ((String.length cmd) - 1) in + let cmd = try Hashtbl.find cmd_aliases cmd with Not_found -> cmd in + try + let (_, f) = (Hashtbl.find cmd_managers cmd) in + begin + try + f cl_token cl_tail + with + Not_found -> printh "E" ("Command " ^ cmd ^ " raised Not_found!") + end + with + Not_found -> printh "E" ("Unknown command '" ^ cmd ^ "'"); + end + + | '@' -> + begin + let (cl_token, cl_tail) = tokenizer line ' ' in + match cl_token () with + "@ssfe@i" -> + begin + ssfe := true; + printh "I" "You are using ssfe"; + term_bold := ""; + term_underline := ""; + term_inverse := ""; + term_reset := ""; + end + | _ -> () + end + + | _ -> + if !default_channel = "" + then printh "E" "Not in a channel" + else + begin + print ("<" ^ !current_nick ^ "> " ^ line); + tell_server ("PRIVMSG " ^ !default_channel ^ " :" ^ line ^ "\n") + end;; + +let console_reader = linizer Unix.stdin stdin_line_handler +and console_error = fun error_message -> printh "E" ("Stdin error (" ^ error_message ^ ")"); exit 1 in + Hashtbl.replace fd_active Unix.stdin { reader = console_reader; error_handler = console_error };; + +(*****************************************************************************) +(* Functions to handle scripts *) +(*****************************************************************************) + +Hashtbl.add cmd_managers + "LOAD" + begin + ": Loads the given bytecode object", + fun token tail -> + try + let module_name = token () in + printh "I" ("loading module " ^ module_name); + try + Dynlink.loadfile(module_name) + with + Dynlink.Error error -> printh "E" ("Module loading error (" ^ (Dynlink.error_message error) ^ ")"); + | Sys_error error_message -> printh "E" ("Module loading error (" ^ error_message ^ ")"); + with + Not_found -> printh "E" "Missing argument" + end; + +(*****************************************************************************) +(* Functions to handle the various user commands *) +(*****************************************************************************) + +(* Each manager gets two (unit -> string), the first one to get tokens + one after another and the second one to get the tail when required *) + +Hashtbl.add cmd_managers + "TEST" + begin + "", + fun token tail -> + Hashtbl.iter + begin + fun name chan -> + Hashtbl.iter + (fun nick user -> print ("on " ^ name ^ " : [" ^ (string_of_user user) ^ "] " ^ nick)) + chan.people + end + joined_channels + end; + +Hashtbl.add cmd_managers + "HELP" + begin + "[]: Shows the help for the given command, or for all of them", + fun token tail -> + try + let cmd = String.uppercase (token ()) in + try + let (h, f) = (Hashtbl.find cmd_managers cmd) in + printh "H" ("/" ^ cmd ^ " " ^ h) + with + Not_found -> printh "H" ("Unknown command " ^ cmd) + with + Not_found -> Hashtbl.iter (fun cmd (help, f) -> (printh "H" ("/" ^ cmd ^ " " ^ help))) cmd_managers + end; + +Hashtbl.add cmd_managers + "ME" + begin + "[]: Describes an action in the default channel", + fun token tail -> + if !default_channel = "" + then printh "E" "Not in a channel" + else let msg = try (tail ()) with Not_found -> "" in + tell_server ("PRIVMSG " ^ !default_channel ^ " :ACTION " ^ msg ^ "\n"); + print ("* " ^ !current_nick ^ " " ^ msg) + end; + +Hashtbl.add cmd_managers + "AWAY" + begin + "[]: Sets yourself away", + fun token tail -> + try tell_server ("AWAY :" ^ (tail ()) ^ "\n") + with Not_found -> tell_server "AWAY\n"; + end; + +Hashtbl.add cmd_managers + "MSG" + begin + " : Sends a message to a user, or a channel", + fun token tail -> + try + let dest = (token ()) and msg = (tail ()) in + tell_ssfe (Tabulable ("/msg " ^ dest ^ " ")); + match String.get dest 0 with + '#' | '&' -> + begin + print ("<" ^ !current_nick ^ (if same_channel !default_channel dest then "" else "/" ^ dest) ^ "> " ^ msg); + tell_server ("PRIVMSG " ^ dest ^ " :" ^ msg ^ "\n") + end + + | _ -> + begin + print (">" ^ dest ^ "< " ^ msg); + tell_server ("PRIVMSG " ^ dest ^ " :" ^ msg ^ "\n") + end + + with Not_found -> printh "E" "Missing parameter" + end; + +Hashtbl.add cmd_managers + "CTCP" + begin + " : Sends a CTCP (string quoted between ^A) to a user or a channel", + fun token tail -> + try + let dest = (token ()) and msg = (tail ()) in + tell_ssfe (Tabulable ("/msg " ^ dest ^ " ")); + printh "I" ("Sending a CTCP " ^ msg ^ " to " ^ dest); + tell_server ("PRIVMSG " ^ dest ^ " :" ^ msg ^ "\n") + with Not_found -> printh "E" "Missing parameter" + end; + +Hashtbl.add cmd_managers + "NOTICE" + begin + " : Sends a notice to a user or a channel", + fun token tail -> + try + let dest = (token ()) and msg = (tail ()) in + print ("-> -" ^ dest ^ "- " ^ msg); tell_server ("PRIVMSG " ^ dest ^ " :" ^ msg ^ "\n") + with Not_found -> printh "E" "Missing parameter" + end; + +Hashtbl.add cmd_managers + "WHOIS" + begin + "[]: Requests information about a user", + fun token tail -> + let nick = try token () with Not_found -> !current_nick in + if nick = "" + then printh "E" "Missing argument" + else tell_server ("WHOIS " ^ nick ^ "\n") + end; + +Hashtbl.add cmd_managers + "WI" + begin + "[]: Requests information about a user on his server (get the idle)", + fun token tail -> + let nick = try token () with Not_found -> !current_nick in + if nick = "" + then printh "E" "Missing argument" + else tell_server ("WHOIS " ^ nick ^ " " ^ nick ^ "\n") + end; + +Hashtbl.add cmd_managers + "SERVER" + begin + "[[:]]: Establishes a connection to a new server", + fun token tail -> + begin + try + let (stoken, stail) = tokenizer (token ()) ':' in + desired_server := stoken (); + desired_port := int_of_string (stoken ()) + with + Not_found -> () + | Failure(_) -> printh "E" "Syntax error" + end; + establish_connection () + end; + +Hashtbl.add cmd_managers + "NEXT" + begin + ": Selects the next joined channel as default", + fun token tail -> + try + default_channel := (find_joined (circular_succ (String.uppercase !default_channel) (keys joined_channels))).name; + if not !ssfe then printh "I" ("Talking to " ^ !default_channel ^ " now") + with + Not_found -> printh "E" "You have to join a channel first" + end; + +Hashtbl.add cmd_managers + "JOIN" + begin + "[<#channel> []]: Joins a channel or tells what is the default channel", + fun token tail -> + try + let channel = token () in let chan = match String.get channel 0 with '#' | '&' -> channel | _ -> "#" ^ channel in + let key = try " " ^ (token ()) with Not_found -> "" in + if mem_joined channel + then (default_channel := chan; if not !ssfe then printh "I" ("Talking to " ^ chan ^ " now")) + else tell_server ("JOIN " ^ chan ^ key ^ "\n") + with Not_found -> + if !default_channel = "" + then printh "I" "You are not in a channel" + else printh "I" ("You current channel is " ^ !default_channel) + end; + +Hashtbl.add cmd_managers + "TOPIC" + begin + "[]: Sets or requests the topic in the current channel", + fun token tail -> + if !default_channel = "" + then printh "E" "Not in a channel" + else + try let topic = tail () in tell_server ("TOPIC " ^ !default_channel ^ " :" ^ topic ^ "\n") + with Not_found -> tell_server ("TOPIC " ^ !default_channel ^ "\n") + end; + +Hashtbl.add cmd_managers + "MODE" + begin + "[]: Changes mode or shows the mode of the current channel", + fun token tail -> + let chan = try token () with Not_found -> !default_channel in + if chan = "" + then printh "E" "Need to specify a channel" + else + let chan = match String.get chan 0 with '#' | '&' -> chan | _ -> "#" ^ chan in + try tell_server ("MODE " ^ chan ^ " " ^ (tail ()) ^ "\n") + with Not_found -> tell_server ("MODE " ^ chan ^ "\n") + end; + +Hashtbl.add cmd_managers + "KICK" + begin + "[<#channel>] []: Kicks the given user from the given (or current) channel", + fun token tail -> + if !default_channel = "" + then printh "E" "Not in a channel" + else try + let t = token () in + let (channel, nick) = match String.get t 0 with '#' | '&' -> (t, token ()) | _ -> (!default_channel, t) + and comment = try tail () with Not_found -> "B1G d0Rk5 SuCk M00z b4LLz" in + tell_server ("KICK " ^ !default_channel ^ " " ^ nick ^ " :" ^ comment ^ "\n") + with Not_found -> printh "E" "Missing parameter" + end; + +Hashtbl.add cmd_managers + "LEAVE" + begin + "[<#channel>]: Leaves the current or the specified channel", + fun token tail -> + let chan = try token () with Not_found -> !default_channel in + if chan = "" + then printh "E" "Need to specify a channel" + else let chan = match String.get chan 0 with '#' | '&' -> chan | _ -> "#" ^ chan in + tell_server ("PART " ^ chan ^ "\n") + end; + +Hashtbl.add cmd_managers + "CHANINFO" + begin + "[<#channel>]: Gets the user list for the given channel", + fun token tail -> + let chan = try token () with Not_found -> !default_channel in + if chan = "" then printh "E" "Need to specify a channel" + else + let chan = match String.get chan 0 with '#' | '&' -> chan | _ -> "#" ^ chan in + tell_server ("LIST " ^ chan ^ "\n"); + tell_server ("NAMES " ^ chan ^ "\n") + end; + +Hashtbl.add cmd_managers + "NICK" + begin + "[]: Changes or requests the current nick", + fun token tail -> + try let nick = token () in tell_server ("NICK " ^ nick ^ "\n") + with Not_found -> printh "I" ("You current nick is " ^ !current_nick) + end; + +Hashtbl.add cmd_managers + "DISCONNECT" + begin + "[]: Signoffs on the current server with the given quit message", + fun token tail -> + let msg = try tail () with Not_found -> (version ^ ", the light IRC client in CAML") in + tell_server ("QUIT :" ^ msg ^ "\n"); + end; + +Hashtbl.add cmd_managers + "QUIT" + begin + "[]: Signoffs on the current server if connected, and terminates operations", + fun token tail -> + if !server_connection != Broken then begin + let msg = try tail () with Not_found -> (version ^ ", the light IRC client in CAML") in + tell_server ("QUIT :" ^ msg ^ "\n"); + end; + alive := false + end; + +Hashtbl.add cmd_managers + "QUOTE" + begin + ": Sends the line to the server, as it is", + fun token tail -> + try tell_server (tail () ^ "\n") + with Not_found -> printh "E" "Missing parameter" + end; + +Hashtbl.add cmd_managers + "VERBOSE" + begin + ": Set the verbose mode (everything form the server will be printed)", + fun token tail -> + verbose := not !verbose; + if !verbose then printh "I" "Verbose mode on" else printh "I" "Verbose mode off" + end; + +(*****************************************************************************) +(* Function to handle the various CTCPs *) +(*****************************************************************************) + +Hashtbl.add ctcp_managers + "VERSION" + begin + fun token tail from dest -> tell_server ("NOTICE " ^ from ^ " :" ^ version ^ ", the light IRC client in CAML\n") + end;; + +Hashtbl.add ctcp_managers + "ACTION" + begin + fun token tail from dest -> try print ("* " ^ from ^ " " ^ (tail())) with Not_found -> print ("* " ^ from) + end;; + +(*****************************************************************************) +(* Functions to handle the mode changes (that part of the protocole sucks) *) +(*****************************************************************************) + +let rec flatten_modes = fun polarity mode_string mode_indice param_strings param_indice -> + if mode_indice < (String.length mode_string) + then begin + match (String.get mode_string mode_indice) with + '+' -> flatten_modes 1 mode_string (mode_indice+1) param_strings param_indice + | '-' -> flatten_modes (-1) mode_string (mode_indice+1) param_strings param_indice + | 'k' | 'o' | 'v' | 'b' as c -> + (c, polarity, param_strings.(param_indice))::(flatten_modes polarity mode_string (mode_indice+1) param_strings (param_indice+1)) + | 'm' | 'i' | 's' | 't' | 'n' as c -> + (c, polarity, "")::(flatten_modes polarity mode_string (mode_indice+1) param_strings param_indice) + | 'l' -> + if polarity = 1 + then ('l', polarity, param_strings.(param_indice))::(flatten_modes polarity mode_string (mode_indice+1) param_strings (param_indice+1)) + else ('l', polarity, "")::(flatten_modes polarity mode_string (mode_indice+1) param_strings param_indice) + | other -> (other, polarity, "")::(flatten_modes polarity mode_string (mode_indice+1) param_strings param_indice) + end + else [] +;; + +let rec string_of_modelist = function + [] -> "" + | (c, l, p)::t -> + (if l > 0 then " +" else " -") ^ + (String.make 1 c) ^ + (if p = "" then "" else " " ^ p) ^ + (string_of_modelist t) + +let set_modes channel l = + let chan = find_joined channel in + List.iter + begin + function + | ('b', pol, pattern) -> () + | ('v', pol, nick) -> () + | ('o', pol, nick) -> (Hashtbl.find chan.people nick).operator <- (pol > 0) + | (c, 1, param) -> Hashtbl.replace chan.modes c param + | (c, -1, param) -> Hashtbl.remove chan.modes c + | _ -> () + end + l;; + +let get_status = fun () -> + " [" ^ version ^ "] " ^ + (try string_of_user (Hashtbl.find (find_joined !default_channel).people !current_nick) + with Not_found -> "") + ^ !current_nick ^ + " (+" ^ + (if Hashtbl.mem current_modes 'i' then "i" else "") ^ + (if Hashtbl.mem current_modes 'O' then "i" else "") ^ + (if Hashtbl.mem current_modes 'o' then "i" else "") ^ + (if Hashtbl.mem current_modes 'w' then "w" else "") ^ + (if Hashtbl.mem current_modes 'a' then "a" else "") ^ + ")" ^ + if !default_channel = "" then "" + else + " on " ^ !default_channel ^ + let modes = (find_joined !default_channel).modes in + " (+" ^ + (if Hashtbl.mem modes 'm' then "m" else "") ^ + (if Hashtbl.mem modes 'i' then "i" else "") ^ + (if Hashtbl.mem modes 's' then "s" else "") ^ + (if Hashtbl.mem modes 'n' then "n" else "") ^ + (if Hashtbl.mem modes 't' then "t" else "") ^ + (try " key=" ^ (Hashtbl.find modes 'k') with Not_found -> "") ^ + (try " limit=" ^ (Hashtbl.find modes 'l') with Not_found -> "") ^ + ")" +;; + +(*****************************************************************************) +(* Function to handle the various commands received from the server *) +(*****************************************************************************) + +(* This one just write a certain token as it is *) + +let print_information i = fun tokens -> printh "I" tokens.(i);; + +(* Here is the serious stuff ... each entry is a fun able to + interprete the tokens given as parameters *) + +Hashtbl.add protocole_managers "001" + begin + fun tokens -> current_nick := tokens.(2); + printh "I" ("You are now connected as " ^ tokens.(2)) + end; + +Hashtbl.add protocole_managers "PING" + begin + fun tokens -> tell_server ("PONG " ^ tokens.(2) ^ "\n") + end; + +Hashtbl.add protocole_managers "JOIN" + begin + fun tokens -> + let (nick, login, host) = split_prefix tokens.(0) in + if nick = !current_nick + then begin + printh ">" ("You have joined " ^ tokens.(2)); + set_joined tokens.(2) { name=tokens.(2); people= Hashtbl.create 10; modes = Hashtbl.create 10 }; + default_channel := tokens.(2); + tell_server ("MODE " ^ tokens.(2) ^ "\n") + end + else printh ">" (nick ^ " (" ^ login ^ "@" ^ host ^ ") has joined " ^ tokens.(2)); + Hashtbl.replace (find_joined tokens.(2)).people nick { operator = false } + end; + +Hashtbl.add protocole_managers "PART" + begin + fun tokens -> + let (nick, login, host) = split_prefix tokens.(0) in + if nick = !current_nick + then begin + printh "<" ("You have left " ^ tokens.(2)); + part_channel tokens.(2) + end + else begin + printh "<" (nick ^ " (" ^ login ^ "@" ^ host ^ ") has left " ^ tokens.(2)); + Hashtbl.remove (find_joined tokens.(2)).people nick; + end + end; + +Hashtbl.add protocole_managers "QUIT" + begin + fun tokens -> let (nick, login, host) = split_prefix tokens.(0) in + let channels = + Hashtbl.fold + (fun name data s -> if Hashtbl.mem data.people nick then s ^ " " ^ data.name else s) + joined_channels "" in + printh "<" ("Signoff: " ^ nick ^ " (" ^ tokens.(2) ^ ") from" ^ channels); + Hashtbl.iter (fun name data -> Hashtbl.remove data.people nick) joined_channels; + end; + +Hashtbl.add protocole_managers "KICK" + begin + fun tokens -> + let (nick, login, host) = split_prefix tokens.(0) in + if tokens.(3) = !current_nick + then begin + printh "<" ("You have been kicked from " ^ tokens.(2) ^ " by " ^ nick ^ " (" ^ tokens.(4)^ ")"); + part_channel tokens.(2) + end + else printh "<" (tokens.(3) ^ " has been kicked from " ^ tokens.(2) ^ " by " ^ nick ^ " (" ^ tokens.(4) ^ ")"); + Hashtbl.remove (find_joined tokens.(2)).people tokens.(3); + end; + +Hashtbl.add protocole_managers "NICK" + begin + fun tokens -> let (nick, login, host) = split_prefix tokens.(0) in + if nick = !current_nick + then begin + printh "I" ("You are now known as " ^ tokens.(2)); + current_nick := tokens.(2) + end + else printh "I" (nick ^ " is now known as " ^ tokens.(2)); + let rename = begin + fun name data -> + let u = Hashtbl.find data.people nick in + try + Hashtbl.remove data.people nick; + Hashtbl.add data.people tokens.(2) u + with + Not_found -> () + end in + Hashtbl.iter rename joined_channels; + end; + +Hashtbl.add protocole_managers "MODE" + begin + fun tokens -> + let (nick, login, host) = try split_prefix tokens.(0) with Not_found -> (tokens.(0), "", "") in + let modes = flatten_modes 1 tokens.(3) 0 tokens 4 in + if match String.get tokens.(2) 0 with '#' | '&' -> true | _ -> false + then + begin + set_modes (String.uppercase tokens.(2)) modes; + printh "I" ("Mode change by " ^ nick ^ " on channel " ^ tokens.(2) ^ (string_of_modelist modes)) + end + else + begin + List.iter + (function (c, 1, x) -> Hashtbl.replace current_modes c x | (c, -1, x) -> Hashtbl.remove current_modes c | _ -> ()) + modes; + printh "I" ("Mode change" ^ (string_of_modelist modes) ^ " by " ^ nick ^ " for user " ^ tokens.(2)) + end + end; + +Hashtbl.add protocole_managers "TOPIC" + begin + fun tokens -> + let (nick, login, host) = split_prefix tokens.(0) in + printh "I" (nick ^ " has changed the topic on " ^ tokens.(2) ^ " to \"" ^ tokens.(3) ^ "\"") + end; + +Hashtbl.add protocole_managers "ERROR" + begin + fun tokens -> printh "E" tokens.(2) + end; + +Hashtbl.add protocole_managers "PRIVMSG" + begin + fun tokens -> + let (nick, login, host) = split_prefix tokens.(0) in + try + let n1 = String.index tokens.(3) '' in + let n2 = String.index_from tokens.(3) (n1 + 1) '' in + let ctcp_line = (String.sub tokens.(3) (n1 + 1) (n2 - n1 - 1)) in + let (ctcp_token, ctcp_tail) = tokenizer ctcp_line ' ' in + let cmd = ctcp_token () in + try + (Hashtbl.find ctcp_managers cmd) ctcp_token ctcp_tail nick tokens.(2) + with + Not_found -> printh "E" ("Unknown CTCP [" ^ ctcp_line ^ "] from " ^ nick); + tell_server ("NOTICE " ^ nick ^ " :Unknown CTCP " ^ cmd ^ "'\n") + with + Not_found -> + begin + if (String.get tokens.(2) 0) = '#' + then print ("<" ^ nick ^ (if same_channel tokens.(2) !default_channel then "" else ("/" ^ tokens.(2))) ^ "> " ^ + tokens.(3)) + else begin + tell_ssfe (Tabulable ("/msg " ^ nick ^ " ")); + print ("[" ^ nick ^ "] " ^ tokens.(3)) + end + end + end; + +Hashtbl.add protocole_managers "NOTICE" + begin + fun tokens -> + let (nick, login, host) = split_prefix tokens.(0) in + print ("-" ^ nick ^ (if tokens.(2) = !current_nick then "" else "/" ^ tokens.(2)) ^ "- " ^ tokens.(3)) + end; + +Hashtbl.add protocole_managers "301" + begin + fun tokens -> printh "I" (tokens.(3) ^ " is away (" ^ tokens.(4) ^ ")") + end; + +Hashtbl.add protocole_managers "311" + begin + fun tokens -> printh "I" (tokens.(3) ^ " is " ^ tokens.(4) ^ "@" ^ tokens.(5) ^ " (" ^ tokens.(7) ^ ")") + end; + +Hashtbl.add protocole_managers "312" + begin + fun tokens -> printh "I" ("on IRC via server " ^ tokens.(4) ^ " (" ^ tokens.(5) ^ ")") + end; + +Hashtbl.add protocole_managers "317" + begin + fun tokens -> + let duration = int_of_string tokens.(4) in + printh "I" (tokens.(3) ^ " has been idle for " ^ (duration_of_seconds duration)) + end; + +Hashtbl.add protocole_managers "319" + begin + fun tokens -> printh "I" ("on channels: " ^ tokens.(4)) + end; + +Hashtbl.add protocole_managers "324" + begin + fun tokens -> set_modes tokens.(3) (flatten_modes 1 tokens.(4) 0 tokens 5) + end; + +Hashtbl.add protocole_managers "322" + begin + fun tokens -> printh "I" ("There are " ^ tokens.(4) ^ " users on " ^ tokens.(3)) + end; + +Hashtbl.add protocole_managers "331" + begin + fun tokens -> printh "I" ("No topic is set on " ^ tokens.(3)) + end; + +Hashtbl.add protocole_managers "333" + begin + fun tokens -> printh "I" ("Topic for " ^ tokens.(3) ^ " set by " ^ tokens.(2)) + end; + +List.iter + begin + fun s -> Hashtbl.add protocole_managers s (print_information 3) + end + [ "002"; "003"; "005"; "020"; "042"; + "251"; "252"; "253"; "255"; "265"; "266"; + "372"; "375"; "376"; + "422"; "451" ]; + +Hashtbl.add protocole_managers "305" + begin + fun tokens -> printh "I" tokens.(3); Hashtbl.remove current_modes 'a' + end; + +Hashtbl.add protocole_managers "306" + begin + fun tokens -> printh "I" tokens.(3); Hashtbl.replace current_modes 'a' "" + end; + +Hashtbl.add protocole_managers "403" (print_information 4); + +List.iter + begin + fun s -> Hashtbl.add protocole_managers s (fun tokens -> ()) + end + [ "318"; "323" ]; + +Hashtbl.add protocole_managers "004" + begin + fun tokens -> printh "I" (tokens.(3) ^ " " ^ tokens.(4) ^ " " ^ tokens.(5) ^ " " ^ tokens.(6)) + end; + +Hashtbl.add protocole_managers "254" + begin + fun tokens -> printh "I" ("There are " ^ tokens.(3) ^ " " ^ tokens.(4)) + end; + +Hashtbl.add protocole_managers "332" + begin + fun tokens -> printh "I" ("Topic for " ^ tokens.(3) ^ " is '" ^ tokens.(4) ^ "'") + end; + +Hashtbl.add protocole_managers "353" + begin + fun tokens -> + printh "I" ("Users on " ^ tokens.(4) ^ ": " ^ tokens.(5)); + let (n_token, n_tail) = tokenizer tokens.(5) ' ' + and people_table = (find_joined tokens.(4)).people in + let rec add_nick = fun () -> + try + (let nick = n_token () in match String.get nick 0 with + '@' -> Hashtbl.replace people_table (String.sub nick 1 ((String.length nick) - 1)) { operator = true } + | _ -> Hashtbl.replace people_table nick { operator = false }); + add_nick () + with Not_found -> () + in add_nick (); + end; + +Hashtbl.add protocole_managers "366" + begin + fun tokens -> () + (*let users = Hashtbl.fold (fun nick status s -> " " ^ nick ^ s) (find_joined tokens.(3)).people "" in + printh "I" ("Users on " ^ tokens.(3) ^ ":" ^ users)*) + end; + +Hashtbl.add protocole_managers "401" + begin + fun tokens -> printh "E" ("Can not find " ^ tokens.(3) ^ " on IRC") + end; + +Hashtbl.add protocole_managers "433" + begin + fun tokens -> + if tokens.(2) = "*" + then printh "E" ("Nickname " ^ tokens.(3) ^ " already in used, type /nick to choose another one") + else printh "E" ("Nickname " ^ tokens.(3) ^ " already in used, you keep " ^ tokens.(2)) + end; + +Hashtbl.add protocole_managers "441" + begin + fun tokens -> printh "E" (tokens.(3) ^ " is not on channel " ^ tokens.(4)) + end; + +Hashtbl.add protocole_managers "461" + begin + fun tokens -> printh "E" ("Not enough parameters for " ^ tokens.(3)) + end; + +Hashtbl.add protocole_managers "472" + begin + fun tokens -> printh "E" ("Mode '" ^ tokens.(3) ^ "' " ^ tokens.(4)) + end; + +Hashtbl.add protocole_managers "474" + begin + fun tokens -> printh "E" ("Can not join " ^ tokens.(3) ^ " (banned)") + end; + +Hashtbl.add protocole_managers "475" + begin + fun tokens -> printh "E" (tokens.(3) ^ ": " ^ tokens.(4)) + end; + +Hashtbl.add protocole_managers "482" + begin + fun tokens -> printh "E" ("You are not an operator on " ^ tokens.(3)) + end; + +(*****************************************************************************) +(* The module initialization *) +(*****************************************************************************) + +try + Dynlink.init (); + + Dynlink.add_interfaces + [ "Ircml"; "Buffer"; "List"; "Arg"; "String"; "Digest"; "Dynlink"; "Hashtbl"; "Sys"; + "Connection"; "Unix"; "Pervasives"; "Array" ] + [ Sys.getcwd(); "/home/fleuret/local/lib/ocaml" ]; + +with + Dynlink.Error error -> printh "E" ("Module loading error (" ^ (Dynlink.error_message error) ^ ")");; + +try ignore (Unix.tcgetattr Unix.stdout) with Unix.Unix_error _ -> print "`#ssfe#i";; + +(*****************************************************************************) +(* The main loop *) +(*****************************************************************************) + +print "-----------------------------------------------------------------------------"; +print (" " ^ version ^ ", the IRC client in OCAML"); +print " Written and (c) by "; +print "-----------------------------------------------------------------------------"; + +establish_connection (); + +while !alive do + + flush stdout; + + let (reading, _, _) = Unix.select (keys fd_active) [] [] 1.0 in + + List.iter + begin + fun fd -> + let h = Hashtbl.find fd_active fd in + try h.reader () with Network_error(e) -> h.error_handler e + end + reading; + + tell_ssfe (Status (get_status ())) + +done; + +printh "I" "You'll be back, ho yes ... you'll be back" -- 2.39.5