X-Git-Url: http://git.annexia.org/?a=blobdiff_plain;f=utils.ml;h=3afcf99be5f1b5cb04c8d56cd3ea71af4424fa4f;hb=fb002571a0432d83a25487c2644fc831180c4443;hp=8ad67c4669ca7283f2f43b222df43a5c870ffd6f;hpb=73f1dc10b4279528818fe0fda33daf4c34488d21;p=guestfs-browser.git diff --git a/utils.ml b/utils.ml index 8ad67c4..3afcf99 100644 --- a/utils.ml +++ b/utils.ml @@ -16,6 +16,9 @@ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) +open ExtString +open ExtList + open Printf let (+^) = Int64.add @@ -25,6 +28,8 @@ let (/^) = Int64.div type ('a, 'b) either = Left of 'a | Right of 'b +let (//) = Filename.concat + let verbose = ref false let set_verbose_flag () = verbose := true let verbose () = !verbose @@ -59,19 +64,75 @@ let connect_uri () = !connect_uri let utf8_rarrow = "\xe2\x86\x92" +let pretty_string_of_exn = + function + | Guestfs.Error str -> + "Libguestfs error", + sprintf "libguestfs reported an error: + +%s + +To get more information about libguestfs errors, run guestfs-browser +with the -x flag on the command line." + str + + | Libvirt.Virterror err -> + "Libvirt error", + sprintf "libvirt reported an error: + +%s + +To get more information about libvirt errors, run guestfs-browser +from the command line like this: + +LIBVIRT_DEBUG=1 guestfs-browser" + (Libvirt.Virterror.to_string err) + + (* Add more exception types here as we come across them. Last + * case below is the catch-all. + *) + | exn -> + let str = Printexc.to_string exn in + debug "pretty_string_of_exn: unhandled exception %s" str; + "Error", str + +let human_size i = + if i < 1024L then + sprintf "%Ld" i + else if i < 1024L *^ 1024L then + sprintf "%.1f KB" (Int64.to_float i /. 1024.) + else if i < 1024L *^ 1024L *^ 1024L then + sprintf "%.1f MB" (Int64.to_float i /. 1024. /. 1024.) + else if i < 1024L *^ 1024L *^ 1024L *^ 1024L then + sprintf "%.1f GB" (Int64.to_float i /. 1024. /. 1024. /. 1024.) + else + sprintf "%.1f TB" (Int64.to_float i /. 1024. /. 1024. /. 1024. /. 1024.) + let human_size_1k i = if i < 1024L then - sprintf "%LdK" i + sprintf "%Ld KB" i else if i < 1024L *^ 1024L then - sprintf "%.1fM" (Int64.to_float i /. 1024.) + sprintf "%.1f MB" (Int64.to_float i /. 1024.) else - sprintf "%.1fG" (Int64.to_float i /. 1024. /. 1024.) + sprintf "%.1f GB" (Int64.to_float i /. 1024. /. 1024.) let unique = let i = ref 0 in fun () -> incr i; !i let mklabel text = (GMisc.label ~text () :> GObj.widget) +(* g_markup_escape is not bound by lablgtk2, but we want to provide + * extra protection for \0 characters appearing in the string + * anyway. + *) +let markup_escape name = + let f = function + | '&' -> "&" | '<' -> "<" | '>' -> ">" + | '\000' -> "\\0" + | c -> String.make 1 c + in + String.replace_chars f name + let libguestfs_version_string () = let g = new Guestfs.guestfs () in let v = g#version () in @@ -85,4 +146,130 @@ let libvirt_version_string () = let v = fst (Libvirt.get_version ()) in sprintf "%d.%d.%d" (v / 1_000_000) ((v / 1_000) mod 1_000) (v mod 1_000) -let (//) = Filename.concat +(* File type tests. + * + * Note these have to be on Linux ABI modes. We cannot use the + * OCaml (ie. host) equivalents here. + *) +let rec file_type mask mode = Int64.logand mode 0o170000L = mask + +and is_socket mode = file_type 0o140000L mode +and is_symlink mode = file_type 0o120000L mode +and is_regular_file mode = file_type 0o100000L mode +and is_block mode = file_type 0o060000L mode +and is_directory mode = file_type 0o040000L mode +and is_char mode = file_type 0o020000L mode +and is_fifo mode = file_type 0o010000L mode + +and is_suid mode = test_bit 0o4000L mode +and is_sgid mode = test_bit 0o2000L mode +and is_svtx mode = test_bit 0o1000L mode + +and is_ru mode = test_bit 0o400L mode +and is_wu mode = test_bit 0o200L mode +and is_xu mode = test_bit 0o100L mode +and is_rg mode = test_bit 0o040L mode +and is_wg mode = test_bit 0o020L mode +and is_xg mode = test_bit 0o010L mode +and is_ro mode = test_bit 0o004L mode +and is_wo mode = test_bit 0o002L mode +and is_xo mode = test_bit 0o001L mode + +and test_bit mask mode = Int64.logand mode mask = mask + +let tmpdir () = + let chan = open_in "/dev/urandom" in + let data = String.create 16 in + really_input chan data 0 (String.length data); + close_in chan; + let data = Digest.to_hex (Digest.string data) in + (* Note this is secure, because if the name already exists, even as a + * symlink, mkdir(2) will fail. + *) + let tmpdir = Filename.temp_dir_name // sprintf "guestfsbrowser%s.tmp" data in + Unix.mkdir tmpdir 0o700; + at_exit + (fun () -> + let cmd = sprintf "rm -rf %s" (Filename.quote tmpdir) in + ignore (Sys.command cmd)); + tmpdir + +module CE = CamomileLibraryDefault.Camomile.CharEncoding +module UTF8 = CamomileLibraryDefault.Camomile.UTF8 +module UChar = CamomileLibraryDefault.Camomile.UChar +let utf16le = CE.utf16le +let utf8 = CE.utf8 +let recode = CE.recode_string ~in_enc:utf16le ~out_enc:utf8 + +let windows_string_to_utf8 str = + let str = recode str in + + (* Windows strings include the final \0 so remove this if present. *) + let len = UTF8.length str in + if len > 0 && UChar.code (UTF8.get str (len-1)) = 0 then + String.sub str 0 (UTF8.last str) + else + str + +(* Best effort convert hive value to printable string. *) +let rec printable_hivex_value ?split_long_lines t v = + let hex = reg_hex_of_string ?split_long_lines in + match t with + | Hivex.REG_NONE -> if v = "" then "" else hex v + | Hivex.REG_SZ -> + (try windows_string_to_utf8 v with _ -> hex v) + | Hivex.REG_EXPAND_SZ -> + (try windows_string_to_utf8 v with _ -> hex v) + | Hivex.REG_BINARY -> hex v + | Hivex.REG_DWORD -> + (bitmatch Bitstring.bitstring_of_string v with + | { i : 32 : littleendian } -> sprintf "%08lx" i + | { _ } -> hex v) + | Hivex.REG_DWORD_BIG_ENDIAN -> + (bitmatch Bitstring.bitstring_of_string v with + | { i : 32 : bigendian } -> sprintf "%08lx" i + | { _ } -> hex v) + | Hivex.REG_LINK -> hex v + | Hivex.REG_MULTI_SZ -> (* XXX should be better for this one *) + hex v + | Hivex.REG_RESOURCE_LIST -> hex v + | Hivex.REG_FULL_RESOURCE_DESCRIPTOR -> hex v + | Hivex.REG_RESOURCE_REQUIREMENTS_LIST -> hex v + | Hivex.REG_QWORD -> + (bitmatch Bitstring.bitstring_of_string v with + | { i : 64 : littleendian } -> sprintf "%016Lx" i + | { _ } -> hex v) + | Hivex.REG_UNKNOWN i32 -> hex v + +(* Convert binary data to a hex string. This includes line breaks. *) +and reg_hex_of_string ?(split_long_lines=false) v = + let vs = String.explode v in + let vs = List.mapi ( + fun i c -> + sprintf "%s%02x" + (if split_long_lines && i mod 16 = 0 then "\n" else "") + (int_of_char c) + ) vs in + String.concat "," vs + +let local_file_exists filename = + try Unix.access filename [Unix.F_OK]; true + with Unix.Unix_error _ -> false + +let basename pathname = + let len = String.length pathname in + try + let i = String.rindex pathname '/' in + let r = String.sub pathname (i+1) (len-i-1) in + if r = "" then "root" else r + with + Not_found -> pathname + +let extension pathname = + let len = String.length pathname in + try + let i = String.rindex pathname '.' in + let r = String.sub pathname i (len-i) in + r + with + Not_found -> ""