xcat-core/xCAT-server/lib/xcat/plugins/lsslp.pm

# IBM(c) 2007 EPL license http://www.eclipse.org/legal/epl-v10.html

package xCAT_plugin::lsslp;
use strict;
use Getopt::Long;
use Socket;
use POSIX "WNOHANG";  
use Storable qw(freeze thaw);
use Time::HiRes qw(gettimeofday);
use IO::Select;
use XML::Simple;
if ($^O =~ /^linux/i) {
 $XML::Simple::PREFERRED_PARSER='XML::Parser';
}
use xCAT::PPCdb;

#######################################
# Perl::SNMP not working on AIX yet
#######################################
if ($^O =~ /^linux/i) {
  eval { require xCAT::MacMap };
  eval { require xCAT_plugin::blade };
}


#######################################
# Constants
#######################################
use constant {
    HARDWARE_SERVICE => "service:management-hardware.IBM",
    SOFTWARE_SERVICE => "service:management-software.IBM",
    WILDCARD_SERVICE => "service:management-*",
    P6_SERVICE       => "service:management-hardware.IBM",
    SERVICE_FSP      => "cec-service-processor",
    SERVICE_BPA      => "bulk-power-controller",
    SERVICE_HMC      => "hardware-management-console",
    SERVICE_IVM      => "integrated-virtualization-manager",
    SERVICE_MM       => "management-module",
    SERVICE_RSA      => "remote-supervisor-adapter",
    SERVICE_RSA2     => "remote-supervisor-adapter-2",
    SLP_CONF         => "/usr/local/etc/slp.conf",
    SLPTOOL          => "/usr/local/bin/slptool",
    TYPE_MM          => "MM",
    TYPE_RSA         => "RSA",
    TYPE_BPA         => "BPA",
    TYPE_HMC         => "HMC",
    TYPE_IVM         => "IVM",
    TYPE_FSP         => "IVM",
    IP_ADDRESSES     => 3,
    TEXT             => 0,
    FORMAT           => 1,
    SUCCESS          => 0,
    RC_ERROR         => 1
};

#######################################
# Globals
#######################################
my %service_slp = (
    @{[ SERVICE_FSP  ]} => TYPE_FSP,
    @{[ SERVICE_BPA  ]} => TYPE_BPA,
    @{[ SERVICE_HMC  ]} => TYPE_HMC,
    @{[ SERVICE_IVM  ]} => TYPE_IVM,
    @{[ SERVICE_MM   ]} => TYPE_MM,
    @{[ SERVICE_RSA  ]} => TYPE_RSA, 
    @{[ SERVICE_RSA2 ]} => TYPE_RSA 
);

#######################################
# SLP display header
#######################################
my @header = (
    ["device",        "%-8s" ],
    ["type-model",    "%-12s"],
    ["serial-number", "%-15s"],
    ["ip-addresses",  "placeholder"],
    ["hostname",      "%s"]
);

#######################################
# Hardware specific SLP attributes
#######################################
my %exattr = (
  @{[ SERVICE_FSP ]} => [
      "bpc-machinetype-model",
      "bpc-serial-number",
      "cage-number"
    ],
  @{[ SERVICE_BPA ]} => [
      "frame-number"
    ]
);

#######################################
# Power methods 
#######################################
my %mgt = (
    lc(TYPE_FSP) => "hmc",
    lc(TYPE_HMC) => "hmc",
    lc(TYPE_MM)  => "blade",
    lc(TYPE_HMC) => "hmc",
    lc(TYPE_IVM) => "ivm",
    lc(TYPE_RSA) => "blade"   
);

my @attribs    = qw(nodetype model serial groups node mgt mpa id);
my $verbose    = 0;
my %ip_addr    = ();
my %slp_result = ();
my %rsp_result = ();
my %opt        = ();
my $maxtries   = 1;
my $openSLP    = 1;
my @converge;
my $macmap;


##########################################################################
# Command handler method from tables
##########################################################################
sub handled_commands {

    if ($^O =~ /^linux/i) {
        $macmap = xCAT::MacMap->new();
    } 
    return( {lsslp=>"lsslp"} );
}


##########################################################################
# Invokes the callback with the specified message                    
##########################################################################
sub send_msg {

    my $request = shift;
    my $ecode   = shift;
    my %output;

    #################################################
    # Called from child process - send to parent
    #################################################
    if ( exists( $request->{pipe} )) {
        my $out = $request->{pipe};

        $output{errorcode} = $ecode;
        $output{data} = \@_;
        print $out freeze( [\%output] );
        print $out "\nENDOFFREEZE6sK4ci\n";
    }
    #################################################
    # Called from parent - invoke callback directly
    #################################################
    elsif ( exists( $request->{callback} )) {
        my $callback = $request->{callback};
        $output{errorcode} = $ecode;
        $output{data} = \@_;
        $callback->( \%output );
    }
}



##########################################################################
# Parse the command line options and operands
##########################################################################
sub parse_args {

    my $request  = shift;
    my $args     = $request->{arg};
    my $cmd      = $request->{command};
    my %services = (
        HMC => SOFTWARE_SERVICE.":".SERVICE_HMC.":",
        IVM => SOFTWARE_SERVICE.":".SERVICE_IVM.":",
        BPA => HARDWARE_SERVICE.":".SERVICE_BPA,
        FSP => HARDWARE_SERVICE.":".SERVICE_FSP,
        RSA => HARDWARE_SERVICE.":".SERVICE_RSA.":",
        MM  => HARDWARE_SERVICE.":".SERVICE_MM.":" 
    );
    #############################################
    # Responds with usage statement
    #############################################
    local *usage = sub {
        my $usage_string = xCAT::Usage->getUsage($cmd);
        return( [$_[0], $usage_string] );
    };
    #############################################
    # No command-line arguments - use defaults
    #############################################
    if ( !defined( $args )) {
        return(0);
    }
    #############################################
    # Checks case in GetOptions, allows opts
    # to be grouped (e.g. -vx), and terminates
    # at the first unrecognized option.
    #############################################
    @ARGV = @$args;
    $Getopt::Long::ignorecase = 0;
    Getopt::Long::Configure( "bundling" );

    #############################################
    # Process command-line flags
    #############################################
    if (!GetOptions( \%opt,
            qw(h|help V|Verbose v|version i=s x z w r s=s e=s t=s m c))) { 
        return( usage() );
    }
    #############################################
    # Check for switch "-" with no option
    #############################################
    if ( grep(/^-$/, @ARGV )) {
        return(usage( "Missing option: -" ));
    }
    #############################################
    # Set convergence 
    #############################################
    if ( exists( $opt{c} )) {
 
        #################################
        # Use values set in slp.conf
        #################################
        if ( !defined( $ARGV[0] )) {
            @converge = (0); 
        }
        #################################
        # Use new values 
        #################################
        else {
            @converge = split /,/,$ARGV[0];
            if ( scalar( @converge ) > 5 ) {
                return(usage( "Convergence timeouts limited to 5 maximum" ));
            }
            foreach ( @converge ) { 
                unless ( /^[1-9]{1}$|^[1-9]{1}[0-9]{1,4}$/) { 
                    return(usage( "Invalid convergence timeout: $_" ));
                }
            }
        }
    } 
    #############################################
    # Check for an argument
    #############################################
    elsif ( defined( $ARGV[0] )) {
        return(usage( "Invalid Argument: $ARGV[0]" ));
    }
    #############################################
    # Option -V for verbose output
    #############################################
    if ( exists( $opt{V} )) {
        $verbose = 1;
    }
    #############################################
    # Check for mutually-exclusive formatting 
    #############################################
    if ( (exists($opt{r}) + exists($opt{x}) + exists($opt{z})) > 1 ) {
        return( usage() );
    }
    #############################################
    # Command tries 
    #############################################
    if ( exists( $opt{t} )) {
       $maxtries = $opt{t};

       if ( $maxtries !~ /^0?[1-5]$/ ) {
           return( usage( "Invalid command tries (1-5)" ));
       }
    }
    #############################################
    # Select SLP command 
    #############################################
    if ( exists( $opt{e} )) {
       if ( $opt{e} !~ /slptool/ ) {
           $openSLP = 0;
       }
    }
    #############################################
    # Check for unsupported service type 
    #############################################
    if ( exists( $opt{s} )) {
        if ( !exists( $services{$opt{s}} )) {
            return(usage( "Invalid service: $opt{s}" ));
        }
        $request->{service} = $services{$opt{s}}; 
    }
    return(0);
}


##########################################################################
# Validate comma-seperated list of IPs
##########################################################################
sub validate_ip {

    my $request = shift;

    ###########################################
    # Option -i not specified (no IPs specified)
    ###########################################
    if ( !exists( $opt{i} )) {

        #######################################
        # Determine interfaces
        #######################################
        my $ips = $openSLP ? 
                  slptool_ifconfig( $request ) : slpquery_ifconfig( $request );

        #######################################
        # Command failed
        #######################################
        if ( @$ips[0] ) {
            return( $ips );
        }
        return( [0] );
    }
    ###########################################
    # Option -i specified - validate entries 
    ###########################################
    foreach ( split /,/, $opt{i} ) {
        my $ip = $_;

        ###################################
        # Length for IPv4 addresses
        ###################################
        my (@octets) = /^(\d{1,3})\.(\d{1,3})\.(\d{1,3})\.(\d{1,3})$/;
        if ( scalar(@octets) != 4 ) {
            return( [1,"Invalid IP address: $ip"] );
        }
        foreach my $octet ( @octets ) {
            if (( $octet < 0 ) or ( $octet > 255 )) {
                return( [1,"Invalid IP address: $ip"] );
            }
        }
        $ip_addr{$ip} = 1;
    }
    return( [0] );
}


##########################################################################
# Verbose mode (-V)
##########################################################################
sub trace {

    my $request = shift;
    my $msg     = shift;

    if ( $verbose ) {
        my ($sec,$min,$hour,$mday,$mon,$yr,$wday,$yday,$dst) = localtime(time);
        my $msg = sprintf "%02d:%02d:%02d %5d %s", $hour,$min,$sec,$$,$msg;
        send_msg( $request, 0, $msg );
    }
} 


##########################################################################
# Determine adapters available - slptool always uses adapter IP 
##########################################################################
sub slptool_ifconfig {

    my $request = shift;
    my $cmd     = "ifconfig -a";
    my $result  = `$cmd`;
    my $mode    = "MULTICAST";

    #############################################
    # Display broadcast IPs, but use adapter IP 
    #############################################
    if ( !exists( $opt{m} )) {
        $mode = "BROADCAST";
    }
    #############################################
    # Error running command
    #############################################
    if ( !$result ) {
        return( [1, "Error running '$cmd': $!"] );
    }
    if ( $verbose ) {
        trace( $request, $cmd );
        trace( $request, "$mode Interfaces:" );
    }
    if (xCAT::Utils->isAIX()) {
        ##############################################################
        # Should look like this for AIX:
        # en0: flags=4e080863,80<UP,BROADCAST,NOTRAILERS,RUNNING,
        #      SIMPLEX,MULTICAST,GROUPRT,64BIT,PSEG,CHAIN>
        #      inet 30.0.0.1    netmask 0xffffff00 broadcast 30.0.0.255
        #      inet 192.168.2.1 netmask 0xffffff00 broadcast 192.168.2.255
        # en1: ...
        #
        ##############################################################
        my @adapter = split /\w+\d+:\s+flags=/, $result;
        foreach ( @adapter ) {
            if ( !($_ =~ /LOOPBACK/ ) and
                   $_ =~ /UP(,|>)/ and
                   $_ =~ /$mode/ ) {
                my @ip = split /\n/;
                foreach ( @ip ) {
                    if ( $mode eq "BROADCAST" ) {
                        if ( $_ =~ /^\s*inet\s+/ and
                             $_ =~ /broadcast\s+(\d+\.\d+\.\d+\.\d+)/ ) {

                            if ( $verbose ) {
                                trace( $request, "\t\t$1\tUP,$mode" );
                            }
                        }
                    }
                    if ( $_ =~ /^\s*inet\s*(\d+\.\d+\.\d+\.\d+)/ ) {
                        $ip_addr{$1} = 1;

                        if ( exists( $opt{m} )) {
                            trace( $request, "\t\t$1\tUP,$mode" );
                        }         
                    }
                }
            }
        }
    }
    else {
        ##############################################################
        # Should look like this for Linux:
        # eth0 Link encap:Ethernet  HWaddr 00:02:55:7B:06:30
        #      inet addr:9.114.154.193  Bcast:9.114.154.223
        #      inet6 addr: fe80::202:55ff:fe7b:630/64 Scope:Link
        #      UP BROADCAST RUNNING MULTICAST  MTU:1500  Metric:1
        #      RX packets:1280982 errors:0 dropped:0 overruns:0 frame:0
        #      TX packets:3535776 errors:0 dropped:0 overruns:0 carrier:0
        #      collisions:0 txqueuelen:1000
        #      RX bytes:343489371 (327.5 MiB)  TX bytes:870969610 (830.6 MiB)
        #      Base address:0x2600 Memory:fbfe0000-fc0000080
        #
        # eth1 ...
        #
        ##############################################################
        my @adapter= split /\n{2,}/, $result;
        foreach ( @adapter ) {
            if ( !($_ =~ /LOOPBACK / ) and
                   $_ =~ /UP / and
                   $_ =~ /$mode / ) {

                my @ip = split /\n/;
                foreach ( @ip ) {
                    if ( $mode eq "BROADCAST" ) {
                        if ( $_ =~ /^\s*inet addr:/ and
                             $_ =~ /Bcast:(\d+\.\d+\.\d+\.\d+)/ ) {

                            if ( $verbose ) {
                                trace( $request, "\t\t$1\tUP,$mode" );
                            }
                        }
                    }
                    if ( $_ =~ /^\s*inet addr:\s*(\d+\.\d+\.\d+\.\d+)/ ) {
                        $ip_addr{$1} = 1;

                        if ( exists( $opt{m} )) {
                            trace( $request, "\t\t$1\tUP,$mode" );
                        }         
                    }
                }
            }
        }
    }
    if ( (keys %ip_addr) == 0 ) {
        return( [1,"No adapters configured for $mode"] );
    }
    #########################
    # Log results
    #########################
    if ( $verbose ) {
        if ( (keys %ip_addr) == 0 ) {
            trace( $request, "$cmd\n$result" );
        }
    }
    return([0]);
}


##########################################################################
# Determine adapters available - slp_query always used broadcast IP 
##########################################################################
sub slpquery_ifconfig {

    my $request = shift;
    my $cmd     = "ifconfig -a";
    my $result  = `$cmd`;
    my $mode    = "BROADCAST";

    ######################################
    # Error running command
    ######################################
    if ( !$result ) {
        return( [1, "Error running '$cmd': $!"] );
    }
    if ( $verbose ) {
        trace( $request, $cmd );
        trace( $request, "$mode Interfaces:" );
    }
    if (xCAT::Utils->isAIX()) {
        ##############################################################
        # Should look like this for AIX:
        # en0: flags=4e080863,80<UP,BROADCAST,NOTRAILERS,RUNNING,
        #      SIMPLEX,MULTICAST,GROUPRT,64BIT,PSEG,CHAIN>
        #      inet 30.0.0.1    netmask 0xffffff00 broadcast 30.0.0.255
        #      inet 192.168.2.1 netmask 0xffffff00 broadcast 192.168.2.255
        # en1: ...
        #
        ##############################################################
        my @adapter = split /\w+\d+:\s+flags=/, $result;
        foreach ( @adapter ) {
            if ( !($_ =~ /LOOPBACK/ ) and
                   $_ =~ /UP(,|>)/ and
                   $_ =~ /$mode/ ) {

                my @ip = split /\n/;
                foreach ( @ip ) {
                    if ( $_ =~ /^\s*inet\s+/ and
                         $_ =~ /broadcast\s+(\d+\.\d+\.\d+\.\d+)/ ) {
                        $ip_addr{$1} = 1;
                    }
                }
            }
        }
    }
    else {
        ##############################################################
        # Should look like this for Linux:
        # eth0 Link encap:Ethernet  HWaddr 00:02:55:7B:06:30
        #      inet addr:9.114.154.193  Bcast:9.114.154.223
        #      inet6 addr: fe80::202:55ff:fe7b:630/64 Scope:Link
        #      UP BROADCAST RUNNING MULTICAST  MTU:1500  Metric:1
        #      RX packets:1280982 errors:0 dropped:0 overruns:0 frame:0
        #      TX packets:3535776 errors:0 dropped:0 overruns:0 carrier:0
        #      collisions:0 txqueuelen:1000
        #      RX bytes:343489371 (327.5 MiB)  TX bytes:870969610 (830.6 MiB)
        #      Base address:0x2600 Memory:fbfe0000-fc0000080
        #
        # eth1 ...
        #
        ##############################################################
        my @adapter= split /\n{2,}/, $result;
        foreach ( @adapter ) {
            if ( !($_ =~ /LOOPBACK / ) and
                   $_ =~ /UP / and
                   $_ =~ /$mode / ) {

                my @ip = split /\n/;
                foreach ( @ip ) {
                    if ( $_ =~ /^\s*inet addr:/ and
                         $_ =~ /Bcast:(\d+\.\d+\.\d+\.\d+)/ ) {
                        $ip_addr{$1} = 1;
                    }
                }
            }
        }
    }
    if ( (keys %ip_addr) == 0 ) {
        return( [1,"No adapters configured for $mode"] );
    }
    #########################
    # Log results
    #########################
    if ( $verbose ) {
        foreach ( keys %ip_addr ) {
            trace( $request, "\t\t$_\tUP,BROADCAST" );
        }
        if ( (keys %ip_addr) == 0 ) {
            trace( $request, "$cmd\n$result" );
        }
    }
    return([0]);
}


##########################################################################
# Forks a process to run the slp command (1 per adapter) 
##########################################################################
sub fork_cmd {

    my $request  = shift;
    my $ip       = shift;
    my $arg      = shift;
    my $services = shift;

    #######################################
    # Pipe childs output back to parent
    #######################################
    my $parent;
    my $child;
    pipe $parent, $child;
    my $pid = fork;

    if ( !defined($pid) ) {
        ###################################
        # Fork error 
        ###################################
        send_msg( $request, 1, "Fork error: $!" );
        return undef;
    }
    elsif ( $pid == 0 ) {
        ###################################
        # Child process
        ###################################
        close( $parent );
        $request->{pipe} = $child;

        invoke_cmd( $request, $ip, $arg, $services );
        exit(0);
    }
    else {
        ###################################
        # Parent process
        ###################################
        close( $child );
        return( $parent );
    }
    return(0);
}


 
##########################################################################
# Run the forked command and send reply to parent  
##########################################################################
sub invoke_cmd {

    my $request  = shift;
    my $ip       = shift;
    my $args     = shift;
    my $services = shift;

    ########################################
    # Telnet (rspconfig) command  
    ########################################
    if ( !defined( $services )) {
        my $mm = $args->{$ip};
        my @cmds = (
            "snmpcfg=enable",
            "sshcfg=enable",
            "network_reset=$mm->{args}"
        );
        if ( $verbose ) {
            trace( $request, "Forked: ($ip)->($mm->{args})" );
        }
        my $result = xCAT_plugin::blade::telnetcmds(
                          $ip,
                          $mm->{username},
                          $mm->{password},
                          0,
                          @cmds );
 
        ####################################
        # Pass result array back to parent
        ####################################
        my @data = ("RSPCONFIG6sK4ci", $ip, @$result[0], @$result[2]);
        my $out = $request->{pipe};


        print $out freeze( \@data );
        print $out "\nENDOFFREEZE6sK4ci\n";
        return;
    }

    ########################################
    # SLP command  
    ########################################
    my $result  = runslp( $args, $ip, $services, $request );
    my $unicast = @$result[0];
    my $values  = @$result[1];

    ########################################
    # May have to send additional unicasts  
    ########################################
    if ( keys (%$unicast) )  { 
        foreach my $url ( keys %$unicast ) {
            my ($service,$addr) = split "://", $url;

            ####################################
            # Strip off trailing ",lifetime"
            ####################################
            $addr =~ s/,*\d*$//;
            my $sockaddr = inet_aton( $addr );
            $url =~ s/,*\d*$//;

            ####################################
            # Make sure can resolve if hostname  
            ####################################
            if  ( !defined( $sockaddr )) {
                if ( $verbose ) {
                    trace( $request, "Cannot convert '$addr' to dot-notation" );           
                }
                next;
            }
            $addr = inet_ntoa( $sockaddr );

            ####################################
            # Select command format 
            ####################################
            if ( $openSLP ) {
                $result = runslp( $args, $ip, [$url], $request, 1 );
            } else {
                $result = runslp( $args, $addr, [$service], $request, 1 );
            }
            my $data   = @$result[1];
            my ($attr) = keys %$data;

            ####################################
            # Save results
            ####################################
            if ( defined($attr) ) {
                $values->{"URL: $url\n$attr\n"} = 1;
            }
        }
    }
    ########################################
    # No valid responses received 
    ########################################
    if (( keys (%$values )) == 0 ) { 
        return;
    }
    ########################################
    # Pass result array back to parent 
    ########################################
    my @results = ("FORMATDATA6sK4ci", $values );
    my $out = $request->{pipe};

    print $out freeze( \@results );
    print $out "\nENDOFFREEZE6sK4ci\n";
}



##########################################################################
# Run the SLP command, process the response, and send to parent  
##########################################################################
sub runslp {

    my $slpcmd   = shift;
    my $ip       = shift;
    my $services = shift;
    my $request  = shift;
    my $attreq   = shift;
    my %result   = ();
    my %unicast  = ();
    my $cmd;

    foreach my $type ( @$services ) {
        my $try = 0;

        ###########################################
        # OpenSLP - slptool command 
        ###########################################
        if ( $openSLP ) {
            $cmd = $attreq ? 
               "$slpcmd findattrsusingiflist $ip $type" : 
               "$slpcmd findsrvsusingiflist $ip $type";
        } 
        ###########################################
        # IBM SLP - slp_query command 
        ###########################################
        else {
            $cmd = $attreq ? 
               "$slpcmd --address=$ip --type=$type" : 
               "$slpcmd --address=$ip --type=$type --converge=1"; 
        }

        ###########################################
        # Run the command 
        ###########################################
        while ( $try++ < $maxtries ) {
            if ( $verbose ) {
                trace( $request, $cmd );
                trace( $request, "Attempt $try of $maxtries\t( $ip\t$type )" );
            } 
            #######################################
            # Serialize transmits out each adapter 
            #######################################
            if ( !open( OUTPUT, "$cmd 2>&1 |")) {
                send_msg( $request, 1, "Fork error: $!" );
                return undef;
            }
            ###############################
            # Get command output 
            ###############################
            my $rsp;
            while ( <OUTPUT> ) {
                $rsp.=$_;
            }
            close OUTPUT;

            ###############################
            # No replies
            ###############################
            if ( !$rsp ) {
                if ( $verbose ) {
                    trace( $request, ">>>>>> No Response" );
                }
                next;
            }
            ###########################################
            # For IVM, running AIX 53J (6/07) release,
            # there is an AIX SLP bug where IVM will 
            # respond to SLP service-requests with its 
            # URL only and not its attributes. An SLP
            # unicast to the URL address is necessary  
            # to acquire the attributes. This was fixed 
            # in AIX 53L (11/07).
            #
            ###########################################

            ###########################################
            # OpenSLP response format:
            #   service:management-software.IBM...
            #   (type=hardware-management-cons...
            #   (serial-number=KPHHK24),(name=c76v2h...
            #   1ab1dd89ca8e0763e),(ip-address=192.1...
            #   0CR3*KPHHK24),(web-management-interf...
            #   2.ppd.pok.ibm.com:8443),(cimom-port=...
            #   ...
            ###########################################
            if ( $openSLP ) {
                my @data = split /\n/,$rsp;
                my $length = scalar( @data );
                my $i = 0;

                while ($i < $length ) {
                    ###################################
                    # Service-Request response
                    ###################################
                    if ( $data[$i] =~ 
                        /^service\:management-(software|hardware)\.IBM\:([^\:]+)/) {

                        ###############################
                        # Invalid service-type 
                        ###############################
                        if ( !exists( $service_slp{$2} )) {
                            if ( $verbose ) {
                                trace( $request, "DISCARDING: $data[$i]" );
                            }
                            $i++;
                            next;
                        } 
                        my $url  = $data[$i++];
                        my $attr = $data[$i];
 
                        if ( $verbose ) {
                            trace( $request, ">>>> SrvRqst Response" );
                            trace( $request, "URL: $url" );
                        }
                        ###############################
                        # No "ATTR" - have to unicast
                        ###############################
                        if ( $attr !~ /^(\(type=.*)$/ ) {
                           $unicast{$url} = $url;
                        }
                        ###############################
                        # Response has "ATTR" field 
                        ###############################
                        else {
                            if ( $verbose ) {
                                trace( $request, "ATTR: $attr\n" );
                            }
                            my $val = "URL: $url\nATTR: $attr";
                            $result{$val} = 1;
                            $i++;
                        }
                    }
                    ###################################
                    # Attribute-Request response
                    ###################################
                    elsif ( $data[$i] =~ /(\(type=.*)$/ ) {
                        my $attr = "ATTR: $data[$i++]";

                        if ( $verbose ) {
                            trace( $request, ">>>> AttrRqst Response" );
                            trace( $request, $attr );
                        }
                        $result{$attr} = 1;
                    } 
                    ###################################
                    # Unrecognized response
                    ###################################
                    else {
                        if ( $verbose ) {
                            trace( $request, "DISCARDING: $data[$i]" );
                        }
                        $i++;
                    }
                }
            } 
            ###########################################
            # IBM SLP response format:
            #   0
            #   1
            #   75
            #   URL: service:management-software.IBM...
            #   ATTR: (type=hardware-management-cons...
            #   (serial-number=KPHHK24),(name=c76v2h...
            #   1ab1dd89ca8e0763e),(ip-address=192.1...
            #   0CR3*KPHHK24),(web-management-interf...
            #   2.ppd.pok.ibm.com:8443),(cimom-port=...
            #
            #   0
            #   1
            #   69
            #   URL:...
            #   ATTR:..
            #   ..
            ###########################################
            else {
                foreach ( split /\n{2,}/,$rsp ) {
                    if ( $_ =~ s/(\d+)\n(\d+)\n(\d+)\n// ) {
                        if ( $verbose ) {
                            trace( $request, "SrvRqst Response ($1)($2)($3)" );
                            trace( $request, "$_\n" );
                        }
                        ###############################
                        # Response has "ATTR" field
                        ###############################
                        if ( /ATTR: /  ) {
                            $result{$_} = 1;
                        }
                        ###############################
                        # No "ATTR" - have to unicast
                        ###############################
                        elsif ( /.*URL: (.*)/ ) {
                            $unicast{$1} = $1;
                        }
                    } 
                    elsif ( $verbose ) {
                        trace( $request, "DISCARDING: $_" );
                    }
                }
            }
        }
    }
    return( [\%unicast,\%result] );
}



##########################################################################
# Formats slp responses
##########################################################################
sub format_output {

    my $request = shift;
    my $values  = shift;
    my $length  = length( $header[IP_ADDRESSES][TEXT] );
    my $result;

    ###########################################
    # Query switch ports
    ###########################################
    my $mm = switch_cmd( $request, $values );

    ###########################################
    # Parse responses and add to hash
    ###########################################
    my $outhash = parse_responses( $request, $values, $mm, \$length );

    ###########################################
    # No responses 
    ###########################################
    if (( keys %$outhash ) == 0 ){
        send_msg( $request, 0, "No responses" );
        return;   
    }
    ###########################################
    # -w flag for write to xCat database
    ###########################################
    if ( exists( $opt{w} )) {
        xCATdB( $outhash );
    }
    ###########################################
    # -r flag for raw response format
    ###########################################
    if ( exists( $opt{r} )) {
        foreach ( keys %$outhash ) {
            $result .= "@{ $outhash->{$_}}[5]\n";
        }
        send_msg( $request, 0, $result );
        return;
    }
    ###########################################
    # -x flag for xml format
    ###########################################
    if ( exists( $opt{x} )) {
        send_msg( $request, 0, format_xml( $outhash ));
        return;
    }
    ###########################################
    # -z flag for stanza format
    ###########################################
    if ( exists( $opt{z} )) {
        send_msg( $request, 0, format_stanza( $outhash ));
        return;
    }

    ###########################################
    # Get longest IP for formatting purposes
    ###########################################
    my $format = sprintf "%%-%ds", ( $length + 2 );
    $header[IP_ADDRESSES][FORMAT] = $format;

    ###########################################
    # Display header
    ###########################################
    foreach ( @header ) {
        $result .= sprintf @$_[1], @$_[0];
    }
    $result .= "\n";

    ###########################################
    # Display response attributes
    ###########################################
    foreach ( sort keys %$outhash ) {
        my $data = $outhash->{$_};
        my $i = 0;

        foreach ( @header ) {
            $result .= sprintf @$_[1], @$data[$i++];
        }
        $result .= "\n";
    }
    send_msg( $request, 0, $result );
}


##########################################################################
# Get IP from SLP URL response
##########################################################################
sub getip_from_url {

    my $request = shift;
    my $url     = shift;

    ######################################################################
    # Extract the IP from the URL. Generally, the URL
    # should be in the following format (the ":0" port number
    # may or may not be present):
    # service:management-hardware.IBM:management-module://9.114.113.78:0
    # service:management-software.IBM:integrated-virtualization-manager://zd21p1.rchland.ibm.com
    ######################################################################
    if (($url !~ /service:.*:\/\/(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}).*/ )) {
        return undef;
    }
    return( $1 );
}



##########################################################################
# Get hostname from SLP URL response
##########################################################################
sub gethost_from_url {

    my $request = shift;
    my $url     = shift;

    #######################################
    # Extract IP from URL 
    #######################################
    my $ip = getip_from_url( $request, $url );
    if ( !defined( $ip )) {
        return undef;
    }
    #######################################
    # Check if valid IP
    #######################################
    my $packed = inet_aton( $ip );
    if ( length( $packed ) != 4 ) {
        if ( $verbose ) {
            trace( $request, "Invalid IP address in URL: $ip" );
        }
        return undef;
    }
    #######################################
    # Convert IP to hostname
    #######################################
    my $host = gethostbyaddr( $packed, AF_INET );
    if ( !$host or $! ) {
        return( $ip );
    }
    #######################################
    # Convert hostname to short-hostname
    #######################################
    if ( $host =~ /([^\.]+)\./ ) {
        $host = $1;
    }
    return( $host );
  
    ###########################################
    #  Otherwise, URL is not in IP format
    ###########################################
    if ( !($url =~ /service:.*:\/\/(.*)/  )) {
        if ( $verbose ) {
            trace( $request, "Invalid URL: $_[0]" );
        }
        return undef;
    }
    return( $1 );

}


##########################################################################
# Example OpenSLP slptool "service-request" output. The following 
# attributes can be returned in any order within an SLP response.
#
# service:management-hardware.IBM:management-module://192.20.154.19,48659
# (type=management-module),(level=3),(serial-number= K10WM39916W),
# (fru=73P9297     ),(name=WMN315724834),(ip-address=192.20.154.19),
# (enclosure-serial-number=78AG034),(enclosure-fru=59P6609     ),
# (enclosure-machinetype-model=86772XX),(status=0),(enclosure-uuid=
#  \ff\e6\4f\0b\41\de\0d\11\d7\bd\be\b5\3c\ab\f0\46\04),
# (web-url=http://192.20.154.19:80),(snmp-port=161),(slim-port=6090),
# (ssh-port=22),(secure-slim-port=0),(secure-slim-port-enabled=false),
# (firmware-image-info=BRET86P:16:01-29-08,BRBR82A:16:06-01-05),
# (telnet-port=23),(slot=1),0
#  ...
#
# Example OpenSLP slptool "attribute-request" output. The following 
# attributes can be returned in any order within an SLP response.
#
# (type=integrated-virtualization-manager),(level=3),(machinetype-model=911051A),
# (serial-number=1075ECF),(name=p510ivm.clusters.com)(ip-address=192.168.1.103),
# (web-url=http://p510ivm.clusters.com/),(mtms=911051A*1075ECF),
# (web-management-interface=TRUE),(secure-web-url=https://p510ivm.clusters.com/),
# (cimom-port=5988),(secure-cimom-port=5989),(lparid=1)
#  ...
#
#------------------------------------------------------------------------
#
# Example IBM SLP slp_query command "service-request" output. The following
# attributes can be returned in any order within an SLP response.
# Note: The leading 3 numbers preceeding the URL: and ATTR: fields
# represent:
#        error code,
#        URL count,
#        URL length, respectively.
# 0
# 1
# 75
# URL: service:management-software.IBM:hardware-management-console://192.168.1.110
# ATTR: (type=hardware-management-console),(level=3),(machinetype-model=7310CR3),
# (serial-number=KPHHK24),(name=c76v2hmc02.ppd.pok.ibm.com),(uuid=de335adf051eb21
# 1ab1dd89ca8e0763e),(ip-address=192.168.1.110,9.114.47.154),(web-url=),(mtms=731
# 0CR3*KPHHK24),(web-management-interface=true),(secure-web-url=https://c76v2hmc0
# 2.ppd.pok.ibm.com:8443),(cimom-port=),(secure-cimom-port=5989)
#
# 0
# 1
# 69
# ...
#
# Example IBM SLP slp_query command "attribute-request" output. The following
# attributes can be returned in any order within an SLP response.
# Note: The leading 3 numbers preceeding the URL: and ATTR: fields
# represent:
#        error code,
#        0, (hardcoded)
#        ATTR  length, respectively.
# 0
# 0
# 354
# ATTR: (type=integrated-virtualization-manager),(level=3),(machinetype-model=911051A),
# (serial-number=1075ECF),(name=p705ivm.clusters.com),(ip-address=192.168.1.103),
# (web-url=http://p705ivm.clusters.com/),(mtms=911051A*1075ECF),(web-management-
# interface=TRUE),(secure-web-url=https://p705ivm.clusters.com/),(cimom-port=5988),
# (secure-cimom-port=5989),(lparid=1)
#
#########################################################################
sub parse_responses {

    my $request = shift;
    my $values  = shift;
    my $mm      = shift;
    my $length  = shift;

    my %outhash = ();
    my @attrs   = (
       "type",
       "machinetype-model",
       "serial-number",
       "ip-address" );

    #######################################
    # RSA/MM Attributes
    #######################################
    my @xattrs = (
       "type",
       "enclosure-machinetype-model",
       "enclosure-serial-number",
       "ip-address" );

    foreach my $rsp ( @$values ) {
        ###########################################
        # Get service-type from response 
        ###########################################
        my @result = ();
        my $host;

        ###########################################
        # service-type attribute not found 
        ###########################################
        if ( $rsp !~ /\(type=([^\)]+)/ ) {
            if ( $verbose ) {
                trace( $request, "(type) attribute not found: $rsp" );
            }
            next;
        }
        ###########################################
        # Valid service-type attribute 
        ###########################################
        my $type = $1;

        ###########################################
        # Unsupported service-type 
        ###########################################
        if ( !exists($service_slp{$type} )) {
            if ( $verbose ) {
                trace( $request, "Discarding unsupported type: $type" );
            }
            next;
        }
        ###########################################
        # RSA/MM - slightly different attributes
        ###########################################
        my $attr = \@attrs;
        if (( $type eq SERVICE_RSA ) or ( $type eq SERVICE_RSA2 ) or 
            ( $type eq SERVICE_MM )) {
            $attr = \@xattrs;
        }

        ###########################################
        # Extract the attributes
        ###########################################
        foreach ( @$attr ) {
            unless ( $rsp =~ /\($_=([^\)]+)/ ) {
                if ( $verbose ) {
                    trace( $request, "Attribute not found: [$_]->($rsp)" );
                }
                next;
            }
            push @result, $1;
        }
        ###########################################
        # Use the IP/Hostname contained in the URL
        # not the (ip-address) field since for FSPs
        # it may contain default IPs which could  
        # all be the same. If the response contains 
        # a "name" attribute as the HMC does, use
        # that instead of the URL.
        #
        ###########################################
        if (( $type eq SERVICE_HMC ) or ( $type eq SERVICE_IVM )) {
            if ( $rsp =~ /\(name=([^\)]+)/ ) {
                $host = $1;

                ###################################
                # Convert to short-hostname
                ###################################
                if ( $host =~ /([^\.]+)\./ ) {
                    $host = $1;
                }
            }
        }
        ###########################################
        # Seperate ATTR and URL portions:
        # URL: service:management-software.IBM...
        # ATTR: (type=hardware-management-cons...
        # (serial-number=KPHHK24),(name=c76v2h...
        # 1ab1dd89ca8e0763e),(ip-address=192.1...
        # 0CR3*KPHHK24),(web-management-interf...
        # 2.ppd.pok.ibm.com:8443),(cimom-port=...
        #
        ###########################################
        $rsp =~ /.*URL: (.*)\nATTR: +(.*)/;

        ###########################################
        # If MM, use the discovered host
        ###########################################
        if (( $type eq SERVICE_MM ) and ( defined( $mm ))) {
            my $ip = getip_from_url( $request, $1 );

            if ( defined( $ip )) {
                if ( exists( $mm->{$ip}->{args} )) {
                    $mm->{$ip}->{args} =~ /^.*,(.*)$/; 
                    $host = $1;
                }
            }   
        }
        ###########################################
        # Get host directly from URL
        ###########################################
        if ( !defined($host) ) {
            $host = gethost_from_url( $request, $1 );
            if ( !defined( $host )) {
                next;
            }
        }
        push @result, $host;

        ###################################
        # Strip off trailing ",lifetime"
        ###################################
        my $at = $2;
        $at =~ s/,\d+$//;
        push @result, $at;

        ###########################################
        # Strip commas from IP list
        ###########################################
        $result[3] =~ s/,/ /g;
        my $ip     = $result[3];

        ###########################################
        # Process any extra attributes
        ###########################################
        foreach ( @{$exattr{$type}} ) {
             push @result, ($rsp =~ /\($_=([\w\-\.,]+)\)/) ? $1 : "0";
        }
        ###########################################
        # Save longest IP for formatting purposes
        ###########################################
        if ( length( $ip ) > $$length ) {
            $$length = length( $ip );
        }
        $result[0] = $service_slp{$type};
        $outhash{$host} = \@result;
    }
    return( \%outhash );
}



##########################################################################
# Write result to xCat database 
##########################################################################
sub xCATdB {

    my $outhash = shift;
    my %keyhash = ();
    my %updates = ();
  
    foreach ( keys %$outhash ) {
        my $data = $outhash->{$_};
        my $type = @$data[0];

        if ( $type =~ /^BPA$/ ) {
            my $model  = @$data[1];
            my $serial = @$data[2];
            my $ips    = @$data[3];
            my $name   = @$data[4];
            my $id     = @$data[6];

            ####################################
            # N/A Values
            ####################################
            my $prof  = "";
            my $frame = "";

            my $values = join( ",",
               lc($type),$name,$id,$model,$serial,$name,$prof,$frame,$ips );
            xCAT::PPCdb::add_ppc( $type, [$values] );
        }
        elsif ( $type =~ /^(HMC|IVM)$/ ) {
            xCAT::PPCdb::add_ppchcp( $type, $data );
        }
        elsif ( $type =~ /^FSP$/ ) {
            ########################################
            # BPA frame this CEC is in 
            ########################################
            my $frame      = "";
            my $model      = @$data[1];
            my $serial     = @$data[2];
            my $ips        = @$data[3];
            my $name       = @$data[4];
            my $bpc_model  = @$data[6];
            my $bpc_serial = @$data[7];
            my $cageid     = @$data[8];

            ########################################
            # May be no Frame with this FSP
            ########################################
            if (( $bpc_model ne "0" ) and ( $bpc_serial ne "0" )) {
                $frame = "$bpc_model*$bpc_serial";
            }
            ########################################
            # "Factory-default" FSP name format: 
            # Server-<type>-<model>-<serialnumber>
            # ie. Server-9117-MMA-SN10F6F3D
            #
            # If the IP address cannot be converted
            # to a shirt-hostname use the following:
            #
            # Note that this may not be the name
            # that the user (or the HMC) knows this 
            # CEC as. This is the "factory-default"
            # CEC name. SLP does not return the
            # user- or system-defined CEC name and
            # FSPs are assigned dynamic hostnames
            # by DHCP so there is no point in using
            # the short-hostname as the name.
            ########################################
            if ( $name =~ /^[\d]{1}/ ) {
                $name = "Server-$model-$serial";
            }
            ########################################
            # N/A Values
            ########################################
            my $prof   = "";
            my $server = "";

            my $values = join( ",",
               $type,$name,$cageid,$model,$serial,$server,$prof,$frame,$ips );
            xCAT::PPCdb::add_ppc( "fsp", [$values] );
        }
        elsif ( $type =~ /^(RSA|MM)$/ ) {
            xCAT::PPCdb::add_systemX( $type, $data );
        }
    }
}


##########################################################################
# Stanza formatting 
##########################################################################
sub format_stanza {

    my $outhash = shift;
    my $result;

    #####################################
    # Write attributes
    #####################################
    foreach ( keys %$outhash ) {
        my @data = @{$outhash->{$_}};
        my $type = lc($data[0]);
        my $name = $data[4];
        my $i = 0;

        #################################
        # Node attributes
        #################################
        $result .= "$name:\n\tobjtype=node\n";

        #################################
        # Add each attribute
        #################################
        foreach ( @attribs ) {
            my $d = $data[$i++];
                
            if ( /^node$/ ) {
                next;
            } elsif ( /^nodetype$/ ) {
                $d = $type;
            } elsif ( /^groups$/ ) {
                $d = "$type,all";
            } elsif ( /^mgt$/ ) {
                $d = $mgt{$type};
            } elsif ( /^(id|mpa)$/ ) {
                if ( $type =~ /^(mm|rsa)$/ ) {
                    $d = (/^id$/) ? "0" : $name;
                } else {
                    next;
                }
            }
            $result .= "\t$_=$d\n";
        }
    }
    return( $result );
}



##########################################################################
# XML formatting
##########################################################################
sub format_xml {
 
    my $outhash = shift;
    my $xml;

    #####################################
    # Create XML formatted attributes
    #####################################
    foreach ( keys %$outhash ) {
        my @data = @{ $outhash->{$_}};
        my $type = lc($data[0]);
        my $name = $data[4];
        my $i = 0;

        #################################
        # Initialize hash reference
        #################################
        my $href = {
            Node => { }
        };
        #################################
        # Add each attribute
        #################################
        foreach ( @attribs ) {
            my $d = $data[$i++];

            if ( /^nodetype$/ ) {
                $d = $type;
            } elsif ( /^groups$/ ) {
                $d = "$type,all";
            } elsif ( /^mgt$/ ) {
                $d = $mgt{$type};
            } elsif ( /^(id|mpa)$/ ) {
                if ( $type =~ /^(mm|rsa)$/ ) {
                    $d = (/^id$/) ? "0" : $name;
                } else {
                    next;
                }
            }
            $href->{Node}->{$_} = $d;
        }
        #################################
        # XML encoding
        #################################
        $xml.= XMLout($href,
                     NoAttr   => 1,
                     KeyAttr  => [],
                     RootName => undef );
    }
    return( $xml );
}


##########################################################################
# OpenSLP running on:
#     P6 FSP
#     P6 BPA
# IBM SLP running on:
#     P5 FSP
#     P5 BPA
#     HMC
#     MM
#     RSA
# AIX SLP
#     IVM
#
# Notes:
# IBM SLP requires trailing ':' (i.e. service:management-hardware.IBM:)
# There is one exception to this rule when dealing with FSP
# concrete" service types, it will work with/without the trailing ':'
# (i.e. "service:management-hardware.IBM:cec-service-processor[:]")
#
# OpenSLP does not support ':' at the end of services
# (i.e. service:management-hardware.IBM:). Unfortunately, IBM SLP
# requires it.
#
# Given the above, to collect all the above service types, it is
# necessary to multicast:
# (1) "service:management-*" for all IBM SLP hardware
# (2) "service:management-hardware.IBM" for OpenSLP hardware (P6 FSP/BPA)
#      (IBM SLP hardware will not respond to this since there is no trailing ":")
#
# * One exception to the above rule is when using FSP concrete
#   service type, it will work with/without the trailing ":"
#   (i.e. "service:management-hardware.IBM:cec-service-processor[:]"
#
##########################################################################


##########################################################################
# Run IBM SLP version
##########################################################################
sub slp_query {

    my $request  = shift;
    my $callback = $request->{callback};
    my $cmd      = $opt{e};

    #############################################
    # slp_query not installed
    #############################################
    if ( !-x $cmd ) {
        send_msg( $request, 1, "Command not found: $cmd" );
        return( [RC_ERROR] );
    }
    #############################################
    # slp_query runnable - dependent on libstdc++
    # Test for usage statement.
    #############################################
    my $output = `$cmd 2>&1`;
    if ( $output !~ /slp_query --type=service-type-string/ ) {
        send_msg( $request, 1, $output );
        return( [RC_ERROR] );
    }
    my $result = runcmd( $request, $cmd );
    return( $result );
}


##########################################################################
# Run OpenSLP version
##########################################################################
sub slptool {

    my $request = shift;
    my $cmd     = SLPTOOL;
    my $start;

    #########################################
    # slptool not installed   
    #########################################
    if ( !-x $cmd ) {
        send_msg( $request, 1, "Command not found: $cmd" );
        return( [RC_ERROR] );
    }
    #########################################
    # slptool runnable - test for version 
    #########################################
    my $output = `$cmd -v 2>&1`;
    if ( $output !~ /^slptool version = 1.2.1\nlibslp version = 1.2.1/ ) {
        send_msg( $request, 1, "Incorrect 'slptool' command installed" );
        return( [RC_ERROR] );
    }
    #########################################
    # Select broadcast, convergence, etc 
    #########################################
    my $mode = selectmode( $request );
    if ( defined($mode) ) {
        return( $mode );
    }
    my $result = runcmd( $request, $cmd );
    return( $result );
}


##########################################################################
# Select OpenSLP slptool broadcast convergence, etc 
##########################################################################
sub selectmode {

    my $request = shift;
    my $fname   = SLP_CONF;
    my $mode;
    my $maxtimeout;
    my $converge;

    ##################################
    # Select convergence  
    ##################################
    if ( exists( $opt{c} )) {
        $converge = join( ',',@converge );

        ##############################
        # Maximum timeout
        ##############################
        foreach ( @converge ) {
            $maxtimeout += $_;
        }
    }
    ##################################
    # Select multicast or broadcast  
    ##################################
    if ( !exists( $opt{m} )) {
        $mode = "true";    
    }

    ##################################
    # slp.conf attributes  
    ##################################
    my %attr = (
        "net.slp.multicastTimeouts"    => $converge,
        "net.slp.isBroadcastOnly"      => $mode,
        "net.slp.multicastMaximumWait" => $maxtimeout 
    );

    if ( $verbose ) {
        my $msg = !defined($mode) ? "Multicasting SLP...":"Broadcasting SLP...";
        trace( $request, $msg );
    }
    ##################################
    # Open/read slp.conf  
    ##################################
    unless ( open( CONF, $fname )) {
        send_msg( $request, 1, "Error opening: '$fname'" );
        return( [RC_ERROR] );
    }
    my @raw_data = <CONF>;
    close( CONF );

    ##################################
    # Find attribute
    ##################################
    foreach my $name ( keys %attr ) {
        my $found = 0;

        foreach ( @raw_data ) {
            if ( /^;*$name\s*=/ ) {
                if ( !defined( $attr{$name} )) {
                    s/^;*($name\s*=\s*[\w,]+)/;$1/;
                } elsif ( $attr{$name} == 0 ) {
                    s/^;*($name\s*=\s*[\w,]+)/$1/;
                } else {
                    s/^;*$name\s*=\s*[\w,]+/$name = $attr{$name}/;
                }
                $found = 1;
                last;
            }
        }
        if ( !$found ) {
            send_msg( $request, 1, "'$name' not found in '$fname'" );
            return( [RC_ERROR] );
        }
    }
    ##################################
    # Rewrite file contents 
    ##################################
    unless ( open( CONF, "+>$fname" )) {
        send_msg( $request, 1, "Error opening: '$fname'" );
        return( [RC_ERROR] );
    }
    print CONF @raw_data;
    close( CONF );
    return undef;
}


##########################################################################
# Run the SLP command 
##########################################################################
sub runcmd {

    my $request  = shift;
    my $cmd      = shift;
    my $services = shift;
    my $callback = $request->{callback};
    my @services = ( WILDCARD_SERVICE, P6_SERVICE );
    my $start;

    ###########################################
    # Query specific service; otherwise, 
    # query all hardware/software services
    ###########################################
    if ( exists( $opt{s} )) {
        @services = $request->{service};
    }

    if ( $verbose ) {
        #######################################
        # Write header for trace
        #######################################
        my $tm  = localtime( time );
        my $msg = "\n--------  $tm\nTime     PID";
        trace( $request, $msg );
    }
    ###########################################
    # Get/validate broadcast IPs
    ###########################################
    my $result = validate_ip( $request );
    my $Rc = shift(@$result);

    if ( $Rc ) {
        send_msg( $request, 1, @$result[0] );
        return( [RC_ERROR] );
    }
    if ( $verbose ) {
        $start = Time::HiRes::gettimeofday(); 
    }
    ###########################################
    # Fork one process per adapter 
    ###########################################
    my $children = 0;
    $SIG{CHLD} = sub { while (waitpid(-1, WNOHANG) > 0) { $children--; } };
    my $fds = new IO::Select;
    
    foreach ( keys %ip_addr ) {
        my $pipe = fork_cmd( $request, $_, $cmd, \@services );
        if ( $pipe ) {
            $fds->add( $pipe );
            $children++;
        }
    }
    ###########################################
    # Process slp responses from children 
    ###########################################
    while ( $children > 0 ) {
        child_response( $callback, $fds );
    }
    while (child_response($callback,$fds)) {}

    if ( $verbose ) {
        my $elapsed = Time::HiRes::gettimeofday() - $start;
        my $msg = sprintf( "Total SLP Time: %.3f sec\n", $elapsed );
        trace( $request, $msg ); 
    }
    ###########################################
    # Combined responses from all children 
    ###########################################
    my @all_results = keys %slp_result;
    format_output( $request, \@all_results );
    return( [SUCCESS,\@all_results] );
}


##########################################################################
# Collect output from the child processes 
##########################################################################
sub child_response {

    my $callback = shift; 
    my $fds = shift;
    my @ready_fds = $fds->can_read(1);

    foreach my $rfh (@ready_fds) {
        my $data = <$rfh>;

        #################################
        # Read from child process
        #################################
        if ( defined( $data )) {
            while ($data !~ /ENDOFFREEZE6sK4ci/) {
                $data .= <$rfh>;
            }
            my $responses = thaw($data);

            #############################
            # Formatted SLP results
            #############################
            if ( @$responses[0] =~ /^FORMATDATA6sK4ci$/ ) {
                shift @$responses;
                foreach ( keys %$responses ) {
                    $slp_result{$_} = 1;
                }
                next;
            }
            #############################
            # rspconfig results
            #############################
            if ( @$responses[0] =~ /^RSPCONFIG6sK4ci$/ ) {
                shift @$responses;
                my $ip = shift(@$responses);

                $rsp_result{$ip} = $responses;
                next;
            }
            #############################
            # Message or verbose trace
            #############################
            foreach ( @$responses ) {
                $callback->( $_ );
            }
            next;
        }
        #################################
        # Done - close handle 
        #################################
        $fds->remove($rfh);
        close($rfh);
    }
}



#############################################################################
# Preprocess request from xCat daemon and send request to service nodes
#############################################################################
sub preprocess_request {

    my $req = shift;
    if ($req->{_xcatdest}) { return [$req]; }    #exit if preprocessed
    my $callback=shift;
    my @requests;

    ####################################
    # Prompt for usage if needed
    ####################################
    my $noderange = $req->{node}; #Should be arrayref
    my $command = $req->{command}->[0];
    my $extrargs = $req->{arg};
    my @exargs=($req->{arg});
    if (ref($extrargs)) {
        @exargs=@$extrargs;
    }
    my $usage_string=xCAT::Usage->parseCommand($command, @exargs);
    if ($usage_string) {
        $callback->({data=>[$usage_string]});
        $req = {};
        return;
    }
    ###########################################
    # find all the service nodes for xCAT cluster
    # build an individual request for each service node
    ###########################################
    my $nrtab=xCAT::Table->new("noderes", -create =>0);  
    my @all=$nrtab->getAllNodeAttribs(['servicenode']);
    my %sv_hash=();
    foreach (@all) {
      if ($_->{servicenode}) {$sv_hash{$_->{servicenode}}=1;}
    }
    ###########################################
    # build each request for each service node
    ###########################################
    my @result = ();
    foreach my $sn (keys (%sv_hash)) {
      my $reqcopy = {%$req};
      $reqcopy->{_xcatdest} = $sn;
      push @result, $reqcopy;
    }
    return \@result;
}


##########################################################################
# Match SLP IP/ARP MAC/Switch table port to actual switch data 
##########################################################################
sub switch_cmd {

    my $req = shift;
    my $slp = shift;
    my %mm;
    my %slp;
    my %hosts;
    my @entries;
    my $hosttab  = xCAT::Table->new( 'hosts' );
    my $swtab    = xCAT::Table->new( 'switch' );

    ###########################################
    # No tables
    ###########################################
    if ( !defined($swtab) or !defined($hosttab) ) {
        return;
    }
    ###########################################
    # Any MMs in SLP response
    ###########################################
    foreach ( @$slp ) {
        if ( /\(type=management-module\)/ and /\(ip-address=([^\),]+)/) {
           $slp{$1} = undef;
        }
    }
    ###########################################
    # No MMs in response
    ###########################################
    if ( !%slp ) {
        return;
    }
    ###########################################
    # Any entries in switch table
    ###########################################
    foreach ( $swtab->getAllNodeAttribs([qw(node)]) ) {
        push @entries, $_->{node};
    }
    ###########################################
    # Any entries in hosts table
    ###########################################
    if ( $verbose ) {
        trace( $req, "SWITCH/HOSTS TABLE:" );
    }
    foreach ( @entries ) {
        my $ent = $hosttab->getNodeAttribs($_,[qw(ip)]);
        if ( !$ent ) {
            next;
        }
        $hosts{$_} = $ent->{ip};
        if ( $verbose ) {
            trace( $req, "\t\t($_)->($ent->{ip})" );
        }
    }
    ###########################################
    # No MMs in hosts/switch table 
    ###########################################
    if ( !%hosts ) {
        return;
    }
    ###########################################
    # Ping each MM to update arp table 
    ###########################################
    foreach my $ip ( keys %slp ) {
        my $cmd = `ping -c 1 -w 0 $ip`;
    }    
    ###########################################
    # Match discovered IP to MAC in arp table
    ###########################################
    my $arp = `/sbin/arp -n`;
    my @arpents = split /\n/, $arp;

    if ( $verbose ) {
        trace( $req, "ARP TABLE:" );
    }
    foreach ( @arpents ) {
        /^(\S+)+\s+\S+\s+(\S+)\s/;
        if ( exists( $slp{$1} )) {
            if ( $verbose ) {
                trace( $req, "\t\t($1)->($2)" );
            }
            $slp{$1} = $2;
        }
    }
    ###########################################
    # No discovered IP - MAC matches 
    ###########################################
    if ( !grep( defined($_), values %slp )) {
        return;
    }
    if ( $verbose ) {
        trace( $req, "getting switch information...." );
    }
    foreach my $ip ( keys %slp ) {
        #######################################
        # Not in SLP response
        #######################################
        if ( !defined( $slp{$ip} ) or !defined( $macmap )) { 
            next;
        }
        #######################################
        # Get node from switch 
        #######################################
        my $name = $macmap->find_mac( $slp{$ip} );
        if ( !defined( $name )) {
            if ( $verbose ) {
                trace( $req, "\t\t($slp{$ip})-> NOT FOUND" ); 
            }
            next;
        }
        if ( $verbose ) {
            trace( $req, "\t\t($slp{$ip})-> $name" ); 
        }
        #######################################
        # In hosts table 
        #######################################
        if ( defined( $hosts{$name} )) {
            if ( $ip eq $hosts{$name} ) {
                if ( $verbose ) {
                    trace( $req, "MM already set '$ip' - skipping" );
                }
                next;
            }
            $mm{$ip}->{args} = "$hosts{$name},$name";
        }
    }
    ###########################################
    # No MMs   
    ###########################################
    if ( !%mm ) {
        if ( $verbose ) {
            trace( $req, "No ARP-Switch-SLP matches found" ); 
        }
        return;
    }
    ###########################################
    # Update MM hardware w/discovery info
    ###########################################
    my $result = rspconfig( $req, \%mm );
    return( $result );
}



##########################################################################
# Run rspconfig against MMs
##########################################################################
sub rspconfig {

    my $request   = shift;
    my $mm        = shift;
    my $callback  = $request->{callback};
    my $bladeuser = 'USERID';
    my $bladepass = 'PASSW0RD';
    my $start;

    if ( $verbose ) {
        trace( $request, "telneting to management-modules....." );
        $start = Time::HiRes::gettimeofday();
    }
    #############################################
    # Check passwd table for userid/password
    #############################################
    my $passtab = xCAT::Table->new('passwd');
    if ( $passtab ) {
        my ($ent) = $passtab->getAttribs({key=>'blade'},'username','password');
        if ( defined( $ent )) {
            $bladeuser = $ent->{username};
            $bladepass = $ent->{password};
        }
    }
    #############################################
    # Get MM userid/password
    #############################################
    my $mpatab = xCAT::Table->new('mpa');
    foreach ( keys %$mm ) {
        my $user = $bladeuser;
        my $pass = $bladepass;

        if ( defined( $mpatab )) {
            my ($ent) = $mpatab->getAttribs({mpa=>$_},'username','password');
            if ( defined( $ent->{password} )) { $pass = $ent->{password}; } 
            if ( defined( $ent->{username} )) { $user = $ent->{username}; } 
        }
        $mm->{$_}->{username} = $user;
        $mm->{$_}->{password} = $pass;
    }
    
    #############################################
    # Fork one process per MM 
    #############################################
    my $children = 0;
    $SIG{CHLD} = sub { while (waitpid(-1, WNOHANG) > 0) { $children--; } };
    my $fds = new IO::Select;
   
    foreach my $ip ( keys %$mm ) {
        my $pipe = fork_cmd( $request, $ip, $mm );
        if ( $pipe ) {
            $fds->add( $pipe );
            $children++;
        }
    }
    #############################################
    # Process responses from children
    #############################################
    while ( $children > 0 ) {
        child_response( $callback, $fds );
    }
    while (child_response($callback,$fds)) {}

    if ( $verbose ) {
        my $elapsed = Time::HiRes::gettimeofday() - $start;
        my $msg = sprintf( "Total rspconfig Time: %.3f sec\n", $elapsed );
        trace( $request, $msg );
    }
    
    foreach my $ip ( keys %rsp_result ) {
        #################################
        # Error logging on to MM
        #################################
        my $result = $rsp_result{$ip};
        my $Rc = shift(@$result);

        if ( $Rc != SUCCESS ) {
            #############################
            # MM connect error
            #############################
            if ( ref(@$result[0]) ne 'ARRAY' ) {
                if ( $verbose ) {
                    trace( $request, "$ip: @$result[0]" );
                }
                delete $mm->{$ip};
                next;
            } 
        }        
        ##################################
        # Process each response
        ##################################
        foreach ( @{@$result[0]} ) {
            if ( $verbose ) {
                trace( $request, "$ip: $_" );
            }
            /^(\S+)\s+(\d+)/;
            my $cmd = $1;
            $Rc = $2;

            if ( $cmd =~ /^network_reset/ ) {
                if ( $Rc != SUCCESS ) {
                    delete $mm->{$ip};
                    next;
                }
                if ( $verbose ) {
                    trace( $request,"Resetting management-module ($ip)...." );
                }
            }
        }
    }
    ######################################
    # Update etc/hosts 
    ######################################
    my $fname = "/etc/hosts";
    if ( $verbose ) {
        trace( $request, "updating /etc/hosts...." );
    }
    unless ( open( HOSTS,"<$fname" )) {
        if ( $verbose ) {
            trace( $request, "Error opening '$fname'" );
        }
        return( $mm );
    } 
    my @rawdata = <HOSTS>;
    close( HOSTS );

    ######################################
    # Remove old entry 
    ######################################
    foreach ( keys %$mm) {
        my ($ip,$host) = split /,/,$mm->{$_}->{args};
        foreach ( @rawdata ) {
            if ( /^#/ or /^\s*\n$/ ) {
                next;
            } elsif ( /\s+$host\s+$/ ) {
                s/$_//;
            }
        }
        push @rawdata,"$ip\t$host\n";
    }
    ######################################
    # Rewrite file 
    ######################################
    unless ( open( HOSTS,">$fname" )) {
        if ( $verbose ) {
            trace( $request, "Error opening '$fname'" );
        }
        return( $mm );
    }
    print HOSTS @rawdata;
    close( HOSTS );
    return( $mm );
}


##########################################################################
# Process request from xCat daemon
##########################################################################
sub process_request {

    my $req      = shift;
    my $callback = shift;
    my $doreq    = shift;

    ###########################################
    # Build hash to pass around
    ###########################################
    my %request;
    $request{arg}      = $req->{arg};
    $request{callback} = $callback;
    $request{command}  = $req->{command}->[0];

    ####################################
    # Process command-specific options
    ####################################
    my $result = parse_args( \%request );
    
    ####################################
    # Return error
    ####################################
    if ( ref($result) eq 'ARRAY' ) {
        send_msg( \%request, 1, @$result );
        return(1);
    }   
    ###########################################
    # SLP service-request - select program
    ###########################################
    $result = $openSLP ? slptool( \%request ) : slp_query( \%request );
    my $Rc  = shift(@$result);

    return( $Rc );
}


1;