generator/generator_erlang.ml

   1 (* libguestfs
   2  * Copyright (C) 2011 Red Hat Inc.
   3  *
   4  * This program is free software; you can redistribute it and/or modify
   5  * it under the terms of the GNU General Public License as published by
   6  * the Free Software Foundation; either version 2 of the License, or
   7  * (at your option) any later version.
   8  *
   9  * This program is distributed in the hope that it will be useful,
  10  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  11  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12  * GNU General Public License for more details.
  13  *
  14  * You should have received a copy of the GNU General Public License
  15  * along with this program; if not, write to the Free Software
  16  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  17  *)
  18
  19 (* Please read generator/README first. *)
  20
  21 open Printf
  22
  23 open Generator_types
  24 open Generator_utils
  25 open Generator_pr
  26 open Generator_docstrings
  27 open Generator_optgroups
  28 open Generator_actions
  29 open Generator_structs
  30 open Generator_c
  31 open Generator_events
  32
  33 let rec generate_erlang_erl () =
  34   generate_header ErlangStyle LGPLv2plus;
  35
  36   pr "-module(guestfs).\n";
  37   pr "\n";
  38   pr "-export([create/0, create/1, close/1, init/1]).\n";
  39   pr "\n";
  40
  41   (* Export the public actions. *)
  42   List.iter (
  43     fun (name, (_, args, optargs), _, _, _, _, _) ->
  44       let nr_args = List.length args in
  45       if optargs = [] then
  46         pr "-export([%s/%d]).\n" name (nr_args+1)
  47       else
  48         pr "-export([%s/%d, %s/%d]).\n" name (nr_args+1) name (nr_args+2)
  49   ) all_functions_sorted;
  50
  51   pr "\n";
  52
  53   pr "\
  54 create() ->
  55   create(\"erl-guestfs\").
  56
  57 create(ExtProg) ->
  58   G = spawn(?MODULE, init, [ExtProg]),
  59   {ok, G}.
  60
  61 close(G) ->
  62   G ! close,
  63   ok.
  64
  65 call_port(G, Args) ->
  66   G ! {call, self(), Args},
  67   receive
  68     {guestfs, Result} ->
  69       Result
  70   end.
  71
  72 init(ExtProg) ->
  73   process_flag(trap_exit, true),
  74   Port = open_port({spawn, ExtProg}, [{packet, 4}, binary]),
  75   loop(Port).
  76 loop(Port) ->
  77   receive
  78     {call, Caller, Args} ->
  79       Port ! { self(), {command, term_to_binary(Args)}},
  80       receive
  81         {Port, {data, Result}} ->
  82           Caller ! { guestfs, binary_to_term(Result)}
  83       end,
  84       loop(Port);
  85     close ->
  86       port_close(Port),
  87       exit(normal);
  88     { 'EXIT', Port, _ } ->
  89       exit(port_terminated)
  90   end.
  91
  92 ";
  93
  94   (* These bindings just marshal the parameters and call the back-end
  95    * process which dispatches them to the port.
  96    *)
  97   List.iter (
  98     fun (name, (_, args, optargs), _, _, _, _, _) ->
  99       pr "%s(G" name;
 100       List.iter (
 101         fun arg ->
 102           pr ", %s" (String.capitalize (name_of_argt arg))
 103       ) args;
 104       if optargs <> [] then
 105         pr ", Optargs";
 106       pr ") ->\n";
 107
 108       pr "  call_port(G, {%s" name;
 109       List.iter (
 110         fun arg ->
 111           pr ", %s" (String.capitalize (name_of_argt arg))
 112       ) args;
 113       if optargs <> [] then
 114         pr ", Optargs";
 115       pr "}).\n";
 116
 117       (* For functions with optional arguments, make a variant that
 118        * has no optarg array, which just calls the function above with
 119        * an empty list as the final arg.
 120        *)
 121       if optargs <> [] then (
 122         pr "%s(G" name;
 123         List.iter (
 124           fun arg ->
 125             pr ", %s" (String.capitalize (name_of_argt arg))
 126         ) args;
 127         pr ") ->\n";
 128
 129         pr "  %s(G" name;
 130         List.iter (
 131           fun arg ->
 132             pr ", %s" (String.capitalize (name_of_argt arg))
 133         ) args;
 134         pr ", []";
 135         pr ").\n"
 136       );
 137
 138       pr "\n"
 139   ) all_functions_sorted
 140
 141 and generate_erlang_c () =
 142   generate_header CStyle GPLv2plus;
 143
 144   pr "\
 145 #include <stdio.h>
 146 #include <stdlib.h>
 147 #include <string.h>
 148 #include <errno.h>
 149
 150 #include <erl_interface.h>
 151 #include <ei.h>
 152
 153 #include \"guestfs.h\"
 154
 155 extern guestfs_h *g;
 156
 157 extern ETERM *dispatch (ETERM *message);
 158 extern int atom_equals (ETERM *atom, const char *name);
 159 extern ETERM *make_error (const char *funname);
 160 extern ETERM *unknown_optarg (const char *funname, ETERM *optargname);
 161 extern ETERM *unknown_function (ETERM *fun);
 162 extern ETERM *make_string_list (char **r);
 163 extern ETERM *make_table (char **r);
 164 extern ETERM *make_bool (int r);
 165 extern char **get_string_list (ETERM *term);
 166 extern int get_bool (ETERM *term);
 167 extern void free_strings (char **r);
 168
 169 #define ARG(i) (ERL_TUPLE_ELEMENT(message,(i)+1))
 170
 171 ";
 172
 173   (* Struct copy functions. *)
 174   let emit_copy_list_function typ =
 175     pr "static ETERM *\n";
 176     pr "make_%s_list (const struct guestfs_%s_list *%ss)\n" typ typ typ;
 177     pr "{\n";
 178     pr "  ETERM *t[%ss->len];\n" typ;
 179     pr "  size_t i;\n";
 180     pr "\n";
 181     pr "  for (i = 0; i < %ss->len; ++i)\n" typ;
 182     pr "    t[i] = make_%s (&%ss->val[i]);\n" typ typ;
 183     pr "\n";
 184     pr "  return erl_mk_list (t, %ss->len);\n" typ;
 185     pr "}\n";
 186     pr "\n";
 187   in
 188
 189   List.iter (
 190     fun (typ, cols) ->
 191       pr "static ETERM *\n";
 192       pr "make_%s (const struct guestfs_%s *%s)\n" typ typ typ;
 193       pr "{\n";
 194       pr "  ETERM *t[%d];\n" (List.length cols);
 195       pr "\n";
 196       iteri (
 197         fun i col ->
 198           (match col with
 199            | name, FString ->
 200                pr "  t[%d] = erl_mk_string (%s->%s);\n" i typ name
 201            | name, FBuffer ->
 202                pr "  t[%d] = erl_mk_estring (%s->%s, %s->%s_len);\n"
 203                  i typ name typ name
 204            | name, FUUID ->
 205                pr "  t[%d] = erl_mk_estring (%s->%s, 32);\n" i typ name
 206            | name, (FBytes|FInt64|FUInt64) ->
 207                pr "  t[%d] = erl_mk_longlong (%s->%s);\n" i typ name
 208            | name, (FInt32|FUInt32) ->
 209                pr "  t[%d] = erl_mk_int (%s->%s);\n" i typ name
 210            | name, FOptPercent ->
 211                pr "  if (%s->%s >= 0)\n" typ name;
 212                pr "    t[%d] = erl_mk_float (%s->%s);\n" i typ name;
 213                pr "  else\n";
 214                pr "    t[%d] = erl_mk_atom (\"undefined\");\n" i;
 215            | name, FChar ->
 216                pr "  t[%d] = erl_mk_int (%s->%s);\n" i typ name
 217           );
 218       ) cols;
 219       pr "\n";
 220       pr "  return erl_mk_list (t, %d);\n" (List.length cols);
 221       pr "}\n";
 222       pr "\n";
 223   ) structs;
 224
 225   (* Emit a copy_TYPE_list function definition only if that function is used. *)
 226   List.iter (
 227     function
 228     | typ, (RStructListOnly | RStructAndList) ->
 229         (* generate the function for typ *)
 230         emit_copy_list_function typ
 231     | typ, _ -> () (* empty *)
 232   ) (rstructs_used_by all_functions);
 233
 234   (* The wrapper functions. *)
 235   List.iter (
 236     fun (name, ((ret, args, optargs) as style), _, _, _, _, _) ->
 237       pr "static ETERM *\n";
 238       pr "run_%s (ETERM *message)\n" name;
 239       pr "{\n";
 240
 241       iteri (
 242         fun i ->
 243           function
 244           | Pathname n
 245           | Device n | Dev_or_Path n
 246           | String n
 247           | FileIn n
 248           | FileOut n
 249           | Key n ->
 250             pr "  char *%s = erl_iolist_to_string (ARG (%d));\n" n i
 251           | OptString n ->
 252             pr "  char *%s;\n" n;
 253             pr "  if (atom_equals (ARG (%d), \"undefined\"))\n" i;
 254             pr "    %s = NULL;\n" n;
 255             pr "  else\n";
 256             pr "    %s = erl_iolist_to_string (ARG (%d));\n" n i
 257           | BufferIn n ->
 258             pr "  size_t %s_size = erl_iolist_length (ARG (%d));\n" n i;
 259             pr "  char *%s = erl_iolist_to_string (ARG (%d));\n" n i
 260           | StringList n | DeviceList n ->
 261             pr "  char **%s = get_string_list (ARG (%d));\n" n i
 262           | Bool n ->
 263             pr "  int %s = get_bool (ARG (%d));\n" n i
 264           | Int n ->
 265             pr "  int %s = ERL_INT_VALUE (ARG (%d));\n" n i
 266           | Int64 n ->
 267             pr "  int64_t %s = ERL_LL_VALUE (ARG (%d));\n" n i
 268           | Pointer (t, n) ->
 269             assert false
 270       ) args;
 271
 272       let uc_name = String.uppercase name in
 273
 274       (* Optional arguments. *)
 275       if optargs <> [] then (
 276         pr "\n";
 277         pr "  struct guestfs_%s_argv optargs_s = { .bitmask = 0 };\n" name;
 278         pr "  struct guestfs_%s_argv *optargs = &optargs_s;\n" name;
 279         pr "  ETERM *optargst = ARG (%d);\n" (List.length args);
 280         pr "  while (!ERL_IS_EMPTY_LIST (optargst)) {\n";
 281         pr "    ETERM *hd = ERL_CONS_HEAD (optargst);\n";
 282         pr "    ETERM *hd_name = ERL_TUPLE_ELEMENT (hd, 0);\n";
 283         pr "    ETERM *hd_value = ERL_TUPLE_ELEMENT (hd, 1);\n";
 284         pr "\n";
 285         List.iter (
 286           fun argt ->
 287             let n = name_of_argt argt in
 288             let uc_n = String.uppercase n in
 289             pr "    if (atom_equals (hd_name, \"%s\")) {\n" n;
 290             pr "      optargs_s.bitmask |= GUESTFS_%s_%s_BITMASK;\n" uc_name uc_n;
 291             pr "      optargs_s.%s = " n;
 292             (match argt with
 293              | Bool _ -> pr "get_bool (hd_value)"
 294              | Int _ -> pr "ERL_INT_VALUE (hd_value)"
 295              | Int64 _ -> pr "ERL_LL_VALUE (hd_value)"
 296              | String _ -> pr "erl_iolist_to_string (hd_value)"
 297              | _ -> assert false
 298             );
 299             pr ";\n";
 300             pr "    }\n";
 301             pr "    else\n";
 302         ) optargs;
 303         pr "      return unknown_optarg (\"%s\", hd_name);\n" name;
 304         pr "    optargst = ERL_CONS_TAIL (optargst);\n";
 305         pr "  }\n";
 306         pr "\n";
 307       );
 308
 309       (match ret with
 310        | RErr -> pr "  int r;\n"
 311        | RInt _ -> pr "  int r;\n"
 312        | RInt64 _ -> pr "  int64_t r;\n"
 313        | RBool _ -> pr "  int r;\n"
 314        | RConstString _ | RConstOptString _ ->
 315            pr "  const char *r;\n"
 316        | RString _ -> pr "  char *r;\n"
 317        | RStringList _ ->
 318            pr "  size_t i;\n";
 319            pr "  char **r;\n"
 320        | RStruct (_, typ) ->
 321            pr "  struct guestfs_%s *r;\n" typ
 322        | RStructList (_, typ) ->
 323            pr "  struct guestfs_%s_list *r;\n" typ
 324        | RHashtable _ ->
 325            pr "  size_t i;\n";
 326            pr "  char **r;\n"
 327        | RBufferOut _ ->
 328            pr "  char *r;\n";
 329            pr "  size_t size;\n"
 330       );
 331       pr "\n";
 332
 333       if optargs = [] then
 334         pr "  r = guestfs_%s " name
 335       else
 336         pr "  r = guestfs_%s_argv " name;
 337       generate_c_call_args ~handle:"g" style;
 338       pr ";\n";
 339
 340       (* Free strings if we copied them above. *)
 341       List.iter (
 342         function
 343         | Pathname n | Device n | Dev_or_Path n | String n | OptString n
 344         | FileIn n | FileOut n | BufferIn n | Key n ->
 345             pr "  free (%s);\n" n
 346         | StringList n | DeviceList n ->
 347             pr "  free_strings (%s);\n" n;
 348         | Bool _ | Int _ | Int64 _ | Pointer _ -> ()
 349       ) args;
 350       List.iter (
 351         function
 352         | String n ->
 353             let uc_n = String.uppercase n in
 354             pr "  if ((optargs_s.bitmask & GUESTFS_%s_%s_BITMASK))\n"
 355               uc_name uc_n;
 356             pr "    free ((char *) optargs_s.%s);\n" n
 357         | Bool _ | Int _ | Int64 _
 358         | Pathname _ | Device _ | Dev_or_Path _ | OptString _
 359         | FileIn _ | FileOut _ | BufferIn _ | Key _
 360         | StringList _ | DeviceList _ | Pointer _ -> ()
 361       ) optargs;
 362
 363       (match errcode_of_ret ret with
 364        | `CannotReturnError -> ()
 365        | `ErrorIsMinusOne ->
 366            pr "  if (r == -1)\n";
 367            pr "    return make_error (\"%s\");\n" name;
 368        | `ErrorIsNULL ->
 369            pr "  if (r == NULL)\n";
 370            pr "    return make_error (\"%s\");\n" name;
 371       );
 372       pr "\n";
 373
 374       (match ret with
 375        | RErr -> pr "  return erl_mk_atom (\"ok\");\n"
 376        | RInt _ -> pr "  return erl_mk_int (r);\n"
 377        | RInt64 _ -> pr "  return erl_mk_longlong (r);\n"
 378        | RBool _ -> pr "  return make_bool (r);\n"
 379        | RConstString _ -> pr "  return erl_mk_string (r);\n"
 380        | RConstOptString _ ->
 381            pr "  ETERM *rt;\n";
 382            pr "  if (r)\n";
 383            pr "    rt = erl_mk_string (r);\n";
 384            pr "  else\n";
 385            pr "    rt = erl_mk_atom (\"undefined\");\n";
 386            pr "  return rt;\n"
 387        | RString _ ->
 388            pr "  ETERM *rt = erl_mk_string (r);\n";
 389            pr "  free (r);\n";
 390            pr "  return rt;\n"
 391        | RStringList _ ->
 392            pr "  ETERM *rt = make_string_list (r);\n";
 393            pr "  free_strings (r);\n\n";
 394            pr "  return rt;\n"
 395        | RStruct (_, typ) ->
 396            pr "  ETERM *rt = make_%s (r);\n" typ;
 397            pr "  guestfs_free_%s (r);\n" typ;
 398            pr "  return rt;\n"
 399        | RStructList (_, typ) ->
 400            pr "  ETERM *rt = make_%s_list (r);\n" typ;
 401            pr "  guestfs_free_%s_list (r);\n" typ;
 402            pr "  return rt;\n"
 403        | RHashtable _ ->
 404            pr "  ETERM *rt = make_table (r);\n";
 405            pr "  free_strings (r);\n";
 406            pr "  return rt;\n"
 407        | RBufferOut _ ->
 408            pr "  ETERM *rt = erl_mk_estring (r, size);\n";
 409            pr "  free (r);\n";
 410            pr "  return rt;\n"
 411       );
 412
 413       pr "}\n";
 414       pr "\n";
 415   ) all_functions_sorted;
 416
 417   pr "\
 418
 419 ETERM *
 420 dispatch (ETERM *message)
 421 {
 422   ETERM *fun;
 423
 424   fun = ERL_TUPLE_ELEMENT (message, 0);
 425
 426   /* XXX We should use gperf here. */
 427   ";
 428
 429   List.iter (
 430     fun (name, (ret, args, optargs), _, _, _, _, _) ->
 431       pr "if (atom_equals (fun, \"%s\"))\n" name;
 432       pr "    return run_%s (message);\n" name;
 433       pr "  else ";
 434   ) all_functions_sorted;
 435
 436   pr "return unknown_function (fun);
 437 }
 438 ";