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