← Back to branch summary

~ressu/+junk/xen-debian

« back to all changes in this revision

Viewing changes to tools/ocaml/libs/xb/xb.ml

  • Committer: sami at haahtinen
  • Author(s): Bastian Blank
  • Date: 2011-03-17 14:12:45 UTC
  • mfrom: (1.1.1 upstream)
  • Revision ID: sami@haahtinen.name-20110317141245-owgqox0l0p3g5857
Tags: 4.1.0~rc6-1
http://bugs.debian.org/596545
* New upstream release candidate.
* Build documentation using pdflatex.
* Use python 2.6. (closes: #596545)
* Fix lintian override.
* Install new tools: xl, xenpaging.
* Enable blktap2.
  - Use own md5 implementation.
  - Fix includes.
  - Fix linking of blktap2 binaries.
  - Remove optimization setting.
* Temporarily disable hvmloader, wants to download ipxe.
* Remove xenstored pid check from xl.

Show diffs side-by-side

added added

removed removed

Lines of Context:
tools/ocaml/libs/xb/xb.ml
 
1
(*
 
2
 * Copyright (C) 2006-2007 XenSource Ltd.
 
3
 * Copyright (C) 2008      Citrix Ltd.
 
4
 * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
 
5
 *
 
6
 * This program is free software; you can redistribute it and/or modify
 
7
 * it under the terms of the GNU Lesser General Public License as published
 
8
 * by the Free Software Foundation; version 2.1 only. with the special
 
9
 * exception on linking described in file LICENSE.
 
10
 *
 
11
 * This program is distributed in the hope that it will be useful,
 
12
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 
13
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 
14
 * GNU Lesser General Public License for more details.
 
15
 *)
 
16
 
 
17
module Op = struct include Op end
 
18
module Packet = struct include Packet end
 
19
 
 
20
exception End_of_file
 
21
exception Eagain
 
22
exception Noent
 
23
exception Invalid
 
24
 
 
25
type backend_mmap =
 
26
{
 
27
        mmap: Mmap.mmap_interface;     (* mmaped interface = xs_ring *)
 
28
        eventchn_notify: unit -> unit; (* function to notify through eventchn *)
 
29
        mutable work_again: bool;
 
30
}
 
31
 
 
32
type backend_fd =
 
33
{
 
34
        fd: Unix.file_descr;
 
35
}
 
36
 
 
37
type backend = Fd of backend_fd | Mmap of backend_mmap
 
38
 
 
39
type partial_buf = HaveHdr of Partial.pkt | NoHdr of int * string
 
40
 
 
41
type t =
 
42
{
 
43
        backend: backend;
 
44
        pkt_in: Packet.t Queue.t;
 
45
        pkt_out: Packet.t Queue.t;
 
46
        mutable partial_in: partial_buf;
 
47
        mutable partial_out: string;
 
48
}
 
49
 
 
50
let init_partial_in () = NoHdr
 
51
        (Partial.header_size (), String.make (Partial.header_size()) '\000')
 
52
 
 
53
let queue con pkt = Queue.push pkt con.pkt_out
 
54
 
 
55
let read_fd back con s len =
 
56
        let rd = Unix.read back.fd s 0 len in
 
57
        if rd = 0 then
 
58
                raise End_of_file;
 
59
        rd
 
60
 
 
61
let read_mmap back con s len =
 
62
        let rd = Xs_ring.read back.mmap s len in
 
63
        back.work_again <- (rd > 0);
 
64
        if rd > 0 then
 
65
                back.eventchn_notify ();
 
66
        rd
 
67
 
 
68
let read con s len =
 
69
        match con.backend with
 
70
        | Fd backfd     -> read_fd backfd con s len
 
71
        | Mmap backmmap -> read_mmap backmmap con s len
 
72
 
 
73
let write_fd back con s len =
 
74
        Unix.write back.fd s 0 len
 
75
 
 
76
let write_mmap back con s len =
 
77
        let ws = Xs_ring.write back.mmap s len in
 
78
        if ws > 0 then
 
79
                back.eventchn_notify ();
 
80
        ws
 
81
 
 
82
let write con s len =
 
83
        match con.backend with
 
84
        | Fd backfd     -> write_fd backfd con s len
 
85
        | Mmap backmmap -> write_mmap backmmap con s len
 
86
 
 
87
let output con =
 
88
        (* get the output string from a string_of(packet) or partial_out *)
 
89
        let s = if String.length con.partial_out > 0 then
 
90
                        con.partial_out
 
91
                else if Queue.length con.pkt_out > 0 then
 
92
                        Packet.to_string (Queue.pop con.pkt_out)
 
93
                else
 
94
                        "" in
 
95
        (* send data from s, and save the unsent data to partial_out *)
 
96
        if s <> "" then (
 
97
                let len = String.length s in
 
98
                let sz = write con s len in
 
99
                let left = String.sub s sz (len - sz) in
 
100
                con.partial_out <- left
 
101
        );
 
102
        (* after sending one packet, partial is empty *)
 
103
        con.partial_out = ""
 
104
 
 
105
let input con =
 
106
        let newpacket = ref false in
 
107
        let to_read =
 
108
                match con.partial_in with
 
109
                | HaveHdr partial_pkt -> Partial.to_complete partial_pkt
 
110
                | NoHdr   (i, buf)    -> i in
 
111
 
 
112
        (* try to get more data from input stream *)
 
113
        let s = String.make to_read '\000' in
 
114
        let sz = if to_read > 0 then read con s to_read else 0 in
 
115
 
 
116
        (
 
117
        match con.partial_in with
 
118
        | HaveHdr partial_pkt ->
 
119
                (* we complete the data *)
 
120
                if sz > 0 then
 
121
                        Partial.append partial_pkt s sz;
 
122
                if Partial.to_complete partial_pkt = 0 then (
 
123
                        let pkt = Packet.of_partialpkt partial_pkt in
 
124
                        con.partial_in <- init_partial_in ();
 
125
                        Queue.push pkt con.pkt_in;
 
126
                        newpacket := true
 
127
                )
 
128
        | NoHdr (i, buf)      ->
 
129
                (* we complete the partial header *)
 
130
                if sz > 0 then
 
131
                        String.blit s 0 buf (Partial.header_size () - i) sz;
 
132
                con.partial_in <- if sz = i then
 
133
                        HaveHdr (Partial.of_string buf) else NoHdr (i - sz, buf)
 
134
        );
 
135
        !newpacket
 
136
 
 
137
let newcon backend = {
 
138
        backend = backend;
 
139
        pkt_in = Queue.create ();
 
140
        pkt_out = Queue.create ();
 
141
        partial_in = init_partial_in ();
 
142
        partial_out = "";
 
143
        }
 
144
 
 
145
let open_fd fd = newcon (Fd { fd = fd; })
 
146
 
 
147
let open_mmap mmap notifyfct =
 
148
        newcon (Mmap {
 
149
                mmap = mmap;
 
150
                eventchn_notify = notifyfct;
 
151
                work_again = false; })
 
152
 
 
153
let close con =
 
154
        match con.backend with
 
155
        | Fd backend   -> Unix.close backend.fd
 
156
        | Mmap backend -> Mmap.unmap backend.mmap
 
157
 
 
158
let is_fd con =
 
159
        match con.backend with
 
160
        | Fd _   -> true
 
161
        | Mmap _ -> false
 
162
 
 
163
let is_mmap con = not (is_fd con)
 
164
 
 
165
let output_len con = Queue.length con.pkt_out
 
166
let has_new_output con = Queue.length con.pkt_out > 0
 
167
let has_old_output con = String.length con.partial_out > 0
 
168
 
 
169
let has_output con = has_new_output con || has_old_output con
 
170
 
 
171
let peek_output con = Queue.peek con.pkt_out
 
172
 
 
173
let input_len con = Queue.length con.pkt_in
 
174
let has_in_packet con = Queue.length con.pkt_in > 0
 
175
let get_in_packet con = Queue.pop con.pkt_in
 
176
let has_more_input con =
 
177
        match con.backend with
 
178
        | Fd _         -> false
 
179
        | Mmap backend -> backend.work_again
 
180
 
 
181
let is_selectable con =
 
182
        match con.backend with
 
183
        | Fd _   -> true
 
184
        | Mmap _ -> false
 
185
 
 
186
let get_fd con =
 
187
        match con.backend with
 
188
        | Fd backend -> backend.fd
 
189
        | Mmap _     -> raise (Failure "get_fd")