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