libvirt/generator.pl

   1 #!/usr/bin/perl -w
   2 #
   3 # OCaml bindings for libvirt.
   4 # (C) Copyright 2007-2008 Richard W.M. Jones, Red Hat Inc.
   5 # http://libvirt.org/
   6 #
   7 # This library is free software; you can redistribute it and/or
   8 # modify it under the terms of the GNU Lesser General Public
   9 # License as published by the Free Software Foundation; either
  10 # version 2 of the License, or (at your option) any later version.
  11 #
  12 # This library is distributed in the hope that it will be useful,
  13 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15 # Lesser General Public License for more details.
  16 #
  17 # You should have received a copy of the GNU Lesser General Public
  18 # License along with this library; if not, write to the Free Software
  19 # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301  USA
  20
  21 # This generates libvirt_c.c (the core of the bindings).  You don't
  22 # need to run this program unless you are extending the bindings
  23 # themselves (eg. because libvirt has been extended).
  24 #
  25 # Please read libvirt/README.
  26
  27 use strict;
  28
  29 #----------------------------------------------------------------------
  30
  31 # The functions in the libvirt API that we can generate.
  32
  33 # The 'sig' (signature) doesn't have a meaning or any internal structure.
  34 # It is interpreted by the generation functions below to indicate what
  35 # "class" the function falls into, and to generate the right class of
  36 # binding.
  37 #
  38 # Any function added since libvirt 0.2.1 must be marked weak.
  39
  40 my @functions = (
  41     { name => "virConnectClose", sig => "conn : free" },
  42     { name => "virConnectGetHostname", sig => "conn : string", weak => 1 },
  43     { name => "virConnectGetURI", sig => "conn : string", weak => 1 },
  44     { name => "virConnectGetType", sig => "conn : static string" },
  45     { name => "virConnectNumOfDomains", sig => "conn : int" },
  46     { name => "virConnectListDomains", sig => "conn, int : int array" },
  47     { name => "virConnectNumOfDefinedDomains", sig => "conn : int" },
  48     { name => "virConnectListDefinedDomains",
  49       sig => "conn, int : string array" },
  50     { name => "virConnectNumOfNetworks", sig => "conn : int" },
  51     { name => "virConnectListNetworks", sig => "conn, int : string array" },
  52     { name => "virConnectNumOfDefinedNetworks", sig => "conn : int" },
  53     { name => "virConnectListDefinedNetworks",
  54       sig => "conn, int : string array" },
  55     { name => "virConnectNumOfStoragePools", sig => "conn : int", weak => 1 },
  56     { name => "virConnectListStoragePools",
  57       sig => "conn, int : string array", weak => 1 },
  58     { name => "virConnectNumOfDefinedStoragePools",
  59       sig => "conn : int", weak => 1 },
  60     { name => "virConnectListDefinedStoragePools",
  61       sig => "conn, int : string array", weak => 1 },
  62     { name => "virConnectGetCapabilities", sig => "conn : string" },
  63
  64     { name => "virDomainCreateLinux", sig => "conn, string, 0U : dom" },
  65     { name => "virDomainCreateLinuxJob",
  66       sig => "conn, string, 0U : job", weak => 1 },
  67     { name => "virDomainFree", sig => "dom : free" },
  68     { name => "virDomainDestroy", sig => "dom : free" },
  69     { name => "virDomainLookupByName", sig => "conn, string : dom" },
  70     { name => "virDomainLookupByID", sig => "conn, int : dom" },
  71     { name => "virDomainLookupByUUID", sig => "conn, uuid : dom" },
  72     { name => "virDomainLookupByUUIDString", sig => "conn, string : dom" },
  73     { name => "virDomainGetName", sig => "dom : static string" },
  74     { name => "virDomainGetOSType", sig => "dom : string" },
  75     { name => "virDomainGetXMLDesc", sig => "dom, 0 : string" },
  76     { name => "virDomainGetUUID", sig => "dom : uuid" },
  77     { name => "virDomainGetUUIDString", sig => "dom : uuid string" },
  78     { name => "virDomainGetMaxVcpus", sig => "dom : int" },
  79     { name => "virDomainSave", sig => "dom, string : unit" },
  80     { name => "virDomainSaveJob",
  81       sig => "dom, string : job from dom", weak => 1 },
  82     { name => "virDomainRestore", sig => "conn, string : unit" },
  83     { name => "virDomainRestoreJob",
  84       sig => "conn, string : job", weak => 1 },
  85     { name => "virDomainCoreDump", sig => "dom, string, 0 : unit" },
  86     { name => "virDomainCoreDumpJob",
  87       sig => "dom, string, 0 : job from dom", weak => 1 },
  88     { name => "virDomainSuspend", sig => "dom : unit" },
  89     { name => "virDomainResume", sig => "dom : unit" },
  90     { name => "virDomainShutdown", sig => "dom : unit" },
  91     { name => "virDomainReboot", sig => "dom, 0 : unit" },
  92     { name => "virDomainDefineXML", sig => "conn, string : dom" },
  93     { name => "virDomainUndefine", sig => "dom : unit" },
  94     { name => "virDomainCreate", sig => "dom : unit" },
  95     { name => "virDomainCreateJob",
  96       sig => "dom, 0U : job from dom", weak => 1 },
  97     { name => "virDomainAttachDevice", sig => "dom, string : unit" },
  98     { name => "virDomainDetachDevice", sig => "dom, string : unit" },
  99     { name => "virDomainGetAutostart", sig => "dom : bool" },
 100     { name => "virDomainSetAutostart", sig => "dom, bool : unit" },
 101
 102     { name => "virNetworkFree", sig => "net : free" },
 103     { name => "virNetworkDestroy", sig => "net : free" },
 104     { name => "virNetworkLookupByName", sig => "conn, string : net" },
 105     { name => "virNetworkLookupByUUID", sig => "conn, uuid : net" },
 106     { name => "virNetworkLookupByUUIDString", sig => "conn, string : net" },
 107     { name => "virNetworkGetName", sig => "net : static string" },
 108     { name => "virNetworkGetXMLDesc", sig => "net, 0 : string" },
 109     { name => "virNetworkGetBridgeName", sig => "net : string" },
 110     { name => "virNetworkGetUUID", sig => "net : uuid" },
 111     { name => "virNetworkGetUUIDString", sig => "net : uuid string" },
 112     { name => "virNetworkUndefine", sig => "net : unit" },
 113     { name => "virNetworkCreateXML", sig => "conn, string : net" },
 114     { name => "virNetworkCreateXMLJob",
 115       sig => "conn, string : job", weak => 1 },
 116     { name => "virNetworkDefineXML", sig => "conn, string : net" },
 117     { name => "virNetworkCreate", sig => "net : unit" },
 118     { name => "virNetworkCreateJob",
 119       sig => "net : job from net", weak => 1 },
 120     { name => "virNetworkGetAutostart", sig => "net : bool" },
 121     { name => "virNetworkSetAutostart", sig => "net, bool : unit" },
 122
 123     { name => "virStoragePoolFree", sig => "pool : free", weak => 1 },
 124     { name => "virStoragePoolDestroy", sig => "pool : free", weak => 1 },
 125     { name => "virStoragePoolLookupByName",
 126       sig => "conn, string : pool", weak => 1 },
 127     { name => "virStoragePoolLookupByUUID",
 128       sig => "conn, uuid : pool", weak => 1 },
 129     { name => "virStoragePoolLookupByUUIDString",
 130       sig => "conn, string : pool", weak => 1 },
 131     { name => "virStoragePoolGetName",
 132       sig => "pool : static string", weak => 1 },
 133     { name => "virStoragePoolGetXMLDesc",
 134       sig => "pool, 0 : string", weak => 1 },
 135     { name => "virStoragePoolGetUUID",
 136       sig => "pool : uuid", weak => 1 },
 137     { name => "virStoragePoolGetUUIDString",
 138       sig => "pool : uuid string", weak => 1 },
 139     { name => "virStoragePoolCreateXML",
 140       sig => "conn, string : pool", weak => 1 },
 141     { name => "virStoragePoolDefineXML",
 142       sig => "conn, string : pool", weak => 1 },
 143     { name => "virStoragePoolUndefine",
 144       sig => "pool : unit", weak => 1 },
 145     { name => "virStoragePoolCreate",
 146       sig => "pool : unit", weak => 1 },
 147     { name => "virStoragePoolShutdown",
 148       sig => "pool : unit", weak => 1 },
 149     { name => "virStoragePoolRefresh",
 150       sig => "pool, 0U : unit", weak => 1 },
 151     { name => "virStoragePoolGetAutostart",
 152       sig => "pool : bool", weak => 1 },
 153     { name => "virStoragePoolSetAutostart",
 154       sig => "pool, bool : unit", weak => 1 },
 155
 156     { name => "virStorageVolFree", sig => "vol : free", weak => 1 },
 157     { name => "virStorageVolDestroy", sig => "vol : free", weak => 1 },
 158 #    { name => "virStorageVolLookupByName", XXX see libvir-list posting
 159 #      sig => "pool, string : vol", weak => 1 },
 160     { name => "virStorageVolLookupByKey",
 161       sig => "conn, string : vol", weak => 1 },
 162     { name => "virStorageVolLookupByPath",
 163       sig => "conn, string : vol", weak => 1 },
 164 #    { name => "virStorageVolCreateXML",
 165 #      sig => "pool, string : vol", weak => 1 }, XXX
 166     { name => "virStorageVolGetXMLDesc",
 167       sig => "vol, 0 : string", weak => 1 },
 168     { name => "virStorageVolGetPath",
 169       sig => "vol : string", weak => 1 },
 170     { name => "virStorageVolGetKey",
 171       sig => "vol : static string", weak => 1 },
 172     { name => "virStorageVolGetName",
 173       sig => "vol : static string", weak => 1 },
 174     { name => "virStoragePoolLookupByVolume",
 175       sig => "vol : pool from vol", weak => 1 },
 176
 177     { name => "virJobFree",
 178       sig => "job : free", weak => 1 },
 179     { name => "virJobCancel",
 180       sig => "job : unit", weak => 1 },
 181     { name => "virJobGetNetwork",
 182       sig => "job : net from job", weak => 1 },
 183     { name => "virJobGetDomain",
 184       sig => "job : dom from job", weak => 1 },
 185
 186     );
 187
 188 # Functions we haven't implemented anywhere yet but which are mentioned
 189 # in 'libvirt.ml'.
 190 #
 191 # We create stubs for these, but eventually they need to either be
 192 # moved ^^^ so they are auto-generated, or implementations of them
 193 # written in 'libvirt_c_oneoffs.c'.
 194
 195 my @unimplemented = (
 196     "ocaml_libvirt_storage_pool_get_info",
 197     "ocaml_libvirt_storage_vol_lookup_by_name", # XXX see above
 198     "ocaml_libvirt_storage_vol_create_xml",     # XXX see above
 199     "ocaml_libvirt_storage_vol_get_info",
 200     "ocaml_libvirt_job_get_info",
 201     );
 202
 203 #----------------------------------------------------------------------
 204
 205 # Open the output file.
 206
 207 my $filename = "libvirt_c.c";
 208 open F, ">$filename" or die "$filename: $!";
 209
 210 # Write the prologue.
 211
 212 print F <<'END';
 213 /* !!! WARNING WARNING WARNING WARNING WARNING WARNING WARNING !!!
 214  *
 215  * THIS FILE IS AUTOMATICALLY GENERATED BY 'generator.pl'.
 216  *
 217  * Any changes you make to this file may be overwritten.
 218  */
 219
 220 /* OCaml bindings for libvirt.
 221  * (C) Copyright 2007-2008 Richard W.M. Jones, Red Hat Inc.
 222  * http://libvirt.org/
 223  *
 224  * This library is free software; you can redistribute it and/or
 225  * modify it under the terms of the GNU Lesser General Public
 226  * License as published by the Free Software Foundation; either
 227  * version 2 of the License, or (at your option) any later version.
 228  *
 229  * This library is distributed in the hope that it will be useful,
 230  * but WITHOUT ANY WARRANTY; without even the implied warranty of
 231  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 232  * Lesser General Public License for more details.
 233  *
 234  * You should have received a copy of the GNU Lesser General Public
 235  * License along with this library; if not, write to the Free Software
 236  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301  USA
 237  */
 238
 239 #include "config.h"
 240
 241 #include <stdio.h>
 242 #include <stdlib.h>
 243 #include <string.h>
 244
 245 #include <libvirt/libvirt.h>
 246 #include <libvirt/virterror.h>
 247
 248 #include <caml/config.h>
 249 #include <caml/alloc.h>
 250 #include <caml/callback.h>
 251 #include <caml/custom.h>
 252 #include <caml/fail.h>
 253 #include <caml/memory.h>
 254 #include <caml/misc.h>
 255 #include <caml/mlvalues.h>
 256 #include <caml/signals.h>
 257
 258 #include "libvirt_c_prologue.c"
 259
 260 #include "libvirt_c_oneoffs.c"
 261
 262 END
 263
 264 #----------------------------------------------------------------------
 265
 266 sub camel_case_to_underscores
 267 {
 268     my $name = shift;
 269
 270     $name =~ s/([A-Z][a-z]+|XML|URI|OS|UUID)/$1,/g;
 271     my @subs = split (/,/, $name);
 272     @subs = map { lc($_) } @subs;
 273     join "_", @subs
 274 }
 275
 276 # Helper functions dealing with signatures.
 277
 278 sub short_name_to_c_type
 279 {
 280     local $_ = shift;
 281
 282     if ($_ eq "conn") { "virConnectPtr" }
 283     elsif ($_ eq "dom") { "virDomainPtr" }
 284     elsif ($_ eq "net") { "virNetworkPtr" }
 285     elsif ($_ eq "pool") { "virStoragePoolPtr" }
 286     elsif ($_ eq "vol") { "virStorageVolPtr" }
 287     elsif ($_ eq "job") { "virJobPtr" }
 288     else {
 289         die "unknown short name $_"
 290     }
 291 }
 292
 293 # Generate a C signature for the original function.  Used when building
 294 # weak bindings.
 295
 296 sub gen_c_signature
 297 {
 298     my $sig = shift;
 299     my $c_name = shift;
 300
 301     if ($sig =~ /^(\w+) : string$/) {
 302         my $c_type = short_name_to_c_type ($1);
 303         "char *$c_name ($c_type $1)"
 304     } elsif ($sig =~ /^(\w+) : static string$/) {
 305         my $c_type = short_name_to_c_type ($1);
 306         "const char *$c_name ($c_type $1)"
 307     } elsif ($sig =~ /^(\w+) : int$/) {
 308         my $c_type = short_name_to_c_type ($1);
 309         "int $c_name ($c_type $1)"
 310     } elsif ($sig =~ /^(\w+) : uuid$/) {
 311         my $c_type = short_name_to_c_type ($1);
 312         "int $c_name ($c_type $1, unsigned char *)"
 313     } elsif ($sig =~ /^(\w+) : uuid string$/) {
 314         my $c_type = short_name_to_c_type ($1);
 315         "int $c_name ($c_type $1, char *)"
 316     } elsif ($sig =~ /^(\w+) : bool$/) {
 317         my $c_type = short_name_to_c_type ($1);
 318         "int $c_name ($c_type $1, int *r)"
 319     } elsif ($sig =~ /^(\w+), bool : unit$/) {
 320         my $c_type = short_name_to_c_type ($1);
 321         "int $c_name ($c_type $1, int b)"
 322     } elsif ($sig eq "conn, int : int array") {
 323         "int $c_name (virConnectPtr conn, int *ids, int maxids)"
 324     } elsif ($sig eq "conn, int : string array") {
 325         "int $c_name (virConnectPtr conn, char **const names, int maxnames)"
 326     } elsif ($sig =~ /^(\w+), 0(U?) : string$/) {
 327         my $c_type = short_name_to_c_type ($1);
 328         my $unsigned = $2 eq "U" ? "unsigned " : "";
 329         "char *$c_name ($c_type $1, $unsigned int flags)"
 330     } elsif ($sig =~ /^(\w+), 0(U?) : unit$/) {
 331         my $c_type = short_name_to_c_type ($1);
 332         my $unsigned = $2 eq "U" ? "unsigned " : "";
 333         "int $c_name ($c_type $1, $unsigned int flags)"
 334     } elsif ($sig =~ /^(\w+) : unit$/) {
 335         my $c_type = short_name_to_c_type ($1);
 336         "int $c_name ($c_type $1)"
 337     } elsif ($sig =~ /^(\w+) : free$/) {
 338         my $c_type = short_name_to_c_type ($1);
 339         "int $c_name ($c_type $1)"
 340     } elsif ($sig =~ /^(\w+), string : unit$/) {
 341         my $c_type = short_name_to_c_type ($1);
 342         "int $c_name ($c_type $1, const char *str)"
 343     } elsif ($sig =~ /^(\w+), string, 0(U?) : unit$/) {
 344         my $c_type = short_name_to_c_type ($1);
 345         my $unsigned = $2 eq "U" ? "unsigned " : "";
 346         "int $c_name ($c_type $1, const char *str, $unsigned int flags)"
 347     } elsif ($sig =~ /^(\w+), string : (\w+)$/) {
 348         my $c_type = short_name_to_c_type ($1);
 349         my $c_ret_type = short_name_to_c_type ($2);
 350         "$c_ret_type $c_name ($c_type $1, const char *str)"
 351     } elsif ($sig =~ /^(\w+), string, 0(U?) : (\w+)$/) {
 352         my $c_type = short_name_to_c_type ($1);
 353         my $unsigned = $2 eq "U" ? "unsigned " : "";
 354         my $c_ret_type = short_name_to_c_type ($3);
 355         "$c_ret_type $c_name ($c_type $1, const char *str, $unsigned int flags)"
 356     } elsif ($sig =~ /^(\w+), int : (\w+)$/) {
 357         my $c_type = short_name_to_c_type ($1);
 358         my $c_ret_type = short_name_to_c_type ($2);
 359         "$c_ret_type $c_name ($c_type $1, int i)"
 360     } elsif ($sig =~ /^(\w+), uuid : (\w+)$/) {
 361         my $c_type = short_name_to_c_type ($1);
 362         my $c_ret_type = short_name_to_c_type ($2);
 363         "$c_ret_type $c_name ($c_type $1, const unsigned char *str)"
 364     } elsif ($sig =~ /^(\w+), 0(U?) : (\w+)$/) {
 365         my $c_type = short_name_to_c_type ($1);
 366         my $unsigned = $2 eq "U" ? "unsigned " : "";
 367         my $c_ret_type = short_name_to_c_type ($3);
 368         "$c_ret_type $c_name ($c_type $1, $unsigned int flags)"
 369     } elsif ($sig =~ /^(\w+) : (\w+)$/) {
 370         my $c_type = short_name_to_c_type ($1);
 371         my $c_ret_type = short_name_to_c_type ($2);
 372         "$c_ret_type $c_name ($c_type $1)"
 373     } elsif ($sig =~ /^(\w+), string : (\w+) from \w+$/) {
 374         my $c_type = short_name_to_c_type ($1);
 375         my $c_ret_type = short_name_to_c_type ($2);
 376         "$c_ret_type $c_name ($c_type $1, const char *str)"
 377     } elsif ($sig =~ /^(\w+), string, 0(U?) : (\w+) from \w+$/) {
 378         my $c_type = short_name_to_c_type ($1);
 379         my $unsigned = $2 eq "U" ? "unsigned " : "";
 380         my $c_ret_type = short_name_to_c_type ($3);
 381         "$c_ret_type $c_name ($c_type $1, const char *str, $unsigned int flags)"
 382     } elsif ($sig =~ /^(\w+), 0(U?) : (\w+) from \w+$/) {
 383         my $c_type = short_name_to_c_type ($1);
 384         my $unsigned = $2 eq "U" ? "unsigned " : "";
 385         my $c_ret_type = short_name_to_c_type ($3);
 386         "$c_ret_type $c_name ($c_type $1, $unsigned int flags)"
 387     } elsif ($sig =~ /^(\w+) : (\w+) from \w+$/) {
 388         my $c_type = short_name_to_c_type ($1);
 389         my $c_ret_type = short_name_to_c_type ($2);
 390         "$c_ret_type $c_name ($c_type $1)"
 391     } else {
 392         die "unknown signature $sig"
 393     }
 394 }
 395
 396 # OCaml argument names.
 397
 398 sub gen_arg_names
 399 {
 400     my $sig = shift;
 401
 402     if ($sig =~ /^(\w+) : string$/) {
 403         ( "$1v" )
 404     } elsif ($sig =~ /^(\w+) : static string$/) {
 405         ( "$1v" )
 406     } elsif ($sig =~ /^(\w+) : int$/) {
 407         ( "$1v" )
 408     } elsif ($sig =~ /^(\w+) : uuid$/) {
 409         ( "$1v" )
 410     } elsif ($sig =~ /^(\w+) : uuid string$/) {
 411         ( "$1v" )
 412     } elsif ($sig =~ /^(\w+) : bool$/) {
 413         ( "$1v" )
 414     } elsif ($sig =~ /^(\w+), bool : unit$/) {
 415         ( "$1v", "bv" )
 416     } elsif ($sig eq "conn, int : int array") {
 417         ( "connv", "iv" )
 418     } elsif ($sig eq "conn, int : string array") {
 419         ( "connv", "iv" )
 420     } elsif ($sig =~ /^(\w+), 0U? : string$/) {
 421         ( "$1v" )
 422     } elsif ($sig =~ /^(\w+), 0U? : unit$/) {
 423         ( "$1v" )
 424     } elsif ($sig =~ /^(\w+) : unit$/) {
 425         ( "$1v" )
 426     } elsif ($sig =~ /^(\w+) : free$/) {
 427         ( "$1v" )
 428     } elsif ($sig =~ /^(\w+), string : unit$/) {
 429         ( "$1v", "strv" )
 430     } elsif ($sig =~ /^(\w+), string, 0U? : unit$/) {
 431         ( "$1v", "strv" )
 432     } elsif ($sig =~ /^(\w+), string : (\w+)$/) {
 433         ( "$1v", "strv" )
 434     } elsif ($sig =~ /^(\w+), string, 0U? : (\w+)$/) {
 435         ( "$1v", "strv" )
 436     } elsif ($sig =~ /^(\w+), int : (\w+)$/) {
 437         ( "$1v", "iv" )
 438     } elsif ($sig =~ /^(\w+), uuid : (\w+)$/) {
 439         ( "$1v", "uuidv" )
 440     } elsif ($sig =~ /^(\w+), 0U? : (\w+)$/) {
 441         ( "$1v" )
 442     } elsif ($sig =~ /^(\w+) : (\w+)$/) {
 443         ( "$1v" )
 444     } elsif ($sig =~ /^(\w+), string : (\w+) from \w+$/) {
 445         ( "$1v", "strv" )
 446     } elsif ($sig =~ /^(\w+), string, 0U? : (\w+) from \w+$/) {
 447         ( "$1v", "strv" )
 448     } elsif ($sig =~ /^(\w+), 0U? : (\w+) from \w+$/) {
 449         ( "$1v" )
 450     } elsif ($sig =~ /^(\w+) : (\w+) from \w+$/) {
 451         ( "$1v" )
 452     } else {
 453         die "unknown signature $sig"
 454     }
 455 }
 456
 457 # Unpack the first (object) argument.
 458
 459 sub gen_unpack_args
 460 {
 461     local $_ = shift;
 462
 463     if ($_ eq "conn") {
 464         "virConnectPtr conn = Connect_val (connv);"
 465     } elsif ($_ eq "dom") {
 466         "virDomainPtr dom = Domain_val (domv);\n".
 467         "  virConnectPtr conn = Connect_domv (domv);"
 468     } elsif ($_ eq "net") {
 469         "virNetworkPtr net = Network_val (netv);\n".
 470         "  virConnectPtr conn = Connect_netv (netv);"
 471     } elsif ($_ eq "pool") {
 472         "virStoragePoolPtr pool = Pool_val (poolv);\n".
 473         "  virConnectPtr conn = Connect_polv (poolv);"
 474     } elsif ($_ eq "vol") {
 475         "virStorageVolPtr vol = Volume_val (volv);\n".
 476         "  virConnectPtr conn = Connect_volv (volv);"
 477     } elsif ($_ eq "job") {
 478         "virJobPtr job = Job_val (jobv);\n".
 479         "  virConnectPtr conn = Connect_jobv (jobv);"
 480     } else {
 481         die "unknown short name $_"
 482     }
 483 }
 484
 485 # Pack the result if it's an object.
 486
 487 sub gen_pack_result
 488 {
 489     local $_ = shift;
 490
 491     if ($_ eq "dom") {     "rv = Val_domain (r, connv);" }
 492     elsif ($_ eq "net") {  "rv = Val_network (r, connv);" }
 493     elsif ($_ eq "pool") { "rv = Val_pool (r, connv);" }
 494     elsif ($_ eq "vol") {  "rv = Val_volume (r, connv);" }
 495     elsif ($_ eq "job") {  "rv = Val_job (r, connv);" }
 496     else {
 497         die "unknown short name $_"
 498     }
 499 }
 500
 501 sub gen_free_arg
 502 {
 503     local $_ = shift;
 504
 505     if ($_ eq "conn") {     "Connect_val (connv) = NULL;" }
 506     elsif ($_ eq "dom") {   "Domain_val (domv) = NULL;" }
 507     elsif ($_ eq "net") {   "Network_val (netv) = NULL;" }
 508     elsif ($_ eq "pool") {  "Pool_val (poolv) = NULL;" }
 509     elsif ($_ eq "vol") {   "Volume_val (volv) = NULL;" }
 510     elsif ($_ eq "job") {   "Job_val (jobv) = NULL;" }
 511     else {
 512         die "unknown short name $_"
 513     }
 514 }
 515
 516 # Generate the C body for each signature (class of function).
 517
 518 sub gen_c_code
 519 {
 520     my $sig = shift;
 521     my $c_name = shift;
 522
 523     if ($sig =~ /^(\w+) : string$/) {
 524         "\
 525   CAMLlocal1 (rv);
 526   " . gen_unpack_args ($1) . "
 527   char *r;
 528
 529   NONBLOCKING (r = $c_name ($1));
 530   CHECK_ERROR (!r, conn, \"$c_name\");
 531
 532   rv = caml_copy_string (r);
 533   free (r);
 534   CAMLreturn (rv);
 535 "
 536     } elsif ($sig =~ /^(\w+) : static string$/) {
 537         "\
 538   CAMLlocal1 (rv);
 539   " . gen_unpack_args ($1) . "
 540   const char *r;
 541
 542   NONBLOCKING (r = $c_name ($1));
 543   CHECK_ERROR (!r, conn, \"$c_name\");
 544
 545   rv = caml_copy_string (r);
 546   CAMLreturn (rv);
 547 "
 548     } elsif ($sig =~ /^(\w+) : int$/) {
 549         "\
 550   " . gen_unpack_args ($1) . "
 551   int r;
 552
 553   NONBLOCKING (r = $c_name ($1));
 554   CHECK_ERROR (r == -1, conn, \"$c_name\");
 555
 556   CAMLreturn (Val_int (r));
 557 "
 558     } elsif ($sig =~ /^(\w+) : uuid$/) {
 559         "\
 560   CAMLlocal1 (rv);
 561   " . gen_unpack_args ($1) . "
 562   unsigned char uuid[VIR_UUID_BUFLEN];
 563   int r;
 564
 565   NONBLOCKING (r = $c_name ($1, uuid));
 566   CHECK_ERROR (r == -1, conn, \"$c_name\");
 567
 568   rv = caml_copy_string ((char *) uuid);
 569   CAMLreturn (rv);
 570 "
 571     } elsif ($sig =~ /^(\w+) : uuid string$/) {
 572         "\
 573   CAMLlocal1 (rv);
 574   " . gen_unpack_args ($1) . "
 575   char uuid[VIR_UUID_STRING_BUFLEN];
 576   int r;
 577
 578   NONBLOCKING (r = $c_name ($1, uuid));
 579   CHECK_ERROR (r == -1, conn, \"$c_name\");
 580
 581   rv = caml_copy_string (uuid);
 582   CAMLreturn (rv);
 583 "
 584     } elsif ($sig =~ /^(\w+) : bool$/) {
 585         "\
 586   " . gen_unpack_args ($1) . "
 587   int r, b;
 588
 589   NONBLOCKING (r = $c_name ($1, &b));
 590   CHECK_ERROR (r == -1, conn, \"$c_name\");
 591
 592   CAMLreturn (b ? Val_true : Val_false);
 593 "
 594     } elsif ($sig =~ /^(\w+), bool : unit$/) {
 595         "\
 596   " . gen_unpack_args ($1) . "
 597   int r, b;
 598
 599   b = bv == Val_true ? 1 : 0;
 600
 601   NONBLOCKING (r = $c_name ($1, b));
 602   CHECK_ERROR (r == -1, conn, \"$c_name\");
 603
 604   CAMLreturn (Val_unit);
 605 "
 606     } elsif ($sig eq "conn, int : int array") {
 607         "\
 608   CAMLlocal1 (rv);
 609   virConnectPtr conn = Connect_val (connv);
 610   int i = Int_val (iv);
 611   int ids[i], r;
 612
 613   NONBLOCKING (r = $c_name (conn, ids, i));
 614   CHECK_ERROR (r == -1, conn, \"$c_name\");
 615
 616   rv = caml_alloc (r, 0);
 617   for (i = 0; i < r; ++i)
 618     Store_field (rv, i, Val_int (ids[i]));
 619
 620   CAMLreturn (rv);
 621 "
 622     } elsif ($sig eq "conn, int : string array") {
 623         "\
 624   CAMLlocal2 (rv, strv);
 625   virConnectPtr conn = Connect_val (connv);
 626   int i = Int_val (iv);
 627   char *names[i];
 628   int r;
 629
 630   NONBLOCKING (r = $c_name (conn, names, i));
 631   CHECK_ERROR (r == -1, conn, \"$c_name\");
 632
 633   rv = caml_alloc (r, 0);
 634   for (i = 0; i < r; ++i) {
 635     strv = caml_copy_string (names[i]);
 636     Store_field (rv, i, strv);
 637     free (names[i]);
 638   }
 639
 640   CAMLreturn (rv);
 641 "
 642     } elsif ($sig =~ /^(\w+), 0U? : string$/) {
 643         "\
 644   CAMLlocal1 (rv);
 645   " . gen_unpack_args ($1) . "
 646   char *r;
 647
 648   NONBLOCKING (r = $c_name ($1, 0));
 649   CHECK_ERROR (!r, conn, \"$c_name\");
 650
 651   rv = caml_copy_string (r);
 652   free (r);
 653   CAMLreturn (rv);
 654 "
 655     } elsif ($sig =~ /^(\w+), 0U? : unit$/) {
 656         "\
 657   " . gen_unpack_args ($1) . "
 658   int r;
 659
 660   NONBLOCKING (r = $c_name ($1, 0));
 661   CHECK_ERROR (r == -1, conn, \"$c_name\");
 662
 663   CAMLreturn (Val_unit);
 664 "
 665     } elsif ($sig =~ /^(\w+) : unit$/) {
 666         "\
 667   " . gen_unpack_args ($1) . "
 668   int r;
 669
 670   NONBLOCKING (r = $c_name ($1));
 671   CHECK_ERROR (r == -1, conn, \"$c_name\");
 672
 673   CAMLreturn (Val_unit);
 674 "
 675     } elsif ($sig =~ /^(\w+) : free$/) {
 676         "\
 677   " . gen_unpack_args ($1) . "
 678   int r;
 679
 680   NONBLOCKING (r = $c_name ($1));
 681   CHECK_ERROR (r == -1, conn, \"$c_name\");
 682
 683   /* So that we don't double-free in the finalizer: */
 684   " . gen_free_arg ($1) . "
 685
 686   CAMLreturn (Val_unit);
 687 "
 688     } elsif ($sig =~ /^(\w+), string : unit$/) {
 689         "\
 690   CAMLlocal1 (rv);
 691   " . gen_unpack_args ($1) . "
 692   char *str = String_val (strv);
 693   int r;
 694
 695   NONBLOCKING (r = $c_name ($1, str));
 696   CHECK_ERROR (r == -1, conn, \"$c_name\");
 697
 698   CAMLreturn (Val_unit);
 699 "
 700     } elsif ($sig =~ /^(\w+), string, 0U? : unit$/) {
 701         "\
 702   CAMLlocal1 (rv);
 703   " . gen_unpack_args ($1) . "
 704   char *str = String_val (strv);
 705   int r;
 706
 707   NONBLOCKING (r = $c_name ($1, str, 0));
 708   CHECK_ERROR (!r, conn, \"$c_name\");
 709
 710   CAMLreturn (Val_unit);
 711 "
 712     } elsif ($sig =~ /^(\w+), string : (\w+)$/) {
 713         my $c_ret_type = short_name_to_c_type ($2);
 714         "\
 715   CAMLlocal1 (rv);
 716   " . gen_unpack_args ($1) . "
 717   char *str = String_val (strv);
 718   $c_ret_type r;
 719
 720   NONBLOCKING (r = $c_name ($1, str));
 721   CHECK_ERROR (!r, conn, \"$c_name\");
 722
 723   " . gen_pack_result ($2) . "
 724
 725   CAMLreturn (rv);
 726 "
 727     } elsif ($sig =~ /^(\w+), string, 0U? : (\w+)$/) {
 728         my $c_ret_type = short_name_to_c_type ($2);
 729         "\
 730   CAMLlocal1 (rv);
 731   " . gen_unpack_args ($1) . "
 732   char *str = String_val (strv);
 733   $c_ret_type r;
 734
 735   NONBLOCKING (r = $c_name ($1, str, 0));
 736   CHECK_ERROR (!r, conn, \"$c_name\");
 737
 738   " . gen_pack_result ($2) . "
 739
 740   CAMLreturn (rv);
 741 "
 742     } elsif ($sig =~ /^(\w+), int : (\w+)$/) {
 743         my $c_ret_type = short_name_to_c_type ($2);
 744         "\
 745   CAMLlocal1 (rv);
 746   " . gen_unpack_args ($1) . "
 747   int i = Int_val (iv);
 748   $c_ret_type r;
 749
 750   NONBLOCKING (r = $c_name ($1, i));
 751   CHECK_ERROR (!r, conn, \"$c_name\");
 752
 753   " . gen_pack_result ($2) . "
 754
 755   CAMLreturn (rv);
 756 "
 757     } elsif ($sig =~ /^(\w+), uuid : (\w+)$/) {
 758         my $c_ret_type = short_name_to_c_type ($2);
 759         "\
 760   CAMLlocal1 (rv);
 761   " . gen_unpack_args ($1) . "
 762   unsigned char *uuid = (unsigned char *) String_val (uuidv);
 763   $c_ret_type r;
 764
 765   NONBLOCKING (r = $c_name ($1, uuid));
 766   CHECK_ERROR (!r, conn, \"$c_name\");
 767
 768   " . gen_pack_result ($2) . "
 769
 770   CAMLreturn (rv);
 771 "
 772     } elsif ($sig =~ /^(\w+), 0U? : (\w+)$/) {
 773         my $c_ret_type = short_name_to_c_type ($2);
 774         "\
 775   CAMLlocal1 (rv);
 776   " . gen_unpack_args ($1) . "
 777   $c_ret_type r;
 778
 779   NONBLOCKING (r = $c_name ($1, 0));
 780   CHECK_ERROR (!r, conn, \"$c_name\");
 781
 782   " . gen_pack_result ($2) . "
 783
 784   CAMLreturn (rv);
 785 "
 786     } elsif ($sig =~ /^(\w+) : (\w+)$/) {
 787         my $c_ret_type = short_name_to_c_type ($2);
 788         "\
 789   CAMLlocal1 (rv);
 790   " . gen_unpack_args ($1) . "
 791   $c_ret_type r;
 792
 793   NONBLOCKING (r = $c_name ($1));
 794   CHECK_ERROR (!r, conn, \"$c_name\");
 795
 796   " . gen_pack_result ($2) . "
 797
 798   CAMLreturn (rv);
 799 "
 800     } elsif ($sig =~ /^(\w+), string : (\w+) from (\w+)$/) {
 801         my $c_ret_type = short_name_to_c_type ($2);
 802         "\
 803   CAMLlocal2 (rv, connv);
 804   " . gen_unpack_args ($1) . "
 805   char *str = String_val (strv);
 806   $c_ret_type r;
 807
 808   NONBLOCKING (r = $c_name ($1, str));
 809   CHECK_ERROR (!r, conn, \"$c_name\");
 810
 811   connv = Field ($3v, 1);
 812   " . gen_pack_result ($2) . "
 813
 814   CAMLreturn (rv);
 815 "
 816     } elsif ($sig =~ /^(\w+), string, 0U? : (\w+) from (\w+)$/) {
 817         my $c_ret_type = short_name_to_c_type ($2);
 818         "\
 819   CAMLlocal2 (rv, connv);
 820   " . gen_unpack_args ($1) . "
 821   char *str = String_val (strv);
 822   $c_ret_type r;
 823
 824   NONBLOCKING (r = $c_name ($1, str, 0));
 825   CHECK_ERROR (!r, conn, \"$c_name\");
 826
 827   connv = Field ($3v, 1);
 828   " . gen_pack_result ($2) . "
 829
 830   CAMLreturn (rv);
 831 "
 832     } elsif ($sig =~ /^(\w+), 0U? : (\w+) from (\w+)$/) {
 833         my $c_ret_type = short_name_to_c_type ($2);
 834         "\
 835   CAMLlocal2 (rv, connv);
 836   " . gen_unpack_args ($1) . "
 837   $c_ret_type r;
 838
 839   NONBLOCKING (r = $c_name ($1, 0));
 840   CHECK_ERROR (!r, conn, \"$c_name\");
 841
 842   connv = Field ($3v, 1);
 843   " . gen_pack_result ($2) . "
 844
 845   CAMLreturn (rv);
 846 "
 847     } elsif ($sig =~ /^(\w+) : (\w+) from (\w+)$/) {
 848         my $c_ret_type = short_name_to_c_type ($2);
 849         "\
 850   CAMLlocal2 (rv, connv);
 851   " . gen_unpack_args ($1) . "
 852   $c_ret_type r;
 853
 854   NONBLOCKING (r = $c_name ($1));
 855   CHECK_ERROR (!r, conn, \"$c_name\");
 856
 857   connv = Field ($3v, 1);
 858   " . gen_pack_result ($2) . "
 859
 860   CAMLreturn (rv);
 861 "
 862     } else {
 863         die "unknown signature $sig"
 864     }
 865 }
 866
 867 # Generate each function.
 868
 869 foreach my $function (@functions) {
 870     my $c_name = $function->{name};
 871     my $is_weak = $function->{weak};
 872     my $sig = $function->{sig};
 873
 874     my $is_pool_func = $c_name =~ /^virStoragePool/;
 875     my $is_vol_func = $c_name =~ /^virStorageVol/;
 876
 877     # Generate an equivalent C-external name for the function, unless
 878     # one is defined already.
 879     my $c_external_name;
 880     if (exists ($function->{c_external_name})) {
 881         $c_external_name = $function->{c_external_name};
 882     } elsif ($c_name =~ /^vir/) {
 883         $c_external_name = substr $c_name, 3;
 884         $c_external_name = camel_case_to_underscores ($c_external_name);
 885         $c_external_name = "ocaml_libvirt_" . $c_external_name;
 886     } else {
 887         die "cannot convert c_name $c_name to c_external_name"
 888     }
 889
 890     # Generate a full function prototype if the function is weak.
 891     my $have_name = "HAVE_" . uc ($c_name);
 892     if ($is_weak) {
 893         my $c_sig = gen_c_signature ($sig, $c_name);
 894         print F <<END;
 895 #ifdef HAVE_WEAK_SYMBOLS
 896 #ifdef $have_name
 897 extern $c_sig __attribute__((weak));
 898 #endif
 899 #endif
 900
 901 END
 902     }
 903
 904     my @arg_names = gen_arg_names ($sig);
 905     my $nr_arg_names = scalar @arg_names;
 906     my $arg_names = join ", ", @arg_names;
 907     my $arg_names_as_values = join (", ", map { "value $_" } @arg_names);
 908
 909     # Generate the start of the function, arguments.
 910     print F <<END;
 911 CAMLprim value
 912 $c_external_name ($arg_names_as_values)
 913 {
 914   CAMLparam$nr_arg_names ($arg_names);
 915 END
 916
 917     # If weak, check the function exists at compile time or runtime.
 918     if ($is_weak) {
 919         print F <<END;
 920 #ifndef $have_name
 921   /* Symbol $c_name not found at compile time. */
 922   not_supported ("$c_name");
 923   /* Suppresses a compiler warning. */
 924   (void) caml__frame;
 925 #else
 926   /* Check that the symbol $c_name
 927    * is in runtime version of libvirt.
 928    */
 929   WEAK_SYMBOL_CHECK ($c_name);
 930 END
 931     }
 932
 933     # Generate the internals of the function.
 934     print F (gen_c_code ($sig, $c_name));
 935
 936     # Finish off weak #ifdef.
 937     if ($is_weak) {
 938         print F <<END;
 939 #endif
 940 END
 941     }
 942
 943     # Finish off the function.
 944     print F <<END;
 945 }
 946
 947 END
 948 }
 949
 950 #----------------------------------------------------------------------
 951
 952 # Unimplemented functions.
 953
 954 printf "$0: warning: %d unimplemented functions\n", scalar (@unimplemented);
 955
 956 if (@unimplemented) {
 957     print F <<'END';
 958 /* The following functions are unimplemented and always fail.
 959  * See generator.pl '@unimplemented'
 960  */
 961
 962 END
 963
 964     foreach my $c_external_name (@unimplemented) {
 965         print F <<END;
 966 CAMLprim value
 967 $c_external_name ()
 968 {
 969   failwith ("$c_external_name is unimplemented");
 970 }
 971
 972 END
 973     } # end foreach
 974 } # end if @unimplemented
 975
 976 #----------------------------------------------------------------------
 977
 978 # Write the epilogue.
 979
 980 print F <<'END';
 981 #include "libvirt_c_epilogue.c"
 982
 983 /* EOF */
 984 END
 985
 986 close F;
 987 print "$0: written $filename\n"
 988