--- orig/config/Makefile.config.in +++ mod/config/Makefile.config.in @@ -32,6 +32,7 @@ address@hidden@ address@hidden@ address@hidden@ address@hidden@ address@hidden@ address@hidden@ --- orig/config/Makefile.in +++ mod/config/Makefile.in @@ -230,7 +230,7 @@ $(COMMON)/commonUploads.ml \ $(COMMON)/commonSources.ml -all: Makefile config/Makefile.config $(TARGET_TYPE) +all: Makefile config/Makefile.config pa_log.cmo $(TARGET_TYPE) config/configure: config/configure.in cd config; autoconf @@ -1289,20 +1289,24 @@ pa_zog.cma: $(PA_ZOG_FILES) $(OCAMLC) -I tools/zoggy -I +camlp4 -pp "$(CAMLP4) pa_o.cmo pr_dump.cmo" -a -o pa_zog.cma $(PA_ZOG_FILES) +pa_log.cmo: tools/pa_log.ml + $(OCAMLC) -I +camlp4 -pp "$(CAMLP4) pa_o.cmo pa_op.cmo pr_dump.cmo " -o pa_log.cmo -c tools/pa_log.ml + OCAMLPP=./ocamlpp.byte $(ZOGSOURCES): pa_zog.cma $(MLTSOURCES): $(OCAMLPP) +LOGPREPROC=-I +camlp4 -pp "$(CAMLP4)o ./tools/pa_log.cmo q_MLast.cmo -V$(VERBOSE_FLAGS)" #$(TMPSOURCES): $(OCAMLPP) #ocamlpp.byte: tools/ocamlpp.ml # $(OCAMLC) str.cma -o ocamlpp.byte tools/ocamlpp.ml -depend: pa_zog.cma $(LIB)/http_lexer.ml $(TMPSOURCES) $(TMPFILES) - $(OCAMLDEP) $(OCAMLDEP_OPTIONS) $(patsubst -I +lablgtk,,$(INCLUDES)) *.ml *.mli > .depend +depend: pa_log.cmo pa_zog.cma $(LIB)/http_lexer.ml $(TMPSOURCES) $(TMPFILES) + $(OCAMLDEP) $(OCAMLDEP_OPTIONS) $(patsubst -I +lablgtk,,$(INCLUDES)) $(LOGPREPROC) *.ml *.mli > .depend (for i in $(SUBDIRS); do \ - $(OCAMLDEP) $(OCAMLDEP_OPTIONS) $(patsubst -I +lablgtk,,$(INCLUDES)) $$i/*.ml $$i/*.mli >> .depend; \ + $(OCAMLDEP) $(OCAMLDEP_OPTIONS) $(patsubst -I +lablgtk,,$(INCLUDES)) $(LOGPREPROC) $$i/*.ml $$i/*.mli >> .depend; \ $(OCAMLPP) $$i/*.mlt >> .depend; \ done) @@ -1517,7 +1521,7 @@ mv $*.mlii $*.mli .ml.cmi : - $(OCAMLC) $(OFLAGS) $(INCLUDES) -c $< + $(OCAMLC) $(OFLAGS) $(INCLUDES) $(LOGPREPROC) -c $< .xpm.ml_icons : echo "let t = [|" > $@ @@ -1529,10 +1533,10 @@ cp -f $@ $*_xpm.ml .ml.cmx : - $(OCAMLOPT) $(PLUGIN_FLAG) $(OFLAGS) $(INCLUDES) -c $< + $(OCAMLOPT) $(PLUGIN_FLAG) $(OFLAGS) $(INCLUDES) $(LOGPREPROC) -c $< .ml.cmo : - $(OCAMLC) $(OFLAGS) $(INCLUDES) -c $< + $(OCAMLC) $(OFLAGS) $(INCLUDES) $(LOGPREPROC) -c $< .mll.ml : $(OCAMLLEX) $< --- orig/config/configure.in +++ mod/config/configure.in @@ -39,6 +39,21 @@ BUILD_GUI=yes BUILD_NEWGUI=yes +VERBOSITY=info +AC_ARG_ENABLE(verbosity, [--enable-verbosity=level allows you to specify the level of verbosity in mldonkey], [VERBOSITY="$enableval"]) + +case "$VERBOSITY" in + n* | N* ) VERBOSE_FLAGS="NOLOG";; + nolog ) VERBOSE_FLAGS="NOLOG";; + extra ) VERBOSE_FLAGS="EXTRA";; + y* | Y* | debug ) VERBOSE_FLAGS="DEBUG";; + info ) VERBOSE_FLAGS="INFO";; + warn ) VERBOSE_FLAGS="WARN";; + error ) VERBOSE_FLAGS="ERROR";; + fatal ) VERBOSE_FLAGS="FATAL";; + * ) VERBOSE_FLAGS="DEBUG";; +esac + MULTINET=yes AC_ARG_ENABLE(multinet, [--disable-multinet: allows you to only compile support for edonkey + Overnet], [MULTINET="$enableval"]) @@ -827,6 +842,7 @@ AC_SUBST(OPEN_DONKEY) AC_SUBST(DONKEY_SERVER) AC_SUBST(CYMES) +AC_SUBST(VERBOSE_FLAGS) AC_SUBST(CPP) AC_SUBST(DEVEL) @@ -885,5 +901,5 @@ echo "Building dependencies" $GNU_MAKE depend 2> /dev/null > /dev/null || echo "Building dependencies fails: try: 'make depend' or 'gmake depend'" - -echo "The following modules will not be compiled: {" $BAD_TARGETS "}" +echo "Verbosity level is : " $VERBOSE_FLAGS +echo "The following modules will not be compiled : {" $BAD_TARGETS "}" --- orig/src/daemon/common/commonGlobals.ml +++ mod/src/daemon/common/commonGlobals.ml @@ -101,14 +101,41 @@ (Ip.to_inet_addr bind_addr) port handler in port_option =:= port; + BLOG INFO : "%s listening on %s\n" server_name + (if bind_addr = Ip.null then + Printf.sprintf "port %d" port + else + Printf.sprintf "%s:%d" + (Ip.to_string bind_addr) port + ) + ELOG; Some sock - with e -> - if !find_other_port then iter (port+1) - else begin - lprintf "Exception %s while starting %s\n" server_name - (Printexc2.to_string e); + with + | Unix.Unix_error(Unix.EADDRINUSE,_,_) -> + if !find_other_port then + begin + BLOG WARN (port == (!!port_option) ) : + "Can't listen on default port : trying another one...\n" + ELOG; + iter (port+1) + end + else + begin + BLOG WARN : + "Failed to start %s! port %d is already used somewhere else\n" + server_name port + ELOG; None end + | e -> + if !find_other_port then iter (port+1) + else + begin + BLOG DEBUG : "Exception %s while starting %s\n" server_name + (Printexc2.to_string e) + ELOG; + None + end in iter !!port_option else None @@ -835,4 +862,4 @@ end; activity := new_activity () ) - \ Pas de fin de ligne à la fin du fichier. + --- orig/src/daemon/common/commonOptions.ml +++ mod/src/daemon/common/commonOptions.ml @@ -1162,7 +1162,18 @@ " string_option "" - +let verbosity_level = define_expert_option current_section ["verbosity_level"] +" +A level of verbosity. All message from the level choice to fatal are logged +(if you choose info, messages of level info, warn, error and fatal will be logged). +debug : Log debug messages. Only useful for developpers +info : Log informative messages to users (things are 'ok') +warn : Log important messages to users (things can be 'not ok') +error : Log error messages (things are 'not ok') +fatal : Log fatal messages (arrrrrrrrghh) +nolog : Don't log anything +" +string_option "info" @@ -1387,6 +1398,17 @@ ) (String2.split_simplify !!verbosity ' ') ) +let _ = + option_hook verbosity_level (fun _ -> + match !!verbosity_level with + | "nolog" -> Printf2.set_log_level Printf2.Nolog + | "debug" -> Printf2.set_log_level Printf2.Debug + | "info" -> Printf2.set_log_level Printf2.Info + | "warn" -> Printf2.set_log_level Printf2.Warn + | "error" -> Printf2.set_log_level Printf2.Error + | "fatal" -> Printf2.set_log_level Printf2.Fatal + | _ -> Printf2.set_log_level Printf2.Info + ) let _ = option_hook loop_delay (fun _ -> --- orig/src/networks/bittorrent/bTClients.ml +++ mod/src/networks/bittorrent/bTClients.ml @@ -968,9 +968,9 @@ *) let listen () = try - let s = TcpServerSocket.create "bittorrent client server" - (Ip.to_inet_addr !!client_bind_addr) - !!client_port + let s = find_port "bittorrent client server" + !!client_bind_addr + client_port (fun sock event -> match event with TcpServerSocket.CONNECTION (s, @@ -1032,7 +1032,7 @@ Unix.close s | _ -> () ) in - listen_sock := Some s; + listen_sock := s; () with e -> lprintf "Exception %s while init bittorrent server\n" --- orig/src/utils/cdk/printf2.ml +++ mod/src/utils/cdk/printf2.ml @@ -190,6 +190,40 @@ print_newline (); ) +type level = + | Debug + | Info + | Warn + | Error + | Fatal + | Nolog + +let log_level = ref Debug + +let set_log_level l = + log_level := l + + +let ldebug (msg : ('a, unit, unit) format) = + cprintf (fun s -> if !log_level <= Debug then + try !lprintf_handler s with _-> ()) msg + +let linfo (msg : ('a, unit, unit) format) = + cprintf (fun s -> if !log_level <= Info then + try !lprintf_handler s with _-> ()) msg + +let lwarn (msg : ('a, unit, unit) format) = + cprintf (fun s -> if !log_level <= Warn then + try !lprintf_handler s with _-> ()) msg + +let lerror (msg : ('a, unit, unit) format) = + cprintf (fun s -> if !log_level <= Error then + try !lprintf_handler s with _-> ()) msg + +let lfatal (msg : ('a, unit, unit) format) = + cprintf (fun s -> if !log_level <= Fatal then + try !lprintf_handler s with _-> ()) msg + let lprintf fmt = cprintf (fun s -> try !lprintf_handler s with _ -> ()) (fmt : ('a,unit, unit) format ) --- orig/src/utils/cdk/printf2.mli +++ mod/src/utils/cdk/printf2.mli @@ -19,11 +19,24 @@ open Autoconf +type level = + | Debug + | Info + | Warn + | Error + | Fatal + | Nolog + val cprintf : (string -> unit) -> ('a, unit, unit) format -> 'a (** [cprintf k format arguments] is the same as [printf format arguments], except that the resulting string is passed as argument to [k]; the result of [k] is then returned as the result of [cprintf]. *) +val ldebug : ('a, unit, unit) format -> 'a +val linfo : ('a, unit, unit) format -> 'a +val lwarn : ('a, unit, unit) format -> 'a +val lerror : ('a, unit, unit) format -> 'a +val lfatal : ('a, unit, unit) format -> 'a val lprintf : ('a, unit, unit) format -> 'a val lprintf_nl : ('a, unit, unit) format -> 'a val lprint_newline : unit -> unit @@ -45,4 +58,5 @@ val log_to_file : out_channel -> unit val log_to_buffer : Buffer.t -> unit val set_logging : bool -> unit +val set_log_level : level -> unit val close_log : unit -> unit --- orig/src/utils/net/tcpServerSocket.ml +++ mod/src/utils/net/tcpServerSocket.ml @@ -101,7 +101,6 @@ t.sock <- sock; t with e -> - lprintf "Exception: %s at port %d\n" (Printexc2.to_string e) port; raise e let create_connections_contoler name f = @@ -146,4 +145,3 @@ lprintf "[BW3 %6d] %20s: stop accepting connections\n" (last_time ()) cc.cc_name ) !connections_controlers ) - \ Pas de fin de ligne à la fin du fichier. --- /dev/null +++ mod/tools/pa_log.ml @@ -0,0 +1,189 @@ +(* Copyright 2004 Denis Fortin *) +(* + This file is part of mldonkey. + + mldonkey 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. + + mldonkey 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 mldonkey; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +*) +(* + Based on pa_trace.ml from Basile STARYNKEVITCH + http://www.starynkevitch.net/Basile/index_en.html +*) + +#load "pa_extend.cmo";; +#load "q_MLast.cmo";; + +open Pcaml + + +type bloc = + | Format of string * (MLast.expr list) + | Express of MLast.expr + +type level = + | Debug + | Info + | Warn + | Error + | Fatal + | Nolog + +let level_to_expr loc l = + match l with + | Debug -> <:expr< Printf2.ldebug >> + | Info -> <:expr< Printf2.linfo >> + | Warn -> <:expr< Printf2.lwarn >> + | Error -> <:expr< Printf2.lerror >> + | Fatal -> <:expr< Printf2.lfatal >> + | _ -> <:expr< () >> + +let level_to_string l = + match l with + | Debug -> "DEBUG " + | Info -> "INFO " + | Warn -> "WARN " + | Error -> "ERROR " + | Fatal -> "FATAL " + | _ -> "Unknown " + + +let log_level = ref Debug;; +let with_line_num = ref false + +let enable_logging s = + log_level := ( + match String.uppercase s with + | "EXTRA" -> with_line_num := true;Debug + | "DEBUG" -> Debug + | "INFO" -> Info + | "WARN" -> Warn + | "ERROR" -> Error + | "FATAL" -> Fatal + | "NOLOG" -> Nolog + | _ -> Debug + ) + + + +(** get the line of a given location, with memoization to avoid + rereading the source file for every trace *) + let memoized_line_of_loc = + let curfil = ref "" and curposarr = ref [| max_int |] in + fun fname (bp, ep) -> + if fname != !curfil then begin + curfil := fname; + curposarr := Array.create 10 max_int; + let addline lineno pos = + let curposmax = Array.length !curposarr in + if lineno >= curposmax then begin + let newarr = Array.create (3*pos/2+10) max_int in + Array.blit !curposarr 0 newarr 0 curposmax; + curposarr := newarr + end; + !curposarr.(lineno) <- pos + in + begin + try + let ic = open_in_bin fname in + let rec loop lin cnt = + match input_char ic with + '\n' -> addline lin cnt ; loop (lin+1) (cnt+1) + | _ -> loop lin (cnt+1) + in + begin try loop 0 0 with End_of_file -> () end; + with Sys_error e -> Printf.eprintf "cannot read file %s: %s\n" fname e + end + end; + let rec dicholoop pos lolin hilin = + if (lolin + 2 >= hilin) then + if !curposarr.(lolin) > pos then lolin + else if !curposarr.(lolin+1) > pos then lolin+1 + else lolin+2 + else + let midlin = (lolin+hilin)/2 in + let midpos = !curposarr.(midlin) in + if midpos > pos then dicholoop pos lolin midlin + else dicholoop pos midlin hilin + in + let lineno = dicholoop bp 0 ((Array.length !curposarr)-1) in + let pos = if (lineno>0) then !curposarr.(lineno-1) else 0 in + (lineno+1), bp - pos, ep - pos + + +let append_level loc lev str = + let b = level_to_expr loc lev in + match lev with + Debug when !with_line_num -> + let filename = !Pcaml.input_file in + let (lineno, _, _) = memoized_line_of_loc filename loc in + let newf = Filename.basename filename in + let newfm = (level_to_string lev)^"in %s line %d : "^str in + <:expr< $b$ $str:newfm$ $str:newf$ $int:(string_of_int lineno)$ >> + | _ -> + let newfm = (level_to_string lev)^": "^str in + <:expr< $b$ $str:newfm$ >> + + +(**** our grammar extensions ****) +EXTEND + + GLOBAL: Pcaml.expr; + + Pcaml.expr: LEVEL "top" + [ [ "BLOG" ; lev = llev ; cond = OPT condt ; r = linst ; "ELOG" -> + if lev >= !log_level then + let ex = + (match r with + | Format(fm,l) -> + List.fold_left (fun e_1 e_2 -> <:expr< $e_1$ $e_2$ >>) + (append_level loc lev fm) l + | Express(e) -> + <:expr< $e$ >> + ) in + match cond with + None -> <:expr< do {$ex$} >> + | Some t -> <:expr< do { if $t$ then $ex$ else ()} >> + else + <:expr< () >> + ] ] + ; + linst : + [ [ + ":" ; fmt = STRING ; args = LIST0 Pcaml.expr LEVEL "simple" -> + Format(fmt,args) + | + "#" ; e = Pcaml.expr LEVEL "simple" -> Express(e) + ] ] + ; + llev: + [ [ + "DEBUG" -> Debug + | "INFO" -> Info + | "WARN" -> Warn + | "ERROR" -> Error + | "FATAL" -> Fatal + ] + ] + ; + condt: + [ [ "(" ; e = Pcaml.expr LEVEL "simple" ; ")" -> e + ] + ] + ; +END; + +Pcaml.add_option "-V" (Arg.String enable_logging) + "V : verbosity level" +;; +