X-Git-Url: http://git.annexia.org/?p=libguestfs.git;a=blobdiff_plain;f=src%2Fgenerator.ml;h=95a0985366b4d5120186bd922fc9bb5b8838da26;hp=d598975458db95babd954113033ea79cb9108e9f;hb=13339826ea01f8dbd581b5d2544e7692171cf386;hpb=6085137e65cb63aaf725207f2929a571d1149420 diff --git a/src/generator.ml b/src/generator.ml index d598975..95a0985 100755 --- a/src/generator.ml +++ b/src/generator.ml @@ -32,9 +32,15 @@ and ret = * indication, ie. 0 or -1. *) | Err - (* "RString" and "RStringList" require special treatment because - * the caller must free them. + (* "RBool" is a bool return value which can be true/false or + * -1 for error. *) + | RBool of string + (* "RConstString" is a string that refers to a constant value. + * Try to avoid using this. + *) + | RConstString of string + (* "RString" and "RStringList" are caller-frees. *) | RString of string | RStringList of string (* LVM PVs, VGs and LVs. *) @@ -48,10 +54,130 @@ and args = | P2 of argt * argt and argt = | String of string (* const char *name, cannot be NULL *) + | OptString of string (* const char *name, may be NULL *) + | Bool of string (* boolean *) + +type flags = + | ProtocolLimitWarning (* display warning about protocol size limits *) + | FishAlias of string (* provide an alias for this cmd in guestfish *) + | FishAction of string (* call this function in guestfish *) + | NotInFish (* do not export via guestfish *) + +(* Note about long descriptions: When referring to another + * action, use the format C (ie. the full name of + * the C function). This will be replaced as appropriate in other + * language bindings. + * + * Apart from that, long descriptions are just perldoc paragraphs. + *) + +let non_daemon_functions = [ + ("launch", (Err, P0), -1, [FishAlias "run"; FishAction "launch"], + "launch the qemu subprocess", + "\ +Internally libguestfs is implemented by running a virtual machine +using L. + +You should call this after configuring the handle +(eg. adding drives) but before performing any actions."); + + ("wait_ready", (Err, P0), -1, [NotInFish], + "wait until the qemu subprocess launches", + "\ +Internally libguestfs is implemented by running a virtual machine +using L. + +You should call this after C to wait for the launch +to complete."); + + ("kill_subprocess", (Err, P0), -1, [], + "kill the qemu subprocess", + "\ +This kills the qemu subprocess. You should never need to call this."); + + ("add_drive", (Err, P1 (String "filename")), -1, [FishAlias "add"], + "add an image to examine or modify", + "\ +This function adds a virtual machine disk image C to the +guest. The first time you call this function, the disk appears as IDE +disk 0 (C) in the guest, the second time as C, and +so on. + +You don't necessarily need to be root when using libguestfs. However +you obviously do need sufficient permissions to access the filename +for whatever operations you want to perform (ie. read access if you +just want to read the image or write access if you want to modify the +image). + +This is equivalent to the qemu parameter C<-drive file=filename>."); + + ("add_cdrom", (Err, P1 (String "filename")), -1, [FishAlias "cdrom"], + "add a CD-ROM disk image to examine", + "\ +This function adds a virtual CD-ROM disk image to the guest. + +This is equivalent to the qemu parameter C<-cdrom filename>."); + + ("config", (Err, P2 (String "qemuparam", OptString "qemuvalue")), -1, [], + "add qemu parameters", + "\ +This can be used to add arbitrary qemu command line parameters +of the form C<-param value>. Actually it's not quite arbitrary - we +prevent you from setting some parameters which would interfere with +parameters that we use. + +The first character of C string must be a C<-> (dash). + +C can be NULL."); + + ("set_path", (Err, P1 (String "path")), -1, [FishAlias "path"], + "set the search path", + "\ +Set the path that libguestfs searches for kernel and initrd.img. + +The default is C<$libdir/guestfs> unless overridden by setting +C environment variable. + +The string C is stashed in the libguestfs handle, so the caller +must make sure it remains valid for the lifetime of the handle. + +Setting C to C restores the default path."); + + ("get_path", (RConstString "path", P0), -1, [], + "get the search path", + "\ +Return the current search path. + +This is always non-NULL. If it wasn't set already, then this will +return the default path."); + + ("set_autosync", (Err, P1 (Bool "autosync")), -1, [FishAlias "autosync"], + "set autosync mode", + "\ +If C is true, this enables autosync. Libguestfs will make a +best effort attempt to run C when the handle is closed +(also if the program exits without closing handles)."); + + ("get_autosync", (RBool "autosync", P0), -1, [], + "get autosync mode", + "\ +Get the autosync flag."); + + ("set_verbose", (Err, P1 (Bool "verbose")), -1, [FishAlias "verbose"], + "set verbose mode", + "\ +If C is true, this turns on verbose messages (to C). -type flags = ProtocolLimitWarning +Verbose messages are disabled unless the environment variable +C is defined and set to C<1>."); -let functions = [ + ("get_verbose", (RBool "verbose", P0), -1, [], + "get verbose mode", + "\ +This returns the verbose messages flag.") +] + +let daemon_functions = [ ("mount", (Err, P2 (String "device", String "mountpoint")), 1, [], "mount a guest disk at a position in the filesystem", "\ @@ -79,7 +205,7 @@ This syncs the disk, so that any writes are flushed through to the underlying disk image. You should always call this if you have modified a disk image, before -calling C."); +closing the handle."); ("touch", (Err, P1 (String "path")), 3, [], "update file timestamps or create a new file", @@ -122,8 +248,7 @@ should probably use C instead."); "\ List all the block devices. -The full block device names are returned, eg. C -"); +The full block device names are returned, eg. C"); ("list_partitions", (RStringList "partitions", P0), 8, [], "list the partitions", @@ -187,6 +312,14 @@ List all the logical volumes detected. This is the equivalent of the L command. The \"full\" version includes all fields."); ] +let all_functions = non_daemon_functions @ daemon_functions + +(* In some places we want the functions to be displayed sorted + * alphabetically, so this is useful: + *) +let all_functions_sorted = + List.sort (fun (n1,_,_,_,_,_) (n2,_,_,_,_,_) -> compare n1 n2) all_functions + (* Column names and types from LVM PVs/VGs/LVs. *) let pv_cols = [ "pv_name", `String; @@ -250,15 +383,13 @@ let lv_cols = [ "modules", `String; ] -(* In some places we want the functions to be displayed sorted - * alphabetically, so this is useful: +(* Useful functions. + * Note we don't want to use any external OCaml libraries which + * makes this a bit harder than it should be. *) -let sorted_functions = - List.sort (fun (n1,_,_,_,_,_) (n2,_,_,_,_,_) -> compare n1 n2) functions - -(* Useful functions. *) let failwithf fs = ksprintf failwith fs -let replace s c1 c2 = + +let replace_char s c1 c2 = let s2 = String.copy s in let r = ref false in for i = 0 to String.length s2 - 1 do @@ -269,6 +400,50 @@ let replace s c1 c2 = done; if not !r then s else s2 +let rec find s sub = + let len = String.length s in + let sublen = String.length sub in + let rec loop i = + if i <= len-sublen then ( + let rec loop2 j = + if j < sublen then ( + if s.[i+j] = sub.[j] then loop2 (j+1) + else -1 + ) else + i (* found *) + in + let r = loop2 0 in + if r = -1 then loop (i+1) else r + ) else + -1 (* not found *) + in + loop 0 + +let rec replace_str s s1 s2 = + let len = String.length s in + let sublen = String.length s1 in + let i = find s s1 in + if i = -1 then s + else ( + let s' = String.sub s 0 i in + let s'' = String.sub s (i+sublen) (len-i-sublen) in + s' ^ s2 ^ replace_str s'' s1 s2 + ) + +let rec find_map f = function + | [] -> raise Not_found + | x :: xs -> + match f x with + | Some y -> y + | None -> find_map f xs + +let iteri f xs = + let rec loop i = function + | [] -> () + | x :: xs -> f i x; loop (i+1) xs + in + loop 0 xs + (* 'pr' prints to the current output file. *) let chan = ref stdout let pr fs = ksprintf (output_string !chan) fs @@ -293,14 +468,29 @@ let nr_args = function | P0 -> 0 | P1 _ -> 1 | P2 _ -> 2 (* Check function names etc. for consistency. *) let check_functions () = List.iter ( - fun (name, _, _, _, _, _) -> + fun (name, _, _, _, _, longdesc) -> if String.contains name '-' then - failwithf "Function name '%s' should not contain '-', use '_' instead." - name - ) functions; + failwithf "function name '%s' should not contain '-', use '_' instead." + name; + if longdesc.[String.length longdesc-1] = '\n' then + failwithf "long description of %s should not end with \\n." name + ) all_functions; + + List.iter ( + fun (name, _, proc_nr, _, _, _) -> + if proc_nr <= 0 then + failwithf "daemon function %s should have proc_nr > 0" name + ) daemon_functions; + + List.iter ( + fun (name, _, proc_nr, _, _, _) -> + if proc_nr <> -1 then + failwithf "non-daemon function %s should have proc_nr -1" name + ) non_daemon_functions; let proc_nrs = - List.map (fun (name, _, proc_nr, _, _, _) -> name, proc_nr) functions in + List.map (fun (name, _, proc_nr, _, _, _) -> name, proc_nr) + daemon_functions in let proc_nrs = List.sort (fun (_,nr1) (_,nr2) -> compare nr1 nr2) proc_nrs in let rec loop = function @@ -380,6 +570,11 @@ and generate_actions_pod () = (match fst style with | Err -> pr "This function returns 0 on success or -1 on error.\n\n" + | RBool _ -> + pr "This function returns a C truth value on success or -1 on error.\n\n" + | RConstString _ -> + pr "This function returns a string or NULL on error. +The string is owned by the guest handle and must I be freed.\n\n" | RString _ -> pr "This function returns a string or NULL on error. I.\n\n" @@ -401,7 +596,7 @@ I after use.>.\n\n" pr "Because of the message protocol, there is a transfer limit of somewhere between 2MB and 4MB. To transfer large files you should use FTP.\n\n"; - ) sorted_functions + ) all_functions_sorted and generate_structs_pod () = (* LVM structs documentation. *) @@ -466,7 +661,7 @@ and generate_xdr () = ) ["pv", pv_cols; "vg", vg_cols; "lv", lv_cols]; List.iter ( - fun (shortname, style, _, _, _, _) -> + fun(shortname, style, _, _, _, _) -> let name = "guestfs_" ^ shortname in pr "/* %s */\n\n" name; (match snd style with @@ -476,11 +671,19 @@ and generate_xdr () = iter_args ( function | String name -> pr " string %s<>;\n" name + | OptString name -> pr " string *%s<>;\n" name + | Bool name -> pr " bool %s;\n" name ) args; pr "};\n\n" ); (match fst style with - | Err -> () + | Err -> () + | RBool n -> + pr "struct %s_ret {\n" name; + pr " bool %s;\n" n; + pr "};\n\n" + | RConstString _ -> + failwithf "RConstString cannot be returned from a daemon function" | RString n -> pr "struct %s_ret {\n" name; pr " string %s<>;\n" n; @@ -502,14 +705,14 @@ and generate_xdr () = pr " guestfs_lvm_int_lv_list %s;\n" n; pr "};\n\n" ); - ) functions; + ) daemon_functions; (* Table of procedure numbers. *) pr "enum guestfs_procedure {\n"; List.iter ( fun (shortname, _, proc_nr, _, _, _) -> pr " GUESTFS_PROC_%s = %d,\n" (String.uppercase shortname) proc_nr - ) functions; + ) daemon_functions; pr " GUESTFS_PROC_dummy\n"; (* so we don't have a "hanging comma" *) pr "};\n"; pr "\n"; @@ -602,7 +805,7 @@ and generate_actions_h () = let name = "guestfs_" ^ shortname in generate_prototype ~single_line:true ~newline:true ~handle:"handle" name style - ) functions + ) all_functions (* Generate the client-side dispatch stubs. *) and generate_client_actions () = @@ -620,7 +823,10 @@ and generate_client_actions () = pr " struct guestfs_message_error err;\n"; (match fst style with | Err -> () - | RString _ | RStringList _ | RPVList _ | RVGList _ | RLVList _ -> + | RConstString _ -> + failwithf "RConstString cannot be returned from a daemon function" + | RBool _ | RString _ | RStringList _ + | RPVList _ | RVGList _ | RLVList _ -> pr " struct %s_ret ret;\n" name ); pr "};\n\n"; @@ -644,7 +850,10 @@ and generate_client_actions () = (match fst style with | Err -> () - | RString _ | RStringList _ | RPVList _ | RVGList _ | RLVList _ -> + | RConstString _ -> + failwithf "RConstString cannot be returned from a daemon function" + | RBool _ | RString _ | RStringList _ + | RPVList _ | RVGList _ | RLVList _ -> pr " if (!xdr_%s_ret (xdr, &rv->ret)) {\n" name; pr " error (g, \"%s: failed to parse reply\");\n" name; pr " return;\n"; @@ -662,7 +871,9 @@ and generate_client_actions () = let error_code = match fst style with - | Err -> "-1" + | Err | RBool _ -> "-1" + | RConstString _ -> + failwithf "RConstString cannot be returned from a daemon function" | RString _ | RStringList _ | RPVList _ | RVGList _ | RLVList _ -> "NULL" in @@ -693,7 +904,12 @@ and generate_client_actions () = | args -> iter_args ( function - | String name -> pr " args.%s = (char *) %s;\n" name name + | String name -> + pr " args.%s = (char *) %s;\n" name name + | OptString name -> + pr " args.%s = %s ? *%s : NULL;\n" name name name + | Bool name -> + pr " args.%s = %s;\n" name name ) args; pr " serial = dispatch (g, GUESTFS_PROC_%s,\n" (String.uppercase shortname); @@ -729,11 +945,17 @@ and generate_client_actions () = (match fst style with | Err -> pr " return 0;\n" + | RBool n -> pr " return rv.ret.%s;\n" n + | RConstString _ -> + failwithf "RConstString cannot be returned from a daemon function" | RString n -> pr " return rv.ret.%s; /* caller will free */\n" n | RStringList n -> pr " /* caller will free this, but we need to add a NULL entry */\n"; - pr " rv.ret.%s.%s_val = safe_realloc (g, rv.ret.%s.%s_val, rv.ret.%s.%s_len + 1);\n" n n n n n n; + pr " rv.ret.%s.%s_val =" n n; + pr " safe_realloc (g, rv.ret.%s.%s_val,\n" n n; + pr " sizeof (char *) * (rv.ret.%s.%s_len + 1));\n" + n n; pr " rv.ret.%s.%s_val[rv.ret.%s.%s_len] = NULL;\n" n n n n; pr " return rv.ret.%s.%s_val;\n" n n | RPVList n -> @@ -748,7 +970,7 @@ and generate_client_actions () = ); pr "}\n\n" - ) functions + ) daemon_functions (* Generate daemon/actions.h. *) and generate_daemon_actions_h () = @@ -759,9 +981,9 @@ and generate_daemon_actions_h () = List.iter ( fun (name, style, _, _, _, _) -> - generate_prototype - ~single_line:true ~newline:true ~in_daemon:true ("do_" ^ name) style; - ) functions + generate_prototype + ~single_line:true ~newline:true ~in_daemon:true ("do_" ^ name) style; + ) daemon_functions (* Generate the server-side stubs. *) and generate_daemon_actions () = @@ -790,6 +1012,9 @@ and generate_daemon_actions () = let error_code = match fst style with | Err -> pr " int r;\n"; "-1" + | RBool _ -> pr " int r;\n"; "-1" + | RConstString _ -> + failwithf "RConstString cannot be returned from a daemon function" | RString _ -> pr " char *r;\n"; "NULL" | RStringList _ -> pr " char **r;\n"; "NULL" | RPVList _ -> pr " guestfs_lvm_int_pv_list *r;\n"; "NULL" @@ -802,7 +1027,9 @@ and generate_daemon_actions () = pr " struct guestfs_%s_args args;\n" name; iter_args ( function - | String name -> pr " const char *%s;\n" name + | String name + | OptString name -> pr " const char *%s;\n" name + | Bool name -> pr " int %s;\n" name ) args ); pr "\n"; @@ -819,6 +1046,8 @@ and generate_daemon_actions () = iter_args ( function | String name -> pr " %s = args.%s;\n" name name + | OptString name -> pr " %s = args.%s;\n" name name (* XXX? *) + | Bool name -> pr " %s = args.%s;\n" name name ) args; pr "\n" ); @@ -834,6 +1063,12 @@ and generate_daemon_actions () = (match fst style with | Err -> pr " reply (NULL, NULL);\n" + | RBool n -> + pr " struct guestfs_%s_ret ret;\n" name; + pr " ret.%s = r;\n" n; + pr " reply ((xdrproc_t) &xdr_guestfs_%s_ret, (char *) &ret);\n" name + | RConstString _ -> + failwithf "RConstString cannot be returned from a daemon function" | RString n -> pr " struct guestfs_%s_ret ret;\n" name; pr " ret.%s = r;\n" n; @@ -863,7 +1098,7 @@ and generate_daemon_actions () = ); pr "}\n\n"; - ) functions; + ) daemon_functions; (* Dispatch function. *) pr "void dispatch_incoming_message (XDR *xdr_in)\n"; @@ -872,10 +1107,10 @@ and generate_daemon_actions () = List.iter ( fun (name, style, _, _, _, _) -> - pr " case GUESTFS_PROC_%s:\n" (String.uppercase name); - pr " %s_stub (xdr_in);\n" name; - pr " break;\n" - ) functions; + pr " case GUESTFS_PROC_%s:\n" (String.uppercase name); + pr " %s_stub (xdr_in);\n" name; + pr " break;\n" + ) daemon_functions; pr " default:\n"; pr " reply_with_error (\"dispatch_incoming_message: unknown procedure number %%d\", proc_nr);\n"; @@ -1052,6 +1287,15 @@ and generate_daemon_actions () = and generate_fish_cmds () = generate_header CStyle GPLv2; + let all_functions = + List.filter ( + fun (_, _, _, flags, _, _) -> not (List.mem NotInFish flags) + ) all_functions in + let all_functions_sorted = + List.filter ( + fun (_, _, _, flags, _, _) -> not (List.mem NotInFish flags) + ) all_functions_sorted in + pr "#include \n"; pr "#include \n"; pr "#include \n"; @@ -1067,11 +1311,11 @@ and generate_fish_cmds () = pr " printf (\" %%-16s %%s\\n\", \"Command\", \"Description\");\n"; pr " list_builtin_commands ();\n"; List.iter ( - fun (name, _, _, _, shortdesc, _) -> - let name = replace name '_' '-' in + fun (name, _, _, flags, shortdesc, _) -> + let name = replace_char name '_' '-' in pr " printf (\"%%-20s %%s\\n\", \"%s\", \"%s\");\n" name shortdesc - ) sorted_functions; + ) all_functions_sorted; pr " printf (\" Use -h / help to show detailed help for a command.\\n\");\n"; pr "}\n"; pr "\n"; @@ -1081,7 +1325,11 @@ and generate_fish_cmds () = pr "{\n"; List.iter ( fun (name, style, _, flags, shortdesc, longdesc) -> - let name2 = replace name '_' '-' in + let name2 = replace_char name '_' '-' in + let alias = + try find_map (function FishAlias n -> Some n | _ -> None) flags + with Not_found -> name in + let longdesc = replace_str longdesc "C name2 @@ -1090,7 +1338,7 @@ and generate_fish_cmds () = name2 ( String.concat "> <" ( map_args (function - | String n -> n) args + | String n | OptString n | Bool n -> n) args ) ) in @@ -1101,16 +1349,23 @@ of somewhere between 2MB and 4MB. To transfer large files you should use FTP." else "" in + let describe_alias = + if name <> alias then + sprintf "\n\nYou can use '%s' as an alias for this command." alias + else "" in + pr " if ("; pr "strcasecmp (cmd, \"%s\") == 0" name; if name <> name2 then pr " || strcasecmp (cmd, \"%s\") == 0" name2; + if name <> alias then + pr " || strcasecmp (cmd, \"%s\") == 0" alias; pr ")\n"; pr " pod2text (\"%s - %s\", %S);\n" name2 shortdesc - (" " ^ synopsis ^ "\n\n" ^ longdesc ^ warnings); + (" " ^ synopsis ^ "\n\n" ^ longdesc ^ warnings ^ describe_alias); pr " else\n" - ) functions; + ) all_functions; pr " display_builtin_command (cmd);\n"; pr "}\n"; pr "\n"; @@ -1156,11 +1411,13 @@ FTP." (* run_ actions *) List.iter ( - fun (name, style, _, _, _, _) -> + fun (name, style, _, flags, _, _) -> pr "static int run_%s (const char *cmd, int argc, char *argv[])\n" name; pr "{\n"; (match fst style with - | Err -> pr " int r;\n" + | Err + | RBool _ -> pr " int r;\n" + | RConstString _ -> pr " const char *r;\n" | RString _ -> pr " char *r;\n" | RStringList _ -> pr " char **r;\n" | RPVList _ -> pr " struct guestfs_lvm_pv_list *r;\n" @@ -1170,6 +1427,8 @@ FTP." iter_args ( function | String name -> pr " const char *%s;\n" name + | OptString name -> pr " const char *%s;\n" name + | Bool name -> pr " int %s;\n" name ) (snd style); (* Check and convert parameters. *) @@ -1184,19 +1443,35 @@ FTP." fun i -> function | String name -> pr " %s = argv[%d];\n" name i + | OptString name -> + pr " %s = strcmp (argv[%d], \"\") != 0 ? argv[%d] : NULL;\n" + name i i + | Bool name -> + pr " %s = is_true (argv[%d]) ? 1 : 0;\n" name i ) (snd style); (* Call C API function. *) - pr " r = guestfs_%s " name; + let fn = + try find_map (function FishAction n -> Some n | _ -> None) flags + with Not_found -> sprintf "guestfs_%s" name in + pr " r = %s " fn; generate_call_args ~handle:"g" style; pr ";\n"; (* Check return value for errors and display command results. *) (match fst style with | Err -> pr " return r;\n" + | RBool _ -> + pr " if (r == -1) return -1;\n"; + pr " if (r) printf (\"true\\n\"); else printf (\"false\\n\");\n"; + pr " return 0;\n" + | RConstString _ -> + pr " if (r == NULL) return -1;\n"; + pr " printf (\"%%s\\n\", r);\n"; + pr " return 0;\n" | RString _ -> pr " if (r == NULL) return -1;\n"; - pr " printf (\"%%s\", r);\n"; + pr " printf (\"%%s\\n\", r);\n"; pr " free (r);\n"; pr " return 0;\n" | RStringList _ -> @@ -1222,22 +1497,27 @@ FTP." ); pr "}\n"; pr "\n" - ) functions; + ) all_functions; (* run_action function *) pr "int run_action (const char *cmd, int argc, char *argv[])\n"; pr "{\n"; List.iter ( - fun (name, _, _, _, _, _) -> - let name2 = replace name '_' '-' in + fun (name, _, _, flags, _, _) -> + let name2 = replace_char name '_' '-' in + let alias = + try find_map (function FishAlias n -> Some n | _ -> None) flags + with Not_found -> name in pr " if ("; pr "strcasecmp (cmd, \"%s\") == 0" name; if name <> name2 then pr " || strcasecmp (cmd, \"%s\") == 0" name2; + if name <> alias then + pr " || strcasecmp (cmd, \"%s\") == 0" alias; pr ")\n"; pr " return run_%s (cmd, argc, argv);\n" name; pr " else\n"; - ) functions; + ) all_functions; pr " {\n"; pr " fprintf (stderr, \"%%s: unknown command\\n\", cmd);\n"; pr " return -1;\n"; @@ -1246,6 +1526,38 @@ FTP." pr "}\n"; pr "\n" +(* Generate the POD documentation for guestfish. *) +and generate_fish_actions_pod () = + let all_functions_sorted = + List.filter ( + fun (_, _, _, flags, _, _) -> not (List.mem NotInFish flags) + ) all_functions_sorted in + + List.iter ( + fun (name, style, _, flags, _, longdesc) -> + let longdesc = replace_str longdesc "C Some n | _ -> None) flags + with Not_found -> name in + + pr "=head2 %s" name; + if name <> alias then + pr " | %s" alias; + pr "\n"; + pr "\n"; + pr " %s" name; + iter_args ( + function + | String n -> pr " %s" n + | OptString n -> pr " %s" n + | Bool _ -> pr " true|false" + ) (snd style); + pr "\n"; + pr "\n"; + pr "%s\n\n" longdesc + ) all_functions_sorted + (* Generate a C function prototype. *) and generate_prototype ?(extern = true) ?(static = false) ?(semicolon = true) ?(single_line = false) ?(newline = false) ?(in_daemon = false) @@ -1254,6 +1566,8 @@ and generate_prototype ?(extern = true) ?(static = false) ?(semicolon = true) if static then pr "static "; (match fst style with | Err -> pr "int " + | RBool _ -> pr "int " + | RConstString _ -> pr "const char *" | RString _ -> pr "char *" | RStringList _ -> pr "char **" | RPVList _ -> @@ -1281,6 +1595,8 @@ and generate_prototype ?(extern = true) ?(static = false) ?(semicolon = true) iter_args ( function | String name -> next (); pr "const char *%s" name + | OptString name -> next (); pr "const char *%s" name + | Bool name -> next (); pr "int %s" name ) (snd style); pr ")"; if semicolon then pr ";"; @@ -1300,9 +1616,633 @@ and generate_call_args ?handle style = comma := true; match arg with | String name -> pr "%s" name + | OptString name -> pr "%s" name + | Bool name -> pr "%s" name ) (snd style); pr ")" +(* Generate the OCaml bindings interface. *) +and generate_ocaml_mli () = + generate_header OCamlStyle LGPLv2; + + pr "\ +(** For API documentation you should refer to the C API + in the guestfs(3) manual page. The OCaml API uses almost + exactly the same calls. *) + +type t +(** A [guestfs_h] handle. *) + +exception Error of string +(** This exception is raised when there is an error. *) + +val create : unit -> t + +val close : t -> unit +(** Handles are closed by the garbage collector when they become + unreferenced, but callers can also call this in order to + provide predictable cleanup. *) + +"; + generate_ocaml_lvm_structure_decls (); + + (* The actions. *) + List.iter ( + fun (name, style, _, _, shortdesc, _) -> + generate_ocaml_prototype name style; + pr "(** %s *)\n" shortdesc; + pr "\n" + ) all_functions + +(* Generate the OCaml bindings implementation. *) +and generate_ocaml_ml () = + generate_header OCamlStyle LGPLv2; + + pr "\ +type t +exception Error of string +external create : unit -> t = \"ocaml_guestfs_create\" +external close : t -> unit = \"ocaml_guestfs_close\" + +let () = + Callback.register_exception \"ocaml_guestfs_error\" (Error \"\") + +"; + + generate_ocaml_lvm_structure_decls (); + + (* The actions. *) + List.iter ( + fun (name, style, _, _, shortdesc, _) -> + generate_ocaml_prototype ~is_external:true name style; + ) all_functions + +(* Generate the OCaml bindings C implementation. *) +and generate_ocaml_c () = + generate_header CStyle LGPLv2; + + pr "#include \n"; + pr "#include \n"; + pr "#include \n"; + pr "\n"; + pr "#include \n"; + pr "#include \n"; + pr "#include \n"; + pr "#include \n"; + pr "#include \n"; + pr "#include \n"; + pr "#include \n"; + pr "\n"; + pr "#include \n"; + pr "\n"; + pr "#include \"guestfs_c.h\"\n"; + pr "\n"; + + (* LVM struct copy functions. *) + List.iter ( + fun (typ, cols) -> + let has_optpercent_col = + List.exists (function (_, `OptPercent) -> true | _ -> false) cols in + + pr "static CAMLprim value\n"; + pr "copy_lvm_%s (const struct guestfs_lvm_%s *%s)\n" typ typ typ; + pr "{\n"; + pr " CAMLparam0 ();\n"; + if has_optpercent_col then + pr " CAMLlocal3 (rv, v, v2);\n" + else + pr " CAMLlocal2 (rv, v);\n"; + pr "\n"; + pr " rv = caml_alloc (%d, 0);\n" (List.length cols); + iteri ( + fun i col -> + (match col with + | name, `String -> + pr " v = caml_copy_string (%s->%s);\n" typ name + | name, `UUID -> + pr " v = caml_alloc_string (32);\n"; + pr " memcpy (String_val (v), %s->%s, 32);\n" typ name + | name, `Bytes + | name, `Int -> + pr " v = caml_copy_int64 (%s->%s);\n" typ name + | name, `OptPercent -> + pr " if (%s->%s >= 0) { /* Some %s */\n" typ name name; + pr " v2 = caml_copy_double (%s->%s);\n" typ name; + pr " v = caml_alloc (1, 0);\n"; + pr " Store_field (v, 0, v2);\n"; + pr " } else /* None */\n"; + pr " v = Val_int (0);\n"; + ); + pr " Store_field (rv, %d, v);\n" i + ) cols; + pr " CAMLreturn (rv);\n"; + pr "}\n"; + pr "\n"; + + pr "static CAMLprim value\n"; + pr "copy_lvm_%s_list (const struct guestfs_lvm_%s_list *%ss)\n" + typ typ typ; + pr "{\n"; + pr " CAMLparam0 ();\n"; + pr " CAMLlocal2 (rv, v);\n"; + pr " int i;\n"; + pr "\n"; + pr " if (%ss->len == 0)\n" typ; + pr " CAMLreturn (Atom (0));\n"; + pr " else {\n"; + pr " rv = caml_alloc (%ss->len, 0);\n" typ; + pr " for (i = 0; i < %ss->len; ++i) {\n" typ; + pr " v = copy_lvm_%s (&%ss->val[i]);\n" typ typ; + pr " caml_modify (&Field (rv, i), v);\n"; + pr " }\n"; + pr " CAMLreturn (rv);\n"; + pr " }\n"; + pr "}\n"; + pr "\n"; + ) ["pv", pv_cols; "vg", vg_cols; "lv", lv_cols]; + + List.iter ( + fun (name, style, _, _, _, _) -> + pr "CAMLprim value\n"; + pr "ocaml_guestfs_%s (value gv" name; + iter_args ( + function + | String n | OptString n | Bool n -> pr ", value %sv" n + ) (snd style); + pr ")\n"; + pr "{\n"; + pr " CAMLparam%d (gv" (1 + (nr_args (snd style))); + iter_args ( + function + | String n | OptString n | Bool n -> pr ", %sv" n + ) (snd style); + pr ");\n"; + pr " CAMLlocal1 (rv);\n"; + pr "\n"; + + pr " guestfs_h *g = Guestfs_val (gv);\n"; + pr " if (g == NULL)\n"; + pr " caml_failwith (\"%s: used handle after closing it\");\n" name; + pr "\n"; + + iter_args ( + function + | String n -> + pr " const char *%s = String_val (%sv);\n" n n + | OptString n -> + pr " const char *%s =\n" n; + pr " %sv != Val_int (0) ? String_val (Field (%sv, 0)) : NULL;\n" + n n + | Bool n -> + pr " int %s = Bool_val (%sv);\n" n n + ) (snd style); + let error_code = + match fst style with + | Err -> pr " int r;\n"; "-1" + | RBool _ -> pr " int r;\n"; "-1" + | RConstString _ -> pr " const char *r;\n"; "NULL" + | RString _ -> pr " char *r;\n"; "NULL" + | RStringList _ -> + pr " int i;\n"; + pr " char **r;\n"; + "NULL" + | RPVList _ -> + pr " struct guestfs_lvm_pv_list *r;\n"; + "NULL" + | RVGList _ -> + pr " struct guestfs_lvm_vg_list *r;\n"; + "NULL" + | RLVList _ -> + pr " struct guestfs_lvm_lv_list *r;\n"; + "NULL" in + pr "\n"; + + pr " caml_enter_blocking_section ();\n"; + pr " r = guestfs_%s " name; + generate_call_args ~handle:"g" style; + pr ";\n"; + pr " caml_leave_blocking_section ();\n"; + pr " if (r == %s)\n" error_code; + pr " ocaml_guestfs_raise_error (g, \"%s\");\n" name; + pr "\n"; + + (match fst style with + | Err -> pr " rv = Val_unit;\n" + | RBool _ -> pr " rv = r ? Val_true : Val_false;\n" + | RConstString _ -> pr " rv = caml_copy_string (r);\n" + | RString _ -> + pr " rv = caml_copy_string (r);\n"; + pr " free (r);\n" + | RStringList _ -> + pr " rv = caml_copy_string_array ((const char **) r);\n"; + pr " for (i = 0; r[i] != NULL; ++i) free (r[i]);\n"; + pr " free (r);\n" + | RPVList _ -> + pr " rv = copy_lvm_pv_list (r);\n"; + pr " guestfs_free_lvm_pv_list (r);\n"; + | RVGList _ -> + pr " rv = copy_lvm_vg_list (r);\n"; + pr " guestfs_free_lvm_vg_list (r);\n"; + | RLVList _ -> + pr " rv = copy_lvm_lv_list (r);\n"; + pr " guestfs_free_lvm_lv_list (r);\n"; + ); + + pr " CAMLreturn (rv);\n"; + pr "}\n"; + pr "\n" + ) all_functions + +and generate_ocaml_lvm_structure_decls () = + List.iter ( + fun (typ, cols) -> + pr "type lvm_%s = {\n" typ; + List.iter ( + function + | name, `String -> pr " %s : string;\n" name + | name, `UUID -> pr " %s : string;\n" name + | name, `Bytes -> pr " %s : int64;\n" name + | name, `Int -> pr " %s : int64;\n" name + | name, `OptPercent -> pr " %s : float option;\n" name + ) cols; + pr "}\n"; + pr "\n" + ) ["pv", pv_cols; "vg", vg_cols; "lv", lv_cols] + +and generate_ocaml_prototype ?(is_external = false) name style = + if is_external then pr "external " else pr "val "; + pr "%s : t -> " name; + iter_args ( + function + | String _ -> pr "string -> " + | OptString _ -> pr "string option -> " + | Bool _ -> pr "bool -> " + ) (snd style); + (match fst style with + | Err -> pr "unit" (* all errors are turned into exceptions *) + | RBool _ -> pr "bool" + | RConstString _ -> pr "string" + | RString _ -> pr "string" + | RStringList _ -> pr "string array" + | RPVList _ -> pr "lvm_pv array" + | RVGList _ -> pr "lvm_vg array" + | RLVList _ -> pr "lvm_lv array" + ); + if is_external then pr " = \"ocaml_guestfs_%s\"" name; + pr "\n" + +(* Generate Perl xs code, a sort of crazy variation of C with macros. *) +and generate_perl_xs () = + generate_header CStyle LGPLv2; + + pr "\ +#include \"EXTERN.h\" +#include \"perl.h\" +#include \"XSUB.h\" + +#include + +#ifndef PRId64 +#define PRId64 \"lld\" +#endif + +static SV * +my_newSVll(long long val) { +#ifdef USE_64_BIT_ALL + return newSViv(val); +#else + char buf[100]; + int len; + len = snprintf(buf, 100, \"%%\" PRId64, val); + return newSVpv(buf, len); +#endif +} + +#ifndef PRIu64 +#define PRIu64 \"llu\" +#endif + +static SV * +my_newSVull(unsigned long long val) { +#ifdef USE_64_BIT_ALL + return newSVuv(val); +#else + char buf[100]; + int len; + len = snprintf(buf, 100, \"%%\" PRIu64, val); + return newSVpv(buf, len); +#endif +} + +/* XXX Not thread-safe, and in general not safe if the caller is + * issuing multiple requests in parallel (on different guestfs + * handles). We should use the guestfs_h handle passed to the + * error handle to distinguish these cases. + */ +static char *last_error = NULL; + +static void +error_handler (guestfs_h *g, + void *data, + const char *msg) +{ + if (last_error != NULL) free (last_error); + last_error = strdup (msg); +} + +MODULE = Sys::Guestfs PACKAGE = Sys::Guestfs + +guestfs_h * +_create () + CODE: + RETVAL = guestfs_create (); + if (!RETVAL) + croak (\"could not create guestfs handle\"); + guestfs_set_error_handler (RETVAL, error_handler, NULL); + OUTPUT: + RETVAL + +void +DESTROY (g) + guestfs_h *g; + PPCODE: + guestfs_close (g); + +"; + + List.iter ( + fun (name, style, _, _, _, _) -> + (match fst style with + | Err -> pr "void\n" + | RBool _ -> pr "SV *\n" + | RConstString _ -> pr "SV *\n" + | RString _ -> pr "SV *\n" + | RStringList _ + | RPVList _ | RVGList _ | RLVList _ -> + pr "void\n" (* all lists returned implictly on the stack *) + ); + (* Call and arguments. *) + pr "%s " name; + generate_call_args ~handle:"g" style; + pr "\n"; + pr " guestfs_h *g;\n"; + iter_args ( + function + | String n -> pr " char *%s;\n" n + | OptString n -> pr " char *%s;\n" n + | Bool n -> pr " int %s;\n" n + ) (snd style); + (* Code. *) + (match fst style with + | Err -> + pr " PPCODE:\n"; + pr " if (guestfs_%s " name; + generate_call_args ~handle:"g" style; + pr " == -1)\n"; + pr " croak (\"%s: %%s\", last_error);\n" name + | RConstString n -> + pr "PREINIT:\n"; + pr " const char *%s;\n" n; + pr " CODE:\n"; + pr " %s = guestfs_%s " n name; + generate_call_args ~handle:"g" style; + pr ";\n"; + pr " if (%s == NULL)\n" n; + pr " croak (\"%s: %%s\", last_error);\n" name; + pr " RETVAL = newSVpv (%s, 0);\n" n; + pr " OUTPUT:\n"; + pr " RETVAL\n" + | RString n -> + pr "PREINIT:\n"; + pr " char *%s;\n" n; + pr " CODE:\n"; + pr " %s = guestfs_%s " n name; + generate_call_args ~handle:"g" style; + pr ";\n"; + pr " if (%s == NULL)\n" n; + pr " croak (\"%s: %%s\", last_error);\n" name; + pr " RETVAL = newSVpv (%s, 0);\n" n; + pr " free (%s);\n" n; + pr " OUTPUT:\n"; + pr " RETVAL\n" + | RBool n -> + pr "PREINIT:\n"; + pr " int %s;\n" n; + pr " CODE:\n"; + pr " %s = guestfs_%s " n name; + generate_call_args ~handle:"g" style; + pr ";\n"; + pr " if (%s == -1)\n" n; + pr " croak (\"%s: %%s\", last_error);\n" name; + pr " RETVAL = newSViv (%s);\n" n; + pr " OUTPUT:\n"; + pr " RETVAL\n" + | RStringList n -> + pr "PREINIT:\n"; + pr " char **%s;\n" n; + pr " int i, n;\n"; + pr " PPCODE:\n"; + pr " %s = guestfs_%s " n name; + generate_call_args ~handle:"g" style; + pr ";\n"; + pr " if (%s == NULL)\n" n; + pr " croak (\"%s: %%s\", last_error);\n" name; + pr " for (n = 0; %s[n] != NULL; ++n) /**/;\n" n; + pr " EXTEND (SP, n);\n"; + pr " for (i = 0; i < n; ++i) {\n"; + pr " PUSHs (sv_2mortal (newSVpv (%s[i], 0)));\n" n; + pr " free (%s[i]);\n" n; + pr " }\n"; + pr " free (%s);\n" n; + | RPVList n -> + generate_perl_lvm_code "pv" pv_cols name style n; + | RVGList n -> + generate_perl_lvm_code "vg" vg_cols name style n; + | RLVList n -> + generate_perl_lvm_code "lv" lv_cols name style n; + ); + pr "\n" + ) all_functions + +and generate_perl_lvm_code typ cols name style n = + pr "PREINIT:\n"; + pr " struct guestfs_lvm_%s_list *%s;\n" typ n; + pr " int i;\n"; + pr " HV *hv;\n"; + pr " PPCODE:\n"; + pr " %s = guestfs_%s " n name; + generate_call_args ~handle:"g" style; + pr ";\n"; + pr " if (%s == NULL)\n" n; + pr " croak (\"%s: %%s\", last_error);\n" name; + pr " EXTEND (SP, %s->len);\n" n; + pr " for (i = 0; i < %s->len; ++i) {\n" n; + pr " hv = newHV ();\n"; + List.iter ( + function + | name, `String -> + pr " (void) hv_store (hv, \"%s\", %d, newSVpv (%s->val[i].%s, 0), 0);\n" + name (String.length name) n name + | name, `UUID -> + pr " (void) hv_store (hv, \"%s\", %d, newSVpv (%s->val[i].%s, 32), 0);\n" + name (String.length name) n name + | name, `Bytes -> + pr " (void) hv_store (hv, \"%s\", %d, my_newSVull (%s->val[i].%s), 0);\n" + name (String.length name) n name + | name, `Int -> + pr " (void) hv_store (hv, \"%s\", %d, my_newSVll (%s->val[i].%s), 0);\n" + name (String.length name) n name + | name, `OptPercent -> + pr " (void) hv_store (hv, \"%s\", %d, newSVnv (%s->val[i].%s), 0);\n" + name (String.length name) n name + ) cols; + pr " PUSHs (sv_2mortal ((SV *) hv));\n"; + pr " }\n"; + pr " guestfs_free_lvm_%s_list (%s);\n" typ n + +(* Generate Sys/Guestfs.pm. *) +and generate_perl_pm () = + generate_header HashStyle LGPLv2; + + pr "\ +=pod + +=head1 NAME + +Sys::Guestfs - Perl bindings for libguestfs + +=head1 SYNOPSIS + + use Sys::Guestfs; + + my $h = Sys::Guestfs->new (); + $h->add_drive ('guest.img'); + $h->launch (); + $h->wait_ready (); + $h->mount ('/dev/sda1', '/'); + $h->touch ('/hello'); + $h->sync (); + +=head1 DESCRIPTION + +The C module provides a Perl XS binding to the +libguestfs API for examining and modifying virtual machine +disk images. + +Amongst the things this is good for: making batch configuration +changes to guests, getting disk used/free statistics (see also: +virt-df), migrating between virtualization systems (see also: +virt-p2v), performing partial backups, performing partial guest +clones, cloning guests and changing registry/UUID/hostname info, and +much else besides. + +Libguestfs uses Linux kernel and qemu code, and can access any type of +guest filesystem that Linux and qemu can, including but not limited +to: ext2/3/4, btrfs, FAT and NTFS, LVM, many different disk partition +schemes, qcow, qcow2, vmdk. + +Libguestfs provides ways to enumerate guest storage (eg. partitions, +LVs, what filesystem is in each LV, etc.). It can also run commands +in the context of the guest. Also you can access filesystems over FTP. + +=head1 ERRORS + +All errors turn into calls to C (see L). + +=head1 METHODS + +=over 4 + +=cut + +package Sys::Guestfs; + +use strict; +use warnings; + +require XSLoader; +XSLoader::load ('Sys::Guestfs'); + +=item $h = Sys::Guestfs->new (); + +Create a new guestfs handle. + +=cut + +sub new { + my $proto = shift; + my $class = ref ($proto) || $proto; + + my $self = Sys::Guestfs::_create (); + bless $self, $class; + return $self; +} + +"; + + (* Actions. We only need to print documentation for these as + * they are pulled in from the XS code automatically. + *) + List.iter ( + fun (name, style, _, flags, _, longdesc) -> + let longdesc = replace_str longdesc "C" in + pr "=item "; + generate_perl_prototype name style; + pr "\n\n"; + pr "%s\n\n" longdesc; + if List.mem ProtocolLimitWarning flags then + pr "Because of the message protocol, there is a transfer limit +of somewhere between 2MB and 4MB. To transfer large files you should use +FTP.\n\n"; + ) all_functions_sorted; + + (* End of file. *) + pr "\ +=cut + +1; + +=back + +=head1 COPYRIGHT + +Copyright (C) 2009 Red Hat Inc. + +=head1 LICENSE + +Please see the file COPYING.LIB for the full license. + +=head1 SEE ALSO + +L, L. + +=cut +" + +and generate_perl_prototype name style = + (match fst style with + | Err -> () + | RBool n + | RConstString n + | RString n -> pr "$%s = " n + | RStringList n + | RPVList n + | RVGList n + | RLVList n -> pr "@%s = " n + ); + pr "$h->%s (" name; + let comma = ref false in + iter_args ( + fun arg -> + if !comma then pr ", "; + comma := true; + match arg with + | String n -> pr "%s" n + | OptString n -> pr "%s" n + | Bool n -> pr "%s" n + ) (snd style); + pr ");" + let output_to filename = let filename_new = filename ^ ".new" in chan := open_out filename_new; @@ -1352,4 +2292,28 @@ let () = let close = output_to "guestfs-actions.pod" in generate_actions_pod (); - close () + close (); + + let close = output_to "guestfish-actions.pod" in + generate_fish_actions_pod (); + close (); + + let close = output_to "ocaml/guestfs.mli" in + generate_ocaml_mli (); + close (); + + let close = output_to "ocaml/guestfs.ml" in + generate_ocaml_ml (); + close (); + + let close = output_to "ocaml/guestfs_c_actions.c" in + generate_ocaml_c (); + close (); + + let close = output_to "perl/Guestfs.xs" in + generate_perl_xs (); + close (); + + let close = output_to "perl/lib/Sys/Guestfs.pm" in + generate_perl_pm (); + close ();