From: Richard W.M. Jones <"Richard W.M. Jones "> Date: Tue, 29 Jan 2008 14:06:58 +0000 (+0000) Subject: Use CPS to simplify the dialog functions. X-Git-Url: http://git.annexia.org/?a=commitdiff_plain;h=24199bac240adc5f5fe66df06143ea5a8e4327a3;p=virt-p2v.git Use CPS to simplify the dialog functions. --- diff --git a/virt-p2v.ml b/virt-p2v.ml index 28650f1..e678d5b 100755 --- a/virt-p2v.ml +++ b/virt-p2v.ml @@ -131,6 +131,7 @@ let shget cmd = | WSIGNALED i -> failwith (sprintf "shget: command killed by signal %d" i) | WSTOPPED i -> failwith (sprintf "shget: command stopped by signal %d" i) +(* (* Parse the output of 'lvs' to get list of LV names, sizes, * corresponding PVs, etc. Returns a list of (lvname, PVs, lvsize). *) @@ -160,7 +161,9 @@ let get_lvs () = | _ -> failwith "lvs: unexpected output" ) lines +*) +(* (* Get the partitions on a block device. eg. "sda" -> ["sda1";"sda2"] *) let get_partitions dev = let parts = Sys.readdir ("/sys/block/" ^ dev) in @@ -168,6 +171,117 @@ let get_partitions dev = let regexp = Str.regexp ("^" ^ dev) in let parts = List.filter (Str.string_match regexp) parts in parts +*) + +(* Dialog functions. + * + * Each function takes some common parameters (eg. ~title) and some + * dialog-specific functions. + * + * Returns the exit status (Yes lines | No | Help | Back | Error). + *) +let msgbox, inputbox, radiolist, checklist = + (* Internal function to actually run the "dialog" shell command. *) + let run_dialog cparams params = + let params = cparams @ params in + eprintf "dialog [%s]\n%!" + (String.concat "; " (List.map (sprintf "%S") params)); + + (* 'dialog' writes its output/result to stderr, so we need to take + * special steps to capture that - in other words, manual pipe/fork. + *) + let rfd, wfd = pipe () in + match fork () with + | 0 -> (* child, runs dialog *) + close rfd; + dup2 wfd stderr; (* capture stderr to pipe *) + execvp "dialog" (Array.of_list ("dialog" :: params)) + | pid -> (* parent *) + close wfd; + let chan = in_channel_of_descr rfd in + let result = input_all_lines chan in + close rfd; + eprintf "dialog result: %S\n%!" (String.concat "\n" result); + match snd (wait ()) with + | WEXITED 0 -> Yes result (* something selected / entered *) + | WEXITED 1 -> No (* cancel / no button *) + | WEXITED 2 -> Help (* help pressed *) + | WEXITED 3 -> Back (* back button *) + | WEXITED _ -> Error (* error or Esc *) + | WSIGNALED i -> failwith (sprintf "dialog: killed by signal %d" i) + | WSTOPPED i -> failwith (sprintf "dialog: stopped by signal %d" i) + in + + (* Handle the common parameters. Note Continuation Passing Style. *) + let with_common cont ?(cancel=false) ?(backbutton=true) title = + let params = ["--title"; title] in + let params = if not cancel then "--nocancel" :: params else params in + let params = + if backbutton then "--extra-button" :: "--extra-label" :: "Back" :: params + else params in + cont params + in + + (* Message box. *) + let msgbox = + with_common ( + fun cparams text height width -> + run_dialog cparams + [ "--msgbox"; text; string_of_int height; string_of_int width ] + ) + in + + (* Simple input box. *) + let inputbox = + with_common ( + fun cparams text height width default -> + run_dialog cparams + [ "--inputbox"; text; string_of_int height; string_of_int width; + default ] + ) + in + + (* Radio list and check list. *) + let radiolist = + with_common ( + fun cparams text height width listheight items -> + let items = List.map ( + function + | tag, item, true -> [ tag; item; "on" ] + | tag, item, false -> [ tag; item; "off" ] + ) items in + let items = List.concat items in + let items = "--single-quoted" :: + "--radiolist" :: text :: + string_of_int height :: string_of_int width :: + string_of_int listheight :: items in + run_dialog cparams items + ) + in + + let checklist = + with_common ( + fun cparams text height width listheight items -> + let items = List.map ( + function + | tag, item, true -> [ tag; item; "on" ] + | tag, item, false -> [ tag; item; "off" ] + ) items in + let items = List.concat items in + let items = "--separate-output" :: + "--checklist" :: text :: + string_of_int height :: string_of_int width :: + string_of_int listheight :: items in + run_dialog cparams items + ) + in + msgbox, inputbox, radiolist, checklist + +(* Print failure dialog and exit. *) +let fail_dialog text = + let text = text ^ "\n\nIf you want to report this error, there is a shell on [ALT] [F2], log in as root with no password.\n\nPlease provide the contents of /tmp/virt-p2v.log and output of the 'dmesg' command." in + ignore (msgbox "Error" text 17 50); + exit 1 (* Main entry point. *) let rec main ttyname = @@ -233,6 +347,7 @@ let rec main ttyname = fail_dialog "No non-removable block devices (hard disks, etc.) could be found on this machine."; devices in +(* (* For each device that we identified above, search for partitions on * the device. These are returned as strings like "hda1" or for * LVs "VolGroup00/LogVol00". This creates a StringMap of block device @@ -252,31 +367,24 @@ let rec main ttyname = let all_partitions = in - +*) (* Dialogs. *) let ask_greeting state = - ignore ( - dialog [ - title "virt-p2v" (); - msgbox "\nWelcome to virt-p2v, a live CD for migrating a physical machine to a virtualized host.\n\nTo continue press the Return key.\n\nTo get a shell you can use [ALT] [F2] and log in as root with no password." 17 50 - ] - ); + ignore (msgbox "virt-p2v" "\nWelcome to virt-p2v, a live CD for migrating a physical machine to a virtualized host.\n\nTo continue press the Return key.\n\nTo get a shell you can use [ALT] [F2] and log in as root with no password." 17 50); Next state in let ask_transport state = match - dialog [ - title "Connection type" ~backbutton:false (); - radiolist "Connection type" 10 50 2 [ + radiolist "Connection type" ~backbutton:false + "Connection type" 10 50 2 [ "ssh", "SSH (secure shell - recommended)", state.remote_transport = Some SSH; "tcp", "TCP socket", state.remote_transport = Some TCP ] - ] with | Yes ("ssh"::_) -> Next { state with remote_transport = Some SSH } | Yes ("tcp"::_) -> Next { state with remote_transport = Some TCP } @@ -286,10 +394,7 @@ in let ask_hostname state = match - dialog [ - title "Remote host" (); - inputbox "Remote host" 10 50 (default "" state.remote_host) - ] + inputbox "Remote host" "Remote host" 10 50 (default "" state.remote_host) with | Yes [] -> Ask_again | Yes (hostname::_) -> Next { state with remote_host = Some hostname } @@ -299,10 +404,7 @@ in let ask_port state = match - dialog [ - title "Remote port" (); - inputbox "Remote port" 10 50 (default "" state.remote_port) - ] + inputbox "Remote port" "Remote port" 10 50 (default "" state.remote_port) with | Yes [] -> if state.remote_transport = Some TCP then @@ -316,10 +418,8 @@ in let ask_directory state = match - dialog [ - title "Remote directory" (); - inputbox "Remote directory" 10 50 (default "" state.remote_directory) - ] + inputbox "Remote directory" "Remote directory" 10 50 + (default "" state.remote_directory) with | Yes [] -> Next { state with remote_directory = Some "/var/lib/xen/images" } @@ -330,12 +430,9 @@ in let ask_network state = match - dialog [ - title "Network configuration" (); - radiolist "Network configuration" 10 50 2 [ - "auto", "Automatic configuration", state.network = Some Auto; - "sh", "Configure from the shell", state.network = Some Shell; - ] + radiolist "Network configuration" "Network configuration" 10 50 2 [ + "auto", "Automatic configuration", state.network = Some Auto; + "sh", "Configure from the shell", state.network = Some Shell; ] with | Yes ("auto"::_) -> Next { state with network = Some Auto } @@ -353,10 +450,7 @@ in List.mem dev selected_devices) ) all_block_devices in match - dialog [ - title "Devices" (); - checklist "Pick devices to send" 15 50 8 devices - ] + checklist "Devices" "Pick devices to send" 15 50 8 devices with | Yes [] | No | Help | Error -> Ask_again | Yes devices -> Next { state with devices_to_send = Some devices } @@ -419,101 +513,6 @@ in () -(* Run the external 'dialog' command with the given list of parameters. - * Actually it's a list-of-list-of-parameters because you would normally - * use this function like this: - * dialog [ - * title (* title and other common parameters *) (); - * dialogtype (* specific parameter *) - * ] - * where 'dialogtype' is a function such as 'msgbox' (see below) - * representing a specific subfunction of dialog. - * - * The functions 'title' and 'dialogtype' return partially-constructed - * lists of shell parameters. See the dialog manpage. - * - * Returns the exit status (Yes lines | No | Help | Back | Error). - *) -and dialog params = - let params = List.concat params in (* list-of-list to flat list *) - eprintf "dialog [%s]\n%!" - (String.concat "; " (List.map (sprintf "%S") params)); - - (* 'dialog' writes its output/result to stderr, so we need to take - * special steps to capture that - in other words, manual pipe/fork. - *) - let rfd, wfd = pipe () in - match fork () with - | 0 -> (* child, runs dialog *) - close rfd; - dup2 wfd stderr; (* capture stderr to pipe *) - execvp "dialog" (Array.of_list ("dialog" :: params)) - | pid -> (* parent *) - close wfd; - let chan = in_channel_of_descr rfd in - let result = input_all_lines chan in - close rfd; - eprintf "dialog result: %S\n%!" (String.concat "\n" result); - match snd (wait ()) with - | WEXITED 0 -> Yes result (* something selected / entered *) - | WEXITED 1 -> No (* cancel / no button *) - | WEXITED 2 -> Help (* help pressed *) - | WEXITED 3 -> Back (* back button *) - | WEXITED _ -> Error (* error or Esc *) - | WSIGNALED i -> failwith (sprintf "dialog: killed by signal %d" i) - | WSTOPPED i -> failwith (sprintf "dialog: stopped by signal %d" i) - -(* Title and common dialog options. *) -and title title ?(cancel=false) ?(backbutton=true) () = - let params = ["--title"; title] in - let params = if not cancel then "--nocancel" :: params else params in - let params = - if backbutton then "--extra-button" :: "--extra-label" :: "Back" :: params - else params in - params - -(* Message box. *) -and msgbox text height width = - [ "--msgbox"; text; string_of_int height; string_of_int width ] - -(* Simple input box. *) -and inputbox text height width default = - [ "--inputbox"; text; string_of_int height; string_of_int width; default ] - -(* Radio list and check list. *) -and radiolist text height width listheight items = - let items = List.map ( - function - | tag, item, true -> [ tag; item; "on" ] - | tag, item, false -> [ tag; item; "off" ] - ) items in - let items = List.concat items in - "--single-quoted" :: - "--radiolist" :: text :: string_of_int height :: string_of_int width :: - string_of_int listheight :: items - -and checklist text height width listheight items = - let items = List.map ( - function - | tag, item, true -> [ tag; item; "on" ] - | tag, item, false -> [ tag; item; "off" ] - ) items in - let items = List.concat items in - "--separate-output" :: - "--checklist" :: text :: string_of_int height :: string_of_int width :: - string_of_int listheight :: items - -(* Print failure dialog and exit. *) -and fail_dialog text = - let text = text ^ "\n\nIf you want to report this error, there is a shell on [ALT] [F2], log in as root with no password.\n\nPlease provide the contents of /tmp/virt-p2v.log and output of the 'dmesg' command." in - ignore ( - dialog [ - title "Error" (); - msgbox text 17 50 - ] - ); - exit 1 - let usage () = eprintf "usage: virt-p2v [ttyname]\n%!"; exit 2