[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Mldonkey-commits] mldonkey distrib/ChangeLog src/daemon/common/co...
|
From: |
mldonkey-commits |
|
Subject: |
[Mldonkey-commits] mldonkey distrib/ChangeLog src/daemon/common/co... |
|
Date: |
Sun, 23 May 2010 09:18:31 +0000 |
CVSROOT: /sources/mldonkey
Module name: mldonkey
Changes by: spiralvoice <spiralvoice> 10/05/23 09:18:31
Modified files:
distrib : ChangeLog
src/daemon/common: commonGlobals.ml commonTypes.ml
src/networks/direct_connect: dcGlobals.ml dcInteractive.ml
dcMain.ml dcProtocol.ml
src/utils/lib : charset.ml charset.mli
Log message:
patch #7183
CVSWeb URLs:
http://cvs.savannah.gnu.org/viewcvs/mldonkey/distrib/ChangeLog?cvsroot=mldonkey&r1=1.1432&r2=1.1433
http://cvs.savannah.gnu.org/viewcvs/mldonkey/src/daemon/common/commonGlobals.ml?cvsroot=mldonkey&r1=1.90&r2=1.91
http://cvs.savannah.gnu.org/viewcvs/mldonkey/src/daemon/common/commonTypes.ml?cvsroot=mldonkey&r1=1.77&r2=1.78
http://cvs.savannah.gnu.org/viewcvs/mldonkey/src/networks/direct_connect/dcGlobals.ml?cvsroot=mldonkey&r1=1.14&r2=1.15
http://cvs.savannah.gnu.org/viewcvs/mldonkey/src/networks/direct_connect/dcInteractive.ml?cvsroot=mldonkey&r1=1.36&r2=1.37
http://cvs.savannah.gnu.org/viewcvs/mldonkey/src/networks/direct_connect/dcMain.ml?cvsroot=mldonkey&r1=1.9&r2=1.10
http://cvs.savannah.gnu.org/viewcvs/mldonkey/src/networks/direct_connect/dcProtocol.ml?cvsroot=mldonkey&r1=1.8&r2=1.9
http://cvs.savannah.gnu.org/viewcvs/mldonkey/src/utils/lib/charset.ml?cvsroot=mldonkey&r1=1.10&r2=1.11
http://cvs.savannah.gnu.org/viewcvs/mldonkey/src/utils/lib/charset.mli?cvsroot=mldonkey&r1=1.6&r2=1.7
Patches:
Index: distrib/ChangeLog
===================================================================
RCS file: /sources/mldonkey/mldonkey/distrib/ChangeLog,v
retrieving revision 1.1432
retrieving revision 1.1433
diff -u -b -r1.1432 -r1.1433
--- distrib/ChangeLog 23 May 2010 09:12:14 -0000 1.1432
+++ distrib/ChangeLog 23 May 2010 09:18:31 -0000 1.1433
@@ -14,6 +14,7 @@
ChangeLog
=========
+7183: DC: magnet links and html ui usability tweaks (ygrek)
7180: DC: better encoding handling (ygrek)
- new option default_encoding for communications with hubs, default CP1252
7181: HTML: Fix sorting of friends' file list (ygrek)
Index: src/daemon/common/commonGlobals.ml
===================================================================
RCS file: /sources/mldonkey/mldonkey/src/daemon/common/commonGlobals.ml,v
retrieving revision 1.90
retrieving revision 1.91
diff -u -b -r1.90 -r1.91
--- src/daemon/common/commonGlobals.ml 23 May 2010 09:12:14 -0000 1.90
+++ src/daemon/common/commonGlobals.ml 23 May 2010 09:18:31 -0000 1.91
@@ -682,29 +682,6 @@
| VerificationBitmap.State_complete | VerificationBitmap.State_verified ->
false
-let parse_magnet url =
- let url = Url.of_string url in
- if url.Url.short_file = "magnet:" then
- let uids = ref [] in
- let name = ref "" in
- List.iter (fun (value, arg) ->
- if String2.starts_with value "xt" then
- uids := Uid.expand (Uid.of_string arg :: !uids)
- else
- if String2.starts_with value "dn" then
- name := Url.decode arg
- else
- if arg = "" then
-(* This is an error in the magnet, where a & has been kept instead of being
- url-encoded *)
- name := Printf.sprintf "%s&%s" !name value
- else
- lprintf_nl "MAGNET: unused field %s = %s"
- value arg
- ) url.Url.args;
- !name, !uids
- else raise Not_found
-
(*
module CanBeCompressed = struct
Index: src/daemon/common/commonTypes.ml
===================================================================
RCS file: /sources/mldonkey/mldonkey/src/daemon/common/commonTypes.ml,v
retrieving revision 1.77
retrieving revision 1.78
diff -u -b -r1.77 -r1.78
--- src/daemon/common/commonTypes.ml 20 Jan 2009 16:47:28 -0000 1.77
+++ src/daemon/common/commonTypes.ml 23 May 2010 09:18:31 -0000 1.78
@@ -58,9 +58,7 @@
let string_of_uid_sep uid sep =
match uid with
Bitprint (sha1,ttr) ->
- "urn" ^ sep ^ "bitprint" ^ sep ^
- (Sha1.to_string sha1) ^ "." ^
- (TigerTree.to_string ttr)
+ "urn" ^ sep ^ "bitprint" ^ sep ^ (Sha1.to_string sha1) ^ "." ^
(TigerTree.to_string ttr)
| Sha1 sha1 ->
"urn" ^ sep ^ "sha1" ^ sep ^ (Sha1.to_string sha1)
| Ed2k ed2k ->
@@ -68,12 +66,11 @@
| Md5 md5 ->
"urn" ^ sep ^ "md5" ^ sep ^ (Md5.to_string md5)
| TigerTree ttr ->
- "urn" ^ sep ^ "ttr" ^ sep ^ (TigerTree.to_string ttr)
+ "urn" ^ sep ^ "tree" ^ sep ^ "tiger" ^ sep ^ (TigerTree.to_string ttr)
| Md5Ext md5 ->
- "urn" ^ sep ^ "sig2dat" ^ sep ^
- (Md5Ext.to_base32 md5)
+ "urn" ^ sep ^ "sig2dat" ^ sep ^ (Md5Ext.to_base32 md5)
| BTUrl url ->
- "urn" ^ sep ^ "bt" ^ sep ^ (Sha1.to_string url)
+ "urn" ^ sep ^ "btih" ^ sep ^ (Sha1.to_string url)
| FileTP file ->
"urn" ^ sep ^ "filetp" ^ sep ^ (Md4.to_string file)
| NoUid -> ""
@@ -105,6 +102,7 @@
let (sign, rem) = String2.cut_at rem !sep in
match sign with
| "ed2k" -> Ed2k (Md4.of_string rem)
+(* | "aich" -> ??? *)
| "bitprint" | "bp" ->
let (sha1, ttr) = String2.cut_at rem '.' in
let sha1 = Sha1.of_string sha1 in
@@ -119,7 +117,7 @@
| "ttr" -> TigerTree (TigerTree.of_string rem)
| "md5" -> Md5 (Md5.of_string rem)
| "sig2dat" -> Md5Ext (Md5Ext.of_base32 rem)
- | "bt" | "bittorrent" ->
+ | "bt" | "bittorrent" | "btih" ->
BTUrl (Sha1.of_string rem)
| "filetp" -> FileTP (Md4.of_string rem)
| _ -> raise (Illegal_urn (s ^ " at " ^ sign ^ " is not known"))
@@ -207,6 +205,50 @@
(fun uid -> string_to_value (to_string uid))
end
+(* TODO group settings: xt.1 xt.2 .. *)
+let parse_magnet_url url =
+ let url = Url.of_string url in
+ if url.Url.short_file = "magnet:" then
+ let uids = ref [] in
+ let name = ref "" in
+ let size = ref None in
+ let each k v =
+ match String2.split k '.' with
+ | "xt"::_ -> uids := Uid.of_string v :: !uids
+ | "xl"::_ -> size := Some (Int64.of_string v) (* exact length *)
+ | "dn"::_ -> name := Url.decode v
+ | "as"::_ -> () (* acceptable source *)
+ | "xs"::_ -> () (* eXtra source *)
+ | "mt"::_ -> () (* manifest topic: url or urn, see
http://rakjar.de/gnuticles/MAGMA-Specsv22.txt *)
+ | "kt"::_ -> () (* keywords topic *)
+ | "tr"::_ -> () (* BT tracker *)
+ | "x"::_ -> () (* extensions *)
+(*
+ | _ when v = "" ->
+(* This is an error in the magnet, where a & has been kept instead of being
+ url-encoded *)
+ name := Printf.sprintf "%s&%s" !name k
+*)
+ | _ -> lprintf_nl "MAGNET: unused field %S=%S" k v
+ in
+ List.iter (fun (k, v) ->
+ try each k v
+ with exn -> lprintf_nl "MAGNET: field %S=%S, exn %s" k v
(Printexc2.to_string exn)
+ ) url.Url.args;
+ object method name = !name method size = !size method uids = List.map
Uid.to_uid (Uid.expand !uids) end
+ else
+ raise Not_found
+
+let show_magnet_url x =
+ let args = ("dn", x#name) :: List.map (fun uid -> "xt", string_of_uid uid)
x#uids in
+ let args = match x#size with Some n -> ("xl", Int64.to_string n) :: args |
None -> args in
+ Url.put_args "magnet:" args
+
+(* compatibility, used in G2 module *)
+let parse_magnet url =
+ let magnet = parse_magnet_url url in
+ magnet#name, (List.map Uid.create magnet#uids)
+
let string_of_uids list =
match list with
[] -> "<unknown>"
Index: src/networks/direct_connect/dcGlobals.ml
===================================================================
RCS file: /sources/mldonkey/mldonkey/src/networks/direct_connect/dcGlobals.ml,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -b -r1.14 -r1.15
--- src/networks/direct_connect/dcGlobals.ml 9 Jul 2007 23:45:44 -0000
1.14
+++ src/networks/direct_connect/dcGlobals.ml 23 May 2010 09:18:31 -0000
1.15
@@ -289,7 +289,12 @@
(* Shorten string to some maximum length *)
let shorten_string s length =
- if (String.length s > length) then String.sub s 0 (length-1)
+ if length < String.length s then
+ try
+ let n = Charset.utf8_nth s length in
+ String.sub s 0 n
+ with
+ _ -> s (* relies on bounds checking! FIXME? *)
else s
(* Replace one string to another string from string *)
@@ -497,6 +502,17 @@
} in
file
+(* FIXME review *)
+let safe_filename s =
+ let s = String.copy s in
+ for i = 0 to String.length s - 1 do
+ match s.[i] with
+ | c when Char.code c < 32 -> s.[i] <- '_'
+ | '.' | '/' | '\\' | ':' -> s.[i] <- '_'
+ | _ -> ()
+ done;
+ s
+
(* Return existing file or create new one *)
let new_file tiger_root (directory:string) (filename:string) (file_size:int64)
=
(try
@@ -511,12 +527,9 @@
if !verbose_download then lprintf_nl "File exists: (%s) (%s)"
f.file_directory f.file_name;
f
with _ ->
- let temp_filename =
+ let temp_filename = safe_filename
(match tiger_root with
- | "" ->
- let dname = ref (String.copy directory) in
- String2.replace_char !dname '/' '_';
- Printf.sprintf "DC_%s_%s" !dname filename
+ | "" -> Printf.sprintf "DC_%s_%s" directory filename
| _ -> Printf.sprintf "DC_%s" tiger_root )
in
let fullname = Filename.concat !!temp_directory temp_filename in
Index: src/networks/direct_connect/dcInteractive.ml
===================================================================
RCS file:
/sources/mldonkey/mldonkey/src/networks/direct_connect/dcInteractive.ml,v
retrieving revision 1.36
retrieving revision 1.37
diff -u -b -r1.36 -r1.37
--- src/networks/direct_connect/dcInteractive.ml 23 May 2010 09:12:14
-0000 1.36
+++ src/networks/direct_connect/dcInteractive.ml 23 May 2010 09:18:31
-0000 1.37
@@ -55,13 +55,13 @@
(* Start new dowload from result *)
let start_new_download u tth fdir fname fsize =
- (try
+ try
ignore (Hashtbl.find dc_shared_files_by_hash tth);
if !verbose_download then lprintf_nl "Shared file with same hash exists
(%s) (%s)" fname tth;
None
with _ ->
let f = new_file tth fdir fname fsize in (* ...create new file *)
- (match (file_state f) with
+ match (file_state f) with
| FileDownloaded | FileShared -> if !verbose_download then lprintf_nl
"File already downloaded"; None
| FileDownloading -> if !verbose_download then lprintf_nl "File being
downloaded"; None
| FilePaused -> if !verbose_download then lprintf_nl "File paused";
None
@@ -69,28 +69,58 @@
if !verbose_download then lprintf_nl "File state invalid"; None
| FileNew ->
file_add f.file_file FileDownloading;
- let c = new_client_to_user_with_file u f in
+ match u with
+ | None -> Some f
+ | Some user ->
+ let c = new_client_to_user_with_file user f in
c.client_state <- DcDownloadWaiting f;
- if (can_user_start_downloading u) then begin
- u.user_state <- TryingToSendFirstContact;
+ if (can_user_start_downloading user) then begin
+ user.user_state <- TryingToSendFirstContact;
c.client_state <- DcDownloadConnecting (f,current_time ());
ignore (DcClients.try_connect_client c)
end;
- Some f ) )
+ Some f
(* Start downloading of a file by user selection from resultlist *)
let start_result_download r =
let filename = List.hd r.result_names in
let rinfo = Hashtbl.find dc_result_info r.result_num in
- let newfile = start_new_download rinfo.user rinfo.tth rinfo.directory
filename r.result_size in
+ let newfile = start_new_download (Some rinfo.user) rinfo.tth rinfo.directory
filename r.result_size in
(match newfile with
| Some f -> as_file f.file_file (* return CommonFile.file *)
| _ -> raise Not_found )
+let exn_catch f x = try `Ok (f x) with exn -> `Exn exn
+let opt_default default = function None -> default | Some v -> v
+let filter_map f l = List.fold_left (fun acc x -> match f x with Some y -> y
:: acc | None -> acc) [] l
+
+let parse_url url user group =
+ match exn_catch parse_magnet_url url with
+ | `Exn _ -> "Not a magnet url", false
+ | `Ok magnet ->
+ if !verbose then
+ lprintf_nl "Got magnet url %S" url;
+ (* TODO multiple TTHs, multiple xt, automatic merge of downloads from
different networks (?!) *)
+ match filter_map (function TigerTree tth -> Some tth | _ -> None)
magnet#uids with
+ | [] -> "No TTH found in magnet url", false
+ | tth::_ ->
+ let _ = start_new_download None (TigerTree.to_string tth) "" magnet#name
(opt_default 0L magnet#size) in
+ magnet#name, true
+
(* register DC commands *)
let register_commands list =
register_commands (List2.tail_map (fun (n,f,h) -> (n, "Direct Connect",
f,h)) list)
+let td_command text title ?(blink=false) ?(target=`Output) cmd =
+ Printf.sprintf
+ "\\<td class=\\\"srb\\\" %sonMouseOver=\\\"mOvr(this);\\\"
+ onMouseOut=\\\"mOut(this);\\\" title=\\\"%s\\\"
+ onClick=\\\"parent.%s.location.href='submit?q=%s'\\\"\\>%s\\</td\\>"
+ (if blink then "style=\\\"text-decoration:blink\\\" " else "")
+ title (match target with `Output -> "output" | `Status -> "fstatus")
+ (String.concat "+" cmd) (* Url.encode ? *)
+ text
+
(* Print DC hubs header *)
let dc_hublist_print_html_header buf ext =
html_mods_table_header buf "serversTable" (Printf.sprintf "servers%s" ext)
[
@@ -104,10 +134,8 @@
(* print in html or txt list of hubs *)
let hublist_print h hnum o =
let buf = o.conn_buf in
- let hname = if (String.length h.dc_name > 50) then String.sub h.dc_name 0 49
- else h.dc_name in
- let hinfo = if (String.length h.dc_info > 50) then String.sub h.dc_info 0 49
- else h.dc_info in
+ let hname = shorten_string h.dc_name 50 in
+ let hinfo = shorten_string h.dc_info 50 in
if use_html_mods o then begin
Printf.bprintf buf "
\\<tr class=\\\"dl-%d\\\"\\>
@@ -119,11 +147,8 @@
\\<td width=\\\"100%%\\\" class=\\\"sr\\\"\\>%s\\</td\\>\\</tr\\>\n"
(html_mods_cntr ())
hnum
- (Printf.sprintf
- "\\<td class=\\\"srb\\\" onMouseOver=\\\"mOvr(this);\\\"
- onMouseOut=\\\"mOut(this);\\\" title=\\\"Add\\\"
-
onClick=\\\"parent.fstatus.location.href='submit?q=dcn+%s+%d'\\\"\\>Add\\</td\\>"
- (Ip.string_of_addr h.dc_ip) h.dc_port)
+ (td_command "Add" "Add" ~target:`Status
+ ["dcn"; Ip.string_of_addr h.dc_ip; string_of_int h.dc_port])
hname
(Ip.string_of_addr h.dc_ip) h.dc_port
h.dc_nusers hinfo
@@ -140,21 +165,21 @@
let dc_user_print_html_header buf =
html_mods_table_header buf "serversTable" "servers" [
( "1", "srh", "User number", "#" );
- ( "1", "srh", "User name", "Name" );
- ( "1", "srh", "User type", "Type" );
+ ( "0", "srh", "User name", "Name" );
+ ( "0", "srh", "User type", "Type" );
( "1", "srh", "Users slots (all/free)", "Slots" );
( "1", "srh", "Users connected hubs (Normal/Vipped/Opped)",
"Hubs" );
- ( "1", "srh", "Users mode", "Mode" );
+ ( "0", "srh", "Users mode", "Mode" );
( "1", "srh", "Users shared size", "Shared" );
- ( "1", "srh", "User state", "State" );
- ( "1", "srh", "User description field", "Description" );
+ ( "0", "srh", "User state", "State" );
+ ( "0", "srh", "User description field", "Description" );
( "1", "srh", "User clients number", "Clients" );
( "1", "srh", "Users servers number", "Servers" );
( "0", "srh", "Download this clients filelist", "Filelist" );
( "0", "srh", "Open chat window with this user. Blinking tells
there are new unread messages", "Chat");
( "1", "srh", "User total uploaded bytes", "Up" );
( "1", "srh", "User total downloaded bytes", "Down" );
- ( "1", "srh", "User client supports", "Supports" ); ];
+ ( "0", "srh", "User client supports", "Supports" ); ];
()
(* print in html or txt list of users *)
@@ -213,10 +238,7 @@
(html_mods_cntr ()) num user.user_nick utype user.user_myinfo.slots hubs
user.user_myinfo.mode
(size_of_int64 user.user_myinfo.sharesize) state
user.user_myinfo.description clients servers
(if not hasmynick && (servers > 0) then (* is connected to any servers
with us *)
- (Printf.sprintf "\\<td class=\\\"srb\\\" onMouseOver=\\\"mOvr(this);\\\"
- onMouseOut=\\\"mOut(this);\\\" title=\\\"Download user filelist\\\"
-
onClick=\\\"parent.fstatus.location.href='submit?q=dcloadfilelist+%s'\\\"\\>Get
List\\</td\\>"
- user.user_nick )
+ td_command "Get List" "Download user filelist" ~target:`Status
["dcloadfilelist"; user.user_nick]
else begin
let txt =
if hasmynick then "Me"
@@ -225,11 +247,9 @@
Printf.sprintf "\\<td class=\\\"sr\\\"\\>%s\\</td\\>" txt
end )
(if not hasmynick then (* not me *)
- (Printf.sprintf "\\<td class=\\\"srb\\\"
%sonMouseOver=\\\"mOvr(this);\\\"
- onMouseOut=\\\"mOut(this);\\\" title=\\\"Open message window to this
user\\\"
-
onClick=\\\"parent.output.location.href='submit?q=dcmessages+%s'\\\"\\>Open
chat\\</td\\>"
- (if messages then "style=\\\"text-decoration:blink\\\" " else "")
user.user_nick )
- else "\\<td class=\\\"sr\\\"\\>\\</td\\>" )
+ td_command "Open chat" "Open message window to this user"
~blink:messages ["dcmessages"; user.user_nick]
+ else
+ "\\<td class=\\\"sr\\\"\\>\\</td\\>" )
(size_of_int64 user.user_uploaded) (size_of_int64 user.user_downloaded)
supports
end else
Printf.bprintf buf "[%5d] %-20s %8s %20s\n" num user.user_nick utype state
@@ -269,23 +289,14 @@
%s\\</tr\\>\n"
(html_mods_cntr ())
num
- (Printf.sprintf
- "\\<td class=\\\"srb\\\" onMouseOver=\\\"mOvr(this);\\\"
- onMouseOut=\\\"mOut(this);\\\" title=\\\"Set this server/hub
autoconnection state\\\"
-
onClick=\\\"parent.output.location.href='submit?q=dcautoconnect+%s+%s'\\\"\\>%s\\</td\\>"
- (if s.server_autoconnect then "false" else "true") sip (if
s.server_autoconnect then "UnSet" else "Set") )
+ (td_command
+ (if s.server_autoconnect then "UnSet" else "Set")
+ "Set this server/hub autoconnection state"
+ ["dcautoconnect"; (if s.server_autoconnect then "false" else "true");
sip] )
sname sip sport sstate
- (Printf.sprintf
- "\\<td class=\\\"srb\\\" onMouseOver=\\\"mOvr(this);\\\"
- onMouseOut=\\\"mOut(this);\\\" title=\\\"Click to show users for this hub
only\\\"
-
onClick=\\\"parent.output.location.href='submit?q=dcusers+%s'\\\"\\>%d\\</td\\>"
- sip susers )
+ (td_command (string_of_int susers) "Show users for this hub only"
["dcusers";sip] )
sinfo
- (Printf.sprintf
- "\\<td class=\\\"srb\\\" %sonMouseOver=\\\"mOvr(this);\\\"
- onMouseOut=\\\"mOut(this);\\\" title=\\\"Open this hubs chat windows\\\"
-
onClick=\\\"parent.output.location.href='submit?q=dcmessages+%s+%d'\\\"\\>Open
chat\\</td\\>"
- (if smessages then "style=\\\"text-decoration:blink\\\" " else "") sip
sport)
+ (td_command "Open chat" "Open this hubs chat windows" ~blink:smessages
["dcmessages";sip;string_of_int sport])
end else begin
Printf.bprintf buf "[%5d] %20s %25s:%-10d Users:%-8d %20s\n"
num
@@ -299,13 +310,13 @@
let dc_client_print_html_header buf =
html_mods_table_header buf "serversTable" "servers" [
( "1", "srh", "Client number", "#" );
- ( "1", "srh", "Remove Client", "Rem" );
- ( "1", "srh", "Clientname", "Name" );
- ( "1", "srh", "Client ip/port", "Ip:Port" );
- ( "1", "srh", "Client state", "State" );
- ( "1", "srh", "Client connection", "Conn" );
- ( "1", "srh", "Client last error/count", "Error" );
- ( "1", "srh", "Client file", "File" ); ];
+ ( "0", "srh", "Remove Client", "Rem" );
+ ( "0", "srh", "Client name", "Name" );
+ ( "0", "srh", "Client ip/port", "Ip:Port" );
+ ( "0", "srh", "Client state", "State" );
+ ( "0", "srh", "Client connection", "Conn" );
+ ( "0", "srh", "Client last error/count", "Error" );
+ ( "0", "srh", "Client file", "File" ); ];
()
(* print in html or txt list of clients *)
@@ -358,11 +369,8 @@
\\<td class=\\\"sr\\\" \\>%s\\</td\\>
\\<td class=\\\"sr\\\" \\>%s\\</td\\>\\</tr\\>\n"
(html_mods_cntr ()) num
- (Printf.sprintf
- "\\<td class=\\\"srb\\\" onMouseOver=\\\"mOvr(this);\\\"
- onMouseOut=\\\"mOut(this);\\\" title=\\\"Remove client\\\"
-
onClick=\\\"parent.fstatus.location.href='submit?q=dcremclient+%d'\\\"\\>Rem\\</td\\>"
- (client_num (as_client client.client_client)) )
+ (td_command "Rem" "Remove client" ~target:`Status
+ ["dcremclient"; string_of_int (client_num (as_client
client.client_client))] )
name ip port state conn error fil
end else
Printf.bprintf buf "[%5d] %25s %25s:%-10d S:%15s C:%15s F:%15s\n"
@@ -372,15 +380,33 @@
let dc_file_print_html_header buf =
html_mods_table_header buf "serversTable" "servers" [
( "1", "srh", "File number", "#" );
- ( "1", "srh", "File name/path", "File" );
+ ( "0", "srh", "File name/path", "File" );
( "1", "srh", "File size", "Size" );
- ( "1", "srh", "TTH Hash", "Hash" );
+ ( "0", "srh", "Tiger Tree Hash and magnet url", "TTH and
magnet" );
( "1", "srh", "Files clients number (sources)", "Clients" );
( "1", "srh", "Autosearches done", "Searches" );
- ( "1", "srh", "Find new source by tth", "Find TTH" );
- ( "1", "srh", "Find new source by similar name context", "Find
similar" ); ];
+ ( "0", "srh", "Find new source by tth", "Find TTH" );
+ ( "0", "srh", "Find new source by similar name context", "Find
similar" ); ];
()
+let html_show_tth file size tth =
+ begin match exn_catch TigerTree.of_string tth with
+ | `Exn _ -> ""
+ | `Ok hash ->
+ let magnet = object
+ method name = Filename.basename file
+ method size = match size with 0L -> None | _ -> Some size (* do not
report size if not available *)
+ method uids = [TigerTree hash]
+ end in
+ Printf.sprintf "\\<a href=\\\"%s\\\"\\>%s\\</a\\>" (show_magnet_url
magnet) tth
+ end
+
+let html_show_shared dcsh =
+ html_show_tth dcsh.dc_shared_fullname dcsh.dc_shared_size
dcsh.dc_shared_tiger_root
+
+let html_show_file file =
+ html_show_tth file.file_name file.file_file.impl_file_size
file.file_unchecked_tiger_root
+
(* print in html or txt list of files *)
let file_print file num o =
let buf = o.conn_buf in
@@ -400,17 +426,9 @@
%s
%s\\</tr\\>\n"
(html_mods_cntr ()) num file.file_name file.file_file.impl_file_size
- (file.file_unchecked_tiger_root) (List.length file.file_clients)
file.file_autosearch_count
- (Printf.sprintf
- "\\<td class=\\\"srb\\\" onMouseOver=\\\"mOvr(this);\\\"
- onMouseOut=\\\"mOut(this);\\\" title=\\\"Find new client for this file by
TTH\\\"
-
onClick=\\\"parent.output.location.href='submit?q=dcfindsource+%s'\\\"\\>Find
TTH\\</td\\>"
- file.file_unchecked_tiger_root )
- (Printf.sprintf
- "\\<td class=\\\"srb\\\" onMouseOver=\\\"mOvr(this);\\\"
- onMouseOut=\\\"mOut(this);\\\" title=\\\"Find new client for this file by
similar name\\\"
-
onClick=\\\"parent.output.location.href='submit?q=dcfindsource+%s'\\\"\\>Find
similar\\</td\\>"
- !fname )
+ (html_show_file file) (List.length file.file_clients)
file.file_autosearch_count
+ (td_command "Find TTH" "Find new client for this file by TTH"
["dcfindsource"; file.file_unchecked_tiger_root])
+ (td_command "Find similar" "Find new client for this file by similar name"
["dcfindsource"; !fname])
end else
Printf.bprintf buf "[%5d] %40s %-15Ld %5d\n"
num file.file_name file.file_file.impl_file_size (List.length
file.file_clients)
@@ -419,9 +437,9 @@
let dc_shared_print_html_header buf =
html_mods_table_header buf "serversTable" "servers" [
( "1", "srh", "File number", "#" );
- ( "1", "srh", "Shared file codedname", "Codedname" );
+ ( "0", "srh", "Shared file name", "Name" );
( "1", "srh", "Shared file size", "Size" );
- ( "1", "srh", "TTH Hash", "Hash" );
+ ( "0", "srh", "Tiger Tree Hash and magnet url", "TTH and
magnet" );
(*( "1", "srh", "Shared files Tiger tree array length", "TTree
#" );*) ];
()
@@ -437,22 +455,43 @@
\\<td class=\\\"srb\\\" \\>%Ld\\</td\\>
\\<td class=\\\"srb\\\" \\>%s\\</td\\>\\</tr\\>\n"
(html_mods_cntr ()) num dcsh.dc_shared_codedname dcsh.dc_shared_size
- dcsh.dc_shared_tiger_root (*(Array.length dcsh.dc_shared_tiger_array)*)
+ (html_show_shared dcsh)
end else
Printf.bprintf buf "[%5d] %40s %-15Ld %24s\n"
num dcsh.dc_shared_codedname dcsh.dc_shared_size
dcsh.dc_shared_tiger_root
- (*(Array.length dcsh.dc_shared_tiger_array)*)
-type dc_int_groups = G_users|G_hubs|G_clients|G_files|G_shared
+(* Print DC filelist header *)
+let dc_filelist_print_html_header buf =
+ html_mods_table_header buf "serversTable" "servers" [
+ ( "1", "srh", "Number", "#" ) ;
+ ( "0", "srh", "Filelist name", "Filelist" ) ]
+
+(* Print one line from filelist *)
+let filelist_print fname line o =
+ let buf = o.conn_buf in
+ if use_html_mods o then begin
+ Printf.bprintf buf "
+ \\<tr class=\\\"dl-%d\\\"\\>
+ \\<td class=\\\"srb\\\" \\>%d\\</td\\>
+ %s
+ \\</tr\\>\n"
+ (html_mods_cntr ())
+ line
+ (td_command fname "Open filelist" ["dcshowfilelist"; fname])
+ end else begin
+ Printf.bprintf buf "[%5d] %s\n" line fname
+ end
+
+type dc_int_groups = G_users|G_hubs|G_clients|G_files|G_shared|G_filelists
(* register users,clients,files *)
let dc_list o group_type group_name =
let buf = o.conn_buf in
let num = ref 1 in
html_mods_cntr_init ();
- if use_html_mods o then begin
- (try
- (match group_type with
+ let html f = if use_html_mods o then f buf else () in
+ begin try
+ begin match group_type with
| G_users ->
let new_messages_list = ref [] in (* lets order users with
unread messages to the top *)
let others_list = ref [] in
@@ -460,66 +499,44 @@
if user_has_new_messages user then new_messages_list := user ::
!new_messages_list
else others_list := user :: !others_list
) users_by_name;
- dc_user_print_html_header buf;
+ html dc_user_print_html_header;
List.iter (fun user -> user_print user !num o; incr num)
!new_messages_list;
List.iter (fun user -> user_print user !num o; incr num)
!others_list;
| G_hubs ->
- dc_hub_print_html_header buf;
+ html dc_hub_print_html_header;
Hashtbl.iter (fun _ s -> hub_print s !num o; incr num)
servers_by_ip
(*List.iter (fun s -> hub_print s !num o; incr num)
!connected_servers*)
| G_clients ->
- dc_client_print_html_header buf;
+ html dc_client_print_html_header;
List.iter (fun c ->
(match c.client_name with
| Some n -> client_print n c !num o; incr num
| None -> () )
) !clients_list
| G_files ->
- dc_file_print_html_header buf;
+ html dc_file_print_html_header;
List.iter (fun file -> file_print file !num o; incr num)
!current_files;
| G_shared ->
- dc_shared_print_html_header buf;
- Hashtbl.iter (fun _ dcsh -> shared_print dcsh !num o; incr num)
dc_shared_files_by_codedname;
- Printf.bprintf buf "\\</table\\>\\</div\\>";
- num := 1;
- dc_shared_print_html_header buf;
- Hashtbl.iter (fun _ dcsh -> shared_print dcsh !num o; incr num)
dc_shared_files_by_hash; )
- with e -> lprintf_nl "Exception %s in printing %s" (Printexc2.to_string
e) group_name );
+ html dc_shared_print_html_header;
+ Hashtbl.iter (fun _ dcsh -> shared_print dcsh !num o; incr num)
dc_shared_files_by_codedname
+ | G_filelists ->
+ html dc_filelist_print_html_header;
+ let filelist = Unix2.list_directory filelist_directory in
+ List.iter (fun fname -> filelist_print fname !num o; incr num)
filelist;
+ end;
+ if use_html_mods o then
Printf.bprintf buf "\\</table\\>\\</div\\>";
+ with e ->
+ lprintf_nl "Exception %s in printing %s" (Printexc2.to_string e)
group_name
end;
empty_string
-(* Print DC filelist header *)
-let dc_filelist_print_html_header buf =
- html_mods_table_header buf "serversTable" "servers" [
- ( "1", "srh", "Number", "#" ) ;
- ( "0", "srh", "Filelist name", "Filelist" ) ]
-
-(* Print one line from filelist *)
-let filelist_print fname line o =
- let buf = o.conn_buf in
- if use_html_mods o then begin
- Printf.bprintf buf "
- \\<tr class=\\\"dl-%d\\\"\\>
- \\<td class=\\\"srb\\\" \\>%d\\</td\\>
- %s"
- (html_mods_cntr ())
- line
- (Printf.sprintf
- "\\<td class=\\\"srb\\\" onMouseOver=\\\"mOvr(this);\\\"
- onMouseOut=\\\"mOut(this);\\\" title=\\\"Click to open filelist\\\"
-
onClick=\\\"parent.output.location.href='submit?q=dcshowfilelist+%s'\\\"\\>%s\\</td\\>\\</tr\\>\n"
- fname fname);
- end else begin
- Printf.bprintf buf "[%5d] %s\n" line fname
- end
-
(* Print DC filelist files header *)
let dc_filelist_files_print_html_header buf =
html_mods_table_header buf "serversTable" (Printf.sprintf "servers") [
( "1", "srh", "Number", "#" );
- ( "0", "srh", "File/Firectory name", "File/Directory name" );
- ( "0", "srh", "File Size", "Size" );
+ ( "0", "srh", "File/Directory name", "File/Directory name" );
+ ( "1", "srh", "File Size", "Size" );
( "0", "srh", "Files TTH", "TTH" ) ]
(* Print one line from filelist file *)
@@ -552,13 +569,10 @@
(html_mods_cntr ())
line
(if is_file then
- (Printf.sprintf
- "\\<td class=\\\"srb\\\" onMouseOver=\\\"mOvr(this);\\\"
- onMouseOut=\\\"mOut(this);\\\" title=\\\"Click to start loading \\\"
-
onClick=\\\"parent.fstatus.location.href='submit?q=dcloadfile+%s+%s+%s+%s+%s'\\\"\\>%s%s\\</td\\>"
- username ftth !sdir !sname fsize spaces fname )
+ td_command (spaces^fname) "Start downloading" ~target:`Status
+ ["dcloadfile"; username; ftth; !sdir; !sname; fsize]
else
- (Printf.sprintf "\\<td class=\\\"srb\\\"
\\>\\<b\\>%s%s\\</b\\>\\</td\\>" spaces fname)
+ Printf.sprintf "\\<td class=\\\"srb\\\"
\\>\\<b\\>%s%s\\</b\\>\\</td\\>" spaces fname
)
fsize
ftth
@@ -585,50 +599,38 @@
Printf.bprintf buf "%s: %s\n" info data
end
+let show_dc_buttons o =
+ let buf = o.conn_buf in
+ let button id ?(cmd="dc"^id) ?(txt=String.capitalize id) () =
+ Printf.bprintf buf "\\<form style=\\\"margin: 0px;\\\" id=\\\"%s\\\"
name=\\\"%s\\\"
+ action=\\\"javascript:parent.output.location.href='submit?q=%s'\\\"\\>
+ \\<td\\>\\<input style=\\\"font-family: verdana; font-size: 12px;\\\"
type=submit
+ Value=\\\"%s\\\"\\>\\</td\\>\\</form\\>" id id cmd txt
+ in
+ if use_html_mods o then
+ begin
+ Printf.bprintf buf "\\<table\\>\\<tr\\>";
+ button "users" ~cmd:"dcusers+all" ();
+ button "clients" ~cmd:"dcclients" ();
+ button "hubs" ();
+ button "shared" ();
+ button "files" ();
+ button "info" ~txt:"DC Info" ();
+ button "hublistshow" ~cmd:"dchublist" ~txt:"Show hublist" ();
+ button "filelists" ();
+ Printf.bprintf buf "\\</tr\\>\\</table\\>";
+ end
(* List of commands to register *)
let commands = [
"dc", Arg_none (fun o ->
- let buf = o.conn_buf in
- if use_html_mods o then begin
- Printf.bprintf buf "\\<table\\>\\<tr\\>\\<form style=\\\"margin:
0px;\\\" id=\\\"users\\\" name=\\\"users\\\"
-
action=\\\"javascript:parent.output.location.href='submit?q=dcusers+all'\\\"\\>
- \\<td\\>\\<input style=\\\"font-family: verdana; font-size: 12px;\\\"
type=submit
- Value=\\\"Users\\\"\\>\\</td\\>\\</form\\>";
- Printf.bprintf buf "\\<form style=\\\"margin: 0px;\\\"
id=\\\"clients\\\" name=\\\"clients\\\"
-
action=\\\"javascript:parent.output.location.href='submit?q=dcclients'\\\"\\>
- \\<td\\>\\<input style=\\\"font-family: verdana; font-size: 12px;\\\"
type=submit
- Value=\\\"Clients\\\"\\>\\</td\\>\\</form\\>";
- Printf.bprintf buf "\\<form style=\\\"margin: 0px;\\\" id=\\\"hubs\\\"
name=\\\"hubs\\\"
-
action=\\\"javascript:parent.output.location.href='submit?q=dchubs'\\\"\\>
- \\<td\\>\\<input style=\\\"font-family: verdana; font-size: 12px;\\\"
type=submit
- Value=\\\"Hubs\\\"\\>\\</td\\>\\</form\\>";
- Printf.bprintf buf "\\<form style=\\\"margin: 0px;\\\" id=\\\"shared\\\"
name=\\\"shared\\\"
-
action=\\\"javascript:parent.output.location.href='submit?q=dcshared'\\\"\\>
- \\<td\\>\\<input style=\\\"font-family: verdana; font-size: 12px;\\\"
type=submit
- Value=\\\"Shared\\\"\\>\\</td\\>\\</form\\>";
- Printf.bprintf buf "\\<form style=\\\"margin: 0px;\\\" id=\\\"files\\\"
name=\\\"files\\\"
-
action=\\\"javascript:parent.output.location.href='submit?q=dcfiles'\\\"\\>
- \\<td\\>\\<input style=\\\"font-family: verdana; font-size: 12px;\\\"
type=submit
- Value=\\\"Files\\\"\\>\\</td\\>\\</form\\>";
- Printf.bprintf buf "\\<form style=\\\"margin: 0px;\\\" id=\\\"info\\\"
name=\\\"info\\\"
-
action=\\\"javascript:parent.output.location.href='submit?q=dcinfo'\\\"\\>
- \\<td\\>\\<input style=\\\"font-family: verdana; font-size: 12px;\\\"
type=submit
- Value=\\\"DC Info\\\"\\>\\</td\\>\\</form\\>";
- Printf.bprintf buf "\\<form style=\\\"margin: 0px;\\\"
id=\\\"hublistshow\\\" name=\\\"hublistshow\\\"
-
action=\\\"javascript:parent.output.location.href='submit?q=dchublist'\\\"\\>
- \\<td\\>\\<input style=\\\"font-family: verdana; font-size: 12px;\\\"
type=submit
- Value=\\\"Show hublist\\\"\\>\\</td\\>\\</form\\>";
- Printf.bprintf buf "\\<form style=\\\"margin: 0px;\\\"
id=\\\"filelists\\\" name=\\\"filelists\\\"
-
action=\\\"javascript:parent.output.location.href='submit?q=dcfilelists'\\\"\\>
- \\<td\\>\\<input style=\\\"font-family: verdana; font-size: 12px;\\\"
type=submit
- Value=\\\"Filelists\\\"\\>\\</td\\>\\</form\\>";
- Printf.bprintf buf "\\</tr\\>\\</table\\>";
- end else
- Printf.bprintf buf "Received command dc\n";
- empty_string
- ), ": Show direct connect buttons";
+ if use_html_mods o then
+ show_dc_buttons o
+ else
+ Printf.bprintf buf "Try `?? dc` for more commands\n";
+ dc_list o G_hubs "hubs"
+ ), ": Show Direct Connect buttons";
(* 'dcn address [port]' Add a new DC server with optional port (default
411) *)
"dcn", Arg_multiple (fun args o ->
@@ -648,11 +650,12 @@
), "<ip> [<port>] : Add a server. Default port number is 411";
(* List connected hubs for chatting *)
- "dchubs", Arg_none (fun o -> dc_list o G_hubs "hubs"
+ "dchubs", Arg_none (fun o -> show_dc_buttons o; dc_list o G_hubs "hubs"
), ": Show connected DC hubs";
(* List all DC users *)
"dcusers", Arg_one (fun args o ->
+ show_dc_buttons o;
let buf = o.conn_buf in
(match args with
| "all" -> dc_list o G_users "users"
@@ -674,19 +677,20 @@
), "<all>|<ip> :Show DC users";
(* List all DC clients *)
- "dcclients", Arg_none (fun o -> dc_list o G_clients "clients"
+ "dcclients", Arg_none (fun o -> show_dc_buttons o; dc_list o G_clients
"clients"
), ": Show all DC clients";
(* List all DC files *)
- "dcfiles", Arg_none (fun o -> dc_list o G_files "files"
+ "dcfiles", Arg_none (fun o -> show_dc_buttons o; dc_list o G_files "files"
), ": Show all DC files";
(* List all DC shared files *)
- "dcshared", Arg_none (fun o -> dc_list o G_shared "shared"
+ "dcshared", Arg_none (fun o -> show_dc_buttons o; dc_list o G_shared "shared"
), ": Show all DC shared files. All/Hashed ";
- (* 'dchubs [args]' - Show dchub list with optional filters args (max 5) *)
+ (* 'dchublist [args]' - Show dchub list with optional filters args (max 5) *)
"dchublist", Arg_multiple (fun args o ->
+ show_dc_buttons o;
let buf = o.conn_buf in
let filter = ref [] in
let print_hublist () =
@@ -786,7 +790,7 @@
in
s.server_read_messages <- List.length s.server_messages; (*
messages are set as read before *)
s.server_messages, (*
they are actually printed to user *)
- (if (String.length s.server_name > 50) then String.sub
s.server_name 0 49 else s.server_name),
+ (shorten_string s.server_name 50),
topic
with _ ->
if !verbose_unexpected_messages then lprintf_nl "dcmsglog: No
server with address found";
@@ -830,7 +834,7 @@
html_mods_td buf [
(empty_string, "sr", Date.simple (BasicSocket.date_of_int t));
(empty_string, "sr", f);
- (empty_string, "srw", msg) ];
+ (empty_string, "srw", String2.replace msg '\r' "\\<br/\\>") ];
Printf.bprintf buf "\\</tr\\>"
end else begin
Printf.bprintf buf "\n%s [%s] : %s\n" (Date.simple
(BasicSocket.date_of_int t)) f msg
@@ -842,6 +846,7 @@
), "<refresh> <user> | <refresh> <serverip> <serverport>";
"dcmessages", Arg_multiple (fun args o ->
+ show_dc_buttons o;
let buf = o.conn_buf in
let s,u =
(match args with
@@ -1014,7 +1019,7 @@
Printf.bprintf buf "Trying to download file: %s from user: %s\n"
!sname uname;
(try
let u = search_user_by_name uname in
- ignore (start_new_download u tth !sdir !sname (Int64.of_string
fsize))
+ ignore (start_new_download (Some u) tth !sdir !sname
(Int64.of_string fsize))
with _ -> if !verbose_download then lprintf_nl "dcloadfile: No user
found" )
| _ ->
if !verbose_unexpected_messages then
@@ -1050,18 +1055,7 @@
empty_string
), "<name> : Download filelist from user";
- "dcfilelists", Arg_none (fun o ->
- let buf = o.conn_buf in
- html_mods_cntr_init ();
- let line = ref 1 in
- if use_html_mods o then dc_filelist_print_html_header buf;
- let filelist = Unix2.list_directory filelist_directory in
- List.iter (fun fname ->
- filelist_print fname !line o;
- incr line
- ) filelist;
- if use_html_mods o then Printf.bprintf buf "\\</table\\>\\</div\\>";
- empty_string
+ "dcfilelists", Arg_none (fun o -> show_dc_buttons o; dc_list o G_filelists
"filelists"
), ": List all filelists on disk";
"dcremclient", Arg_one (fun args o ->
@@ -1130,13 +1124,13 @@
), ": Find new source for a file";
"dcinfo", Arg_none (fun o ->
+ show_dc_buttons o;
let buf = o.conn_buf in
let server_list =
let lst = ref [] in
List.iter (fun s ->
let data =
- String.sub s.server_name 0 (if (String.length s.server_name > 20)
then 20 else
- String.length s.server_name) ^ " (nick = " ^ s.server_last_nick
^ ") (uptime = " ^
+ shorten_string s.server_name 20 ^ " (nick = " ^
s.server_last_nick ^ ") (uptime = " ^
(Date.time_to_string (int_of_float (current_time ()) -
int_of_float (s.server_connection_time)) "verbose") ^
(string_of_int (List.length s.server_users)) ^ ")"
@@ -1170,6 +1164,7 @@
(* load filelist from user *)
"dcshowfilelist", Arg_one (fun args o ->
+ show_dc_buttons o;
let buf = o.conn_buf in
(match args with
| filename ->
@@ -1553,7 +1548,30 @@
file_ops.op_file_resume <- (fun _ -> ());
file_ops.op_file_set_format <- (fun _ _ -> ());
file_ops.op_file_check <- (fun _ -> ());
- file_ops.op_file_recover <- (fun _ -> ())
+ file_ops.op_file_recover <- (fun _ -> ());
+ file_ops.op_file_print <- (fun file o ->
+ let buf = o.conn_buf in
+ if use_html_mods o then
+ begin
+ let td l =
+ Printf.bprintf buf "\\</tr\\>\\<tr class=\\\"dl-%d\\\"\\>"
(html_mods_cntr ());
+ html_mods_td buf l
+ in
+ td [
+ ("Directory", "sr br", "Directory");
+ ("", "sr", file.file_directory) ];
+ td [
+ ("Filename", "sr br", "Filename");
+ ("", "sr", file.file_name) ];
+ td [
+ ("Tiger tree hash and magnet url", "sr", "TTH and magnet");
+ ("", "sr", html_show_file file) ];
+ td [
+ ("Automatic TTH searches performed", "sr", "Autosearches");
+ ("", "sr", string_of_int file.file_autosearch_count) ];
+ end
+ else
+ ())
(*file_ops.op_file_print_html <- (fun _ _ -> lprintf_nl "Received
(op_file_print_html)"; ());*)
(*file_ops.op_file_print_sources_html <- (fun _ _ -> lprintf_nl "Received
(op_file_print_sources_html)"; ())*)
(* mutable op_file_files : ('a -> 'a file_impl -> file list);
Index: src/networks/direct_connect/dcMain.ml
===================================================================
RCS file: /sources/mldonkey/mldonkey/src/networks/direct_connect/dcMain.ml,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -b -r1.9 -r1.10
--- src/networks/direct_connect/dcMain.ml 18 Mar 2008 08:24:38 -0000
1.9
+++ src/networks/direct_connect/dcMain.ml 23 May 2010 09:18:31 -0000
1.10
@@ -215,7 +215,7 @@
network.op_network_connected <- (fun _ ->
!connected_servers <> []
);
- network.op_network_parse_url <- (fun _ _ _ -> empty_string, false);
+ network.op_network_parse_url <- (fun url user group ->
DcInteractive.parse_url url user group);
network.op_network_download <- (fun r _ _ ->
DcInteractive.start_result_download r);
network.op_network_ports <- (fun _ ->
[
Index: src/networks/direct_connect/dcProtocol.ml
===================================================================
RCS file: /sources/mldonkey/mldonkey/src/networks/direct_connect/dcProtocol.ml,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -b -r1.8 -r1.9
--- src/networks/direct_connect/dcProtocol.ml 23 May 2010 09:12:14 -0000
1.8
+++ src/networks/direct_connect/dcProtocol.ml 23 May 2010 09:18:31 -0000
1.9
@@ -880,7 +880,7 @@
message : string;
}
let parse s =
- if ((String.length s) > 1000) then begin
+ if ((String.length s) > 2048) then begin
lprintf_nl "Overlength $To: (%s)" (shorten_string s 50);
raise Not_found
end else begin
Index: src/utils/lib/charset.ml
===================================================================
RCS file: /sources/mldonkey/mldonkey/src/utils/lib/charset.ml,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -b -r1.10 -r1.11
--- src/utils/lib/charset.ml 23 May 2010 09:12:15 -0000 1.10
+++ src/utils/lib/charset.ml 23 May 2010 09:18:31 -0000 1.11
@@ -172,7 +172,7 @@
(**********************************************************************************)
(* taken from camomile *)
-(* $Id: charset.ml,v 1.10 2010/05/23 09:12:15 spiralvoice Exp $ *)
+(* $Id: charset.ml,v 1.11 2010/05/23 09:18:31 spiralvoice Exp $ *)
(* Copyright 2002, 2003 Yamagata Yoriyuki. distributed with LGPL *)
let utf8_look s i =
@@ -243,9 +243,9 @@
if n = 0 then i else
nth_aux s (utf8_next s i) (n - 1)
-let nth s n = nth_aux s 0 n
+let utf8_nth s n = nth_aux s 0 n
-let utf8_get s n = utf8_look s (nth s n)
+let utf8_get s n = utf8_look s (utf8_nth s n)
(**********************************************************************************)
(*
*)
@@ -254,7 +254,7 @@
(**********************************************************************************)
(* taken from camomile *)
-(* $Id: charset.ml,v 1.10 2010/05/23 09:12:15 spiralvoice Exp $ *)
+(* $Id: charset.ml,v 1.11 2010/05/23 09:18:31 spiralvoice Exp $ *)
(* Copyright 2002, 2003 Yamagata Yoriyuki. distributed with LGPL *)
let rec length_aux s c i =
@@ -281,7 +281,7 @@
(* taken from camomile *)
-(* $Id: charset.ml,v 1.10 2010/05/23 09:12:15 spiralvoice Exp $ *)
+(* $Id: charset.ml,v 1.11 2010/05/23 09:18:31 spiralvoice Exp $ *)
(* Copyright 2002, 2003 Yamagata Yoriyuki. distributed with LGPL *)
external uint_code : uchar -> int = "%identity"
Index: src/utils/lib/charset.mli
===================================================================
RCS file: /sources/mldonkey/mldonkey/src/utils/lib/charset.mli,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -b -r1.6 -r1.7
--- src/utils/lib/charset.mli 23 May 2010 09:12:15 -0000 1.6
+++ src/utils/lib/charset.mli 23 May 2010 09:18:31 -0000 1.7
@@ -167,6 +167,9 @@
returns the number of Unicode characters contained in s *)
val utf8_length : string -> int
+(** [utf8_nth s n] @return index of [n]-th utf-8 character in [s] (must be
valid utf-8 string). O(n) *)
+val utf8_nth : string -> int -> int
+
(** [add_uchar buf u]
add one Unicode character to the buffer. *)
val add_uchar : Buffer.t -> uchar -> unit