VERSION=2.0
PACKAGE=qemu-server
-PKGREL=42
+PKGREL=43
DESTDIR=
PREFIX=/usr
+PERLSOURCE = \
+ QemuServer.pm \
+ QemuMigrate.pm \
+ QMPClient.pm
.PHONY: install
install:
- install -D -m 0644 QemuServer.pm ${DESTDIR}${PERLDIR}/PVE/QemuServer.pm
- install -D -m 0644 QemuMigrate.pm ${DESTDIR}${PERLDIR}/PVE/QemuMigrate.pm
+ install -d ${DESTDIR}${PERLDIR}/PVE
+ install -m 0644 ${PERLSOURCE} ${DESTDIR}${PERLDIR}/PVE/
make -C VZDump install
make -C API2 install
\ No newline at end of file
-#!/usr/bin/perl -w
-
package PVE::QMPClient;
use strict;
delete $self->{fhs_lookup}->{$fh};
$self->{mux}->close($fh);
-
- print "CLOSE SOCKET to $vmid\n";
-
};
my $open_connection = sub {
my $fh = IO::Socket::UNIX->new(Peer => $sname, Blocking => 0, Timeout => 1) ||
die "unable to connect to VM $vmid socket - $!\n";
- print "OPEN SOCKET to $vmid \n";
-
$self->{fhs}->{$vmid} = $fh;
$self->{fhs_lookup}->{$fh} = $vmid;
$self->{mux}->add($fh);
arguments => $cmd->{arguments},
id => $cmd->{id}});
- print "WRITECMD:$vmid: $qmpcmd\n";
$self->{mux}->write($fh, $qmpcmd);
};
if (my $err = $@) {
$self->{errors}->{$vmid} = $err;
- # fixme: close fh?
} else {
$running++;
}
$timeout = 3 if !$timeout;
- print "start exec queue\n";
-
$self->{current} = {};
$self->{errors} = {};
}
$self->{queue} = $self->{current} = $self->{fhs} = $self->{fhs_lookup} = {};
-
- print "end exec queue $running\n";
-
}
# mux_input is called when input is available on one of
sub mux_input {
my ($self, $mux, $fh, $input) = @_;
- print "GOT: $$input\n";
-
return if $$input !~ m/}\r\n$/;
my $raw = $$input;
next;
}
- # die $obj->{error}->{desc} if defined($obj->{error}->{desc});
-
- #print "GOTOBJ: " . Dumper($obj);
-
- # we do not need events for now
if (defined($obj->{event})) {
if (my $eventcb = $self->{eventcb}) {
&$eventcb($obj);
my ($self, $mux, $fh) = @_;
if (my $vmid = $self->{fhs_lookup}->{$fh}) {
-
- print "GOT timeout for $vmid\n";
-
$self->{errors}->{$vmid} = "got timeout\n";
}
&$check_queue($self);
}
-
-
-package test;
-
-use strict;
-use PVE::SafeSyslog;
-use PVE::INotify;
-use PVE::QemuServer;
-use PVE::Cluster;
-use Data::Dumper;
-
-initlog($0);
-
-$ENV{'PATH'} = '/sbin:/bin:/usr/sbin:/usr/bin';
-
-die "please run as root\n" if $> != 0;
-
-PVE::INotify::inotify_init();
-
-my $nodename = PVE::INotify::nodename();
-
-sub vm_qmp_command {
- my ($vmid, $cmd, $nocheck) = @_;
-
- my $res;
-
- eval {
- die "VM $vmid not running\n" if !PVE::QemuServer::check_running($vmid, $nocheck);
-
- my $qmpclient = PVE::QMPClient->new();
-
- $res = $qmpclient->cmd($vmid, $cmd);
-
- };
- if (my $err = $@) {
- syslog("err", "VM $vmid qmp command failed - $err");
- die $err;
- }
-
- return $res;
-}
-
-# print Dumper(vm_qmp_command(100, { execute => 'query-status' }));
-
-sub update_qemu_stats {
-
- print "start update\n";
-
- my $ctime = time();
-
- my $vmstatus = PVE::QemuServer::vmstatus();
-
- my $qmpclient = PVE::QMPClient->new();
-
- my $res = {};
-
- my $blockstatscb = sub {
- my ($vmid, $resp) = @_;
- my $data = $resp->{'return'} || [];
- my $totalrdbytes = 0;
- my $totalwrbytes = 0;
- for my $blockstat (@$data) {
- $totalrdbytes = $totalrdbytes + $blockstat->{stats}->{rd_bytes};
- $totalwrbytes = $totalwrbytes + $blockstat->{stats}->{wr_bytes};
- }
- $res->{$vmid}->{diskread} = $totalrdbytes;
- $res->{$vmid}->{diskwrite} = $totalwrbytes;
- };
-
- my $statuscb = sub {
- my ($vmid, $resp) = @_;
- $qmpclient->queue_cmd($vmid, $blockstatscb, 'query-blockstats');
-
- my $status = 'unknown';
- if (!defined($status = $resp->{'return'}->{status})) {
- warn "unable to get VM status\n";
- return;
- }
-
- $res->{$vmid}->{status} = $resp->{'return'}->{status};
- };
-
- foreach my $vmid (keys %$vmstatus) {
- my $d = $vmstatus->{$vmid};
- my $data;
- if ($d->{pid}) { # running
-
- $qmpclient->queue_cmd($vmid, $statuscb, 'query-status');
-
- }
- }
- print "start loop\n";
- $qmpclient->queue_execute();
- print "end loop\n";
- print Dumper($res);
- foreach my $vmid (keys %{$qmpclient->{errors}}) {
- my $msg = "qmp error on VM $vmid: $qmpclient->{errors}->{$vmid}";
- chomp $msg;
- warn "$msg\n";
- }
-
- print "end update\n";
-}
-
-for(;;) {
- PVE::Cluster::cfs_update();
- update_qemu_stats();
- sleep(3);
-}
+1;
use PVE::Cluster qw(cfs_register_file cfs_read_file cfs_write_file cfs_lock_file);
use PVE::INotify;
use PVE::ProcFSTools;
+use PVE::QMPClient;
use Time::HiRes qw(gettimeofday);
my $cpuinfo = PVE::ProcFSTools::read_cpuinfo();
});
}
-my $qmp_read_avail = sub {
- my ($fh, $timeout) = @_;
-
- my $sel = new IO::Select;
- $sel->add($fh);
-
- my $res = '';
- my $buf;
-
- my @ready;
- while (scalar (@ready = $sel->can_read($timeout))) {
- my $count;
- if ($count = $fh->sysread($buf, 8192)) {
- $res .= $buf;
- last if $buf =~ (m/}\r\n$/);
- } else {
- if (!defined($count)) {
- die "$!\n";
- }
- last;
- }
- }
-
- die "qmp read timeout\n" if !scalar(@ready);
-
- my @jsons = split("\n", $res);
- my $obj = {};
- my $event = {};
- my $return = {};
- foreach my $json (@jsons) {
- $obj = from_json($json);
- $event = $obj->{event} if exists $obj->{event};
- $return = $obj->{QMP} if exists $obj->{QMP};
- $return = $obj->{"return"} if exists $obj->{"return"};
- die $obj->{error}->{desc} if exists $obj->{error}->{desc} && $obj->{error}->{desc} !~ m/Connection can not be completed immediately/;
- }
-
- return ($return,$event);
-};
-
sub __read_avail {
my ($fh, $timeout) = @_;
sub vm_mon_cmd {
my ($vmid, $execute, %params) = @_;
- my $cmd = {};
- $cmd->{execute} = $execute;
- $cmd->{arguments} = \%params;
- vm_qmp_command($vmid,$cmd);
+ my $cmd = { execute => $execute, arguments => \%params };
+ vm_qmp_command($vmid, $cmd);
}
sub vm_mon_cmd_nocheck {
my ($vmid, $execute, %params) = @_;
- my $cmd = {};
- $cmd->{execute} = $execute;
- $cmd->{arguments} = \%params;
- vm_qmp_command($vmid,$cmd,1);
+ my $cmd = { execute => $execute, arguments => \%params };
+ vm_qmp_command($vmid, $cmd, 1);
}
sub vm_qmp_command {
my ($vmid, $cmd, $nocheck) = @_;
- #http://git.qemu.org/?p=qemu.git;a=blob;f=qmp-commands.hx;h=db980fa811325aeca8ad43472ba468702d4a25a2;hb=HEAD
my $res;
- my $event;
+
eval {
die "VM $vmid not running\n" if !check_running($vmid, $nocheck);
- my $sname = qmp_socket($vmid);
- my $sock = IO::Socket::UNIX->new( Peer => $sname ) ||
- die "unable to connect to VM $vmid socket - $!\n";
-
- my $timeout = 3;
-
- # maybe this works with qmp, need to be tested
-
- # hack: migrate sometime blocks the monitor (when migrate_downtime
- # is set)
-
- $timeout = 60*60 if ($cmd->{execute} =~ m/(migrate)$/);
-
-
- # read banner;
- my $data = &$qmp_read_avail($sock, $timeout);
- # '{"QMP": {"version": {"qemu": {"micro": 93, "minor": 0, "major": 1}, "package": " (qemu-kvm-devel)"}, "capabilities": []}} ';
- die "got unexpected qemu qmp banner\n" if !$data;
-
- my $sel = new IO::Select;
- $sel->add($sock);
-
- #negociation
- my $negociation = '{ "execute": "qmp_capabilities" }';
-
- if (!scalar(my @ready = $sel->can_write($timeout))) {
- die "monitor write error - timeout";
- }
-
- my $b;
- if (!($b = $sock->syswrite($negociation)) || ($b != length($negociation))) {
- die "monitor write error - $!";
- }
-
- $res = &$qmp_read_avail($sock, $timeout);
- # res = '{"return": {}}
- die "qmp negociation error\n" if !$res;
-
- $timeout = 20;
-
- my $cmdjson;
-
- #generate json from hash for complex cmd
- $cmdjson = to_json($cmd);
-
- if ($cmd->{execute} =~ m/(migrate)$/) {
- $timeout = 60*60; # 1 hour
- } elsif ($cmd->{execute} =~ m/^(eject|change)/) {
- $timeout = 60; # note: cdrom mount command is slow
- }
-
-
- if (!($b = $sock->syswrite($cmdjson)) || ($b != length($cmdjson))) {
- die "monitor write error - $!";
- }
-
-
- return if ($cmd->{execute} eq 'q') || ($cmd->{execute} eq 'quit');
+ my $qmpclient = PVE::QMPClient->new();
+ $res = $qmpclient->cmd($vmid, $cmd);
- ($res,$event) = &$qmp_read_avail($sock, $timeout);
};
-
- my $err = $@;
-
- if ($err) {
+ if (my $err = $@) {
syslog("err", "VM $vmid qmp command failed - $err");
die $err;
}
+qemu-server (2.0-43) unstable; urgency=low
+
+ * use new QMPClient code
+
+ -- Proxmox Support Team <support@proxmox.com> Fri, 13 Jul 2012 07:05:28 +0200
+
qemu-server (2.0-42) unstable; urgency=low
* fix pool permission checks on create
Section: admin
Priority: optional
Architecture: @@ARCH@@
-Depends: libc6 (>= 2.7-18), perl (>= 5.10.0-19), libterm-readline-gnu-perl, pve-qemu-kvm (>= 0.11.1) | pve-qemu-kvm-2.6.18, netcat-traditional, libpve-storage-perl, pve-cluster, redhat-cluster-pve, libjson-perl, libjson-xs-perl
+Depends: libc6 (>= 2.7-18), perl (>= 5.10.0-19), libterm-readline-gnu-perl, pve-qemu-kvm (>= 0.11.1) | pve-qemu-kvm-2.6.18, netcat-traditional, libpve-storage-perl, pve-cluster, redhat-cluster-pve, libjson-perl, libjson-xs-perl, libio-multiplex-perl
Conflicts: netcat-openbsd
Maintainer: Proxmox Support Team <support@proxmox.com>
Description: Qemu Server Tools
projects / qemu-server.git / commitdiff