src/generator.ml

   1 #!/usr/bin/ocamlrun ocaml
   2 (* libguestfs
   3  * Copyright (C) 2009 Red Hat Inc.
   4  *
   5  * This program is free software; you can redistribute it and/or modify
   6  * it under the terms of the GNU General Public License as published by
   7  * the Free Software Foundation; either version 2 of the License, or
   8  * (at your option) any later version.
   9  *
  10  * This program is distributed in the hope that it will be useful,
  11  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  12  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13  * GNU General Public License for more details.
  14  *
  15  * You should have received a copy of the GNU General Public License
  16  * along with this program; if not, write to the Free Software
  17  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18  *
  19  * This script generates a large amount of code and documentation for
  20  * all the daemon actions.  To add a new action there are only two
  21  * files you need to change, this one to describe the interface, and
  22  * daemon/<somefile>.c to write the implementation.
  23  *)
  24
  25 #load "unix.cma";;
  26
  27 open Printf
  28
  29 type styles =
  30   | Int_Void            (* int foo (guestfs_h); *)
  31   | Int_String          (* int foo (guestfs_h, const char * ); *)
  32   | Int_StringString    (* int foo (guestfs_h, const char *, const char * ); *)
  33
  34 let functions = [
  35   ("mount", Int_StringString, [|"device"; "mountpoint"|],
  36    "Mount a guest disk at a position in the filesystem",
  37    "\
  38 Mount a guest disk at a position in the filesystem.  Block devices
  39 are named C</dev/sda>, C</dev/sdb> and so on, as they were added to
  40 the guest.  If those block devices contain partitions, they will have
  41 the usual names (eg. C</dev/sda1>).  Also LVM C</dev/VG/LV>-style
  42 names can be used.
  43
  44 The rules are the same as for L<mount(2)>:  A filesystem must
  45 first be mounted on C</> before others can be mounted.  Other
  46 filesystems can only be mounted on directories which already
  47 exist.");
  48
  49   ("sync", Int_Void, [||],
  50    "Sync disks, writes are flushed through to the disk image",
  51    "\
  52 This syncs the disk, so that any writes are flushed through to the
  53 underlying disk image.
  54
  55 You should always call this if you have modified a disk image, before
  56 calling C<guestfs_close>.");
  57
  58   ("touch", Int_String, [|"path"|],
  59    "Update file timestamps or create a new file",
  60    "\
  61 Touch acts like the L<touch(1)> command.  It can be used to
  62 update the filesystems on a file, or, if the file does not exist,
  63 to create a new zero-length file.");
  64 ]
  65
  66 (* 'pr' prints to the current output file. *)
  67 let chan = ref stdout
  68 let pr fs = ksprintf (output_string !chan) fs
  69
  70 type comment_style = CStyle | HashStyle | OCamlStyle
  71 type license = GPLv2 | LGPLv2
  72
  73 (* Generate a header block in a number of standard styles. *)
  74 let rec generate_header comment license =
  75   let c = match comment with
  76     | CStyle ->     pr "/* "; " *"
  77     | HashStyle ->  pr "# ";  "#"
  78     | OCamlStyle -> pr "(* "; " *" in
  79   pr "libguestfs generated file\n";
  80   pr "%s WARNING: This file is generated by 'src/generator.ml'.\n" c;
  81   pr "%s Any changes you make to this file will be lost.\n" c;
  82   pr "%s\n" c;
  83   pr "%s Copyright (C) 2009 Red Hat Inc.\n" c;
  84   pr "%s\n" c;
  85   (match license with
  86    | GPLv2 ->
  87        pr "%s This program is free software; you can redistribute it and/or modify\n" c;
  88        pr "%s it under the terms of the GNU General Public License as published by\n" c;
  89        pr "%s the Free Software Foundation; either version 2 of the License, or\n" c;
  90        pr "%s (at your option) any later version.\n" c;
  91        pr "%s\n" c;
  92        pr "%s This program is distributed in the hope that it will be useful,\n" c;
  93        pr "%s but WITHOUT ANY WARRANTY; without even the implied warranty of\n" c;
  94        pr "%s MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the\n" c;
  95        pr "%s GNU General Public License for more details.\n" c;
  96        pr "%s\n" c;
  97        pr "%s You should have received a copy of the GNU General Public License along\n" c;
  98        pr "%s with this program; if not, write to the Free Software Foundation, Inc.,\n" c;
  99        pr "%s 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.\n" c;
 100
 101    | LGPLv2 ->
 102        pr "%s This library is free software; you can redistribute it and/or\n" c;
 103        pr "%s modify it under the terms of the GNU Lesser General Public\n" c;
 104        pr "%s License as published by the Free Software Foundation; either\n" c;
 105        pr "%s version 2 of the License, or (at your option) any later version.\n" c;
 106        pr "%s\n" c;
 107        pr "%s This library is distributed in the hope that it will be useful,\n" c;
 108        pr "%s but WITHOUT ANY WARRANTY; without even the implied warranty of\n" c;
 109        pr "%s MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU\n" c;
 110        pr "%s Lesser General Public License for more details.\n" c;
 111        pr "%s\n" c;
 112        pr "%s You should have received a copy of the GNU Lesser General Public\n" c;
 113        pr "%s License along with this library; if not, write to the Free Software\n" c;
 114        pr "%s Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA\n" c;
 115   );
 116   (match comment with
 117    | CStyle -> pr " */\n"
 118    | HashStyle -> ()
 119    | OCamlStyle -> pr " *)\n"
 120   );
 121   pr "\n"
 122
 123 (* Generate the pod documentation for the C API. *)
 124 and generate_pod () =
 125   List.iter (
 126     fun (shortname, style, params, _, longdesc) ->
 127       let name = "guestfs_" ^ shortname in
 128       pr "=head2 %s\n\n" name;
 129       pr " ";
 130       generate_prototype ~extern:false name style params;
 131       pr "\n\n";
 132       pr "%s\n\n" longdesc
 133   ) functions
 134
 135 (* Generate the protocol (XDR) file. *)
 136 and generate_xdr () =
 137   generate_header CStyle LGPLv2;
 138   List.iter (
 139     fun (shortname, style, params, _, longdesc) ->
 140       let name = "guestfs_" ^ shortname in
 141       pr "/* %s */\n" name;
 142
 143
 144       pr "\n";
 145   ) functions
 146
 147 (* Generate a single line prototype. *)
 148 and generate_prototype ~extern ?(semi = true) ?(handle = "handle")
 149     name style params =
 150   if extern then pr "extern ";
 151   (match style with
 152    | Int_Void | Int_String | Int_StringString -> pr "int "
 153   );
 154   pr "%s (guestfs_h *%s" name handle;
 155   (match style with
 156    | Int_Void -> ()
 157    | Int_String ->
 158        pr ", const char *%s" params.(0)
 159    | Int_StringString ->
 160        pr ", const char *%s" params.(0);
 161        pr ", const char *%s" params.(1)
 162   );
 163   pr ")";
 164   if semi then pr ";"
 165
 166 let output_to filename =
 167   let filename_new = filename ^ ".new" in
 168   chan := open_out filename_new;
 169   let close () =
 170     close_out !chan;
 171     chan := stdout;
 172     Unix.rename filename_new filename
 173   in
 174   close
 175
 176 (* Main program. *)
 177 let () =
 178   let close = output_to "guestfs-actions.pod" in
 179   generate_pod ();
 180   close ();
 181
 182   let close = output_to "src/guestfs_protocol.x" in
 183   generate_xdr ();
 184   close ();