#!/usr/bin/env perl
# IBM(c) 2007 EPL license http://www.eclipse.org/legal/epl-v10.html
package xCAT_plugin::xen;

BEGIN
{
    $::XCATROOT = $ENV{'XCATROOT'} ? $ENV{'XCATROOT'} : '/opt/xcat';
}
use lib "$::XCATROOT/lib/perl";
use xCAT::GlobalDef;
use xCAT::NodeRange;
use xCAT_monitoring::monitorctrl;

use xCAT::Table;
use XML::Simple qw(XMLout);
use IO::Socket;
use IO::Select;
use xCAT::Usage;
use strict;

#use warnings;
my %vm_comm_pids;
my @destblacklist;
my $vmhash;
my $hmhash;
my $bptab;
my $bphash;

use XML::Simple;
$XML::Simple::PREFERRED_PARSER = 'XML::Parser';
use Data::Dumper;
use POSIX "WNOHANG";
use Storable qw(freeze thaw);
use IO::Select;
use IO::Handle;
use Time::HiRes qw(gettimeofday sleep usleep);
use xCAT::DBobjUtils;
use Getopt::Long;
use xCAT::SvrUtils;
use xCAT::TableUtils;
use xCAT::ServiceNodeUtils;

my %runningstates;
my $vmmaxp = 64;
my $mactab;
my $nrtab;
my $machash;
my $status_noop = "XXXno-opXXX";

sub handled_commands {

    #unless ($libvirtsupport) {
    #    return {};
    #}
    return {
        rpower     => 'nodehm:power,mgt',
        mkvm       => 'nodehm:power,mgt',
        rmigrate   => 'nodehm:mgt',
        getxencons => 'nodehm:mgt',

        #rvitals => 'nodehm:mgt',
        #rinv => 'nodehm:mgt',
        getrvidparms => 'nodehm:mgt',
        rbeacon      => 'nodehm:mgt',
        revacuate    => 'hypervisor:type',

        #rspreset => 'nodehm:mgt',
        #rspconfig => 'nodehm:mgt',
        #rbootseq => 'nodehm:mgt',
        #reventlog => 'nodehm:mgt',
        mkinstall => 'nodehm:mgt=(xen)',
    };
}

my $virsh;
my $vmhash;
my $hypconn;
my $hyp;
my $doreq;
my %hyphash;
my $node;
my $hmtab;
my $vmtab;
my $chaintab;
my $chainhash;

sub waitforack {
    my $sock   = shift;
    my $select = new IO::Select;
    $select->add($sock);
    my $str;
    if ($select->can_read(60)) { # Continue after 10 seconds, even if not acked...
        if ($str = <$sock>) {
        } else {
            $select->remove($sock);    #Block until parent acks data
        }
    }
}

sub build_oshash {
    my $node = shift;
    my %rethash;
    my $is_pv = $vmhash->{$node}->[0]->{'virtflags'} =~ 'paravirt' ? 1 : 0;
    if ($is_pv) {
        $rethash{type}->{content} = 'linux';
    } else {
        $rethash{type}->{content}   = 'hvm';
        $rethash{loader}->{content} = '/usr/lib/xen/boot/hvmloader';
        if (defined $vmhash->{$node}->[0]->{bootorder}) {
            my $bootorder = $vmhash->{$node}->[0]->{bootorder};
            my @bootdevs  = split(/[:,]/, $bootorder);
            my $bootnum   = 0;
            foreach (@bootdevs) {
                $rethash{boot}->[$bootnum]->{dev} = $_;
                $bootnum++;
            }
        } else {
            $rethash{boot}->[0]->{dev} = 'network';
            $rethash{boot}->[1]->{dev} = 'hd';
        }
    }
    return \%rethash;
}

sub build_diskstruct {
    my $node    = shift;
    my @returns = ();
    my $currdev;
    my @suffixes = ('a' .. 'z');
    my $suffidx  = 0;
    my $is_pv    = $vmhash->{$node}->[0]->{'virtflags'} =~ 'paravirt' ? 1 : 0;
    if (defined $vmhash->{$node}->[0]->{storage}) {
        my $disklocs = $vmhash->{$node}->[0]->{storage};
        my @locations = split /\|/, $disklocs;
        foreach my $disk (@locations) {

            #Setting default values of a virtual disk backed by a file at hd*.
            my $diskhash;
            $diskhash->{type}   = 'file';
            $diskhash->{device} = 'disk';
            if ($is_pv) {
                $diskhash->{target}->{dev} = 'xvd' . $suffixes[$suffidx];
            } else {
                $diskhash->{target}->{dev} = 'hd' . $suffixes[$suffidx];
            }

            my @disk_parts = split(/,/, $disk);

            #Find host file and determine if it is a file or a block device.
            if (substr($disk_parts[0], 0, 4) eq 'phy:') {
                $diskhash->{type} = 'block';
                $diskhash->{source}->{dev} = substr($disk_parts[0], 4);
            } else {
                $diskhash->{source}->{file} = $disk_parts[0];
            }

            #See if there are any other options. If not, increment suffidx because the already determined device node was used.
            if (@disk_parts gt 1) {
                my @disk_opts = split(/:/, $disk_parts[1]);
                if ($disk_opts[0] ne '') {
                    $diskhash->{target}->{dev} = $disk_opts[0];
                } else {
                    $suffidx++;
                }
                if ($disk_opts[1] eq 'cdrom') {
                    $diskhash->{device} = 'cdrom';
                }
            } else {
                $suffidx++;
            }

            push @returns, $diskhash;
        }
    }
    return \@returns;
}

sub getNodeUUID {
    my $node = shift;
    return xCAT::Utils::genUUID();
}

sub build_nicstruct {
    my $rethash;
    my $node = shift;
    my @macs = ();
    if ($machash->{$node}->[0]->{mac}) {
        my $macdata = $machash->{$node}->[0]->{mac};
        foreach my $macaddr (split /\|/, $macdata) {
            $macaddr =~ s/\!.*//;
            push @macs, $macaddr;
        }
    }
    unless (scalar(@macs)) {
        my $allbutmult = 65279; # & mask for bitwise clearing of the multicast bit of mac
        my $localad    = 512;   # | to set the bit for locally admnistered mac address
        my $leading = int(rand(65535));
        $leading = $leading | 512;
        $leading = $leading & 65279;
        my $n = inet_aton($node);
        my $tail;
        if ($n) {
            $tail = unpack("N", $n);
        }
        unless ($tail) {
            $tail = int(rand(4294967295));
        }
        my $macstr = sprintf("%04x%08x", $leading, $tail);
        $macstr =~ s/(..)(..)(..)(..)(..)(..)/$1:$2:$3:$4:$5:$6/;
        $mactab->setNodeAttribs($node, { mac => $macstr });
        $nrtab->setNodeAttribs($node, { netboot => 'pxe' });
        $doreq->({ command => ['makedhcp'], node => [$node] });
        push @macs, $macstr;
    }
    my @rethashes;
    foreach (@macs) {
        my $rethash;
        $rethash->{type}             = 'bridge';
        $rethash->{mac}->{address}   = $_;
        $rethash->{source}->{bridge} = 'xenbr0';
        push @rethashes, $rethash;
    }
    return \@rethashes;
}

sub getUnits {
    my $amount  = shift;
    my $defunit = shift;
    my $divisor = shift;
    unless ($divisor) {
        $divisor = 1;
    }
    if ($amount =~ /(\D)$/) {    #If unitless, add unit
        $defunit = $1;
        chop $amount;
    }
    if ($defunit =~ /k/i) {
        return $amount * 1024 / $divisor;
    } elsif ($defunit =~ /m/i) {
        return $amount * 1048576 / $divisor;
    } elsif ($defunit =~ /g/i) {
        return $amount * 1073741824 / $divisor;
    }
}

sub build_xmldesc {
    my $node  = shift;
    my %xtree = ();
    my $is_pv = $vmhash->{$node}->[0]->{'virtflags'} =~ 'paravirt' ? 1 : 0;
    $xtree{type} = 'xen';
    if (!$is_pv) {
        $xtree{image} = 'hvm';
    }
    $xtree{name}->{content} = $node;
    $xtree{uuid}->{content} = getNodeUUID($node);
    $xtree{os}              = build_oshash($node);
    if (defined $vmhash->{$node}->[0]->{memory}) {
        $xtree{memory}->{content} = getUnits($vmhash->{$node}->[0]->{memory}, "M", 1024);
    } else {
        $xtree{memory}->{content} = 524288;
    }
    $xtree{vcpu}->{content}     = 1;
    $xtree{features}->{pae}     = {};
    $xtree{features}->{acpi}    = {};
    $xtree{features}->{apic}    = {};
    $xtree{features}->{content} = "\n";
    unless ($is_pv) {
        $xtree{devices}->{emulator}->{content} = '/usr/lib64/xen/bin/qemu-dm';
    }
    $xtree{devices}->{disk}                      = build_diskstruct($node);
    $xtree{devices}->{interface}                 = build_nicstruct($node);
    $xtree{devices}->{graphics}->{type}          = 'vnc';
    $xtree{devices}->{graphics}->{'listen'}      = '0.0.0.0';
    $xtree{devices}->{console}->{type}           = 'pty';
    $xtree{devices}->{console}->{target}->{port} = '1';
    if ($is_pv) {
        $xtree{bootloader}{content} = '/usr/bin/pypxeboot';
        $xtree{bootloader_args}{content} = 'mac=' . $xtree{devices}{interface}[0]{mac}{address};
    }
    $xtree{on_poweroff}{content} = 'destroy';
    $xtree{on_reboot}{content}   = 'restart';
    return XMLout(\%xtree, RootName => "domain", KeyAttr => {});
}

sub refresh_vm {
    my $dom = shift;

    my $newxml  = XMLin($dom->get_xml_description());
    my $vncport = $newxml->{devices}->{graphics}->{port};
    my $stty    = $newxml->{devices}->{console}->{tty};
    $vmtab->setNodeAttribs($node, { vncport => $vncport, textconsole => $stty });
    return { vncport => $vncport, textconsole => $stty };
}

sub getvmcons {
    my $node = shift();
    my $type = shift();
    my $dom;
    eval {
        $dom = $hypconn->get_domain_by_name($node);
    };
    unless ($dom) {
        return 1, "Unable to query running VM";
    }
    my $consdata = refresh_vm($dom);
    my $hyper    = $vmhash->{$node}->[0]->{host};

    if ($type eq "text") {
        my $serialspeed;
        if ($hmhash) {
            $serialspeed = $hmhash->{$node}->[0]->{serialspeed};
        }
        my $sconsparms = { node => [ { name => [$node] } ] };
        $sconsparms->{node}->[0]->{sshhost}   = [$hyper];
        $sconsparms->{node}->[0]->{psuedotty} = [ $consdata->{textconsole} ];
        $sconsparms->{node}->[0]->{baudrate}  = [$serialspeed];
        return (0, $sconsparms);
    } elsif ($type eq "vnc") {
        my $domdata  = `ssh $hyper xm list $node -l`;
        my @domlines = split /\n/, $domdata;
        my $foundvfb = 0;
        my $vnclocation;
        foreach (@domlines) {
            if (/\(vfb/) {
                $foundvfb = 1;
            }
            if ($foundvfb and /location\s+([^\)]+)/) {
                $vnclocation = $1;
                $foundvfb    = 0;
                last;
            }
        }
        return (0, 'ssh+vnc@' . $hyper . ": " . $vnclocation); #$consdata->{vncport});
    }
}

sub getrvidparms {
    my $node = shift;
    my $location = getvmcons($node, "vnc");
    if ($location =~ /ssh\+vnc@([^:]*):([^:]*):(\d+)/) {
        my @output = (
            "method: xen",
            "server: $1",
            "vncdisplay: $2:$3",
        );
        return 0, @output;
    } else {
        return (1, "Error: Unable to determine rvid destination for $node");
    }
}

sub pick_target {
    my $node = shift;
    my $target;
    my $leastusedmemory = undef;
    my $currentusedmemory;
    my $candidates = $vmhash->{$node}->[0]->{migrationdest};
    my $currhyp    = $vmhash->{$node}->[0]->{host};
    unless ($candidates) {
        return undef;
    }
    print "$node with $candidates\n";
    foreach (noderange($candidates)) {
        my $targconn;
        my $cand = $_;
        $currentusedmemory = 0;
        if ($_ eq $currhyp) { next; }    #skip current node
        if (grep { "$_" eq $cand } @destblacklist) { print "$_ was blacklisted\n"; next; } #skip blacklisted destinations
        print "maybe $_\n";
        eval { #Sys::Virt has bugs that cause it to die out in weird ways some times, contain it here
            $targconn = Sys::Virt->new(uri => "xen+ssh://" . $_ . "?no_tty=1&netcat=nc");
        };
        unless ($targconn) {
            eval { #Sys::Virt has bugs that cause it to die out in weird ways some times, contain it here
                $targconn = Sys::Virt->new(uri => "xen+ssh://" . $_ . "?no_tty=1");
            };
        }
        unless ($targconn) { next; }    #skip unreachable destinations
        foreach ($targconn->list_domains()) {
            if ($_->get_name() eq 'Domain-0') { next; } #Dom0 memory usage is elastic, we are interested in HVM DomU memory, which is inelastic

            $currentusedmemory += $_->get_info()->{memory};
        }
        if (not defined($leastusedmemory)) {
            $leastusedmemory = $currentusedmemory;
            $target          = $_;
        } elsif ($currentusedmemory < $leastusedmemory) {
            $leastusedmemory = $currentusedmemory;
            $target          = $_;
        }
    }
    return $target;
}


sub migrate {
    my $node = shift();
    my $targ = shift();
    unless ($targ) {
        $targ = pick_target($node);
    }
    unless ($targ) {
        return (1, "Unable to identify a suitable target host for guest $node");
    }
    my $prevhyp;
    my $target  = "xen+ssh://" . $targ . "?no_tty=1";
    my $currhyp = "xen+ssh://";
    if ($vmhash->{$node}->[0]->{host}) {
        $prevhyp = $vmhash->{$node}->[0]->{host};
        $currhyp .= $prevhyp;
    } else {
        return (1, "Unable to find current location of $node");
    }
    $currhyp .= "?no_tty=1";
    if ($currhyp eq $target) {
        return (0, "Guest is already on host $targ");
    }
    my $testhypconn;
    my $srcnetcatadd = "&netcat=nc";
    eval {    #Contain Sys::Virt bugs
        $testhypconn = Sys::Virt->new(uri => "xen+ssh://" . $prevhyp . "?no_tty=1$srcnetcatadd");
    };
    unless ($testhypconn) {
        $srcnetcatadd = "";
        eval {    #Contain Sys::Virt bugs
            $testhypconn = Sys::Virt->new(uri => "xen+ssh://" . $prevhyp . "?no_tty=1");
        };
    }
    unless ($testhypconn) {
        return (1, "Unable to reach $prevhyp to perform operation of $node, use nodech to change vm.host if certain of no split-brain possibility exists");
    }
    undef $testhypconn;
    my $destnetcatadd = "&netcat=nc";
    eval {        #Contain Sys::Virt bugs
        $testhypconn = Sys::Virt->new(uri => $target . $destnetcatadd);
    };
    unless ($testhypconn) {
        $destnetcatadd = "";
        eval {    #Contain Sys::Virt bugs
            $testhypconn = Sys::Virt->new(uri => $target);
        };
    }
    unless ($testhypconn) {
        return (1, "Unable to reach $targ to perform operation of $node, destination unusable.");
    }
    my $sock = IO::Socket::INET->new(Proto => 'udp');
    my $ipa = inet_aton($node);
    my $pa = sockaddr_in(7, $ipa);  #UDP echo service, not needed to be actually
        #serviced, we just want to trigger MAC move in the switch forwarding dbs
    my $rc = system("virsh -c '$currhyp" . $srcnetcatadd . "' migrate --live $node '$target" . "$destnetcatadd'");
    system("arp -d $node");    #Make ethernet fabric take note of change
    send($sock, "dummy", 0, $pa); #UDP packet to force forwarding table update in switches, ideally a garp happened, but just in case...

    if ($rc) {
        return (1, "Failed migration from $prevhyp to $targ");
    } else {
        $vmtab->setNodeAttribs($node, { host => $targ });
        my $newhypconn;
        eval {                    #Contain Sys::Virt bugs
            $newhypconn = Sys::Virt->new(uri => "xen+ssh://" . $targ . "?no_tty=1&netcat=nc");
        };
        unless ($newhypconn) {
            eval {                #Contain Sys::Virt bugs
                $newhypconn = Sys::Virt->new(uri => "xen+ssh://" . $targ . "?no_tty=1");
            };
        }
        if ($newhypconn) {
            my $dom;
            eval {
                $dom = $newhypconn->get_domain_by_name($node);
            };
            if ($dom) {
                refresh_vm($dom);
            }
        } else {
            return (0, "migrated to $targ");
        }
        return (0, "migrated to $targ");
    }
}


sub getpowstate {
    my $dom = shift;
    my $vmstat;
    if ($dom) {
        $vmstat = $dom->get_info;
    }
    if ($vmstat and $runningstates{ $vmstat->{state} }) {
        return "on";
    } else {
        return "off";
    }
}

sub makedom {
    my $node = shift;
    my $dom;
    my $xml = build_xmldesc($node);
    my $errstr;
    eval { $dom = $hypconn->create_domain($xml); };
    if ($@) { $errstr = $@; }
    if (ref $errstr) {
        $errstr = ":" . $errstr->{message};
    }
    if ($errstr) { return (undef, $errstr); }
    if ($dom) {
        refresh_vm($dom);
    }
    return $dom, undef;
}


sub mkvm {
    build_xmldesc($node);
}

sub power {
    my $subcommand = shift;
    my $retstring;
    my $dom;
    eval {
        $dom = $hypconn->get_domain_by_name($node);
    };
    if ($subcommand eq "boot") {
        my $currstate = getpowstate($dom);
        $retstring = $currstate . " ";
        if ($currstate eq "off") {
            $subcommand = "on";
        } elsif ($currstate eq "on") {
            $subcommand = "reset";
        }
    }
    my $errstr;
    if ($subcommand eq 'on') {
        unless ($dom) {
            ($dom, $errstr) = makedom($node);
            if ($errstr) { return (1, $errstr); }
        } else {
            $retstring .= " $status_noop";
        }
    } elsif ($subcommand eq 'off') {
        if ($dom) {
            $dom->destroy();
            undef $dom;
        } else { $retstring .= " $status_noop"; }
    } elsif ($subcommand eq 'softoff') {
        if ($dom) {
            $dom->shutdown();
        } else { $retstring .= " $status_noop"; }
    } elsif ($subcommand eq 'reset') {
        if ($dom) {
            $dom->destroy();
            ($dom, $errstr) = makedom($node);
            if ($errstr) { return (1, $errstr); }
            $retstring .= "reset";
        } else { $retstring .= " $status_noop"; }
    } else {
        unless ($subcommand =~ /^stat/) {
            return (1, "Unsupported power directive '$subcommand'");
        }
    }

    unless ($retstring =~ /reset/) {
        $retstring = getpowstate($dom) . $retstring;
    }
    return (0, $retstring);
}


sub guestcmd {
    $hyp  = shift;
    $node = shift;
    my $command = shift;
    my @args    = @_;
    my $error;
    if ($command eq "rpower") {
        return power(@args);
    } elsif ($command eq "mkvm") {
        return mkvm();
    } elsif ($command eq "rmigrate") {
        return migrate($node, @args);
    } elsif ($command eq "getrvidparms") {
        return getrvidparms($node, @args);
    } elsif ($command eq "getxencons") {
        return getvmcons($node, @args);
    }

    return (1, "$command not a supported command by xen method");
}

sub preprocess_request {
    my $request = shift;

    #if already preprocessed, go straight to request
    if ($request->{_xcatpreprocessed}->[0] == 1) { return [$request]; }

    my $callback = shift;
    my @requests;

    my $noderange = $request->{node};           #Should be arrayref
    my $command   = $request->{command}->[0];
    my $extrargs  = $request->{arg};
    my @exargs    = ($request->{arg});
    if (ref($extrargs)) {
        @exargs = @$extrargs;
    }

    my $usage_string = xCAT::Usage->parseCommand($command, @exargs);
    if ($usage_string) {
        $callback->({ data => $usage_string });
        $request = {};
        return;
    }

    if (!$noderange) {
        $usage_string = xCAT::Usage->getUsage($command);
        $callback->({ data => $usage_string });
        $request = {};
        return;
    }

    #print "noderange=@$noderange\n";

    # find service nodes for requested nodes
    # build an individual request for each service node
    my $service = "xcat";
    my $sn = xCAT::ServiceNodeUtils->get_ServiceNode($noderange, $service, "MN");

    # build each request for each service node

    foreach my $snkey (keys %$sn)
    {
        #print "snkey=$snkey\n";
        my $reqcopy = {%$request};
        $reqcopy->{node}                   = $sn->{$snkey};
        $reqcopy->{'_xcatdest'}            = $snkey;
        $reqcopy->{_xcatpreprocessed}->[0] = 1;

        push @requests, $reqcopy;
    }
    return \@requests;
}


sub adopt {

    #TODO: adopt orphans into suitable homes if possible
    return 0;
}

sub grab_table_data {    #grab table data relevent to VM guest nodes
    my $noderange = shift;
    my $callback  = shift;
    $vmtab = xCAT::Table->new("vm");
    $hmtab = xCAT::Table->new("nodehm");
    if ($hmtab) {
        $hmhash = $hmtab->getNodesAttribs($noderange, ['serialspeed']);
    }
    unless ($vmtab) {
        $callback->({ data => ["Cannot open vm table"] });
        return;
    }
    $vmhash = $vmtab->getNodesAttribs($noderange, [ 'node', 'host', 'migrationdest', 'storage', 'memory', 'cpu', 'nics', 'bootorder', 'virtflags' ]);
    $mactab = xCAT::Table->new("mac",     -create => 1);
    $nrtab  = xCAT::Table->new("noderes", -create => 1);
    $machash = $mactab->getNodesAttribs($noderange, ['mac']);
    $chaintab = xCAT::Table->new("chain", -create => 1);
    $chainhash = $chaintab->getNodesAttribs($noderange, ['currstate']);
    $bptab = xCAT::Table->new("bootparams", -create => 1);
    $bphash = $bptab->getNodesAttribs($noderange, [ 'kernel', 'initrd' ]);
}

sub process_request {
    $SIG{INT} = $SIG{TERM} = sub {
        foreach (keys %vm_comm_pids) {
            kill 2, $_;
        }
        exit 0;
    };

    #makes sense to check it here anyway, this way we avoid the main process
    #sucking up ram with Sys::Virt
    my $libvirtsupport = eval { require Sys::Virt; };
    my $request        = shift;
    my $callback       = shift;
    unless ($libvirtsupport) {    #Still no Sys::Virt module
        $callback->({ error => "Sys::Virt perl module missing, unable to fulfill Xen plugin requirements", errorcode => [42] });
        return [];
    }
    require Sys::Virt::Domain;
    %runningstates = (&Sys::Virt::Domain::STATE_NOSTATE => 1, &Sys::Virt::Domain::STATE_RUNNING => 1, &Sys::Virt::Domain::STATE_BLOCKED => 1);

    $doreq = shift;
    my $level     = shift;
    my $noderange = $request->{node};
    my $command   = $request->{command}->[0];
    my @exargs;
    unless ($command) {
        return;    #Empty request
    }
    if (ref($request->{arg})) {
        @exargs = @{ $request->{arg} };
    } else {
        @exargs = ($request->{arg});
    }

     #pdu commands will be handled in the pdu plugin
     if ($command eq "rpower" and grep(/^pduon|pduoff|pdustat$/, @exargs)) {
         return;
     }
     
    if ($command eq 'revacuate') {
        my $newnoderange;
        foreach (@$noderange) {
            $hypconn = undef;
            push @destblacklist, $_;
            eval {    #Contain bugs that won't be in $@
                $hypconn = Sys::Virt->new(uri => "xen+ssh://" . $_ . "?no_tty=1&netcat=nc");
            };
            unless ($hypconn) {    #retry for socat
                eval {             #Contain bugs that won't be in $@
                    $hypconn = Sys::Virt->new(uri => "xen+ssh://" . $_ . "?no_tty=1");
                };
            }
            unless ($hypconn) {
                $callback->({ node => [ { name => [$_], error => ["Cannot communicate BC via libvirt to node"] } ] });
                next;
            }
            foreach ($hypconn->list_domains()) {
                my $guestname = $_->get_name();
                if ($guestname eq 'Domain-0') {
                    next;
                }
                push @$newnoderange, $guestname;
            }
        }
        $hypconn   = undef;
        $noderange = $newnoderange;
        $command   = 'rmigrate';
    }

    grab_table_data($noderange, $callback);
    if ($command eq 'mkinstall') {
        $DB::single = 1;
        eval {
            require xCAT_plugin::anaconda;
            xCAT_plugin::anaconda::mkinstall($request, $callback, $doreq);
            for my $node (@{ $request->{node} }) {
                my $is_pv = $vmhash->{$node}->[0]->{'virtflags'} =~ 'paravirt' ? 1 : 0;
                if ($is_pv) {
                    my $kernel = $bphash->{$node}[0]{kernel};
                    my $initrd = $bphash->{$node}[0]{initrd};
                    $kernel =~ s|vmlinuz|xen/vmlinuz|;
                    $initrd =~ s|initrd\.img|xen/initrd\.img|;
                    $bptab->setNodeAttribs($node, { kernel => $kernel, initrd => $initrd });
                }
            }
        };

        if ($@) {
            $callback->({ error => $@, errorcode => [1] });
        }
        return;
    }

    if ($command eq 'revacuate' or $command eq 'rmigrate') {
        $vmmaxp = 1; #for now throttle concurrent migrations, requires more sophisticated heuristics to ensure sanity
    } else {

        #my $sitetab = xCAT::Table->new('site');
        #my $tmp;
        #if ($sitetab) {
        #($tmp)=$sitetab->getAttribs({'key'=>'vmmaxp'},'value');
        my @entries = xCAT::TableUtils->get_site_attribute("vmmaxp");
        my $t_entry = $entries[0];
        if (defined($t_entry)) { $vmmaxp = $t_entry; }

        #}
    }

    my $children = 0;
    $SIG{CHLD} = sub { my $cpid; while (($cpid = waitpid(-1, WNOHANG)) > 0) { if ($vm_comm_pids{$cpid}) { delete $vm_comm_pids{$cpid}; $children--; } } };
    my $inputs  = new IO::Select;
    my $sub_fds = new IO::Select;
    %hyphash = ();
    my %orphans = ();
    foreach (keys %{$vmhash}) {
        if ($vmhash->{$_}->[0]->{host}) {
            $hyphash{ $vmhash->{$_}->[0]->{host} }->{nodes}->{$_} = 1;
        } else {
            $orphans{$_} = 1;
        }
    }
    if (keys %orphans) {
        if ($command eq "rpower" and (grep /^on$/, @exargs or grep /^boot$/, @exargs)) {
            unless (adopt(\%orphans, \%hyphash)) {
                $callback->({ error => "Can't find " . join(",", keys %orphans), errorcode => [1] });
                return 1;
            }

        } elsif ($command eq "rmigrate") {
            $callback->({ error => "Can't find " . join(",", keys %orphans), errorcode => [1] });
            return;
        } else {
            $callback->({ error => "Can't find " . join(",", keys %orphans), errorcode => [1] });
            return;
        }
    }
    if ($command eq "rbeacon") {
        my %req = ();
        $req{command} = ['rbeacon'];
        $req{arg}     = \@exargs;
        $req{node}    = [ keys %hyphash ];
        $doreq->(\%req, $callback);
        return;
    }

    #get new node status
    my %oldnodestatus = ();    #saves the old node status
    my @allerrornodes = ();
    my $check         = 0;
    my $global_check  = 1;

    #my $sitetab = xCAT::Table->new('site');
    #if ($sitetab) {
    #(my $ref) = $sitetab->getAttribs({key => 'nodestatus'}, 'value');
    my @entries = xCAT::TableUtils->get_site_attribute("nodestatus");
    my $t_entry = $entries[0];
    if (defined($t_entry)) {
        if ($t_entry =~ /0|n|N/) { $global_check = 0; }
    }

    #}


    if ($command eq 'rpower') {
        my $subcommand = $exargs[0];
        if (($global_check) && ($subcommand ne 'stat') && ($subcommand ne 'status')) {
            $check = 1;
            my @allnodes = @$noderange;

            #save the old status
            my $nodelisttab = xCAT::Table->new('nodelist');
            if ($nodelisttab) {
                my $tabdata = $nodelisttab->getNodesAttribs(\@allnodes, [ 'node', 'status' ]);
                foreach my $node (@allnodes)
                {
                    my $tmp1 = $tabdata->{$node}->[0];
                    if ($tmp1) {
                        if ($tmp1->{status}) { $oldnodestatus{$node} = $tmp1->{status}; }
                        else                 { $oldnodestatus{$node} = ""; }
                    }
                }
            }

            #print "oldstatus:" . Dumper(\%oldnodestatus);

            #set the new status to the nodelist.status
            my %newnodestatus = ();
            my $newstat;
            if (($subcommand eq 'off') || ($subcommand eq 'softoff')) {
                my $newstat = $::STATUS_POWERING_OFF;
                $newnodestatus{$newstat} = \@allnodes;
            } else {

                #get the current nodeset stat
                if (@allnodes > 0) {
                    my $nsh = {};
                    my ($ret, $msg) = xCAT::SvrUtils->getNodesetStates(\@allnodes, $nsh);
                    if (!$ret) {
                        foreach (keys %$nsh) {
                            my $newstat = xCAT_monitoring::monitorctrl->getNodeStatusFromNodesetState($_, "rpower");
                            $newnodestatus{$newstat} = $nsh->{$_};
                        }
                    } else {
                        $callback->({ data => $msg });
                    }
                }
            }

            #donot update node provision status (installing or netbooting) here
            xCAT::Utils->filter_nostatusupdate(\%newnodestatus);

            #print "newstatus" . Dumper(\%newnodestatus);
            xCAT_monitoring::monitorctrl::setNodeStatusAttributes(\%newnodestatus, 1);
        }
    }



    foreach $hyp (sort (keys %hyphash)) {
        while ($children > $vmmaxp) {
            my $handlednodes = {};
            forward_data($callback, $sub_fds, $handlednodes);

            #update the node status to the nodelist.status table
            if ($check) {
                updateNodeStatus($handlednodes, \@allerrornodes);
            }
        }
        $children++;
        my $cfd;
        my $pfd;
        socketpair($pfd, $cfd, AF_UNIX, SOCK_STREAM, PF_UNSPEC) or die "socketpair: $!";
        $cfd->autoflush(1);
        $pfd->autoflush(1);
        my $cpid = xCAT::Utils->xfork;
        unless (defined($cpid)) { die "Fork error"; }

        unless ($cpid) {
            close($cfd);
            dohyp($pfd, $hyp, $command, -args => \@exargs);
            exit(0);
        }
        $vm_comm_pids{$cpid} = 1;
        close($pfd);
        $sub_fds->add($cfd);
    }
    while ($sub_fds->count > 0 or $children > 0) {
        my $handlednodes = {};
        forward_data($callback, $sub_fds, $handlednodes);

        #update the node status to the nodelist.status table
        if ($check) {
            updateNodeStatus($handlednodes, \@allerrornodes);
        }
    }

    #Make sure they get drained, this probably is overkill but shouldn't hurt
    my $rc = 1;
    while ($rc > 0) {
        my $handlednodes = {};
        $rc = forward_data($callback, $sub_fds, $handlednodes);

        #update the node status to the nodelist.status table
        if ($check) {
            updateNodeStatus($handlednodes, \@allerrornodes);
        }
    }

    if ($check) {

        #print "allerrornodes=@allerrornodes\n";
        #revert the status back for there is no-op for the nodes
        my %old = ();
        foreach my $node (@allerrornodes) {
            my $stat = $oldnodestatus{$node};
            if (exists($old{$stat})) {
                my $pa = $old{$stat};
                push(@$pa, $node);
            }
            else {
                $old{$stat} = [$node];
            }
        }
        xCAT_monitoring::monitorctrl::setNodeStatusAttributes(\%old, 1);
    }
}

sub updateNodeStatus {
    my $handlednodes  = shift;
    my $allerrornodes = shift;
    foreach my $node (keys(%$handlednodes)) {
        if ($handlednodes->{$node} == -1) { push(@$allerrornodes, $node); }
    }
}


sub forward_data {
    my $callback   = shift;
    my $fds        = shift;
    my $errornodes = shift;
    my @ready_fds  = $fds->can_read(1);
    my $rfh;
    my $rc = @ready_fds;
    foreach $rfh (@ready_fds) {
        my $data;
        if ($data = <$rfh>) {
            while ($data !~ /ENDOFFREEZE6sK4ci/) {
                $data .= <$rfh>;
            }
            eval { print $rfh "ACK\n"; };
            my $responses = thaw($data);
            foreach (@$responses) {

                #save the nodes that has errors and the ones that has no-op for use by the node status monitoring
                my $no_op = 0;
                if ($_->{node}->[0]->{errorcode}) { $no_op = 1; }
                else {
                    my $text = $_->{node}->[0]->{data}->[0]->{contents}->[0];

                    #print "data:$text\n";
                    if (($text) && ($text =~ /$status_noop/)) {
                        $no_op = 1;

                        #remove the symbols that meant for use by node status
                        $_->{node}->[0]->{data}->[0]->{contents}->[0] =~ s/ $status_noop//;
                    }
                }

                #print "data:". $_->{node}->[0]->{data}->[0]->{contents}->[0] . "\n";
                if ($no_op) {
                    if ($errornodes) { $errornodes->{ $_->{node}->[0]->{name}->[0] } = -1; }
                } else {
                    if ($errornodes) { $errornodes->{ $_->{node}->[0]->{name}->[0] } = 1; }
                }
                $callback->($_);
            }
        } else {
            $fds->remove($rfh);
            close($rfh);
        }
    }
    usleep(0);    # yield
    return $rc;
}


sub dohyp {
    my $out = shift;
    $hyp = shift;
    my $command   = shift;
    my %namedargs = @_;
    my @exargs    = @{ $namedargs{-args} };
    my $node;
    my $args = \@exargs;
    $vmtab = xCAT::Table->new("vm");


    eval {    #Contain Sys::Virt bugs that make $@ useless
        $hypconn = Sys::Virt->new(uri => "xen+ssh://" . $hyp . "?no_tty=1&netcat=nc");
    };
    unless ($hypconn) {
        eval {    #Contain Sys::Virt bugs that make $@ useless
            $hypconn = Sys::Virt->new(uri => "xen+ssh://" . $hyp . "?no_tty=1");
        };
    }
    unless ($hypconn) {
        my %err = (node => []);
        foreach (keys %{ $hyphash{$hyp}->{nodes} }) {
            push(@{ $err{node} }, { name => [$_], error => ["Cannot communicate via libvirt to $hyp"], errorcode => [1] });
        }
        print $out freeze([ \%err ]);
        print $out "\nENDOFFREEZE6sK4ci\n";
        usleep(0);    # yield
        waitforack($out);
        return 1, "General error establishing libvirt communication";
    }
    foreach $node (sort (keys %{ $hyphash{$hyp}->{nodes} })) {
        my ($rc, @output) = guestcmd($hyp, $node, $command, @$args);

        foreach (@output) {
            my %output;
            if (ref($_)) {
                print $out freeze([$_]);
                print $out "\nENDOFFREEZE6sK4ci\n";
                usleep(0);    # yield
                waitforack($out);
                next;
            }

            (my $desc, my $text) = split(/:/, $_, 2);
            unless ($text) {
                $text = $desc;
            } else {
                $desc =~ s/^\s+//;
                $desc =~ s/\s+$//;
                if ($desc) {
                    $output{node}->[0]->{data}->[0]->{desc}->[0] = $desc;
                }
            }
            $text =~ s/^\s+//;
            $text =~ s/\s+$//;
            $output{node}->[0]->{errorcode}                  = $rc;
            $output{node}->[0]->{name}->[0]                  = $node;
            $output{node}->[0]->{data}->[0]->{contents}->[0] = $text;
            $output{node}->[0]->{error} = $text unless $rc == 0;
            print $out freeze([ \%output ]);
            print $out "\nENDOFFREEZE6sK4ci\n";
            usleep(0);    # yield
            waitforack($out);
        }
        usleep(0);        # yield
    }

    #my $msgtoparent=freeze(\@outhashes); # = XMLout(\%output,RootName => 'xcatresponse');
    #print $out $msgtoparent; #$node.": $_\n";
}

1;