\.a$
\.annot$
\/META$
-autom4te\.cache/
-\.swp$
-^stdext/config\.h$
-^config\.log$
-^config\.status$
-^configure$
-doc/*
-~$
-\.rej$
-\.orig$
Jonathan Knowles <jonathan.knowles@citrix.com>
Jonathan Ludlam <Jonathan.Ludlam@eu.citrix.com>
Magnus Therning <magnus.therning@eu.citrix.com>
-Prashanth Mundkur <prashanth.mundkur@gmail.com>
Richard Sharp <richard.sharp@eu.citrix.com>
Thomas Gazagnaire <thomas.gazagnaire@citrix.com>
Tim Deegan <Tim.Deegan@citrix.com>
--- /dev/null
+NO_DEFAULT_BUILD := yes
+ifdef B_BASE
+include $(B_BASE)/common.mk
+else
+MY_OUTPUT_DIR ?= $(CURDIR)/output
+MY_OBJ_DIR ?= $(CURDIR)/obj
+
+%/.dirstamp:
+ @mkdir -p $*
+ @touch $@
+endif
+
+all:
+ $(MAKE) -C uuid
+ $(MAKE) -C camldm
+ $(MAKE) -C stdext
+ $(MAKE) -C cdrom
+ $(MAKE) -C log
+ $(MAKE) -C sha1
+ $(MAKE) -C xml-light2
+
+allxen:
+ $(MAKE) -C mmap
+ $(MAKE) -C xc
+ $(MAKE) -C xb
+ $(MAKE) -C xs
+ $(MAKE) -C xsrpc
+ $(MAKE) -C eventchn
+
+install:
+ $(MAKE) -C uuid install
+ $(MAKE) -C camldm install
+ $(MAKE) -C stdext install
+ $(MAKE) -C cdrom install
+ $(MAKE) -C log install
+ $(MAKE) -C sha1 install
+ $(MAKE) -C xml-light2 install
+
+installxen:
+ $(MAKE) -C mmap install
+ $(MAKE) -C xc install
+ $(MAKE) -C xb install
+ $(MAKE) -C xs install
+ $(MAKE) -C xsrpc install
+ $(MAKE) -C eventchn install
+
+uninstall:
+ $(MAKE) -C uuid uninstall
+ $(MAKE) -C camldm uninstall
+ $(MAKE) -C stdext uninstall
+ $(MAKE) -C cdrom uninstall
+ $(MAKE) -C log uninstall
+ $(MAKE) -C sha1 uninstall
+ $(MAKE) -C xml-light2 uninstall
+
+uninstallxen:
+ $(MAKE) -C eventchn uninstall
+ $(MAKE) -C xsrpc uninstall
+ $(MAKE) -C xs uninstall
+ $(MAKE) -C xb uninstall
+ $(MAKE) -C xc uninstall
+ $(MAKE) -C mmap uninstall
+
+OUTPUT_API_PKG := $(MY_OUTPUT_DIR)/api-libs.tar.gz
+
+$(OUTPUT_API_PKG): DESTDIR=$(MY_OBJ_DIR)/staging/
+$(OUTPUT_API_PKG): PREFIX=$(shell ocamlfind printconf path)
+$(OUTPUT_API_PKG): $(MY_OBJ_DIR)/.dirstamp $(MY_OUTPUT_DIR)/.dirstamp
+ rm -rf $(DESTDIR)
+ mkdir -p $(DESTDIR)$(PREFIX)
+ $(MAKE) clean
+ $(MAKE) all
+ $(MAKE) DESTDIR=$(MY_OBJ_DIR)/staging install
+ tar -C $(DESTDIR) -zcf $@ .
+
+OUTPUT_XAPI_PKG := $(MY_OUTPUT_DIR)/xapi-libs.tar.gz
+
+$(OUTPUT_XAPI_PKG): DESTDIR=$(MY_OBJ_DIR)/staging/
+$(OUTPUT_XAPI_PKG): PREFIX=$(shell ocamlfind printconf path)
+$(OUTPUT_XAPI_PKG): $(MY_OBJ_DIR)/.dirstamp $(MY_OUTPUT_DIR)/.dirstamp
+ rm -rf $(DESTDIR)
+ mkdir -p $(DESTDIR)$(PREFIX)
+ $(MAKE) cleanxen
+ $(MAKE) allxen
+ $(MAKE) DESTDIR=$(MY_OBJ_DIR)/staging installxen
+ tar -C $(DESTDIR) -zcf $@ .
+
+.PHONY: api-libs
+api-libs: $(OUTPUT_API_PKG)
+ @ :
+
+.PHONY: xapi-libs
+xapi-libs: $(OUTPUT_XAPI_PKG)
+ @ :
+
+.PHONY: clean
+clean:
+ make -C uuid clean
+ make -C camldm clean
+ make -C stdext clean
+ make -C cdrom clean
+ make -C log clean
+ make -C sha1 clean
+ make -C xml-light2 clean
+ rm -f $(OUTPUT_API_PKG)
+
+cleanxen:
+ $(MAKE) -C mmap clean
+ $(MAKE) -C xc clean
+ $(MAKE) -C xb clean
+ $(MAKE) -C xs clean
+ $(MAKE) -C xsrpc clean
+ $(MAKE) -C eventchn clean
+ rm -f $(OUTPUT_XAPI_PKG)
version = "@VERSION@"
description = "device-mapper ocaml interface"
-requires = "unix,rpc-light.json"
archive(byte) = "camldm.cma"
archive(native) = "camldm.cmxa"
+
CC = gcc
-CFLAGS = -Wall -fPIC -O2 -I/usr/lib/ocaml
+CFLAGS = -Wall -fPIC -O2 -I/opt/xensource/lib/ocaml
OCAMLC = ocamlc -g
OCAMLOPT = ocamlopt
-FEPP = camlp4o -I ../rpc-light -I $(shell ocamlfind query type-conv) pa_type_conv.cmo pa_rpc.cma
-
LDFLAGS = -cclib -L./
+DESTDIR ?= /
VERSION := $(shell hg parents --template "{rev}" 2>/dev/null || echo 0.0)
OCAMLOPTFLAGS = -g -dtypes
INTF = $(foreach obj, $(OBJS),$(obj).cmi)
LIBS = camldm.cma camldm.cmxa
-DOCDIR = /myrepos/xen-api-libs.hg/doc
-
-OCAMLFLAGS = -pp '${FEPP}' -I ../rpc-light
-
-
all: $(INTF) $(LIBS) $(PROGRAMS)
bins: $(PROGRAMS)
libs: $(LIBS)
camldm.cmxa: libcamldm_stubs.a $(foreach obj,$(OBJS),$(obj).cmx)
- $(OCAMLOPT) $(OCAMLOPTFLAGS) $(OCAMLFLAGS) -a -o $@ -cclib -lcamldm_stubs -cclib -ldevmapper $(foreach obj,$(OBJS),$(obj).cmx)
+ $(OCAMLOPT) $(OCAMLOPTFLAGS) -a -o $@ -cclib -lcamldm_stubs -cclib -ldevmapper $(foreach obj,$(OBJS),$(obj).cmx)
camldm.cma: $(foreach obj,$(OBJS),$(obj).cmo)
- $(OCAMLC) $(OCAMLOPTFLAGS) $(OCAMLFLAGS) -a -dllib dllcamldm_stubs.so -cclib -lcamldm_stubs -cclib -ldevmapper -o $@ $(foreach obj,$(OBJS),$(obj).cmo)
+ $(OCAMLC) -a -dllib dllcamldm_stubs.so -cclib -lcamldm_stubs -cclib -ldevmapper -o $@ $(foreach obj,$(OBJS),$(obj).cmo)
camldm_stubs.a: camldm_stubs.o
ocamlmklib -o camldm_stubs -ldevmapper $+
ocamlmklib -o camldm_stubs -ldevmapper $+
%.cmo: %.ml
- $(OCAMLC) $(OCAMLFLAGS) -c -o $@ $<
+ $(OCAMLC) -c -o $@ $<
%.cmi: %.mli
- $(OCAMLC) $(OCAMLFLAGS) -c -o $@ $<
+ $(OCAMLC) -c -o $@ $<
%.cmx: %.ml
- $(OCAMLOPT) $(OCAMLOPTFLAGS) $(OCAMLFLAGS) -c -o $@ $<
+ $(OCAMLOPT) $(OCAMLOPTFLAGS) -c -o $@ $<
%.o: %.c
$(CC) $(CFLAGS) -c -o $@ $<
sed 's/@VERSION@/$(VERSION)/g' < $< > $@
.PHONY: install
-install: path = $(DESTDIR)$(shell ocamlfind printconf destdir)
install: $(LIBS) META
- mkdir -p $(path)
- ocamlfind install -destdir $(path) -ldconf ignore camldm META $(INTF) $(LIBS) *.a *.so *.cmx
+ ocamlfind install -destdir $(DESTDIR)$(shell ocamlfind printconf destdir) -ldconf ignore camldm META $(INTF) $(LIBS) *.a *.so *.cmx
.PHONY: uninstall
uninstall:
ocamlfind remove camldm
-.PHONY: doc
-doc: $(INTF)
- python ../doc/doc.py $(DOCDIR) "camldm" "package" "$(OBJS)" "." "" ""
-
clean:
rm -f *.o *.so *.a *.cmo *.cmi *.cma *.cmx *.cmxa *.annot $(LIBS) $(PROGRAMS)
-(*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
- *)
-
-type devty =
- | Dereferenced of string (* e.g. PV id *)
- | Real of string (* device *)
-
-and dev = {
- device : devty;
+type dev = {
+ device : string;
offset : int64;
}
-
-and stripety = {
- chunk_size : int64; (* In sectors - must be a power of 2 and at least as large as the system's PAGE_SIZE *)
+
+type stripety = {
+ chunk_size : int64;
dests : dev array;
}
-and mapty =
+type mapty =
| Linear of dev (* Device, offset *)
| Striped of stripety
-and mapping = {
+type mapping = {
start : int64;
- len : int64;
+ len : int64;
map : mapty;
}
-and status = {
+type status = {
exists : bool;
suspended : bool;
live_table : bool;
minor : int32;
read_only : bool;
targets : (int64 * int64 * string * string) list
-}
-
-and mapping_array = {
- m : mapping array
-}
-
-and create_error_t = {
- c : (int64 * int64 * string * string) array
}
-with rpc
-
-
external _create : string -> (int64 * int64 * string * string) array -> unit = "camldm_create"
-external _reload : string -> (int64 * int64 * string * string) array -> unit = "camldm_reload"
external _table : string -> status = "camldm_table"
external _mknods : string -> unit = "camldm_mknods"
external _remove : string -> unit = "camldm_remove"
-external _suspend : string -> unit = "camldm_suspend"
-external _resume : string -> unit = "camldm_resume"
external _mknod : string -> int -> int -> int -> unit = "camldm_mknod"
-external _ls : unit -> (string list) option = "camldm_ls"
(* Helper to convert from our type to the string*string
* type expected by libdevmapper *)
-let resolve_device dev deref_table =
- match dev with
- | Real d -> d
- | Dereferenced d -> List.assoc d deref_table
-
-let convert_mapty m deref_table =
+let convert_mapty m =
let array_concat sep a = String.concat sep (Array.to_list a) in
match m with
| Linear dev ->
- "linear",Printf.sprintf "%s %Ld" (resolve_device dev.device deref_table) dev.offset
+ "linear",Printf.sprintf "%s %Ld" dev.device dev.offset
| Striped st ->
"striped",
Printf.sprintf "%d %Ld %s" (Array.length st.dests) st.chunk_size
(array_concat " "
(Array.map (fun dev ->
- Printf.sprintf "%s %Ld" (resolve_device dev.device deref_table) dev.offset) st.dests))
+ Printf.sprintf "%s %Ld" dev.device dev.offset) st.dests))
-exception CreateError of string
-exception ReloadError of string
+let create dev map =
+ let newmap = Array.map (fun m ->
+ let (ty,params) = convert_mapty m.map in
+ (m.start, m.len, ty, params)) map in
+ _create dev newmap
-let to_string m = Jsonrpc.to_string (rpc_of_mapping_array {m=m})
-let of_string s = (mapping_array_of_rpc (Jsonrpc.of_string s)).m
-
-let _writemap dev map =
- let oc = open_out (Printf.sprintf "/tmp/%s.map" dev) in
- Printf.fprintf oc "%s" (String.concat " " (Array.to_list (Array.map (fun (start,len,ty,params) -> Printf.sprintf "(start: %Ld len: %Ld ty: %s params: %s)" start len ty params) map)));
- close_out oc
-
-let _getmap map dereference_table =
- Array.map (fun m ->
- let (ty,params) = convert_mapty m.map dereference_table in
- (m.start, m.len, ty, params)) map
-
-let create dev map dereference_table =
- let newmap = _getmap map dereference_table in
- try
- _writemap dev newmap;
- _create dev newmap
- with Failure x ->
- raise (CreateError x)
-
-let reload dev map dereference_table =
- let newmap = _getmap map dereference_table in
- try
- _writemap dev newmap;
- _reload dev newmap
- with Failure x ->
- raise (ReloadError x)
-
-let get_sector_pos_of map sector dereference_table =
- match map.map with
- | Linear l -> (resolve_device l.device dereference_table, Int64.add l.offset sector)
- | Striped s ->
- (* Untested *)
- let ndevs = Int64.of_int (Array.length s.dests) in
- let chunk_num = Int64.div sector s.chunk_size in
- let offset_in_chunk = Int64.rem sector s.chunk_size in
- let dev_num = Int64.to_int (Int64.rem chunk_num ndevs) in
- let dev_off = Int64.div chunk_num ndevs in
- let device = s.dests.(dev_num) in
- let offset_from_start = Int64.add (Int64.mul dev_off s.chunk_size) offset_in_chunk in
- let total_offset = Int64.add offset_from_start device.offset in
- (resolve_device device.device dereference_table, total_offset)
-
let remove = _remove
let table = _table
let mknods = _mknods
let mknod = _mknod
-let suspend = _suspend
-let resume = _resume
-let ls = _ls
+
-(*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
- *)
-
-type devty = | Dereferenced of string | Real of string
-type dev = { device : devty; offset : int64; }
+type dev = { device : string; offset : int64; }
type stripety = { chunk_size : int64; dests : dev array; }
type mapty = Linear of dev | Striped of stripety
type mapping = { start : int64; len : int64; map : mapty; }
-type mapping_array = {
- m : mapping array
-}
type status = {
exists : bool;
suspended : bool;
read_only : bool;
targets : (int64 * int64 * string * string) list;
}
-
-exception CreateError of string
-exception ReloadError of string
-
-val rpc_of_mapping_array : mapping_array -> Rpc.t
-val mapping_array_of_rpc : Rpc.t -> mapping_array
-val convert_mapty : mapty -> (string * string) list -> string * string
-val create : string -> mapping array -> (string * string) list -> unit
-val reload : string -> mapping array -> (string * string) list -> unit
-val suspend : string -> unit
-val resume : string -> unit
+val convert_mapty : mapty -> string * string
+val create : string -> mapping array -> unit
val remove : string -> unit
val table : string -> status
val mknods : string -> unit
val mknod : string -> int -> int -> int -> unit
-val get_sector_pos_of : mapping -> int64 -> (string * string) list -> string * int64
-val to_string : mapping array -> string
-val of_string : string -> mapping array
-
-val rpc_of_status : status -> Rpc.t
-val ls : unit -> (string list) option
-/*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
- */
#include <libdevmapper.h>
#include <caml/mlvalues.h>
#include <caml/memory.h>
if(!(dmt = dm_task_create(DM_DEVICE_CREATE)))
caml_failwith("Failed to create task!");
- if(!dm_task_set_name(dmt, String_val(name))) {
- dm_task_destroy(dmt);
- caml_failwith("Failed to set name");
- }
-
- for(i=0; i<Wosize_val(map); i++) {
- start=Int64_val(Field(Field(map,i),0));
- size=Int64_val(Field(Field(map,i),1));
- ty=String_val(Field(Field(map,i),2));
- params=String_val(Field(Field(map,i),3));
-
- printf("%" PRIu64 " %" PRIu64 " %s %s\n", start, size, ty, params);
-
- if(!dm_task_add_target(dmt, start, size, ty, params)) {
- dm_task_destroy(dmt);
- caml_failwith("Failed to add target");
- }
- }
-
- if(!dm_task_run(dmt)) {
- dm_task_destroy(dmt);
- caml_failwith("Failed to run task");
- }
-
- win:
- CAMLreturn0;
-}
-
-void camldm_reload(value name, value map)
-{
- CAMLparam2(name,map);
-
- struct dm_task *dmt;
- int i;
- uint64_t start, size;
- char *ty,*params;
-
- if(!(dmt = dm_task_create(DM_DEVICE_RELOAD)))
- caml_failwith("Failed to create task!");
-
if(!dm_task_set_name(dmt, String_val(name)))
goto out;
tmp=Val_int(0);
- do {
+ do {
next = dm_get_next_target(dmt, next, &start, &length, &target_type, ¶ms);
-
- /* This is how dmsetup.c checks for an empty table: */
- if (!target_type)
- continue;
-
dm_task_get_info(dmt, &info);
tuple=caml_alloc_tuple(4);
Store_field(r, 1, tmp);
tmp=r;
+
+ printf("params=%s\n",params);
} while(next);
Store_field(result,9,tmp);
CAMLreturn0;
}
-void camldm_suspend(value device)
-{
- CAMLparam1(device);
- _simple(DM_DEVICE_SUSPEND,String_val(device));
- CAMLreturn0;
-}
-
-void camldm_resume(value device)
-{
- CAMLparam1(device);
- _simple(DM_DEVICE_RESUME,String_val(device));
- CAMLreturn0;
-}
-
void camldm_mknod(value path, value mode, value major, value minor)
{
CAMLparam4(path, mode, major, minor);
mknod(String_val(path),S_IFBLK | Int_val(mode), makedev(Int_val(major),Int_val(minor)));
CAMLreturn0;
}
-
-
-/* Helper functions for camldm_ls */
-
-#define none Val_int(0)
-#define Tag_some Val_int(0)
-
-value some (value content) {
- CAMLparam1 (content);
- CAMLlocal1 (result);
- result = caml_alloc (1, Tag_some);
- Store_field (result, 0, content);
- CAMLreturn (result);
-};
-value cons (value car_value, value cdr_value) {
- CAMLparam2 (car_value, cdr_value);
- CAMLlocal1 (cell);
-
- const int car = 0;
- const int cdr = 1;
- cell = caml_alloc (2, Tag_cons);
- Store_field (cell, car, car_value);
- Store_field (cell, cdr, cdr_value);
-
- CAMLreturn (cell);
-};
-/*
- camldm_ls may leak memory. Who knows? (Does the c function (_process_all)
- where I copied this from (dmsetup.c) care about memory? dmsetup
- exits shortly after executing it, anyway.
-
- After testing: It does _not_ seem to leak. Probably
- "dm_task_destroy(dmt);" is doing some cleaning up.
-*/
-value camldm_ls()
-{
- CAMLparam0 ();
- CAMLlocal1 (list);
-
- struct dm_names *names;
- struct dm_task *dmt;
-
- if (!(dmt = dm_task_create(DM_DEVICE_LIST)))
- CAMLreturn(none);
-
- if (!dm_task_run(dmt)) {
- dm_task_destroy(dmt);
- CAMLreturn(none);
- }
-
- if (!(names = dm_task_get_names(dmt))) {
- dm_task_destroy(dmt);
- CAMLreturn(none);
- }
-
- list = Val_emptylist;
- if (!names->dev) {
- dm_task_destroy(dmt);
- CAMLreturn(some(list));
- }
-
- unsigned int next = 0;
-
- do {
- names = (void *) names + next;
- // printf("%s\t(%d, %d)\n", names->name,
- // (int) MAJOR(names->dev), (int) MINOR(names->dev));
-
- list = cons (caml_copy_string(names->name), list);
-
- // printf("%s\t(:Debug only)\n", names->name);
- next = names->next;
- } while (next);
-
- dm_task_destroy(dmt);
- CAMLreturn(some(list));
-}
-(*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
- *)
open Camldm
let _ =
version = "@VERSION@"
description = "Cdrom extension"
-requires = "unix"
archive(byte) = "cdrom.cma"
archive(native) = "cdrom.cmxa"
CC = gcc
-CFLAGS = -Wall -fPIC -O2 -I/usr/lib/ocaml
+CFLAGS = -Wall -fPIC -O2 -I/opt/xensource/lib/ocaml
OCAMLC = ocamlc -g
OCAMLOPT = ocamlopt
LDFLAGS = -cclib -L./
+DESTDIR ?= /
VERSION := $(shell hg parents --template "{rev}" 2>/dev/null || echo 0.0)
OCAMLOPTFLAGS = -g -dtypes
INTF = $(foreach obj, $(OBJS),$(obj).cmi)
LIBS = cdrom.cma cdrom.cmxa
-DOCDIR = /myrepos/xen-api-libs.hg/doc
-
all: $(INTF) $(LIBS) $(PROGRAMS)
bins: $(PROGRAMS)
sed 's/@VERSION@/$(VERSION)/g' < $< > $@
.PHONY: install
-install: path = $(DESTDIR)$(shell ocamlfind printconf destdir)
install: $(LIBS) META
- mkdir -p $(path)
- ocamlfind install -destdir $(path) -ldconf ignore cdrom META $(INTF) $(LIBS) *.a *.so *.cmx
+ ocamlfind install -destdir $(DESTDIR)$(shell ocamlfind printconf destdir) -ldconf ignore cdrom META $(INTF) $(LIBS) *.a *.so *.cmx
.PHONY: uninstall
uninstall:
ocamlfind remove cdrom
-.PHONY: doc
-doc: $(INTF)
- python ../doc/doc.py $(DOCDIR) "cdrom" "package" "$(OBJS)" "." "" ""
-
clean:
rm -f *.o *.so *.a *.cmo *.cmi *.cma *.cmx *.cmxa *.annot $(LIBS) $(PROGRAMS)
-(*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
- *)
type cdrom_drive_status =
| NO_INFO
-(*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
- *)
type cdrom_drive_status =
| NO_INFO
| NO_DISC
-/*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
- */
/* Query CDROM info */
#include <string.h>
#include <errno.h>
version = "@VERSION@"
description = "Eventchn interface extension"
-requires = "unix"
archive(byte) = "eventchn.cma"
archive(native) = "eventchn.cmxa"
CC = gcc
-CFLAGS = -Wall -fPIC -O2 -I/usr/lib/ocaml -I$(XEN_ROOT)/usr/include
+CFLAGS = -Wall -fPIC -O2 -I/opt/xensource/lib/ocaml -I$(XEN_ROOT)/usr/include
OCAMLC = ocamlc -g
OCAMLOPT = ocamlopt
LDFLAGS = -cclib -L./
+DESTDIR ?= /
VERSION := $(shell hg parents --template "{rev}" 2>/dev/null || echo 0.0)
OCAMLOPTFLAGS = -g -dtypes
INTF = $(foreach obj, $(OBJS),$(obj).cmi)
LIBS = eventchn.cma eventchn.cmxa
-DOCDIR = /myrepos/xen-api-libs.hg/doc
-
all: $(INTF) $(LIBS) $(PROGRAMS)
bins: $(PROGRAMS)
sed 's/@VERSION@/$(VERSION)/g' < $< > $@
.PHONY: install
-install: path = $(DESTDIR)$(shell ocamlfind printconf destdir)
install: $(LIBS) META
- mkdir -p $(path)
- ocamlfind install -destdir $(path) -ldconf ignore eventchn META $(INTF) $(LIBS) *.a *.so *.cmx
+ ocamlfind install -destdir $(DESTDIR)$(shell ocamlfind printconf destdir) -ldconf ignore eventchn META $(INTF) $(LIBS) *.a *.so *.cmx
.PHONY: uninstall
uninstall:
ocamlfind remove eventchn
-.PHONY: doc
-doc: $(INTF)
- python ../doc/doc.py $(DOCDIR) "eventchn" "package" "$(OBJS)" "." "" ""
-
clean:
rm -f *.o *.so *.a *.cmo *.cmi *.cma *.cmx *.cmxa *.annot $(LIBS) $(PROGRAMS)
(*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
+ * Copyright (c) 2006-2007 XenSource Inc.
+ * Author Vincent Hanquez <vincent@xensource.com>
*
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
+ * All rights reserved.
*)
+
exception Error of string
external init: unit -> Unix.file_descr = "stub_eventchn_init"
-(*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
- *)
exception Error of string
external init : unit -> Unix.file_descr = "stub_eventchn_init"
external notify : Unix.file_descr -> int -> unit = "stub_eventchn_notify"
/*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
+ * Copyright (c) 2006-2007 XenSource Inc.
+ * Author Vincent Hanquez <vincent@xensource.com>
*
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
+ * All rights reserved.
*/
+
#ifdef WITH_INJECTION_CAPABILITY
#include "../fake/marshall.h"
#include "../fake/using.h"
/*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
+ * Copyright (c) 2006-2007 XenSource Inc.
+ * Author Vincent Hanquez <vincent@xensource.com>
*
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
+ * All rights reserved.
*/
+
#include <sys/types.h>
#include <sys/stat.h>
#include <fcntl.h>
#include <caml/callback.h>
#include <caml/fail.h>
-#define EVENTCHN_PATH "/dev/xen/evtchn"
+#define EVENTCHN_PATH "/dev/xen/eventchn"
+#define EVENTCHN_MAJOR 10
+#define EVENTCHN_MINOR 63
#define WITH_INJECTION_CAPABILITY
#include "eventchn_injection.c"
pre_eventchn_open();
fd = open(EVENTCHN_PATH, O_RDWR);
-
+ if (fd == -1 && errno == ENOENT) {
+ mkdir("/dev/xen", 0640);
+ mknod(EVENTCHN_PATH, S_IFCHR | 0640, makedev(10, 63));
+ fd = open(EVENTCHN_PATH, O_RDWR);
+ }
return fd;
}
/*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
+ * Copyright (c) 2007 XenSource Inc.
+ * Author Vincent Hanquez <vincent@xensource.com>
*/
#ifndef FAKE_MARSHALL_H
/*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
+ * Copyright (c) 2007 XenSource Inc.
+ * Author Vincent Hanquez <vincent@xensource.com>
*
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
+ * All rights reserved.
*/
#ifndef FAKE_USING_H
#define FAKE_USING_H
version = "@VERSION@"
description = "Log - logging library"
-requires = "unix,stdext"
archive(byte) = "log.cma"
archive(native) = "log.cmxa"
CC = gcc
-OCAMLLOC := $(shell ocamlc -where)
-CFLAGS = -Wall -fPIC -O2 -I/opt/xensource/lib/ocaml -I$(OCAMLLOC)
+CFLAGS = -Wall -fPIC -O2 -I/opt/xensource/lib/ocaml
OCAMLC = ocamlc
OCAMLOPT = ocamlopt
LDFLAGS = -cclib -L./
+DESTDIR ?= /
VERSION := $(shell hg parents --template "{rev}" 2>/dev/null || echo 0.0)
OCAMLCFLAGS = -g -dtypes -thread -I ../stdext
OCAMLOPTFLAGS = -g -dtypes -thread -I ../stdext
OCAMLLIBDIR := $(shell ocamlc -where)
OCAMLDESTDIR ?= $(OCAMLLIBDIR)
-OBJS = syslog log logs debug
-INTF = log.cmi logs.cmi syslog.cmi debug.cmi
+OBJS = syslog log logs
+INTF = log.cmi logs.cmi syslog.cmi
LIBS = log.cma log.cmxa
-DOCDIR = /myrepos/xen-api-libs.hg/doc
-
all: $(INTF) $(LIBS) $(PROGRAMS)
bins: $(PROGRAMS)
ar rcs $@ $+
ocamlmklib -o syslog_stubs $+
-%.cmi: %.mli
+%.cmo: %.ml
$(OCAMLC) -c $(OCAMLCFLAGS) -o $@ $<
-%.cmo: %.ml %.cmi
- $(OCAMLC) -c $(OCAMLCFLAGS) -thread -o $@ $<
+%.cmi: %.mli
+ $(OCAMLC) -c $(OCAMLCFLAGS) -o $@ $<
-%.cmx: %.ml %.cmi
- $(OCAMLOPT) $(OCAMLOPTFLAGS) -thread -c -o $@ $<
+%.cmx: %.ml
+ $(OCAMLOPT) $(OCAMLOPTFLAGS) -c -o $@ $<
%.o: %.c
$(CC) $(CFLAGS) -c -o $@ $<
+logs.mli : logs.ml
+ $(OCAMLC) -i $(OCAMLCFLAGS) $< > $@
+
+syslog.mli : syslog.ml
+ $(OCAMLC) -i $< > $@
+
META: META.in
sed 's/@VERSION@/$(VERSION)/g' < $< > $@
#dependency:
-log.cmi: syslog.cmi
-logs.cmi: log.cmi
-debug.cmi: logs.cmi
+log.cmo: syslog.cmo log.cmi
+log.cmx: syslog.cmx log.cmi
+logs.cmo: log.cmi
+logs.cmx: log.cmx
.PHONY: install
-install: path = $(DESTDIR)$(shell ocamlfind printconf destdir)
install: $(LIBS) META
- mkdir -p $(path)
- ocamlfind install -destdir $(path) -ldconf ignore log META $(INTF) $(LIBS) *.a *.so *.cmx
+ ocamlfind install -destdir $(DESTDIR)$(shell ocamlfind printconf destdir) -ldconf ignore log META $(INTF) $(LIBS) *.a *.so *.cmx
.PHONY: uninstall
uninstall:
ocamlfind remove log
-.PHONY: doc
-doc: $(INTF)
- python ../doc/doc.py $(DOCDIR) "log" "package" "$(OBJS)" "." "stdext" ""
-
clean:
rm -f *.o *.so *.a *.cmo *.cmi *.cma *.cmx *.cmxa *.annot $(LIBS) $(PROGRAMS)
(*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
+ * Copyright (C) 2006 XenSource LTD
+ * Author: Vincent Hanquez <vincent@xensource.com>
*)
open Printf
-
-module Mutex = struct
- include Mutex
- let execute lock f =
- Mutex.lock lock;
- let r = begin try f () with exn -> Mutex.unlock lock; raise exn end; in
- Mutex.unlock lock;
- r
-end
+open Threadext
exception Unknown_level of string
type t = { output: output; mutable level: level; }
-let get_strings t = match t.output with
- | String s -> !s
- | _ -> []
-
-let get_level t = t.level
-
let make output level = { output = output; level = level; }
let make_stream ty channel =
| String _ -> ()
(** create a string representating the parameters of the logger *)
-let to_string t =
+let string_of_logger t =
match t.output with
| Nil -> "nil"
| Syslog k -> sprintf "syslog:%s" k
end
(** parse a string to a logger *)
-let of_string s : t =
+let logger_of_string s : t =
match s with
| "nil" -> opennil ()
| "stderr" -> openerr Debug
let gettimestring () =
let time = Unix.gettimeofday () in
- let tm = Unix.gmtime time in
+ let tm = Unix.localtime time in
let msec = time -. (floor time) in
- sprintf "%d%.2d%.2dT%.2d:%.2d:%.2d.%.3dZ|" (1900 + tm.Unix.tm_year)
+ sprintf "%d%.2d%.2d %.2d:%.2d:%.2d.%.3d|" (1900 + tm.Unix.tm_year)
(tm.Unix.tm_mon + 1) tm.Unix.tm_mday
tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec
(int_of_float (1000.0 *. msec))
let filesize = ref 0
let mutex = Mutex.create ()
-let output_common t ?(raw=false) ?(syslog_time=false) ?(key="") ?(extra="") priority (message: string) =
- let result_string = ref "" in
+let output t ?(key="") ?(extra="") priority (message: string) =
let construct_string withtime =
(*let key = if key = "" then [] else [ key ] in
let extra = if extra = "" then [] else [ extra ] in
@ [ sprintf "%5s" (string_of_level priority) ] @ extra @ key @ [ message ] in
(* let items = !extra_hook items in*)
String.concat " " items*)
- result_string := (
- if raw
- then Printf.sprintf "%s" message
- else
Printf.sprintf "[%s%.5s|%s] %s"
(if withtime then gettimestring () else "") (string_of_level priority) extra message
- );
- !result_string
in
(* Keep track of how much we write out to streams, so that we can *)
(* log-rotate at appropriate times *)
in
if String.length message > 0 then
- (match t.output with
+ match t.output with
| Syslog k ->
let sys_prio = match priority with
| Debug -> Syslog.Debug
| Info -> Syslog.Info
| Warn -> Syslog.Warning
| Error -> Syslog.Err in
- let facility = try Syslog.facility_of_string k with _->Syslog.Daemon in
- Syslog.log facility sys_prio ((construct_string syslog_time) ^ "\n")
+ Syslog.log Syslog.Daemon sys_prio ((construct_string false) ^ "\n")
| Stream s -> Mutex.execute s.mutex
(fun () ->
match !(s.channel) with
| None -> ())
| Nil -> ()
| String s -> (s := (construct_string true)::!s)
- );
- !result_string
-
-let output t ?(key="") ?(extra="") priority (message: string) =
- ignore(output_common t ~key ~extra priority message)
-
-let output_and_return t ?(raw=false) ~syslog_time ?(key="") ?(extra="") priority (message: string) =
- output_common t ~raw ~syslog_time ~key ~extra priority message
let log t level (fmt: ('a, unit, string, unit) format4): 'a =
let b = (int_of_level t.level) <= (int_of_level level) in
-(*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
- *)
-
-(** Logging utilities *)
-
-type t
-
-(** create a string representating the parameters of the logger *)
-val to_string : t -> string
-
-(** parse a string to a logger *)
-val of_string : string -> t
-
-(** try to reopen a logger *)
-val reopen : t -> t
-
-(** close a logger *)
-val close : t -> unit
-
-val gettimestring : unit -> string
-
-(** {2 Builders} *)
-
+exception Unknown_level of string
type level = Debug | Info | Warn | Error
-val get_level : t -> level
-exception Unknown_level of string
-val level_of_string : string -> level
+type stream_type = Stderr | Stdout | File of string
+type stream_log = {
+ ty : stream_type;
+ channel : out_channel option ref;
+ mutex : Mutex.t;
+}
+type output =
+ Stream of stream_log
+ | String of string list ref
+ | Syslog of string
+ | Nil
+val int_of_level : level -> int
val string_of_level : level -> string
-
-(** open a syslog logger *)
+val level_of_string : string -> level
+val mkdir_safe : string -> Unix.file_perm -> unit
+val mkdir_rec : string -> Unix.file_perm -> unit
+type t = { output : output; mutable level : level; }
+val make : output -> level -> t
val opensyslog : string -> level -> t
-
-(** open a stderr logger *)
val openerr : level -> t
-
-(** open a stdout logger *)
val openout : level -> t
-
-(** open a stream logger - returning the output type *)
val openfile : string -> level -> t
-
-(** open a nil logger *)
val opennil : unit -> t
-
-(** open a string logger *)
val openstring : level -> t
-val get_strings : t -> string list
-
-(** {2 Raw output functions} *)
-
+val reopen : t -> t
+val close : t -> unit
+val string_of_logger : t -> string
+val logger_of_string : string -> t
+val validate : string -> unit
+val set : t -> level -> unit
+val gettimestring : unit -> string
+val filesize : int ref
+val mutex : Mutex.t
val output : t -> ?key:string -> ?extra:string -> level -> string -> unit
-val output_and_return : t -> ?raw:bool -> syslog_time:bool -> ?key:string -> ?extra:string -> level -> string -> string
-
-(** {2 Pretty output functions} *)
-
+val log : t -> level -> ('a, unit, string, unit) format4 -> 'a
val debug : t -> ('a, unit, string, unit) format4 -> 'a
val info : t -> ('a, unit, string, unit) format4 -> 'a
val warn : t -> ('a, unit, string, unit) format4 -> 'a
val error : t -> ('a, unit, string, unit) format4 -> 'a
-val log : t -> level -> ('a, unit, string, unit) format4 -> 'a
-
-(** {2 Output validation} *)
-
-val validate : string -> unit
-
-(** {2 Concurrency} *)
-
-(** TODO: It would be very nice to have a thread-free log module (ie. put the control outside that module).
- This mutex protects all the recorded outputs. *)
-val mutex : Mutex.t
-
-(** TODO: remove the global state (what happens if multiple log files are opened???) ! *)
-val filesize : int ref
-
-(*
-type stream_type = Stderr | Stdout | File of string
-type stream_log = {
- ty : stream_type;
- channel : out_channel option ref;
- mutex : Mutex.t;
-}
-
-val int_of_level : level -> int
-val mkdir_safe : string -> Unix.file_perm -> unit
-val mkdir_rec : string -> Unix.file_perm -> unit
-val set : t -> level -> unit
-val mutex : Mutex.t
-*)
(*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
+ * Copyright (C) 2006-2007 XenSource LTD
+ * Author: Vincent Hanquez <vincent@xensource.com>
*)
type keylogger =
if Hashtbl.mem __all_loggers logstring then
Hashtbl.find __all_loggers logstring
else
- let t = Log.of_string logstring in
+ let t = Log.logger_of_string logstring in
Hashtbl.add __all_loggers logstring t;
t
(** log a fmt message to the key|level logger specified in the log mapping.
* if the logger doesn't exist, assume nil logger.
*)
-let log_common key level ?(extra="") ~ret_fn1 ~ret_fn2 (fmt: ('a, unit, string, 'b) format4): 'a =
+let log key level ?(extra="") (fmt: ('a, unit, string, unit) format4): 'a =
let keylog =
if Hashtbl.mem __log_mapping key then
let keylog = Hashtbl.find __log_mapping key in
__default_logger in
let loggers = get_by_level keylog level in
match loggers with
- | [] -> Printf.kprintf ret_fn1 fmt
+ | [] -> Printf.kprintf ignore fmt
| _ ->
let l = List.fold_left (fun acc logger ->
try get_or_open logger :: acc
with _ -> acc
) [] loggers in
let l = List.rev l in
- ret_fn2 l
-
-let log key level ?(extra="") (fmt: ('a, unit, string, unit) format4): 'a =
- log_common key level ~extra ~ret_fn1:(ignore) fmt
- ~ret_fn2:(fun l ->
- (* ksprintf is the preferred name for kprintf, but the former
- * is not available in OCaml 3.08.3 *)
- Printf.kprintf (fun s ->
- List.iter (fun t -> Log.output t ~key ~extra level s) l) fmt
- )
-
-let log_and_return key level ?(raw=false) ~syslog_time ?(extra="") (fmt: ('a, unit, string, string) format4): 'a =
- log_common key level ~extra ~ret_fn1:(fun s->s) fmt
- ~ret_fn2:(fun l ->
- let ret_str = ref "" in
- Printf.kprintf (fun s ->
- List.iter (fun t -> ret_str := Log.output_and_return t ~raw ~syslog_time ~key ~extra level s) l; !ret_str) fmt
- )
+ (* ksprintf is the preferred name for kprintf, but the former
+ * is not available in OCaml 3.08.3 *)
+ Printf.kprintf (fun s ->
+ List.iter (fun t -> Log.output t ~key ~extra level s) l) fmt
(* define some convenience functions *)
let debug t ?extra (fmt: ('a , unit, string, unit) format4) =
log t Log.Warn ?extra fmt
let error t ?extra (fmt: ('a , unit, string, unit) format4) =
log t Log.Error ?extra fmt
-let audit t ?raw ?extra (fmt: ('a , unit, string, string) format4) =
- log_and_return t Log.Info ?raw ~syslog_time:true ?extra fmt
(*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
+ * Copyright (C) 2006 XenSource Ltd.
+ * Author Vincent Hanquez <vincent@xensource.com>
*)
type level = Emerg | Alert | Crit | Err | Warning | Notice | Info | Debug
(* external init : string -> options list -> facility -> unit = "stub_openlog" *)
external log : facility -> level -> string -> unit = "stub_syslog"
external close : unit -> unit = "stub_closelog"
-
-exception Unknown_facility of string
-let facility_of_string s =
- match s with
- |"auth"->Auth
- |"authpriv"->Authpriv
- |"cron"->Cron
- |"daemon"->Daemon
- |"ftp"->Ftp
- |"kern"->Kern
- |"local0"->Local0
- |"local1"->Local1
- |"local2"->Local2
- |"local3"->Local3
- |"local4"->Local4
- |"local5"->Local5
- |"local6"->Local6
- |"local7"->Local7
- |"lpr"->Lpr
- |"mail"->Mail
- |"news"->News
- |"syslog"->Syslog
- |"user"->User
- |"uucp"->Uucp
- |_-> raise (Unknown_facility s)
/*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
+ * Copyright (C) 2006 XenSource Ltd.
+ * Author Vincent Hanquez <vincent@xensource.com>
*/
#include <syslog.h>
-#include <string.h>
#include <caml/mlvalues.h>
#include <caml/memory.h>
#include <caml/alloc.h>
#include <caml/custom.h>
-#include <caml/signals.h>
static int __syslog_level_table[] = {
LOG_EMERG, LOG_ALERT, LOG_CRIT, LOG_ERR, LOG_WARNING,
value stub_syslog(value facility, value level, value msg)
{
CAMLparam3(facility, level, msg);
- const char *c_msg = strdup(String_val(msg));
- int c_facility = __syslog_facility_table[Int_val(facility)]
- | __syslog_level_table[Int_val(level)];
+ int c_facility;
- caml_enter_blocking_section();
- syslog(c_facility, "%s", c_msg);
- caml_leave_blocking_section();
-
- free(c_msg);
+ c_facility = __syslog_facility_table[Int_val(facility)]
+ | __syslog_level_table[Int_val(level)];
+ syslog(c_facility, "%s", String_val(msg));
CAMLreturn(Val_unit);
}
CC = gcc
-CFLAGS = -Wall -fPIC -O2 -I/usr/lib/ocaml
+CFLAGS = -Wall -fPIC -O2 -I/opt/xensource/lib/ocaml
OCAMLC = ocamlc -g
OCAMLOPT = ocamlopt
LDFLAGS = -cclib -L./
+DESTDIR ?= /
VERSION := $(shell hg parents --template "{rev}" 2>/dev/null || echo 0.0)
OCAMLOPTFLAGS = -g -dtypes
INTF = $(foreach obj, $(OBJS),$(obj).cmi)
LIBS = mmap.cma mmap.cmxa
-DOCDIR = /myrepos/xen-api-libs.hg/doc
-
all: $(INTF) $(LIBS) $(PROGRAMS)
bins: $(PROGRAMS)
sed 's/@VERSION@/$(VERSION)/g' < $< > $@
.PHONY: install
-install: path = $(DESTDIR)$(shell ocamlfind printconf destdir)
install: $(LIBS) META
- mkdir -p $(path)
- ocamlfind install -destdir $(path) -ldconf ignore mmap META $(INTF) $(LIBS) *.a *.so *.cmx
+ ocamlfind install -destdir $(DESTDIR)$(shell ocamlfind printconf destdir) -ldconf ignore mmap META $(INTF) $(LIBS) *.a *.so *.cmx
.PHONY: uninstall
uninstall:
ocamlfind remove mmap
-.PHONY: doc
-doc: $(INTF)
- python ../doc/doc.py $(DOCDIR) "mmap" "package" "$(OBJS)" "." "" ""
-
clean:
rm -f *.o *.so *.a *.cmo *.cmi *.cma *.cmx *.cmxa *.annot $(LIBS) $(PROGRAMS)
(*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
+ * Copyright (c) 2006 XenSource Inc.
+ * Author Vincent Hanquez <vincent@xensource.com>
*
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
+ * All rights reserved.
*)
type mmap_interface
-(*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
- *)
type mmap_interface
type mmap_prot_flag = RDONLY | WRONLY | RDWR
type mmap_map_flag = SHARED | PRIVATE
-/*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
+/**
+ * Copyright (c) 2006 XenSource Inc.
+ * Author Vincent Hanquez <vincent@xensource.com>
*
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
+ * All rights reserved.
*/
#include <unistd.h>
-/*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
+/**
+ * Copyright (c) 2006 XenSource Inc.
+ * Author Vincent Hanquez <vincent@xensource.com>
*
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
+ * All rights reserved.
*/
#ifndef C_MMAP_H
#!/bin/sh
-export REPO=/myrepos/xen-api-libs.hg
-
set -e
make clean; make cleanxen;
-make uninstall; make uninstallxen; make binuninstall
-make all && make bins && make install && make allxen && make installxen && make bininstall
+make uninstall; make uninstallxen;
+make all && make install && make allxen && make installxen
--- /dev/null
+version = "@VERSION@"
+description = "Sha1 hash functions"
+archive(byte) = "sha1.cma"
+archive(native) = "sha1.cmxa"
--- /dev/null
+CC = gcc
+CFLAGS = -Wall -fPIC -O2 -I/opt/xensource/lib/ocaml -I$(XEN_ROOT)/usr/include -I../mmap -I./
+OCAMLC = ocamlc -g
+OCAMLOPT = ocamlopt
+OCAMLOPTFLAGS = -g -dtypes -I ./
+
+LDFLAGS = -cclib -L./
+
+DESTDIR ?= /
+VERSION := $(shell hg parents --template "{rev}" 2>/dev/null || echo 0.0)
+
+OCAMLABI := $(shell ocamlc -version)
+OCAMLLIBDIR := $(shell ocamlc -where)
+OCAMLDESTDIR ?= $(OCAMLLIBDIR)
+
+OBJS = sha1
+INTF = sha1.cmi
+LIBS = sha1.cma sha1.cmxa
+
+PROGRAMS =
+
+all: $(INTF) $(LIBS) $(PROGRAMS)
+
+bins: $(PROGRAMS)
+
+libs: $(LIBS)
+
+sha1.cmxa: libsha1_stubs.a $(foreach obj,$(OBJS),$(obj).cmx)
+ $(OCAMLOPT) $(OCAMLOPTFLAGS) -a -o $@ -cclib -lsha1_stubs $(foreach obj,$(OBJS),$(obj).cmx)
+
+sha1.cma: $(foreach obj,$(OBJS),$(obj).cmo)
+ $(OCAMLC) -a -dllib dllsha1_stubs.so -cclib -lsha1_stubs -o $@ $(foreach obj,$(OBJS),$(obj).cmo)
+
+sha1_stubs.a: sha1_stubs.o
+ ocamlmklib -o sha1_stubs $+
+
+libsha1_stubs.a: sha1_stubs.o
+ ar rcs $@ $+
+ ocamlmklib -o sha1_stubs $+
+
+%.cmo: %.ml
+ $(OCAMLC) -c -o $@ $<
+
+%.cmi: %.mli
+ $(OCAMLC) -c -o $@ $<
+
+%.mli: %.ml
+ $(OCAMLC) -i $< > $@
+
+%.cmx: %.ml
+ $(OCAMLOPT) $(OCAMLOPTFLAGS) -c -o $@ $<
+
+%.o: %.c
+ $(CC) $(CFLAGS) -c -o $@ $<
+
+META: META.in
+ sed 's/@VERSION@/$(VERSION)/g' < $< > $@
+
+.PHONY: install
+install: $(LIBS) META
+ ocamlfind install -destdir $(DESTDIR)$(shell ocamlfind printconf destdir) -ldconf ignore sha1 META $(INTF) $(LIBS) *.a *.so *.cmx
+
+.PHONY: uninstall
+uninstall:
+ ocamlfind remove sha1
+
+clean:
+ rm -f *.o *.so *.a *.cmo *.cmi *.cma *.cmx *.cmxa *.annot $(LIBS) $(PROGRAMS) $(INTF)
+
--- /dev/null
+(*
+ * Copyright (C) 2007 XenSource Ltd.
+ * Author Vincent Hanquez <vincent@xensource.com>
+ *)
+
+type ctx
+type t
+
+external init: unit -> ctx = "stub_sha1_init"
+external update: ctx -> string -> int -> int -> unit = "stub_sha1_update"
+external finalize: ctx -> t = "stub_sha1_finalize"
+external to_hex: t -> string = "stub_sha1_to_hex"
--- /dev/null
+/* Copyright (c) 2007 XenSource Inc.
+ * Author Vincent Hanquez <vincent@xensource.com> */
+
+#include <stdlib.h>
+#include <string.h>
+#include <stdio.h>
+
+#include <byteswap.h>
+
+#ifdef WORDS_BIGENDIAN
+#define be16_to_cpu(x) (x)
+#define be32_to_cpu(x) (x)
+#define be64_to_cpu(x) (x)
+#define le16_to_cpu(x) bswap_16(x)
+#define le32_to_cpu(x) bswap_32(x)
+#define le64_to_cpu(x) bswap_64(x)
+#else
+#define be16_to_cpu(x) bswap_16(x)
+#define be32_to_cpu(x) bswap_32(x)
+#define be64_to_cpu(x) bswap_64(x)
+#define le16_to_cpu(x) (x)
+#define le32_to_cpu(x) (x)
+#define le64_to_cpu(x) (x)
+#endif
+
+struct sha1_ctx
+{
+ unsigned int state[5];
+ unsigned char buf[64];
+ unsigned long long count;
+};
+
+typedef struct { unsigned int digest[5]; } sha1_digest;
+
+static void sha1_init(struct sha1_ctx *ctx)
+{
+ memset(ctx, 0, sizeof(*ctx));
+
+ /* initialize H */
+ ctx->state[0] = 0x67452301;
+ ctx->state[1] = 0xEFCDAB89;
+ ctx->state[2] = 0x98BADCFE;
+ ctx->state[3] = 0x10325476;
+ ctx->state[4] = 0xC3D2E1F0;
+}
+
+#define rol(value, bits) (((value) << (bits)) | ((value) >> (32 - (bits))))
+
+/* (R0+R1), R2, R3, R4 are the different operations used in SHA1 */
+#define blk0(i) (block[i] = be32_to_cpu(((unsigned int*)buffer)[i]))
+#define blk(i) (block[i] = rol(block[i-3]^block[i-8]^block[i-14]^block[i-16],1))
+
+#define R0(v,w,x,y,z,i) z+=((w&(x^y))^y) +blk0(i)+0x5A827999+rol(v,5);w=rol(w,30);
+#define R1(v,w,x,y,z,i) z+=((w&(x^y))^y) +blk (i)+0x5A827999+rol(v,5);w=rol(w,30);
+#define R2(v,w,x,y,z,i) z+=( w^x ^y) +blk (i)+0x6ED9EBA1+rol(v,5);w=rol(w,30);
+#define R3(v,w,x,y,z,i) z+=(((w|x)&y)|(w&x))+blk (i)+0x8F1BBCDC+rol(v,5);w=rol(w,30);
+#define R4(v,w,x,y,z,i) z+=( w^x ^y) +blk (i)+0xCA62C1D6+rol(v,5);w=rol(w,30);
+
+
+static void sha1_transform(unsigned int state[5], unsigned char buffer[64])
+{
+ unsigned int block[80];
+ unsigned int i, a, b, c, d, e;
+
+ a = state[0];
+ b = state[1];
+ c = state[2];
+ d = state[3];
+ e = state[4];
+
+ for (i = 0; i < 15; i += 5) {
+ R0(a, b, c, d, e, 0 + i);
+ R0(e, a, b, c, d, 1 + i);
+ R0(d, e, a, b, c, 2 + i);
+ R0(c, d, e, a, b, 3 + i);
+ R0(b, c, d, e, a, 4 + i);
+ }
+
+ R0(a, b, c, d, e, 15);
+ R1(e, a, b, c, d, 16);
+ R1(d, e, a, b, c, 17);
+ R1(c, d, e, a, b, 18);
+ R1(b, c, d, e, a, 19);
+
+ for (i = 20; i < 40; i += 5) {
+ R2(a, b, c, d, e, 0 + i);
+ R2(e, a, b, c, d, 1 + i);
+ R2(d, e, a, b, c, 2 + i);
+ R2(c, d, e, a, b, 3 + i);
+ R2(b, c, d, e, a, 4 + i);
+ }
+ for (; i < 60; i += 5) {
+ R3(a, b, c, d, e, 0 + i);
+ R3(e, a, b, c, d, 1 + i);
+ R3(d, e, a, b, c, 2 + i);
+ R3(c, d, e, a, b, 3 + i);
+ R3(b, c, d, e, a, 4 + i);
+ }
+ for (; i < 80; i += 5) {
+ R4(a, b, c, d, e, 0 + i);
+ R4(e, a, b, c, d, 1 + i);
+ R4(d, e, a, b, c, 2 + i);
+ R4(c, d, e, a, b, 3 + i);
+ R4(b, c, d, e, a, 4 + i);
+ }
+
+ state[0] += a;
+ state[1] += b;
+ state[2] += c;
+ state[3] += d;
+ state[4] += e;
+}
+
+static void sha1_update(struct sha1_ctx *ctx, unsigned char *data, int len)
+{
+ unsigned int i, j;
+ j = ctx->count & 63;
+ ctx->count += len;
+
+ if ((j + len) > 63) {
+ i = 64 - j;
+ memcpy(&ctx->buf[j], data, i);
+ sha1_transform(ctx->state, ctx->buf);
+ for ( ; i + 63 < len; i += 64) {
+ sha1_transform(ctx->state, &data[i]);
+ }
+ j = 0;
+ } else
+ i = 0;
+ memcpy(&ctx->buf[j], &data[i], len - i);
+}
+
+static void sha1_finalize(struct sha1_ctx *ctx, sha1_digest *digest)
+{
+ int i;
+ unsigned long long finalcount = be64_to_cpu(ctx->count << 3);
+
+ sha1_update(ctx, (unsigned char *)"\200", 1);
+ while ((ctx->count & 63) != 56)
+ sha1_update(ctx, (unsigned char *) "", 1);
+
+ sha1_update(ctx, (unsigned char *) &finalcount, 8);
+ for (i = 0; i < 5; i++)
+ digest->digest[i] = be32_to_cpu(ctx->state[i]);
+}
+
+static inline void sha1_to_hex(sha1_digest *digest, char *out)
+{
+ char *p;
+ int i;
+ for (p = out, i = 0; i < 20; i++, p += 2)
+ snprintf(p, 3, "%02x", ((unsigned char *) digest->digest)[i]);
+}
+
+#define CAML_NAME_SPACE
+#include <caml/alloc.h>
+#include <caml/memory.h>
+#include <caml/signals.h>
+#include <caml/fail.h>
+
+#define GET_CTX_STRUCT(a) ((struct sha1_ctx *) a)
+
+CAMLprim value stub_sha1_init(value unit)
+{
+ CAMLparam1(unit);
+ CAMLlocal1(result);
+
+ result = caml_alloc(sizeof(struct sha1_ctx), Abstract_tag);
+ sha1_init(GET_CTX_STRUCT(result));
+
+ CAMLreturn(result);
+}
+
+CAMLprim value stub_sha1_update(value ctx, value data, value ofs, value len)
+{
+ CAMLparam4(ctx, data, ofs, len);
+ sha1_update(GET_CTX_STRUCT(ctx), (unsigned char *) data + Int_val(ofs),
+ Int_val(len));
+ CAMLreturn(Val_unit);
+}
+
+CAMLprim value stub_sha1_finalize(value ctx)
+{
+ CAMLparam1(ctx);
+ CAMLlocal1(t);
+
+ t = caml_alloc(sizeof(sha1_digest), Abstract_tag);
+ sha1_finalize(GET_CTX_STRUCT(ctx), (sha1_digest *) t);
+
+ CAMLreturn(t);
+}
+
+CAMLprim value stub_sha1_to_hex(value t)
+{
+ CAMLparam1(t);
+ CAMLlocal1(result);
+
+ result = caml_alloc_string(40);
+ sha1_to_hex((sha1_digest *) t, String_val(result));
+
+ CAMLreturn(result);
+}
+
+/*
+ * Local variables:
+ * indent-tabs-mode: t
+ * c-basic-offset: 8
+ * tab-width: 8
+ * End:
+ */
--- /dev/null
+(* Copyright (C) 2007 XenSource Ltd.
+ * Author Vincent Hanquez <vincent@xensource.com>
+ *)
+let channel chan len =
+ let ctx = Sha1.init ()
+ and buf = String.create 4096 in
+
+ let left = ref len and eof = ref false in
+ while (!left == -1 || !left > 0) && not !eof
+ do
+ let len = if !left < 0 then 4096 else (min !left 4096) in
+ let readed = Pervasives.input chan buf 0 len in
+ if readed = 0 then
+ eof := true
+ else (
+ Sha1.update ctx buf 0 readed;
+ if !left <> -1 then left := !left - readed
+ )
+ done;
+ if !left > 0 && !eof then
+ raise End_of_file;
+ Sha1.finalize ctx
+
+let _ =
+ let name = Sys.argv.(1) in
+ let chan = open_in_bin name in
+ let digest = channel chan (-1) in
+ close_in chan;
+ Printf.printf "%s\n" (Sha1.to_hex digest)
version = "@VERSION@"
description = "Stdext - Common stdlib extensions"
-requires = "unix,uuid,bigarray,rpc-light.json"
+requires = "unix,uuid"
archive(byte) = "stdext.cma"
archive(native) = "stdext.cmxa"
-IPROG=install -m 755 -o root -g root
CC = gcc
-OCAMLLOC := $(shell ocamlc -where)
-CFLAGS = -Wall -fPIC -O2 -I/opt/xensource/lib/ocaml -I$(OCAMLLOC)
+CFLAGS = -Wall -fPIC -O2 -I/opt/xensource/lib/ocaml
OCAMLC = ocamlc -g
OCAMLOPT = ocamlopt
LDFLAGS = -cclib -L./
-LIBEXEC = "/opt/xensource/libexec/"
+DESTDIR ?= /
VERSION := $(shell hg parents --template "{rev}" 2>/dev/null || echo 0.0)
OCAMLOPTFLAGS = -g -dtypes
-OCAMLABI := $(OCAMLLOC)
-OCAMLLIBDIR := $(OCAMLLOC)
+OCAMLABI := $(shell ocamlc -version)
+OCAMLLIBDIR := $(shell ocamlc -where)
OCAMLDESTDIR ?= $(OCAMLLIBDIR)
-FEPP = camlp4o -I ../rpc-light -I $(shell ocamlfind query type-conv) pa_type_conv.cmo pa_rpc.cma
-
OCAML_TEST_INC = -I $(shell ocamlfind query oUnit)
OCAML_TEST_LIB = $(shell ocamlfind query oUnit)/oUnit.cmxa
-STDEXT_OBJS = \
- fun \
- opt \
- listext \
- filenameext \
- stringext \
- arrayext \
- hashtblext \
- pervasiveext \
- threadext \
- int64ext \
- ring \
- qring \
- fring \
- bigbuffer \
- unixext \
- range \
- vIO \
- trie \
- config \
- date \
- encodings \
- fe \
- fecomms \
- forkhelpers \
- gzip \
- sha1sum \
- zerocheck \
- base64 \
- backtrace \
- tar \
- mapext \
- os \
- either \
- lazyList \
- extentlistSet \
- set_test
-
+STDEXT_OBJS = filenameext stringext arrayext hashtblext listext pervasiveext threadext ring qring fring opt unixext range bigbuffer vIO trie
INTF = $(foreach obj, $(STDEXT_OBJS),$(obj).cmi)
LIBS = stdext.cma stdext.cmxa
-PROGRAMS = base64pp fe_cli fe_test extentlistset_test
-
-DOCDIR = /myrepos/xen-api-libs.hg/doc
-
-all: $(INTF) $(LIBS)
+all: $(INTF) $(LIBS) $(PROGRAMS)
bins: $(PROGRAMS)
libs: $(LIBS)
-base64pp: base64_main.ml all libstdext_stubs.a
- ocamlfind $(OCAMLOPT) $(OCAMLOPTFLAGS) stdext.cmxa -linkpkg -o $@ $< -ccopt -L.
-
-fe_cli: fe_cli.ml all libstdext_stubs.a
- ocamlfind $(OCAMLOPT) $(OCAMLOPTFLAGS) unix.cmxa ../uuid/uuid.cmxa ../rpc-light/rpc.cmx ../rpc-light/jsonrpc.cmx stdext.cmxa -linkpkg -o $@ $< -ccopt -L.
-
-fe_test: fe_test.ml all libstdext_stubs.a
- ocamlfind $(OCAMLOPT) $(OCAMLOPTFLAGS) unix.cmxa ../uuid/uuid.cmxa ../rpc-light/rpc.cmx ../rpc-light/jsonrpc.cmx stdext.cmxa -linkpkg -I ../uuid -o $@ $< -ccopt -L.
-
-extentlistset_test: extentlistset_test.ml all libstdext_stubs.a
- ocamlfind $(OCAMLOPT) $(OCAMLOPTFLAGS) unix.cmxa stdext.cmxa -linkpkg -o $@ $< -ccopt -L.
-
stdext.cmxa: libstdext_stubs.a $(foreach obj,$(STDEXT_OBJS),$(obj).cmx)
$(OCAMLOPT) $(OCAMLOPTFLAGS) -a -o $@ -cclib -lstdext_stubs $(foreach obj,$(STDEXT_OBJS),$(obj).cmx)
stdext.cma: $(foreach obj,$(STDEXT_OBJS),$(obj).cmo)
$(OCAMLC) -a -dllib dllstdext_stubs.so -cclib -lstdext_stubs -o $@ $(foreach obj,$(STDEXT_OBJS),$(obj).cmo)
-stdext_stubs.a: unixext_stubs.o zerocheck_stub.o
+stdext_stubs.a: unixext_stubs.o
ocamlmklib -o stdext_stubs $+
-libstdext_stubs.a: unixext_stubs.o zerocheck_stub.o
+libstdext_stubs.a: unixext_stubs.o
ar rcs $@ $+
ocamlmklib -o stdext_stubs $+
#camlc unix.cma stdext.cma querycd.cmo -o querycd
## OBJS
-threadext.cmo: threadext.ml threadext.cmi
+threadext.cmo: threadext.ml
$(OCAMLC) -thread -c -o $@ $<
-fecomms.cmo : fecomms.ml
- $(OCAMLC) -I ../rpc-light -c -o $@ $<
-
-fe.cmo: fe.ml
- $(OCAMLC) -pp '$(FEPP)' -I ../jsonrpc -I ../rpc-light -c -o $@ $<
-
-forkhelpers.cmo: forkhelpers.ml forkhelpers.cmi
- $(OCAMLC) -thread -I ../uuid -c -o $@ $<
-
-filenameext.cmo: filenameext.ml filenameext.cmi
+%.cmo: %.ml
$(OCAMLC) -c -I ../uuid -o $@ $<
-%.cmo: %.ml %.cmi
- $(OCAMLC) -c -o $@ $<
-
threadext.cmi: threadext.mli
$(OCAMLC) -thread -c -o $@ $<
-forkhelpers.cmi: forkhelpers.mli
- $(OCAMLC) -thread -c -o $@ $<
-
-filenameext.cmi: filenameext.mli
- $(OCAMLC) -c -I ../uuid -o $@ $<
-
-fe.cmi: fe.cmo
- $(OCAMLC) -pp '$(FEPP)' -c -o $@ $<
-
%.cmi: %.mli
- $(OCAMLC) -c -o $@ $<
-
-fe.cmx: fe.ml
- $(OCAMLOPT) -pp '$(FEPP)' -I ../rpc-light -c -o $@ $<
+ $(OCAMLC) -c -I ../uuid -o $@ $<
-threadext.cmx: threadext.ml threadext.cmi
+threadext.cmx: threadext.ml
$(OCAMLOPT) $(OCAMLOPTFLAGS) -thread -c -o $@ $<
-fecomms.cmx : fecomms.ml
- $(OCAMLOPT) -I ../rpc-light -c -o $@ $<
-
-forkhelpers.cmx: forkhelpers.ml forkhelpers.cmi
- $(OCAMLOPT) $(OCAMLOPTFLAGS) -I ../uuid -thread -c -o $@ $<
-
-filenameext.cmx: filenameext.ml filenameext.cmi
- $(OCAMLOPT) $(OCAMLOPTFLAGS) -thread -c -I ../uuid -o $@ $<
-
-%.cmx: %.ml %.cmi
+%.cmx: %.ml
$(OCAMLOPT) $(OCAMLOPTFLAGS) -I ../uuid -c -o $@ $<
%.o: %.c
sed 's/@VERSION@/$(VERSION)/g' < $< > $@
.PHONY: install
-install: path = $(DESTDIR)$(shell ocamlfind printconf destdir)
install: $(LIBS) META
- mkdir -p $(path)
- ocamlfind install -destdir $(path) -ldconf ignore stdext META $(INTF) $(LIBS) *.a *.so *.cmx
-
-.PHONY: bininstall
-bininstall: path = $(DESTDIR)$(LIBEXEC)
-bininstall: all
- mkdir -p $(path)
- $(IPROG) $(PROGRAMS) $(path)
+ ocamlfind install -destdir $(DESTDIR)$(shell ocamlfind printconf destdir) -ldconf ignore stdext META $(INTF) $(LIBS) *.a *.so *.cmx
.PHONY: uninstall
uninstall:
ocamlfind remove stdext
-.PHONY: binuninstall
-binuninstall:
- rm -f $(DESTDIR)$(LIBEXEC)$(PROGRAMS)
-
-.PHONY: doc
-doc: $(INTF)
- python ../doc/doc.py $(DOCDIR) "stdext" "package" "$(STDEXT_OBJS)" "." "threads,uuid,unix" ""
-
clean:
rm -f *.o *.so *.a *.cmo *.cmi *.cma *.cmx *.cmxa *.annot $(LIBS) $(PROGRAMS)
#dependency:
-unixext.cmi: filenameext.cmi
-gzip.cmi: forkhelpers.cmi
-sha1sum.cmi: forkhelpers.cmi
-tar.cmi: bigbuffer.cmi
+unixext.cmo : filenameext.ml
+unixext.cmx : filenameext.ml
-(*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
- *)
module Array = struct include Array
(* Useful for vector addition. *)
-(*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
- *)
module Array :
sig
external length : 'a array -> int = "%array_length"
(*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
+ * Copyright (C) 2007 XenSource Ltd.
+ * Author Vincent Hanquez <vincent@xensource.com>
*)
type t = {
let length bigbuf = bigbuf.index
-let get bigbuf n =
- let array_offset = Int64.to_int (Int64.div n (Int64.of_int cell_size)) in
- let cell_offset = Int64.to_int (Int64.rem n (Int64.of_int cell_size)) in
- match bigbuf.cells.(array_offset) with
- | None -> "".[0]
- | Some buf -> buf.[cell_offset]
-
let rec append_substring bigbuf s offset len =
let array_offset = Int64.to_int (Int64.div bigbuf.index (Int64.of_int cell_size)) in
let cell_offset = Int64.to_int (Int64.rem bigbuf.index (Int64.of_int cell_size)) in
);
()
-let append_string b s = append_substring b s 0 (String.length s)
-
let to_fct bigbuf f =
let array_offset = Int64.to_int (Int64.div bigbuf.index (Int64.of_int cell_size)) in
let cell_offset = Int64.to_int (Int64.rem bigbuf.index (Int64.of_int cell_size)) in
for i = 0 to array_offset - 1
do
match bigbuf.cells.(i) with
- | None -> (* should never happen *) ()
+ | None -> (* ?!?!? *) ()
| Some cell -> f cell
done;
- if(cell_offset > 0) then
- (* copy last cell *)
- begin match bigbuf.cells.(array_offset) with
- | None -> (* Should never happen (any more) *) ()
- | Some cell -> f (String.sub cell 0 cell_offset)
- end
-
+ (* copy last cell *)
+ begin match bigbuf.cells.(array_offset) with
+ | None -> (* ?!?!?! *) ()
+ | Some cell -> f (String.sub cell 0 cell_offset)
+ end;
+ ()
let to_string bigbuf =
if bigbuf.index > (Int64.of_int Sys.max_string_length) then
);
dest
-
-let test max =
- let rec inner n =
- if n>max then () else begin
- let bb = make () in
- let s = String.create n in
- append_substring bb s 0 n;
- assert ((to_string bb)=s);
- inner (n+1)
- end
- in
- inner 0
-
let to_stream bigbuf outchan =
to_fct bigbuf (fun s -> output_string outchan s)
-(*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
- *)
type t
val make : unit -> t
val length : t -> int64
-val get : t -> int64 -> char
val append_substring : t -> string -> int -> int -> unit
-
-(** [append_string b s] appends the string [x] to the big buffer [b] *)
-val append_string : t -> string -> unit
-
val to_fct : t -> (string -> unit) -> unit
val to_string : t -> string
val to_stream : t -> out_channel -> unit
-(*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
- *)
(** Makes a new file in the same directory as 'otherfile' *)
let temp_file_in_dir otherfile =
-(*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
- *)
val temp_file_in_dir : string -> string
(*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
+ * Copyright (c) 2006-2008 Citrix Systems Ltd.
+ * Authors Vincent Hanquez <vincent@xensource.com>
+ * Thomas Gazagnaire <thomas.gazagnaire@citrix.com>
+ * All rights reserved.
*)
type t = { size: int; mutable current: int; data: (float,Bigarray.float32_elt, Bigarray.c_layout) Bigarray.Array1.t ; }
+(** create a ring structure with @size record. records inited to @initval *)
let make size init =
let ring =
{ size = size; current = size - 1; data = Bigarray.Array1.create Bigarray.float32 Bigarray.c_layout size; }
done;
ring
+(** length of the ring *)
let length ring = ring.size
+(** push into the ring one element *)
let push ring e =
ring.current <- ring.current + 1;
if ring.current = ring.size then
ring.current <- 0;
Bigarray.Array1.set ring.data ring.current e
+(** get the @ith old element from the ring *)
let peek ring i =
if i >= ring.size then
raise (Invalid_argument "peek: index");
if offset >= 0 then offset else ring.size + offset in
Bigarray.Array1.get ring.data index
+(** get the top element of the ring *)
let top ring = Bigarray.Array1.get ring.data ring.current
+(** iterate over nb element of the ring, starting from the top *)
let iter_nb ring f nb =
if nb > ring.size then
raise (Invalid_argument "iter_nb: nb");
f (peek ring i)
done
-(* iter directly on all element without using the index *)
+(** iter directly on all element without using the index *)
let iter f a =
for i=0 to Bigarray.Array1.dim a - 1 do
f (Bigarray.Array1.get a i)
let raw_iter ring f =
iter f ring.data
+(** iterate over all element of the ring, starting from the top *)
let iter ring f = iter_nb ring f (ring.size)
+(** get array of latest #nb value *)
let get_nb ring nb =
if nb > ring.size then
raise (Invalid_argument "get_nb: nb");
a
let get ring = get_nb ring (ring.size)
-
-(*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
- *)
-(** Ring structures *)
-
type t = {
size : int;
mutable current : int;
data : (float, Bigarray.float32_elt, Bigarray.c_layout) Bigarray.Array1.t;
}
-
-(** create a ring structure with [size] record; records initialised to [init] *)
val make : int -> float -> t
-
-(** length of the ring *)
val length : t -> int
-
-(** push into the ring one element *)
val push : t -> float -> unit
-
-(** get the i{^th} old element from the ring *)
val peek : t -> int -> float
-
-(** get the top element of the ring *)
val top : t -> float
-
-(** iterate over nb element of the ring, starting from the top *)
val iter_nb : t -> (float -> 'a) -> int -> unit
-
val raw_iter : t -> (float -> 'a) -> unit
-
-(** iterate over all elements of the ring, starting from the top *)
val iter : t -> (float -> 'a) -> unit
-
-(** get array of latest [nb] value *)
val get_nb : t -> int -> float array
-
val get : t -> float array
-(*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
- *)
module Hashtbl = struct include Hashtbl
let to_list tbl =
-(*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
- *)
module Hashtbl :
sig
type ('a, 'b) t = ('a, 'b) Hashtbl.t
-(*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
- *)
-open Fun
module List = struct include List
(** Turn a list into a set *)
let set_equiv s1 s2 = (subset s1 s2) && (subset s2 s1)
let iteri f list = ignore (fold_left (fun i x -> f i x; i+1) 0 list)
-let iteri_right f list = ignore (fold_right (fun x i -> f i x; i+1) list 0)
let rec inv_assoc k = function
| [] -> raise Not_found
let inner fold_left2 base f l1 l2 g =
fold_left2 (fun accu e1 e2 -> g accu (f e1 e2)) base l1 l2
-let rec is_sorted compare list =
+let filter_map f list =
+ List.fold_right
+ begin
+ fun element list -> match (f element) with
+ | Some x -> x :: list
+ | None -> list
+ end
+ list []
+
+let rec is_sorted compare list =
match list with
- | x :: y :: list ->
+ | x :: y :: list ->
if compare x y <= 0
then is_sorted compare (y :: list)
else false
let assoc_default k l d =
if List.mem_assoc k l then List.assoc k l else d
-
-let map_assoc_with_key op al =
- List.map (fun (k, v1) -> (k, op k v1)) al
-
-(* Like the Lisp cons *)
-let cons a b = a :: b
-
-(* Could use fold_left to get the same value, but that would necessarily go through the whole list everytime, instead of the first n items, only. *)
-(* ToDo: This is complicated enough to warrant a test. *)
-(* Is it wise to fail silently on negative values? (They are treated as zero, here.)
- Pro: Would mask fewer bugs.
- Con: Less robust.
-*)
-let take n list =
- let rec helper i acc list =
- if i <= 0 || list = []
- then acc
- else helper (i-1) (List.hd list :: acc) (List.tl list)
- in List.rev $ helper n [] list
-
-(* Thanks to sharing we only use linear space. (Roughly double the space needed for the spine of the original list) *)
-let rec tails = function
- | [] -> [[]]
- | (_::xs) as l -> l :: tails xs
-
-let safe_hd = function
- | a::_ -> Some a
- | [] -> None
-
-let rec replace_assoc key new_value = function
- | [] -> []
- | (k, _) as p :: tl ->
- if k = key then
- (key, new_value) :: tl
- else
- p :: replace_assoc key new_value tl
-
-let make_assoc op l = map (fun key -> key, op key) l
-
-let unbox_list a = List.map Opt.unbox (List.filter Opt.is_boxed a)
-
-let filter_map f list =
- (unbox_list +++ map) f list
-
-let restrict_with_default default keys al =
- make_assoc (fun k -> assoc_default k al default) keys
-
end
-(*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
- *)
module List :
-sig
- val setify : 'a list -> 'a list
- val subset : 'a list -> 'a list -> bool
- val set_equiv : 'a list -> 'a list -> bool
- val length : 'a list -> int
- val hd : 'a list -> 'a
- val tl : 'a list -> 'a list
- val nth : 'a list -> int -> 'a
- val rev : 'a list -> 'a list
- val append : 'a list -> 'a list -> 'a list
- val rev_append : 'a list -> 'a list -> 'a list
- val concat : 'a list list -> 'a list
- val flatten : 'a list list -> 'a list
- val iter : ('a -> unit) -> 'a list -> unit
- val map : ('a -> 'b) -> 'a list -> 'b list
- val rev_map : ('a -> 'b) -> 'a list -> 'b list
- val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a
- val fold_right : ('a -> 'b -> 'b) -> 'a list -> 'b -> 'b
- val iter2 : ('a -> 'b -> unit) -> 'a list -> 'b list -> unit
- val map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list
- val rev_map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list
- val fold_left2 : ('a -> 'b -> 'c -> 'a) -> 'a -> 'b list -> 'c list -> 'a
- val fold_right2 :
- ('a -> 'b -> 'c -> 'c) -> 'a list -> 'b list -> 'c -> 'c
- val for_all : ('a -> bool) -> 'a list -> bool
- val exists : ('a -> bool) -> 'a list -> bool
- val for_all2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool
- val exists2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool
- val mem : 'a -> 'a list -> bool
- val memq : 'a -> 'a list -> bool
- val find : ('a -> bool) -> 'a list -> 'a
- val filter : ('a -> bool) -> 'a list -> 'a list
- val find_all : ('a -> bool) -> 'a list -> 'a list
- val partition : ('a -> bool) -> 'a list -> 'a list * 'a list
- val assoc : 'a -> ('a * 'b) list -> 'b
- val assq : 'a -> ('a * 'b) list -> 'b
- val mem_assoc : 'a -> ('a * 'b) list -> bool
- val mem_assq : 'a -> ('a * 'b) list -> bool
- val remove_assoc : 'a -> ('a * 'b) list -> ('a * 'b) list
- val remove_assq : 'a -> ('a * 'b) list -> ('a * 'b) list
- val split : ('a * 'b) list -> 'a list * 'b list
- val combine : 'a list -> 'b list -> ('a * 'b) list
- val sort : ('a -> 'a -> int) -> 'a list -> 'a list
- val stable_sort : ('a -> 'a -> int) -> 'a list -> 'a list
- val fast_sort : ('a -> 'a -> int) -> 'a list -> 'a list
- val merge : ('a -> 'a -> int) -> 'a list -> 'a list -> 'a list
-
- (** Perform a lookup on an association list of (value, key) pairs. *)
- val inv_assoc : 'a -> ('b * 'a) list -> 'b
-
- (** A tail-recursive map. *)
- val map_tr : ('a -> 'b) -> 'a list -> 'b list
-
- (** Count the number of list elements matching the given predicate. *)
- val count : ('a -> bool) -> 'a list -> int
-
- (** Find the indices of all elements matching the given predicate. *)
- val position : ('a -> bool) -> 'a list -> int list
-
- (** Map the given function over a list, supplying the integer
- index as well as the element value. *)
- val mapi : (int -> 'a -> 'b) -> 'a list -> 'b list
-
- val iteri : (int -> 'a -> unit) -> 'a list -> unit
-
- val iteri_right : (int -> 'a -> unit) -> 'a list -> unit
-
- (** Map the given function over a list in reverse order. *)
- val rev_mapi : (int -> 'a -> 'b) -> 'a list -> 'b list
-
- (** Tail-recursive [mapi]. *)
- val mapi_tr : (int -> 'a -> 'b) -> 'a list -> 'b list
-
- (** Split a list at the given index to give a pair of lists. *)
- val chop : int -> 'a list -> 'a list * 'a list
-
- (** Split a list at the given index to give a pair of lists, the first in
- reverse order. *)
- val rev_chop : int -> 'a list -> 'a list * 'a list
-
- (** Tail-recursive [chop]. *)
- val chop_tr : int -> 'a list -> 'a list * 'a list
-
- (** Split a list into lists with the given number of elements. *)
- val dice : int -> 'a list -> 'a list list
-
- (** Extract the sub-list between the given indices. *)
- val sub : int -> int -> 'a list -> 'a list
-
- (** Remove the element at the given index. *)
- val remove : int -> 'a list -> 'a list
-
- (** Extract the element at the given index, returning the element and the
- list without that element. *)
- val extract : int -> 'a list -> 'a * 'a list
-
- (** Insert the given element at the given index. *)
- val insert : int -> 'a -> 'a list -> 'a list
-
- (** Replace the element at the given index with the given value. *)
- val replace : int -> 'a -> 'a list -> 'a list
-
- (** Apply the given function to the element at the given index. *)
- val morph : int -> ('a -> 'a) -> 'a list -> 'a list
-
- (** Insert the element [e] between every pair of adjacent elements in the
- given list. *)
- val between : 'a -> 'a list -> 'a list
-
- (** Tail-recursive [between]. *)
- val between_tr : 'a -> 'a list -> 'a list
-
- (** Generate a random permutation of the given list. *)
- val randomize : 'a list -> 'a list
-
- (** Distribute the given element over the given list, returning a list of
- lists with the new element in each position. *)
- val distribute : 'a -> 'a list -> 'a list list
-
- (** Generate all permutations of the given list. *)
- val permute : 'a list -> 'a list list
-
- (** Run-length encode the given list using the given equality function. *)
- val rle_eq : ('a -> 'a -> bool) -> 'a list -> ('a * int) list
+ sig
+ val setify : 'a list -> 'a list
+ val subset : 'a list -> 'a list -> bool
+ val set_equiv : 'a list -> 'a list -> bool
+ val length : 'a list -> int
+ val hd : 'a list -> 'a
+ val tl : 'a list -> 'a list
+ val nth : 'a list -> int -> 'a
+ val rev : 'a list -> 'a list
+ val append : 'a list -> 'a list -> 'a list
+ val rev_append : 'a list -> 'a list -> 'a list
+ val concat : 'a list list -> 'a list
+ val flatten : 'a list list -> 'a list
+ val iter : ('a -> unit) -> 'a list -> unit
+ val map : ('a -> 'b) -> 'a list -> 'b list
+ val rev_map : ('a -> 'b) -> 'a list -> 'b list
+ val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a
+ val fold_right : ('a -> 'b -> 'b) -> 'a list -> 'b -> 'b
+ val iter2 : ('a -> 'b -> unit) -> 'a list -> 'b list -> unit
+ val map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list
+ val rev_map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list
+ val fold_left2 : ('a -> 'b -> 'c -> 'a) -> 'a -> 'b list -> 'c list -> 'a
+ val fold_right2 :
+ ('a -> 'b -> 'c -> 'c) -> 'a list -> 'b list -> 'c -> 'c
+ val for_all : ('a -> bool) -> 'a list -> bool
+ val exists : ('a -> bool) -> 'a list -> bool
+ val for_all2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool
+ val exists2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool
+ val mem : 'a -> 'a list -> bool
+ val memq : 'a -> 'a list -> bool
+ val find : ('a -> bool) -> 'a list -> 'a
+ val filter : ('a -> bool) -> 'a list -> 'a list
+ val find_all : ('a -> bool) -> 'a list -> 'a list
+ val partition : ('a -> bool) -> 'a list -> 'a list * 'a list
+ val assoc : 'a -> ('a * 'b) list -> 'b
+ val assq : 'a -> ('a * 'b) list -> 'b
+ val mem_assoc : 'a -> ('a * 'b) list -> bool
+ val mem_assq : 'a -> ('a * 'b) list -> bool
+ val remove_assoc : 'a -> ('a * 'b) list -> ('a * 'b) list
+ val remove_assq : 'a -> ('a * 'b) list -> ('a * 'b) list
+ val split : ('a * 'b) list -> 'a list * 'b list
+ val combine : 'a list -> 'b list -> ('a * 'b) list
+ val sort : ('a -> 'a -> int) -> 'a list -> 'a list
+ val stable_sort : ('a -> 'a -> int) -> 'a list -> 'a list
+ val fast_sort : ('a -> 'a -> int) -> 'a list -> 'a list
+ val merge : ('a -> 'a -> int) -> 'a list -> 'a list -> 'a list
+
+ (** Perform a lookup on an association list of (value, key) pairs. *)
+ val inv_assoc : 'a -> ('b * 'a) list -> 'b
+
+ (** A tail-recursive map. *)
+ val map_tr : ('a -> 'b) -> 'a list -> 'b list
+
+ (** Count the number of list elements matching the given predicate. *)
+ val count : ('a -> bool) -> 'a list -> int
+
+ (** Find the indices of all elements matching the given predicate. *)
+ val position : ('a -> bool) -> 'a list -> int list
+
+ (** Map the given function over a list, supplying the integer index as well
+ as the element value. *)
+ val mapi : (int -> 'a -> 'b) -> 'a list -> 'b list
+
+ val iteri : (int -> 'a -> unit) -> 'a list -> unit
+
+ (** Map the given function over a list in reverse order. *)
+ val rev_mapi : (int -> 'a -> 'b) -> 'a list -> 'b list
+
+ (** Tail-recursive [mapi]. *)
+ val mapi_tr : (int -> 'a -> 'b) -> 'a list -> 'b list
+
+ (** Split a list at the given index to give a pair of lists. *)
+ val chop : int -> 'a list -> 'a list * 'a list
+
+ (** Split a list at the given index to give a pair of lists, the first in
+ reverse order. *)
+ val rev_chop : int -> 'a list -> 'a list * 'a list
+
+ (** Tail-recursive [chop]. *)
+ val chop_tr : int -> 'a list -> 'a list * 'a list
+
+ (** Split a list into lists with the given number of elements. *)
+ val dice : int -> 'a list -> 'a list list
+
+ (** Extract the sub-list between the given indices. *)
+ val sub : int -> int -> 'a list -> 'a list
+
+ (** Remove the element at the given index. *)
+ val remove : int -> 'a list -> 'a list
+
+ (** Extract the element at the given index, returning the element and the
+ list without that element. *)
+ val extract : int -> 'a list -> 'a * 'a list
+
+ (** Insert the given element at the given index. *)
+ val insert : int -> 'a -> 'a list -> 'a list
+
+ (** Replace the element at the given index with the given value. *)
+ val replace : int -> 'a -> 'a list -> 'a list
+
+ (** Apply the given function to the element at the given index. *)
+ val morph : int -> ('a -> 'a) -> 'a list -> 'a list
+
+ (** Insert the element [e] between every pair of adjacent elements in the
+ given list. *)
+ val between : 'a -> 'a list -> 'a list
+
+ (** Tail-recursive [between]. *)
+ val between_tr : 'a -> 'a list -> 'a list
+
+ (** Generate a random permutation of the given list. *)
+ val randomize : 'a list -> 'a list
+
+ (** Distribute the given element over the given list, returning a list of
+ lists with the new element in each position. *)
+ val distribute : 'a -> 'a list -> 'a list list
+
+ (** Generate all permutations of the given list. *)
+ val permute : 'a list -> 'a list list
+
+ (** Run-length encode the given list using the given equality function. *)
+ val rle_eq : ('a -> 'a -> bool) -> 'a list -> ('a * int) list
+
+ (** Run-length encode the given list using built-in equality. *)
+ val rle : 'a list -> ('a * int) list
+
+ (** Decode a run-length encoded list. *)
+ val unrle : (int * 'a) list -> 'a list
- (** Run-length encode the given list using built-in equality. *)
- val rle : 'a list -> ('a * int) list
-
- (** Decode a run-length encoded list. *)
- val unrle : (int * 'a) list -> 'a list
-
- (** Compute the inner product of two lists. *)
- val inner :
- (('a -> 'b -> 'c -> 'd) -> 'e -> 'f -> 'g -> 'h) ->
- 'e -> ('b -> 'c -> 'i) -> 'f -> 'g -> ('a -> 'i -> 'd) -> 'h
-
- (** Applies a function f that generates optional values, to each
- of the items in a list A [a1; ...; am], generating a new list of
- non-optional values B [b1; ...; bn], with m >= n. For each value
- a in list A, list B contains a corresponding value b if and only
- if the application of (f a) results in Some b. *)
+ (** Compute the inner product of two lists. *)
+ val inner :
+ (('a -> 'b -> 'c -> 'd) -> 'e -> 'f -> 'g -> 'h) ->
+ 'e -> ('b -> 'c -> 'i) -> 'f -> 'g -> ('a -> 'i -> 'd) -> 'h
+
+ (** Applies a function f that generates optional values, to each
+ of the items in a list A [a1; ...; am], generating a new list
+ of non-optional values B [b1; ...; bn], with m >= n. For each
+ value a in list A, list B contains a corresponding value b if
+ and only if the application of (f a) results in Some b. *)
val filter_map : ('a -> 'b option) -> 'a list -> 'b list
(** Returns true if and only if the given list is in sorted order
- according to the given comparison function. *)
+ according to the given comparison function. *)
val is_sorted : ('a -> 'a -> int) -> 'a list -> bool
(** Returns the intersection of two lists. *)
(** Returns the set difference of two lists *)
val set_difference : 'a list -> 'a list -> 'a list
- (** Act as List.assoc, but return the given default value if the
- key is not in the list. *)
- val assoc_default : 'a -> ('a * 'b) list -> 'b -> 'b
-
- (** [map_assoc_with_key op al] transforms every value in [al] based on the
- key and the value using [op]. *)
- val map_assoc_with_key : ('k -> 'v1 -> 'v2) -> ('k * 'v1) list -> ('k * 'v2) list
-
- (* Like Lisp cons*)
- val cons : 'a -> 'a list -> 'a list
-
- (** [take n list] returns the first [n] elements of [list] (or less if list
- is shorter).*)
- val take : int -> 'a list -> 'a list
-
- val tails : 'a list -> ('a list) list
- val safe_hd : 'a list -> 'a option
-
- (** Replace the value belonging to a key in an association list. *)
- val replace_assoc : 'a -> 'b -> ('a * 'b) list -> ('a * 'b) list
-
- val make_assoc : ('a -> 'b) -> 'a list -> ('a * 'b) list
-
- (** Unbox all values from the option list. *)
- val unbox_list : 'a option list -> 'a list
+ (** Act as List.assoc, but return the given default value if the key
+ is not in the list. *)
+ val assoc_default : 'a -> ('a * 'b) list -> 'b -> 'b
- (** [restrict_with_default default keys al] makes a new association map
- from [keys] to previous values for [keys] in [al]. If a key is not found
- in [al], the [default] is used. *)
- val restrict_with_default : 'v -> 'k list -> ('k * 'v) list -> ('k * 'v) list
-end
+ end
-(*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
- *)
-
-(* Perhaps it's better to use `option' from the ocaml-extlib extension
- * to the standard library instead? (Although it would not suffice,
- * since it's not a super-set of our `opt'.)
- * (http://code.google.com/p/ocaml-extlib/)
- *)
-
-open Pervasiveext
-
let iter f = function
| Some x -> f x
| None -> ()
match opt with
| Some x -> f x accu
| None -> accu
-
-let join = function
- | Some (Some a) -> Some a
- | _ -> None
-
-(*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
- *)
val iter : ('a -> unit) -> 'a option -> unit
val map : ('a -> 'b) -> 'a option -> 'b option
val default : 'a -> 'a option -> 'a
val to_list : 'a option -> 'a list
val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b option -> 'a
val fold_right : ('a -> 'b -> 'b) -> 'a option -> 'b -> 'b
-val join : ('a option) option -> 'a option
-(*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
- *)
(** apply the clean_f function after fct function has been called.
* Even if fct raises an exception, clean_f is applied
*)
clean_f ();
result
-(* Those should go into the Opt module: *)
-
let maybe_with_default d f v =
match v with None -> d | Some x -> f x
let ignore_string v = let (_: string) = v in ()
let ignore_float v = let (_: float) = v in ()
let ignore_bool v = let (_: bool) = v in ()
-
-(* To avoid some parens: *)
-(* composition of functions: *)
-let (++) f g x = Fun.comp f g x
-
-(* and application *)
-let ($) f a = f a
-(*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
- *)
val exnhook : (exn -> unit) option ref
val finally : (unit -> 'a) -> (unit -> 'b) -> 'a
val maybe_with_default : 'b -> ('a -> 'b) -> 'a option -> 'b
val ignore_string : string -> unit
val ignore_float : float -> unit
val ignore_bool : bool -> unit
-
-val (++) : ('b -> 'c) -> ('a -> 'b) -> ('a -> 'c)
-val ($) : ('a -> 'b) -> 'a -> 'b
(*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
+ * Copyright 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
*
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
+ * efficient circular string queue
*)
type t = {
sz: int;
-(*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
- *)
type t = {
sz: int;
data: string;
-(*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
- *)
type t = { l : int; u : int }
let make l u =
-(*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
- *)
type t
(** Make a range. *)
(*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
+ * Copyright (c) 2006 XenSource Ltd.
+ * Author Vincent Hanquez <vincent@xensource.com>
*
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
+ * All rights reserved.
*)
type 'a t = { size: int; mutable current: int; data: 'a array; }
-(** create a ring structure with size record. records inited to initval *)
+(** create a ring structure with @size record. records inited to @initval *)
let make size initval =
{ size = size; current = size - 1; data = Array.create size initval; }
ring.current <- 0;
ring.data.(ring.current) <- e
-(** get the ith old element from the ring *)
+(** get the @ith old element from the ring *)
let peek ring i =
if i >= ring.size then
raise (Invalid_argument "peek: index");
(** iterate over all element of the ring, starting from the top *)
let iter ring f = iter_nb ring f (ring.size)
-(** get array of latest nb value *)
+(** get array of latest #nb value *)
let get_nb ring nb =
if nb > ring.size then
raise (Invalid_argument "get_nb: nb");
-(*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
- *)
type 'a t = { size : int; mutable current : int; data : 'a array; }
val make : int -> 'a -> 'a t
val length : 'a t -> int
-(*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
- *)
module String = struct include String
let of_char c = String.make 1 c
concat "" (fold_right aux string [])
(** Take a predicate and a string, return a list of strings separated by
-runs of characters where the predicate was true (excluding those characters from the result) *)
+runs of characters where the predicate was true *)
let split_f p str =
let not_p = fun x -> not (p x) in
let rec split_one p acc = function
-(*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
- *)
module String :
sig
external length : string -> int = "%string_length"
- (** blabla *)
external get : string -> int -> char = "%string_safe_get"
external set : string -> int -> char -> unit = "%string_safe_set"
external create : int -> string = "caml_create_string"
(** find all occurences of needle in haystack and return all their respective index *)
val find_all : string -> string -> int list
- (** replace all [f] substring in [s] by [t] *)
+ (** replace all @f substring in @s by @t *)
val replace : string -> string -> string -> string
(** filter chars from a string *)
(*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
+ * Copyright (C) 2006 XenSource Ltd.
+ * Author: Vincent Hanquez <vincent@xensource.com>
+ * Author: Anil Madhavapeddy <anil@xensource.com>
*)
module Mutex = struct
| None -> x.signalled <- true (* If the wait hasn't happened yet then store up the signal *)
)
end
-
-let keep_alive () =
- while true do
- Thread.delay 20000.
- done
-
-(*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
- *)
module Mutex :
sig
type t = Mutex.t
(** Sends a signal to a waiting thread. See 'wait' *)
val signal : t -> unit
end
-
-(** Keeps a thread alive without doing anything. Used e.g. in XML/RPC daemons. *)
-val keep_alive: unit -> unit
-
-(*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
- *)
module Node =
struct
type ('a,'b) t = {
-(*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
- *)
(** Basic Implementation of polymorphic tries (ie. prefix trees) *)
type ('a, 'b) t
-(*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
- *)
open Pervasiveext
exception Unix_error of int
end
| _ -> exit 0
-let file_lines_fold f start file_path =
- let input = open_in file_path in
- let rec fold accumulator =
- let line =
- try Some (input_line input)
- with End_of_file -> None in
- match line with
- | Some line -> fold (f accumulator line)
- | None -> accumulator in
- finally
- (fun () -> fold start)
- (fun () -> close_in input)
-
-let file_lines_iter f file_path =
- let input = open_in file_path in
+(** Run a function over every line in a file *)
+let readfile_line fn fname =
+ let fin = open_in fname in
try
while true do
- let line = input_line input in
- f line
- done
+ let line = input_line fin in
+ fn line
+ done;
+ close_in fin;
with
- | End_of_file -> close_in input
- | exn -> close_in input; raise exn
-
-let readfile_line = file_lines_iter
+ | End_of_file -> close_in fin
+ | exn -> close_in fin; raise exn
(** open a file, and make sure the close is always done *)
let with_file file mode perms f =
(** Opens a temp file, applies the fd to the function, when the function completes, renames the file
as required. *)
-let atomic_write_to_file fname perms f =
+let atomic_write_to_file fname f =
let tmp = Filenameext.temp_file_in_dir fname in
- Unix.chmod tmp perms;
Pervasiveext.finally
(fun () ->
- let fd = Unix.openfile tmp [Unix.O_WRONLY; Unix.O_CREAT] perms (* ignored since the file exists *) in
+ let fd = Unix.openfile tmp [Unix.O_WRONLY; Unix.O_CREAT] 0o644 in
let result = Pervasiveext.finally
(fun () -> f fd)
(fun () -> Unix.close fd) in
(** Atomically write a string to a file *)
let write_string_to_file fname s =
- atomic_write_to_file fname 0o644 (fun fd ->
+ atomic_write_to_file fname (fun fd ->
let len = String.length s in
let written = Unix.write fd s 0 len in
if written <> len then (failwith "Short write occured!"))
let num64 = Int64.of_int num in
limit := Opt.map (fun x -> Int64.sub x num64) !limit;
- ignore_int (Unix.write ofd buffer 0 num);
+ Unix.write ofd buffer 0 num;
total_bytes := Int64.add !total_bytes num64;
finished := num = 0 || !limit = Some 0L;
done;
really_read fd buf 0 length;
buf
-let really_read_bigbuffer fd bigbuf n =
- let chunk = 4096 in
- let s = String.make chunk '\000' in
- let written = ref 0L in
- while !written < n do
- let remaining = Int64.sub n !written in
- let to_write = min remaining (Int64.of_int chunk) in
- really_read fd s 0 (Int64.to_int to_write);
- Bigbuffer.append_substring bigbuf s 0 (Int64.to_int to_write);
- written := Int64.add !written to_write;
- done
-
let really_write fd string off n =
let written = ref 0 in
while !written < n
external set_tcp_nodelay : Unix.file_descr -> bool -> unit = "stub_unixext_set_tcp_nodelay"
external fsync : Unix.file_descr -> unit = "stub_unixext_fsync"
-external blkgetsize64 : Unix.file_descr -> int64 = "stub_unixext_blkgetsize64"
external get_max_fd : unit -> int = "stub_unixext_get_max_fd"
if not(List.mem i fds') then close' i
done
+exception Process_output_error of string
+let get_process_output ?(handler) cmd : string =
+ let inchan = Unix.open_process_in cmd in
+
+ let buffer = Buffer.create 1024
+ and buf = String.make 1024 '\000' in
+
+ let rec read_until_eof () =
+ let rd = input inchan buf 0 1024 in
+ if rd = 0 then
+ ()
+ else (
+ Buffer.add_substring buffer buf 0 rd;
+ read_until_eof ()
+ ) in
+ (* Make sure an exception doesn't prevent us from waiting for the child process *)
+ (try read_until_eof () with _ -> ());
+ match (Unix.close_process_in inchan), handler with
+ | Unix.WEXITED 0, _ -> Buffer.contents buffer
+ | Unix.WEXITED n, Some handler -> handler cmd n
+ | _ -> raise (Process_output_error cmd)
(** Remove "." and ".." from paths (NB doesn't attempt to resolve symlinks) *)
let resolve_dot_and_dotdot (path: string) : string =
(* 'seek' to the current position, exploiting the return value from Unix.lseek as the new cursor position *)
Unix.lseek fd 0 Unix.SEEK_CUR
+type statfs_t = {
+ statfs_type: int64;
+ statfs_bsize: int;
+ statfs_blocks: int64;
+ statfs_bfree: int64;
+ statfs_bavail: int64;
+ statfs_files: int64;
+ statfs_ffree: int64;
+ statfs_namelen: int;
+}
+
+external statfs: string -> statfs_t = "stub_unixext_statfs"
+
module Fdset = struct
type t
external of_list : Unix.file_descr list -> t = "stub_fdset_of_list"
let select_wo w t = _select_wo w t
end
-let wait_for_path path delay timeout =
- let rec inner ttl =
- if ttl=0 then failwith "No path!";
- try
- ignore(Unix.stat path)
- with _ ->
- delay 0.5;
- inner (ttl - 1)
- in
- inner (timeout * 2)
-
-
let _ = Callback.register_exception "unixext.unix_error" (Unix_error (0))
(* HTTP helpers *)
let http_get = Http.get
let http_put = Http.put
-
-external send_fd : Unix.file_descr -> string -> int -> int -> Unix.msg_flag list -> Unix.file_descr -> int = "stub_unix_send_fd_bytecode" "stub_unix_send_fd"
-external recv_fd : Unix.file_descr -> string -> int -> int -> Unix.msg_flag list -> int * Unix.sockaddr * Unix.file_descr = "stub_unix_recv_fd"
-(*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
- *)
-(** A collection of extensions to the [Unix] module. *)
-
external _exit : int -> unit = "unix_exit"
val unlink_safe : string -> unit
val mkdir_safe : string -> Unix.file_perm -> unit
val daemonize : unit -> unit
val with_file : string -> Unix.open_flag list -> Unix.file_perm -> (Unix.file_descr -> 'a) -> 'a
val with_directory : string -> (Unix.dir_handle -> 'a) -> 'a
-
-(** Folds function [f] over every line in the file at [file_path] using the
-starting value [start]. *)
-val file_lines_fold : ('a -> string -> 'a) -> 'a -> string -> 'a
-
-(** Applies function [f] to every line in the file at [file_path]. *)
-val file_lines_iter : (string -> unit) -> string -> unit
-
-(** Alias for function [file_lines_iter]. *)
val readfile_line : (string -> 'a) -> string -> unit
val read_whole_file : int -> int -> Unix.file_descr -> string
val read_whole_file_to_string : string -> string
-val atomic_write_to_file : string -> Unix.file_perm -> (Unix.file_descr -> 'a) -> 'a
+val atomic_write_to_file : string -> (Unix.file_descr -> 'a) -> 'a
val write_string_to_file : string -> string -> unit
val execv_get_output : string -> string array -> int * Unix.file_descr
val copy_file : ?limit:int64 -> Unix.file_descr -> Unix.file_descr -> int64
val proxy : Unix.file_descr -> Unix.file_descr -> unit
val really_read : Unix.file_descr -> string -> int -> int -> unit
val really_read_string : Unix.file_descr -> int -> string
-val really_read_bigbuffer : Unix.file_descr -> Bigbuffer.t -> int64 -> unit
val really_write : Unix.file_descr -> string -> int -> int -> unit
val really_write_string : Unix.file_descr -> string -> unit
exception Timeout
= "stub_unixext_set_tcp_nodelay"
external fsync : Unix.file_descr -> unit = "stub_unixext_fsync"
external get_max_fd : unit -> int = "stub_unixext_get_max_fd"
-external blkgetsize64 : Unix.file_descr -> int64 = "stub_unixext_blkgetsize64"
-
val int_of_file_descr : Unix.file_descr -> int
val file_descr_of_int : int -> Unix.file_descr
val close_all_fds_except : Unix.file_descr list -> unit
+val get_process_output : ?handler:(string -> int -> string) -> string -> string
val resolve_dot_and_dotdot : string -> string
val seek_to : Unix.file_descr -> int -> int
val seek_rel : Unix.file_descr -> int -> int
val current_cursor_pos : Unix.file_descr -> int
+type statfs_t = {
+ statfs_type: int64;
+ statfs_bsize: int;
+ statfs_blocks: int64;
+ statfs_bfree: int64;
+ statfs_bavail: int64;
+ statfs_files: int64;
+ statfs_ffree: int64;
+ statfs_namelen: int;
+}
+
+val statfs: string -> statfs_t
+
module Fdset : sig
type t
external of_list : Unix.file_descr list -> t = "stub_fdset_of_list"
val select_wo : t -> float -> t
end
-val wait_for_path : string -> (float -> unit) -> int -> unit
-
(** Download a file via an HTTP GET *)
val http_get: open_tcp:(server:string -> (in_channel * out_channel)) -> uri:string -> filename:string -> server:string -> unit
(** Upload a file via an HTTP PUT *)
val http_put: open_tcp:(server:string -> (in_channel * out_channel)) -> uri:string -> filename:string -> server:string -> unit
-
-external send_fd : Unix.file_descr -> string -> int -> int -> Unix.msg_flag list -> Unix.file_descr -> int = "stub_unix_send_fd_bytecode" "stub_unix_send_fd"
-external recv_fd : Unix.file_descr -> string -> int -> int -> Unix.msg_flag list -> int * Unix.sockaddr * Unix.file_descr = "stub_unix_recv_fd"
-/*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
- */
#include <sys/types.h>
#include <sys/socket.h>
#include <errno.h>
#include <netinet/tcp.h>
#include <netinet/in.h>
-#include <sys/un.h>
#include <string.h>
#include <unistd.h> /* needed for _SC_OPEN_MAX */
#include <stdio.h> /* snprintf */
-#include <sys/ioctl.h>
-#include <linux/fs.h>
#include <caml/mlvalues.h>
#include <caml/memory.h>
#include <caml/custom.h>
#include <caml/fail.h>
#include <caml/callback.h>
-#include <caml/unixsupport.h>
+
+static void failwith_errno(void)
+{
+ char buf[256];
+ char buf2[280];
+ memset(buf, '\0', sizeof(buf));
+ strerror_r(errno, buf, sizeof(buf));
+ snprintf(buf2, sizeof(buf2), "errno: %d msg: %s", errno, buf);
+ caml_failwith(buf2);
+}
/* Set the TCP_NODELAY flag on a Unix.file_descr */
CAMLprim value stub_unixext_set_tcp_nodelay (value fd, value bool)
int c_fd = Int_val(fd);
int opt = (Bool_val(bool)) ? 1 : 0;
if (setsockopt(c_fd, IPPROTO_TCP, TCP_NODELAY, (void *)&opt, sizeof(opt)) != 0){
- uerror("setsockopt", Nothing);
+ failwith_errno();
}
CAMLreturn(Val_unit);
}
{
CAMLparam1(fd);
int c_fd = Int_val(fd);
- if (fsync(c_fd) != 0) uerror("fsync", Nothing);
+ if (fsync(c_fd) != 0) failwith_errno();
CAMLreturn(Val_unit);
}
-CAMLprim value stub_unixext_blkgetsize64(value fd)
-{
- CAMLparam1(fd);
- uint64_t size;
- int c_fd = Int_val(fd);
- if(ioctl(c_fd,BLKGETSIZE64,&size)) {
- uerror("ioctl(BLKGETSIZE64)", Nothing);
- }
- CAMLreturn(caml_copy_int64(size));
-}
CAMLprim value stub_unixext_get_max_fd (value unit)
{
CAMLreturn(Val_int(maxfd));
}
+#include <sys/vfs.h>
+
+CAMLprim value stub_unixext_statfs(value path)
+{
+ CAMLparam1(path);
+ CAMLlocal1(statinfo);
+ struct statfs info;
+
+ if (statfs(String_val(path), &info))
+ failwith_errno();
+
+ statinfo = caml_alloc_tuple(8);
+ Store_field(statinfo, 0, caml_copy_int64(info.f_type));
+ Store_field(statinfo, 1, Val_int(info.f_bsize));
+ Store_field(statinfo, 2, caml_copy_int64(info.f_blocks));
+ Store_field(statinfo, 3, caml_copy_int64(info.f_bfree));
+ Store_field(statinfo, 4, caml_copy_int64(info.f_bavail));
+ Store_field(statinfo, 5, caml_copy_int64(info.f_files));
+ Store_field(statinfo, 6, caml_copy_int64(info.f_ffree));
+ Store_field(statinfo, 7, Val_int(info.f_namelen));
+
+ CAMLreturn(statinfo);
+}
+
#define FDSET_OF_VALUE(v) (&(((struct fdset_t *) v)->fds))
#define MAXFD_OF_VALUE(v) (((struct fdset_t *) v)->max)
struct fdset_t { fd_set fds; int max; };
CAMLreturn(Bool_val(ret == 0));
}
-
-static int msg_flag_table[] = {
- MSG_OOB, MSG_DONTROUTE, MSG_PEEK
-};
-
-#define UNIX_BUFFER_SIZE 16384
-
-CAMLprim value stub_unix_send_fd(value sock, value buff, value ofs, value len, value flags, value fd)
-{
- CAMLparam5(sock,buff,ofs,len,flags);
- CAMLxparam1(fd);
- int ret, cv_flags, cfd;
- long numbytes;
- char iobuf[UNIX_BUFFER_SIZE];
- char buf[CMSG_SPACE(sizeof(cfd))];
-
- cfd = Int_val(fd);
-
- cv_flags = convert_flag_list(flags,msg_flag_table);
-
- numbytes = Long_val(len);
- if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE;
- memmove(iobuf, &Byte(buff, Long_val(ofs)), numbytes);
-
- /* Set up sockaddr */
-
- struct msghdr msg;
- struct iovec vec;
- struct cmsghdr *cmsg;
-
- msg.msg_name = NULL;
- msg.msg_namelen = 0;
- vec.iov_base=iobuf;
- vec.iov_len=numbytes;
- msg.msg_iov=&vec;
- msg.msg_iovlen=1;
-
- msg.msg_control = buf;
- msg.msg_controllen = sizeof(buf);
- cmsg = CMSG_FIRSTHDR(&msg);
- cmsg->cmsg_level = SOL_SOCKET;
- cmsg->cmsg_type = SCM_RIGHTS;
- cmsg->cmsg_len = CMSG_LEN(sizeof(cfd));
- *(int*)CMSG_DATA(cmsg) = cfd;
- msg.msg_controllen = cmsg->cmsg_len;
-
- msg.msg_flags = 0;
-
- caml_enter_blocking_section();
- ret=sendmsg(Int_val(sock), &msg, cv_flags);
- caml_leave_blocking_section();
-
- if(ret == -1)
- unixext_error(errno);
-
- CAMLreturn(Val_int(ret));
-}
-
-CAMLprim value stub_unix_send_fd_bytecode(value *argv, int argn)
-{
- return stub_unix_send_fd(argv[0],argv[1],argv[2],argv[3],
- argv[4], argv[5]);
-}
-
-CAMLprim value stub_unix_recv_fd(value sock, value buff, value ofs, value len, value flags)
-{
- CAMLparam5(sock,buff,ofs,len,flags);
- CAMLlocal2(res,addr);
- int ret, cv_flags, fd;
- long numbytes;
- char iobuf[UNIX_BUFFER_SIZE];
- char buf[CMSG_SPACE(sizeof(fd))];
- struct sockaddr_un unix_socket_name;
-
- cv_flags = convert_flag_list(flags,msg_flag_table);
-
- struct msghdr msg;
- struct iovec vec;
- struct cmsghdr *cmsg;
-
- numbytes = Long_val(len);
- if(numbytes > UNIX_BUFFER_SIZE)
- numbytes = UNIX_BUFFER_SIZE;
-
- msg.msg_name=&unix_socket_name;
- msg.msg_namelen=sizeof(unix_socket_name);
- vec.iov_base=iobuf;
- vec.iov_len=numbytes;
- msg.msg_iov=&vec;
-
- msg.msg_iovlen=1;
-
- msg.msg_control = buf;
- msg.msg_controllen = sizeof(buf);
-
- caml_enter_blocking_section();
- ret=recvmsg(Int_val(sock), &msg, cv_flags);
- caml_leave_blocking_section();
-
- if(ret == -1)
- unixext_error(errno);
-
- if(ret>0 && msg.msg_controllen>0) {
- cmsg = CMSG_FIRSTHDR(&msg);
- if(cmsg->cmsg_level == SOL_SOCKET && (cmsg->cmsg_type == SCM_RIGHTS)) {
- fd=Val_int(*(int*)CMSG_DATA(cmsg));
- } else {
- failwith("Failed to receive an fd!");
- }
- } else {
- fd=Val_int(-1);
- }
-
- if(ret<numbytes)
- numbytes = ret;
-
- memmove(&Byte(buff, Long_val(ofs)), iobuf, numbytes);
-
- addr=alloc_small(1,0); /* Unix.sockaddr; must be an ADDR_UNIX of string */
- Field(addr, 0) = Val_unit; /* must set all fields before next allocation */
-
- if(ret>0) {
- Field(addr,0) = copy_string(unix_socket_name.sun_path);
- } else {
- Field(addr,0) = copy_string("nothing");
- }
-
- res=alloc_small(3,0);
- Field(res,0) = Val_int(ret);
- Field(res,1) = addr;
- Field(res,2) = fd;
-
- CAMLreturn(res);
-}
(*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent@xensource.com>
*)
exception End_of_file
-(*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
- *)
exception End_of_file
exception Timeout
-(*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
- *)
(** Test the close_all_fds_except *)
-(*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
- *)
(** Test the copy_file function *)
-(*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
- *)
(* test the "." and ".." removal code *)
let table = [
-(*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
- *)
(** Test the Unixext.safe_unlink function *)
-(*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
- *)
LDFLAGS = -cclib -L./
+DESTDIR ?= /
VERSION := $(shell hg parents --template "{rev}" 2>/dev/null || echo 0.0)
OCAMLOPTFLAGS = -g -dtypes
INTF = $(foreach obj, $(OBJS),$(obj).cmi)
LIBS = uuid.cma uuid.cmxa
-DOCDIR = /myrepos/xen-api-libs.hg/doc
-
all: $(INTF) $(LIBS) $(PROGRAMS)
bins: $(PROGRAMS)
sed 's/@VERSION@/$(VERSION)/g' < $< > $@
.PHONY: install
-install: path = $(DESTDIR)$(shell ocamlfind printconf destdir)
install: $(LIBS) META
- mkdir -p $(path)
- ocamlfind install -destdir $(path) -ldconf ignore uuid META $(INTF) $(LIBS) *.a *.cmx
+ ocamlfind install -destdir $(DESTDIR)$(shell ocamlfind printconf destdir) -ldconf ignore uuid META $(INTF) $(LIBS) *.a *.cmx
.PHONY: uninstall
uninstall:
ocamlfind remove uuid
-.PHONY: doc
-doc: $(INTF)
- python ../doc/doc.py $(DOCDIR) "uuid" "package" "$(OBJS)" "." "" ""
-
clean:
rm -f *.o *.so *.a *.cmo *.cmi *.cma *.cmx *.cmxa *.annot $(LIBS) $(PROGRAMS)
-(*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
- *)
(** Type-safe UUIDs. *)
(** Internally, a UUID is simply a string. *)
a10; a11; a12; a13; a14; a15; ]);
Array.of_list !l
with _ -> invalid_arg "Uuid.int_array_of_uuid"
-
-let is_uuid str =
- try
- Scanf.sscanf str
- "%02x%02x%02x%02x-%02x%02x-%02x%02x-%02x%02x-%02x%02x%02x%02x%02x%02x"
- (fun _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ -> true)
- with _ -> false
-(*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
- *)
(** Type-safe UUIDs.
Probably need to refactor this; UUIDs are used in two places:
1. to uniquely name things across the cluster
val uuid_of_int_array : int array -> 'a t
val int_array_of_uuid : 'a t -> int array
-
-(* check if a string is a uuid *)
-val is_uuid : string -> bool
version = "@VERSION@"
description = "XenBus Interface"
-requires = "unix,mmap"
archive(byte) = "xb.cma"
archive(native) = "xb.cmxa"
CC = gcc
-CFLAGS = -Wall -fPIC -O2 -I/usr/lib/ocaml -I$(XEN_ROOT)/usr/include -I../mmap
+CFLAGS = -Wall -fPIC -O2 -I/opt/xensource/lib/ocaml -I$(XEN_ROOT)/usr/include -I../mmap
OCAMLC = ocamlc -g -I ../mmap
OCAMLOPT = ocamlopt
OCAMLOPTFLAGS = -g -dtypes -I ../mmap
LDFLAGS = -cclib -L./
+DESTDIR ?= /
VERSION := $(shell hg parents --template "{rev}" 2>/dev/null || echo 0.0)
OCAMLABI := $(shell ocamlc -version)
INTF = op.cmi packet.cmi xb.cmi
LIBS = xb.cma xb.cmxa
-DOCDIR = /myrepos/xen-api-libs.hg/doc
-
all: $(PREINTF) $(PRELIBS) $(INTF) $(LIBS) $(PROGRAMS)
bins: $(PROGRAMS)
sed 's/@VERSION@/$(VERSION)/g' < $< > $@
.PHONY: install
-install: path = $(DESTDIR)$(shell ocamlfind printconf destdir)
install: $(LIBS) META
- mkdir -p $(path)
- ocamlfind install -destdir $(path) -ldconf ignore xb META $(INTF) $(LIBS) *.a *.so *.cmx
+ ocamlfind install -destdir $(DESTDIR)$(shell ocamlfind printconf destdir) -ldconf ignore xb META $(INTF) $(LIBS) *.a *.so *.cmx
.PHONY: uninstall
uninstall:
ocamlfind remove xb
-.PHONY: doc
-doc: $(INTF)
- python ../doc/doc.py $(DOCDIR) "xb" "package" "$(OBJS)" "." "mmap" ""
-
clean:
rm -f *.o *.so *.a *.cmo *.cmi *.cma *.cmx *.cmxa *.annot $(LIBS) $(PROGRAMS)
(*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
+ * Copyright (c) 2006 XenSource Inc.
+ * Author Vincent Hanquez <vincent@xensource.com>
*
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
*)
+
type operation = Debug | Directory | Read | Getperms |
Watch | Unwatch | Transaction_start |
Transaction_end | Introduce | Release |
(*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
+ * Copyright (c) 2006 XenSource Inc.
+ * Author Vincent Hanquez <vincent@xensource.com>
*
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
+ * All rights reserved.
*)
+
type t =
{
tid: int;
String.sub pkt.data 0 (l - 1)
else
pkt.data
-let get_rid pkt = pkt.rid
+let get_rid pkt = pkt.rid
\ No newline at end of file
(*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
+ * Copyright (c) 2006 XenSource Inc.
+ * Author Vincent Hanquez <vincent@xensource.com>
*
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
+ * All rights reserved.
*)
+
type pkt =
{
tid: int;
(*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
+ * Copyright (c) 2006 XenSource Inc.
+ * Author Vincent Hanquez <vincent@xensource.com>
*
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
+ * All rights reserved.
*)
+
module Op = struct include Op end
module Packet = struct include Packet end
-(*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
- *)
module Op:
sig
type operation = Op.operation =
/*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
+ * Copyright (c) 2006 XenSource Inc.
+ * Author Vincent Hanquez <vincent@xensource.com>
*
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
+ * All rights reserved.
*/
+
#include <unistd.h>
#include <stdlib.h>
#include <sys/mman.h>
#define u32 uint32_t
#include <xen/io/xs_wire.h>
-/* XS_RESTRICT is defined in
- http://xenbits.xen.org/xapi/xen-3.4.pq.hg?file/c01d38e7092a/restrict_xenstored */
-#include "../include/config.h"
-#if !HAVE_DECL_XS_RESTRICT
-#define XS_RESTRICT 128
-#endif
-
CAMLprim value stub_get_internal_offset(void)
{
CAMLparam0();
(*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
+ * Copyright (c) 2006 XenSource Inc.
+ * Author Vincent Hanquez <vincent@xensource.com>
*
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
+ * All rights reserved.
*)
external read: Mmap.mmap_interface -> string -> int -> int = "ml_interface_read"
/*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
+ * Copyright (c) 2006 XenSource Inc.
+ * Author Vincent Hanquez <vincent@xensource.com>
*
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
+ * All rights reserved.
*/
+
#include <sys/types.h>
#include <sys/stat.h>
#include <fcntl.h>
version = "@VERSION@"
description = "Xen Control Interface"
-requires = "mmap,uuid"
archive(byte) = "xc.cma"
archive(native) = "xc.cmxa"
CC = gcc
-CFLAGS = -Wall -fPIC -O2 -I/usr/lib/ocaml -I$(XEN_ROOT)/usr/include -I../mmap -I./
+CFLAGS = -Wall -fPIC -O2 -I/opt/xensource/lib/ocaml -I$(XEN_ROOT)/usr/include -I../mmap -I./
OCAMLC = ocamlc -g -I ../mmap -I ../uuid
OCAMLOPT = ocamlopt
OCAMLOPTFLAGS = -g -dtypes -I ../mmap -I ../uuid
LDFLAGS = -cclib -L./
+DESTDIR ?= /
VERSION := $(shell hg parents --template "{rev}" 2>/dev/null || echo 0.0)
OCAMLABI := $(shell ocamlc -version)
INTF = xc.cmi
LIBS = xc.cma xc.cmxa
-DOCDIR = /myrepos/xen-api-libs.hg/doc
-
all: $(INTF) $(LIBS) $(PROGRAMS)
bins: $(PROGRAMS)
sed 's/@VERSION@/$(VERSION)/g' < $< > $@
.PHONY: install
-install: path = $(DESTDIR)$(shell ocamlfind printconf destdir)
install: $(LIBS) META
- mkdir -p $(path)
- ocamlfind install -destdir $(path) -ldconf ignore xc META $(INTF) $(LIBS) *.a *.so *.cmx
+ ocamlfind install -destdir $(DESTDIR)$(shell ocamlfind printconf destdir) -ldconf ignore xc META $(INTF) $(LIBS) *.a *.so *.cmx
.PHONY: uninstall
uninstall:
ocamlfind remove xc
-.PHONY: doc
-doc: $(INTF)
- python ../doc/doc.py $(DOCDIR) "xc" "package" "$(OBJS)" "." "mmap,uuid" ""
-
clean:
- rm -f *.o *.so *.a *.cmo *.cmi *.cma *.cmx *.cmxa *.annot $(LIBS) $(PROGRAMS) $(INTF) *~ *.rej *.orig
+ rm -f *.o *.so *.a *.cmo *.cmi *.cma *.cmx *.cmxa *.annot $(LIBS) $(PROGRAMS) $(INTF)
/*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
+ * Copyright (c) 2006 XenSource Inc.
+ * Author Vincent Hanquez <vincent@xensource.com>
*/
#define __XEN_TOOLS__
#include <xen/sysctl.h>
#include <xen/domctl.h>
#include <xen/sched.h>
-#include <xen/platform.h>
+#include <xen/sysctl.h>
#if XEN_SYSCTL_INTERFACE_VERSION < 4
#include <xen/linux/privcmd.h>
#else
int xc_domain_cpuid_apply(int xc, unsigned int domid, int hvm);
int xc_cpuid_check(uint32_t input, uint32_t optsubinput,
char *config[4], char *config_out[4]);
-int xc_domain_suppress_spurious_page_faults(int xc, uint32_t domid);
-
int xc_domain_send_s3resume(int handle, unsigned int domid);
-int xc_domain_set_vpt_align(int handle, unsigned int domid, int vpt_align);
-int xc_domain_set_hpet(int handle, unsigned int domid, int hpet);
-int xc_domain_set_timer_mode(int handle, unsigned int domid, int mode);
-int xc_domain_get_acpi_s_state(int handle, unsigned int domid);
-int xc_domain_trigger_power(int handle, unsigned int domid);
-int xc_domain_trigger_sleep(int handle, unsigned int domid);
-
-int xc_get_boot_cpufeatures(int handle, uint32_t *, uint32_t *, uint32_t *,
- uint32_t *, uint32_t *, uint32_t *, uint32_t *, uint32_t *);
+
+int xc_domain_suppress_spurious_page_faults(int xc, uint32_t domid);
#if XEN_SYSCTL_INTERFACE_VERSION >= 6
#define SAFEDIV(a, b) (((b) >= 0) ? (a) / (b) : (a))
(*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Author Vincent Hanquez <vincent@xensource.com>
*)
(** *)
cap : int;
}
-type physinfo_cap_flag =
- | CAP_HVM
- | CAP_DirectIO
-
type physinfo =
{
nr_cpus : int;
free_pages : nativeint;
scrub_pages : nativeint;
(* XXX hw_cap *)
- capabilities : physinfo_cap_flag list;
}
type version =
= "stub_xc_domain_getinfolist"
let domain_getinfolist handle first_domain =
- let nb = 100 in
+ let nb = 2 in
let last_domid l = (List.hd l).domid + 1 in
let rec __getlist from =
let l = _domain_getinfolist handle from nb in
external domain_suppress_spurious_page_faults: handle -> domid -> unit
= "stub_xc_domain_suppress_spurious_page_faults"
-external domain_set_timer_mode: handle -> domid -> int -> unit = "stub_xc_domain_set_timer_mode"
-external domain_set_hpet: handle -> domid -> int -> unit = "stub_xc_domain_set_hpet"
-external domain_set_vpt_align: handle -> domid -> int -> unit = "stub_xc_domain_set_vpt_align"
-
-external domain_send_s3resume: handle -> domid -> unit = "stub_xc_domain_send_s3resume"
external domain_get_acpi_s_state: handle -> domid -> int = "stub_xc_domain_get_acpi_s_state"
-external domain_trigger_power: handle -> domid -> unit = "stub_xc_domain_trigger_power"
-external domain_trigger_sleep: handle -> domid -> unit = "stub_xc_domain_trigger_sleep"
+external domain_send_s3resume: handle -> domid -> unit = "stub_xc_domain_send_s3resume"
(** check if some hvm domain got pv driver or not *)
external hvm_check_pvdriver: handle -> domid -> bool
external watchdog : handle -> int -> int32 -> int
= "stub_xc_watchdog"
-external get_boot_cpufeatures: handle ->
- (int32 * int32 * int32 * int32 * int32 * int32 * int32 * int32) = "stub_xc_get_boot_cpufeatures"
-
(* core dump structure *)
type core_magic = Magic_hvm | Magic_pv
-(*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
- *)
type domid = int
type vcpuinfo = {
online : bool;
handle : int array;
}
type sched_control = { weight : int; cap : int; }
-type physinfo_cap_flag = CAP_HVM | CAP_DirectIO
type physinfo = {
nr_cpus : int;
threads_per_core : int;
total_pages : nativeint;
free_pages : nativeint;
scrub_pages : nativeint;
- capabilities : physinfo_cap_flag list;
}
type version = { major : int; minor : int; extra : string; }
type compile_info = {
external domain_test_assign_device: handle -> domid -> (int * int * int * int) -> bool
= "stub_xc_domain_test_assign_device"
-external domain_set_timer_mode: handle -> domid -> int -> unit = "stub_xc_domain_set_timer_mode"
-external domain_set_hpet: handle -> domid -> int -> unit = "stub_xc_domain_set_hpet"
-external domain_set_vpt_align: handle -> domid -> int -> unit = "stub_xc_domain_set_vpt_align"
-
+external domain_get_acpi_s_state: handle -> domid -> int = "stub_xc_domain_get_acpi_s_state"
external domain_send_s3resume: handle -> domid -> unit
= "stub_xc_domain_send_s3resume"
-external domain_get_acpi_s_state: handle -> domid -> int = "stub_xc_domain_get_acpi_s_state"
-
-external domain_trigger_power: handle -> domid -> unit
- = "stub_xc_domain_trigger_power"
-external domain_trigger_sleep: handle -> domid -> unit
- = "stub_xc_domain_trigger_sleep"
external hvm_check_pvdriver : handle -> domid -> bool
= "stub_xc_hvm_check_pvdriver"
external cpuid_check: (int64 * (int64 option)) -> string option array -> (bool * string option array)
= "stub_xc_cpuid_check"
-external get_boot_cpufeatures: handle ->
- (int32 * int32 * int32 * int32 * int32 * int32 * int32 * int32) = "stub_xc_get_boot_cpufeatures"
-
-/*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
- */
#ifndef __LIBXC_CPUFEATURE_H
#define __LIBXC_CPUFEATURE_H
-/*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
- */
#ifndef XC_CPUID_H
#define XC_CPUID_H
-/*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
- */
#ifndef __XC_E820_H__
#define __XC_E820_H__
/*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
+ * Copyright (c) 2006-2007 XenSource Inc.
+ * Author Vincent Hanquez <vincent@xensource.com>
*/
#include <stdint.h>
.interface_version = XEN_SYSCTL_INTERFACE_VERSION, \
}
-#define DECLARE_PLATFORM(_cmd) \
- struct xen_platform_op platform = { \
- .cmd = _cmd, \
- .interface_version = XENPF_INTERFACE_VERSION, \
- }
-
#define DECLARE_HYPERCALL2(_cmd, _arg0, _arg1) \
privcmd_hypercall_t hypercall = { \
.op = _cmd, \
return ret;
}
-static int do_platform(int handle, struct xen_platform_op *platform)
-{
- int ret;
- DECLARE_HYPERCALL1(__HYPERVISOR_platform_op, platform);
-
- if (mlock(platform, sizeof(*platform)) != 0) {
- xc_error_set("mlock failed: %s", strerror(errno));
- return -1;
- }
-
- ret = do_xen_hypercall(handle, &hypercall);
- if (ret < 0)
- xc_error_hypercall(hypercall, ret);
-
- munlock(platform, sizeof(*platform));
- return ret;
-}
-
static int do_evtchnctl(int handle, int cmd, void *arg, size_t arg_size)
{
DECLARE_HYPERCALL2(__HYPERVISOR_event_channel_op, cmd, arg);
};
DECLARE_HYPERCALL2(__HYPERVISOR_hvm_op, HVMOP_set_param, (unsigned long) &arg);
int ret;
-
+
if (mlock(&arg, sizeof(arg)) == -1) {
xc_error_set("mlock failed: %s", strerror(errno));
return -1;
return ret;
}
-#ifndef HVM_PARAM_HPET_ENABLED
-#define HVM_PARAM_HPET_ENABLED 11
-#endif
-
-#ifndef HVM_PARAM_ACPI_S_STATE
-#define HVM_PARAM_ACPI_S_STATE 14
-#endif
-
-#ifndef HVM_PARAM_VPT_ALIGN
-#define HVM_PARAM_VPT_ALIGN 16
-#endif
-
int xc_domain_send_s3resume(int handle, unsigned int domid)
{
#define HVM_PARAM_ACPI_S_STATE 14
return xc_set_hvm_param(handle, domid, HVM_PARAM_ACPI_S_STATE, 0);
}
-int xc_domain_set_timer_mode(int handle, unsigned int domid, int mode)
-{
- return xc_set_hvm_param(handle, domid,
- HVM_PARAM_TIMER_MODE, (unsigned long) mode);
-}
-
-int xc_domain_set_hpet(int handle, unsigned int domid, int hpet)
-{
- return xc_set_hvm_param(handle, domid, HVM_PARAM_HPET_ENABLED, (unsigned long) hpet);
-}
-
-int xc_domain_set_vpt_align(int handle, unsigned int domid, int vpt_align)
-{
- return xc_set_hvm_param(handle, domid, HVM_PARAM_HPET_ENABLED, (unsigned long) vpt_align);
-}
-
int xc_domain_get_acpi_s_state(int handle, unsigned int domid)
{
int ret;
return rc;
}
-int xc_domain_trigger_power(int handle, unsigned int domid)
-{
- int ret;
-
- DECLARE_DOMCTL(XEN_DOMCTL_sendtrigger, domid);
- domctl.u.sendtrigger.trigger = XEN_DOMCTL_SENDTRIGGER_POWER;
-
- ret = do_domctl(handle, &domctl);
- if (ret != 0)
- xc_error_set("power button failed: %s", xc_error_get());
- return ret;
-}
-
-int xc_domain_trigger_sleep(int handle, unsigned int domid)
-{
- int ret;
-
- DECLARE_DOMCTL(XEN_DOMCTL_sendtrigger, domid);
- domctl.u.sendtrigger.trigger = XEN_DOMCTL_SENDTRIGGER_SLEEP;
-
- ret = do_domctl(handle, &domctl);
- if (ret != 0)
- xc_error_set("sleep button failed: %s", xc_error_get());
- return ret;
-}
-
-int xc_get_boot_cpufeatures(int handle,
- uint32_t *base_ecx, uint32_t *base_edx,
- uint32_t *ext_ecx, uint32_t *ext_edx,
- uint32_t *masked_base_ecx,
- uint32_t *masked_base_edx,
- uint32_t *masked_ext_ecx,
- uint32_t *masked_ext_edx)
-{
- int ret = -EINVAL;
-#ifdef XENPF_get_cpu_features
- DECLARE_PLATFORM(XENPF_get_cpu_features);
-
- ret = do_platform(handle, &platform);
- if (ret != 0)
- xc_error_set("getting boot cpu features failed: %s", xc_error_get());
- else {
- *base_ecx = platform.u.cpu_features.base_ecx;
- *base_edx = platform.u.cpu_features.base_edx;
- *ext_ecx = platform.u.cpu_features.ext_ecx;
- *ext_edx = platform.u.cpu_features.ext_edx;
- *masked_base_ecx = platform.u.cpu_features.masked_base_ecx;
- *masked_base_edx = platform.u.cpu_features.masked_base_edx;
- *masked_ext_ecx = platform.u.cpu_features.masked_ext_ecx;
- *masked_ext_edx = platform.u.cpu_features.masked_ext_edx;
- }
-#endif
- return ret;
-}
-
/*
* Local variables:
* indent-tabs-mode: t
/*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
+ * Copyright (c) 2007 XenSource Inc.
+ * Author Vincent Hanquez <vincent@xensource.com>
*/
#ifdef WITH_INJECTION_CAPABILITY
#include <sys/socket.h>
#include <sys/un.h>
-#define HYPCALLcmd "hypcall"
-
static int fake_interface_open(void)
{
struct sockaddr_un remote;
marshall_command(handle, "%s,%d,%d\n", DOMCTLcmd, domctl->cmd, domctl->domain);
return unmarshall_return(handle);
case XEN_DOMCTL_createdomain: /* W ssidref */
- marshall_command(handle, "%s,%d,%d,%d," DOMAINHANDLE "\n", DOMCTLcmd,
+ marshall_command(handle, "%s,%d,%d," DOMAINHANDLE "\n", DOMCTLcmd,
domctl->cmd,
- (domctl->u.createdomain.flags|XEN_DOMCTL_CDF_hvm_guest)?1:0,
- (domctl->u.createdomain.flags|XEN_DOMCTL_CDF_hap)?1:0,
+ domctl->u.createdomain.flags,
domctl->u.createdomain.handle[0],
domctl->u.createdomain.handle[1],
domctl->u.createdomain.handle[2],
{
switch (cmd) {
case SCHEDOP_remote_shutdown:
- marshall_command(handle, "%s,%d,%d,%d\n", HYPCALLcmd,
- 1,
- arg->domain_id,
- arg->reason);
- return unmarshall_return(handle);
+ return 0;
default:
return -EINVAL;
}
-/*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
- */
+/* Copyright (c) 2005-2006 XenSource Inc. */
#define _XOPEN_SOURCE 600
#include <stdlib.h>
CAMLprim value stub_xc_physinfo(value xc_handle)
{
CAMLparam1(xc_handle);
- CAMLlocal3(physinfo, cap_list, tmp);
+ CAMLlocal1(physinfo);
xc_physinfo_t c_physinfo;
int r;
if (r)
failwith_xc();
- tmp = cap_list = Val_emptylist;
- for (r = 0; r < 2; r++) {
- if ((c_physinfo.capabilities >> r) & 1) {
- tmp = caml_alloc_small(2, Tag_cons);
- Field(tmp, 0) = Val_int(r);
- Field(tmp, 1) = cap_list;
- cap_list = tmp;
- }
- }
-
- physinfo = caml_alloc_tuple(10);
+ physinfo = caml_alloc_tuple(9);
Store_field(physinfo, 0, Val_int(COMPAT_FIELD_physinfo_get_nr_cpus(c_physinfo)));
Store_field(physinfo, 1, Val_int(c_physinfo.threads_per_core));
Store_field(physinfo, 2, Val_int(c_physinfo.cores_per_socket));
Store_field(physinfo, 6, caml_copy_nativeint(c_physinfo.total_pages));
Store_field(physinfo, 7, caml_copy_nativeint(c_physinfo.free_pages));
Store_field(physinfo, 8, caml_copy_nativeint(c_physinfo.scrub_pages));
- Store_field(physinfo, 9, cap_list);
CAMLreturn(physinfo);
}
CAMLreturn(Val_unit);
}
-CAMLprim value stub_xc_watchdog(value handle, value domid, value timeout)
+CAMLprim value stub_xc_watchdog(value handle, value id, value timeout)
{
- CAMLparam3(handle, domid, timeout);
+ CAMLparam3(handle, id, timeout);
int ret;
unsigned int c_timeout = Int32_val(timeout);
- ret = xc_domain_watchdog(_H(handle), _D(domid), c_timeout);
+ ret = xc_domain_watchdog(_H(handle), Int_val(id), c_timeout);
if (ret < 0)
failwith_xc();
CAMLreturn(Val_unit);
}
-
-CAMLprim value stub_xc_domain_set_timer_mode(value handle, value id, value mode)
-{
- CAMLparam3(handle, id, mode);
- int ret;
-
- ret = xc_domain_set_timer_mode(_H(handle), _D(id), Int_val(mode));
- if (ret < 0)
- failwith_xc();
- CAMLreturn(Val_unit);
-}
-
-CAMLprim value stub_xc_domain_set_hpet(value handle, value id, value mode)
-{
- CAMLparam3(handle, id, mode);
- int ret;
-
- ret = xc_domain_set_hpet(_H(handle), _D(id), Int_val(mode));
- if (ret < 0)
- failwith_xc();
- CAMLreturn(Val_unit);
-}
-
-CAMLprim value stub_xc_domain_set_vpt_align(value handle, value id, value mode)
-{
- CAMLparam3(handle, id, mode);
- int ret;
-
- ret = xc_domain_set_vpt_align(_H(handle), _D(id), Int_val(mode));
- if (ret < 0)
- failwith_xc();
- CAMLreturn(Val_unit);
-}
-
-CAMLprim value stub_xc_domain_trigger_power(value handle, value domid)
-{
- CAMLparam2(handle, domid);
- xc_domain_trigger_power(_H(handle), _D(domid));
- CAMLreturn(Val_unit);
-}
-
-CAMLprim value stub_xc_domain_trigger_sleep(value handle, value domid)
-{
- CAMLparam2(handle, domid);
- xc_domain_trigger_sleep(_H(handle), _D(domid));
- CAMLreturn(Val_unit);
-}
-
-CAMLprim value stub_xc_get_boot_cpufeatures(value handle)
-{
- CAMLparam1(handle);
- CAMLlocal1(v);
- uint32_t a, b, c, d, e, f, g, h;
- int ret;
-
- ret = xc_get_boot_cpufeatures(_H(handle), &a, &b, &c, &d, &e, &f, &g, &h);
- if (ret < 0)
- failwith_xc();
-
- v = caml_alloc_tuple(8);
- Store_field(v, 0, caml_copy_int32(a));
- Store_field(v, 1, caml_copy_int32(b));
- Store_field(v, 2, caml_copy_int32(c));
- Store_field(v, 3, caml_copy_int32(d));
- Store_field(v, 4, caml_copy_int32(e));
- Store_field(v, 5, caml_copy_int32(f));
- Store_field(v, 6, caml_copy_int32(g));
- Store_field(v, 7, caml_copy_int32(h));
-
- CAMLreturn(v);
-}
-
/*
* Local variables:
* indent-tabs-mode: t
version = "@VERSION@"
description = "Xml-light2 - Xml-light replacement"
-requires = "stdext,xmlm"
+requires = "stdext"
archive(byte) = "xml-light2.cma"
archive(native) = "xml-light2.cmxa"
-IPROG=install -m 755 -o root -g root
OCAMLPACKS = xmlm
CC = gcc
LDFLAGS = -cclib -L./
-LIBEXEC = "/opt/xensource/libexec"
+DESTDIR ?= /
VERSION := $(shell hg parents --template "{rev}" 2>/dev/null || echo 0.0)
OCAMLOPTFLAGS = -g -dtypes
OBJS = xml
INTF = xml.cmi
LIBS = xml-light2.cma xml-light2.cmxa
-PROGRAMS = xmlpp
-DOCDIR = /myrepos/xen-api-libs.hg/doc
-
-all: $(INTF) $(LIBS)
+all: $(INTF) $(LIBS) $(PROGRAMS)
bins: $(PROGRAMS)
libs: $(LIBS)
-xmlpp: xmlpp.ml all
- $(OCAMLOPT) $(OCAMLOPTFLAGS) -I ../stdext stdext.cmxa xml-light2.cmxa -linkpkg -o $@ $<
-
xml-light2.cmxa: $(foreach obj,$(OBJS),$(obj).cmx)
$(OCAMLOPT) $(OCAMLOPTFLAGS) -a -o $@ $(foreach obj,$(OBJS),$(obj).cmx)
sed 's/@VERSION@/$(VERSION)/g' < $< > $@
.PHONY: install
-install: path = $(DESTDIR)$(shell ocamlfind printconf destdir)
install: $(LIBS) META
- mkdir -p $(path)
- ocamlfind install -destdir $(path) -ldconf ignore xml-light2 META $(INTF) $(LIBS) *.a *.cmx
-
-.PHONY: bininstall
-bininstall: path = $(DESTDIR)$(LIBEXEC)
-bininstall: all
- mkdir -p $(path)
- $(IPROG) $(PROGRAMS) $(path)
+ ocamlfind install -destdir $(DESTDIR)$(shell ocamlfind printconf destdir) -ldconf ignore xml-light2 META $(INTF) $(LIBS) *.a *.cmx
.PHONY: uninstall
uninstall:
ocamlfind remove xml-light2
-.PHONY: binuninstall
-binuninstall:
- rm -f $(DESTDIR)$(LIBEXEC)$(PROGRAMS)
-
-.PHONY: doc
-doc: $(INTF)
- python ../doc/doc.py $(DOCDIR) "xml-light2" "package" "$(OBJS)" "." "stdext,xmlm" ""
-
clean:
rm -f *.o *.so *.a *.cmo *.cmi *.cma *.cmx *.cmxa *.annot $(LIBS) $(PROGRAMS)
(*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
+ * Copyright (c) 2007 XenSource Ltd.
+ * Author Vincent Hanquez <vincent@xensource.com>
*
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
- *)
-(*
* This is a replacement interface for xml-light that use the superior xmlm
* engine to parse stuff. Also the output functions SKIP characters that are
* not allowed in XML.
Printf.sprintf "%s line %d" msg pos.eline
(* internal parse function *)
-let is_empty xml =
- let is_empty_string s =
- let is_empty = ref true in
- for i = 0 to (String.length s - 1)
- do
- if s.[i] <> '\n' && s.[i] <> ' ' && s.[i] <> '\t' then
- is_empty := false
- done;
- !is_empty in
- match xml with
- | PCData data when is_empty_string data -> true
- | _ -> false
-
let _parse i =
- let el (tag: Xmlm.tag) (children: xml list) : xml =
- let name_local = snd (fst tag) in
- let attrs' = List.map (fun (nameattr, str) -> (snd nameattr, str)) (snd tag) in
- Element (name_local, attrs', List.filter (fun xml -> not (is_empty xml)) children)
+ let filter_empty_pcdata l =
+ let is_empty_string s =
+ let is_empty = ref true in
+ for i = 0 to (String.length s - 1)
+ do
+ if s.[i] <> '\n' && s.[i] <> ' ' && s.[i] <> '\t' then
+ is_empty := false
+ done;
+ not (!is_empty)
+ in
+ List.filter (fun node ->
+ match node with Element _ -> true | PCData data -> is_empty_string data
+ ) l
+ in
+ let d data acc =
+ match acc with
+ | childs :: path -> ((PCData data) :: childs) :: path
+ | [] -> assert false
+ in
+ let s tag acc = [] :: acc in
+ let e tag acc =
+ match acc with
+ | childs :: path ->
+ (* xml light doesn't handle namespace in node *)
+ let (_, name), attrs = tag in
+ (* xml light doesn't have namespace in attributes *)
+ let realattrs = List.map (fun ((_, n), v) -> n, v) attrs in
+ let childs = filter_empty_pcdata childs in
+ let el = Element (name, realattrs, List.rev childs) in
+ begin match path with
+ | parent :: path' -> (el :: parent) :: path'
+ | [] -> [ [ el ] ]
+ end
+ | [] -> assert false
in
- let data s = PCData s in
- match Xmlm.peek i with
- | `Dtd _ -> snd (Xmlm.input_doc_tree ~el ~data i)
- | _ -> Xmlm.input_tree ~el ~data i
+ match Xmlm.input ~d ~s ~e [] i with
+ | [ [ r ] ] -> r
+ | _ -> assert false
let parse i =
try _parse i
let parse_file file =
let chan = open_in file in
try
- let i = Xmlm.make_input (`Channel chan) in
+ let i = Xmlm.input_of_channel chan in
let ret = parse i in
close_in chan;
ret
close_in_noerr chan; raise exn
let parse_in chan =
- let i = Xmlm.make_input (`Channel chan) in
+ let i = Xmlm.input_of_channel chan in
parse i
let parse_string s =
- let i = Xmlm.make_input (`String (0, s)) in
- parse i
-
-let parse_bigbuffer b =
- let n = ref Int64.zero in
- let aux () =
- try
- let c = Bigbuffer.get b !n in
- n := Int64.add !n Int64.one;
- int_of_char c
- with _ -> raise End_of_file in
- let i = Xmlm.make_input (`Fun aux) in
+ let i = Xmlm.input_of_string s in
parse i
(* common output function *)
let str_of_attrs attrs =
let fmt s = Printf.sprintf s in
if List.length attrs > 0 then
- " " ^ (String.concat " " (List.map (fun (k, v) -> fmt "%s=\"%s\"" k (esc_pcdata v)) attrs))
+ " "^(String.concat " " (List.map (fun (k, v) -> fmt "%s=\"%s\"" k (esc_pcdata v)) attrs))
else
""
let buffer = Bigbuffer.make () in
to_fct xml (fun s -> Bigbuffer.append_substring buffer s 0 (String.length s));
buffer
-
-(* helpers functions *)
-exception Not_pcdata of string
-exception Not_element of string
-
-let pcdata = function
- | PCData x -> x
- | e -> raise (Not_pcdata (to_string e))
-
-let children = function
- | Element (_,_,c) -> c
- | e -> raise (Not_element (to_string e))
-
-let tag = function
- | Element (x,_,_) -> x
- | e -> raise (Not_element (to_string e))
-(*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
- *)
(** tree representation *)
type xml =
| Element of (string * (string * string) list * xml list)
val parse_file : string -> xml
val parse_in : in_channel -> xml
val parse_string : string -> xml
-val parse_bigbuffer : Bigbuffer.t -> xml
(** output functions *)
val to_fct : xml -> (string -> unit) -> unit
val to_string : xml -> string
val to_string_fmt : xml -> string
val to_bigbuffer : xml -> Bigbuffer.t
-
-(** helper functions *)
-exception Not_pcdata of string
-exception Not_element of string
-val pcdata : xml -> string
-val children : xml -> xml list
-val tag : xml -> string
version = "@VERSION@"
description = "XenStore Interface"
-requires = "unix,xb"
archive(byte) = "xs.cma"
archive(native) = "xs.cmxa"
CC = gcc
-CFLAGS = -Wall -fPIC -O2 -I/usr/lib/ocaml
+CFLAGS = -Wall -fPIC -O2 -I/opt/xensource/lib/ocaml
OCAMLC = ocamlc -g -I ../xb/
OCAMLOPT = ocamlopt
LDFLAGS = -cclib -L./
+DESTDIR ?= /
VERSION := $(shell hg parents --template "{rev}" 2>/dev/null || echo 0.0)
OCAMLOPTFLAGS = -g -dtypes -I ../xb/
INTF = xsraw.cmi xst.cmi xs.cmi
LIBS = xs.cma xs.cmxa
-DOCDIR = /myrepos/xen-api-libs.hg/doc
-
all: $(PREINTF) $(PRELIBS) $(INTF) $(LIBS) $(PROGRAMS)
bins: $(PROGRAMS)
sed 's/@VERSION@/$(VERSION)/g' < $< > $@
.PHONY: install
-install: path = $(DESTDIR)$(shell ocamlfind printconf destdir)
install: $(LIBS) META
- mkdir -p $(path)
- ocamlfind install -destdir $(path) -ldconf ignore xs META $(INTF) xs.mli xst.mli xsraw.mli $(LIBS) *.a *.cmx
+ ocamlfind install -destdir $(DESTDIR)$(shell ocamlfind printconf destdir) -ldconf ignore xs META $(INTF) xs.mli xst.mli xsraw.mli $(LIBS) *.a *.cmx
.PHONY: uninstall
uninstall:
ocamlfind remove xs
-.PHONY: doc
-doc: $(INTF)
- python ../doc/doc.py $(DOCDIR) "xs" "package" "$(OBJS)" "." "xb" ""
-
clean:
rm -f *.o *.so *.a *.cmo *.cmi *.cma *.cmx *.cmxa *.annot $(LIBS) $(PROGRAMS)
(*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
+ * Copyright (c) 2006 XenSource Inc.
+ * Author Vincent Hanquez <vincent@xensource.com>
*
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
+ * All rights reserved.
*)
let data_concat ls = (String.concat "\000" ls) ^ "\000"
(*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
+ * Copyright (c) 2006 XenSource Inc.
+ * Author Vincent Hanquez <vincent@xensource.com>
*
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
+ * All rights reserved.
*)
type perms = Xsraw.perms
(*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
+ * Copyright (c) 2006 XenSource Inc.
+ * Author Vincent Hanquez <vincent@xensource.com>
*
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
+ * All rights reserved.
*)
exception Timeout
(*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
+ * Copyright (c) 2006 XenSource Inc.
+ * Author Vincent Hanquez <vincent@xensource.com>
*
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
+ * All rights reserved.
*)
exception Partial_not_empty
exception Unexpected_packet of string
-(*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
- *)
exception Partial_not_empty
exception Unexpected_packet of string
exception Invalid_path of string
(*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
+ * Copyright (c) 2006 XenSource Inc.
+ * Author Vincent Hanquez <vincent@xensource.com>
*
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
+ * All rights reserved.
*)
type ops =
-(*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
- *)
type ops = {
directory : string -> string list;
read : string -> string;
version = "@VERSION@"
description = "XenStore RPC"
-requires = "xs"
archive(byte) = "xsrpc.cma"
archive(native) = "xsrpc.cmxa"
LDFLAGS = -cclib -L./
+DESTDIR ?= /
VERSION := $(shell hg parents --template "{rev}" 2>/dev/null || echo 0.0)
OCAMLOPTFLAGS = -g -dtypes -I ../xb/ -I ../xs/
INTF = xsrpc.cmi
LIBS = xsrpc.cma xsrpc.cmxa
-DOCDIR = /myrepos/xen-api-libs.hg/doc
-
all: $(INTF) $(LIBS) $(PROGRAMS)
bins: $(PROGRAMS)
sed 's/@VERSION@/$(VERSION)/g' < $< > $@
.PHONY: install
-install: path = $(DESTDIR)$(shell ocamlfind printconf destdir)
install: $(LIBS) META
- mkdir -p $(path)
- ocamlfind install -destdir $(path) -ldconf ignore xsrpc META $(INTF) $(LIBS) *.a *.cmx
+ ocamlfind install -destdir $(DESTDIR)$(shell ocamlfind printconf destdir) -ldconf ignore xsrpc META $(INTF) $(LIBS) *.a *.cmx
.PHONY: uninstall
uninstall:
ocamlfind remove xsrpc
-
-.PHONY: doc
-doc: $(INTF)
- python ../doc/doc.py $(DOCDIR) "xsrpc" "package" "$(OBJS)" "." "xb,xs" ""
-
+
clean:
rm -f *.o *.so *.a *.cmo *.cmi *.cma *.cmx *.cmxa *.annot META $(LIBS) $(PROGRAMS)
(*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent@xensource.com>
*
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
+ * Xenstore RPC
*)
(*
(*
- * Copyright (C) 2006-2009 Citrix Systems Inc.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent@xensource.com>
*
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
*)
type t
projects / xcp / xen-api-libs.git / commitdiff