]>
git.proxmox.com Git - qemu-server.git/blob - PVE/QMPClient.pm
1 package PVE
::QMPClient
;
10 # Qemu Monitor Protocol (QMP) client.
12 # This implementation uses IO::Multiplex (libio-multiplex-perl) and
13 # allows you to issue qmp commands to different VMs in parallel.
15 # Note: kvm can onyl handle 1 connection, so we close connections asap
18 my ($class, $eventcb) = @_;
20 my $mux = new IO
::Multiplex
;
24 fhs
=> {}, # $vmid => fh
25 fhs_lookup
=> {}, # $fh => $vmid
31 $self->{eventcb
} = $eventcb if $eventcb;
33 $mux->set_callback_object($self);
38 # add a single command to the queue for later execution
39 # with queue_execute()
41 my ($self, $vmid, $callback, $execute, %params) = @_;
44 $cmd->{execute
} = $execute;
45 $cmd->{arguments
} = \
%params;
46 $cmd->{callback
} = $callback;
48 push @{$self->{queue
}->{$vmid}}, $cmd;
51 # execute a single command
53 my ($self, $vmid, $cmd, $timeout) = @_;
58 my ($vmid, $resp) = @_;
59 $result = $resp->{'return'};
62 die "no command specified" if !($cmd && $cmd->{execute
});
64 $cmd->{callback
} = $callback;
65 $cmd->{arguments
} = {} if !defined($cmd->{arguments
});
67 $self->{queue
}->{$vmid} = [ $cmd ];
70 # hack: monitor sometime blocks
71 if ($cmd->{execute
} eq 'query-migrate') {
72 $timeout = 60*60; # 1 hour
73 } elsif ($cmd->{execute
} =~ m/^(eject|change)/) {
74 $timeout = 60; # note: cdrom mount command is slow
76 $timeout = 3; # default
80 $self->queue_execute($timeout);
82 my $cmdstr = $cmd->{execute
} || '';
83 die "VM $vmid qmp command '$cmdstr' failed - $self->{errors}->{$vmid}"
84 if defined($self->{errors
}->{$vmid});
90 my $next_cmdid = sub {
92 return "$$:$cmdid_seq";
95 my $close_connection = sub {
96 my ($self, $vmid) = @_;
98 my $fh = $self->{fhs
}->{$vmid};
101 delete $self->{fhs
}->{$vmid};
102 delete $self->{fhs_lookup
}->{$fh};
104 $self->{mux
}->close($fh);
107 my $open_connection = sub {
108 my ($self, $vmid) = @_;
110 my $sname = PVE
::QemuServer
::qmp_socket
($vmid);
112 my $fh = IO
::Socket
::UNIX-
>new(Peer
=> $sname, Blocking
=> 0, Timeout
=> 1) ||
113 die "unable to connect to VM $vmid socket - $!\n";
115 $self->{fhs
}->{$vmid} = $fh;
116 $self->{fhs_lookup
}->{$fh} = $vmid;
117 $self->{mux
}->add($fh);
122 my $check_queue = sub {
127 foreach my $vmid (keys %{$self->{queue
}}) {
128 my $fh = $self->{fhs
}->{$vmid};
131 if ($self->{errors
}->{$vmid}) {
132 &$close_connection($self, $vmid);
136 if ($self->{current
}->{$vmid}) { # command running, waiting for response
141 if (!scalar(@{$self->{queue
}->{$vmid}})) { # no more commands for the VM
142 &$close_connection($self, $vmid);
148 my $cmd = $self->{current
}->{$vmid} = shift @{$self->{queue
}->{$vmid}};
149 $cmd->{id
} = &$next_cmdid();
151 my $qmpcmd = to_json
({
152 execute
=> $cmd->{execute
},
153 arguments
=> $cmd->{arguments
},
156 $self->{mux
}->write($fh, $qmpcmd);
159 $self->{errors
}->{$vmid} = $err;
165 $self->{mux
}->endloop() if !$running;
170 # execute all queued command
172 my ($self, $timeout) = @_;
174 $timeout = 3 if !$timeout;
176 $self->{current
} = {};
177 $self->{errors
} = {};
179 # open all necessary connections
180 foreach my $vmid (keys %{$self->{queue
}}) {
181 next if !scalar(@{$self->{queue
}->{$vmid}}); # no commands for the VM
184 my $fh = &$open_connection($self, $vmid);
185 my $cmd = { execute
=> 'qmp_capabilities', arguments
=> {} };
186 unshift @{$self->{queue
}->{$vmid}}, $cmd;
187 $self->{mux
}->set_timeout($fh, $timeout);
191 $self->{errors
}->{$vmid} = $err;
199 $running = &$check_queue($self);
206 # make sure we close everything
207 foreach my $vmid (keys %{$self->{fhs
}}) {
208 &$close_connection($self, $vmid);
211 $self->{queue
} = $self->{current
} = $self->{fhs
} = $self->{fhs_lookup
} = {};
214 # mux_input is called when input is available on one of
217 my ($self, $mux, $fh, $input) = @_;
219 return if $$input !~ m/}\r\n$/;
223 # Remove the input from the input buffer.
226 my $vmid = $self->{fhs_lookup
}->{$fh};
228 warn "internal error - unable to lookup vmid";
233 my @jsons = split("\n", $raw);
235 foreach my $json (@jsons) {
236 my $obj = from_json
($json);
237 next if defined($obj->{QMP
}); # skip monitor greeting
239 if (exists($obj->{error
}->{desc
})) {
240 my $desc = $obj->{error
}->{desc
};
242 die "$desc\n" if $desc !~ m/Connection can not be completed immediately/;
246 if (defined($obj->{event
})) {
247 if (my $eventcb = $self->{eventcb
}) {
253 my $cmdid = $obj->{id
};
254 die "received responsed without command id\n" if !$cmdid;
256 my $curcmd = $self->{current
}->{$vmid};
257 die "unable to lookup current command for VM $vmid\n" if !$curcmd;
259 delete $self->{current
}->{$vmid};
261 if ($curcmd->{id
} ne $cmdid) {
262 die "got wrong command id '$cmdid' (expected $curcmd->{id})\n";
265 if (my $callback = $curcmd->{callback
}) {
266 &$callback($vmid, $obj);
271 $self->{errors
}->{$vmid} = $err;
274 &$check_queue($self);
277 # This gets called every second to update player info, etc...
279 my ($self, $mux, $fh) = @_;
281 if (my $vmid = $self->{fhs_lookup
}->{$fh}) {
282 $self->{errors
}->{$vmid} = "got timeout\n";
285 &$check_queue($self);