### Local Variables: *** ### mode:perl *** ### comment-column:0 *** ### comment-start: "### " *** ### comment-end: "***" *** ### End: *** # # ****************DO NOT MOVE OR CHANGE LINES ABOVE THIS********************* # # The first set of lines runs perl from any shell. The second set of lines # identifies the rest of the file as PERL for EMACS autoformatting. # See end of copyright for more information. # # # ------------------------------------------------------------------- # X-BONE # # http://www.isi.edu/xbone # USC Information Sciences Institute (USC/ISI) # Marina del Rey, California 90292, USA # Copyright (c) 1998-2005 # # ------------------------------------------------------------------- # # Copyright (c) 1998-2005 by the University of Southern California. # All rights reserved. # # Permission to use, copy, modify, and distribute this software and # its documentation in source and binary forms for non-commercial # purposes and without fee is hereby granted, provided that the above # copyright notice appear in all copies and that both the copyright # notice and this permission notice appear in supporting # documentation, and that any documentation, advertising materials, # and other materials related to such distribution and use acknowledge # that the software was developed by the University of Southern # California, Information Sciences Institute. The name of the # University may not be used to endorse or promote products derived # from this software without specific prior written permission. # # THE UNIVERSITY OF SOUTHERN CALIFORNIA MAKES NO REPRESENTATIONS ABOUT # THE SUITABILITY OF THIS SOFTWARE FOR ANY PURPOSE. THIS SOFTWARE IS # PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, # INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF # MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # Other copyrights might apply to parts of this software and are so # noted when applicable. # # ------------------------------------------------------------------- # # Effort partly sponsored by the Defense Advanced Research Projects # Agency (DARPA) and Air Force Research Laboratory, Air Force Materiel # Command, USAF, under agreement numbers F30602-98-1-0200 (X-Bone) and # F30602-01-2-0529 (DynaBone). The views and conclusions contained # herein are those of the authors and should not be interpreted as # necessarily representing the official policies or endorsements, # either expressed or implied, of the Defense Advanced Research # Projects Agency (DARPA), the Air Force Research Laboratory, or the # U.S. Government. # # This work was partly supported by the NSF STI-XTEND (ANI-0230789) # and NETFS (ANI-0129689) projects. Any opinions, findings, and # conclusions or recommendations expressed in this material are those # of the authors and do not necessarily reflect the views of the # National Science Foundation. # # ------------------------------------------------------------------- # $RCSfile: XB_Common.pm,v $ # # $Revision: 1.70 $ # $Author: pingali $ # $Date: 2005/04/21 00:14:32 $ # $State: Exp $ # ---------------------------------------------------------------------------- # # Primary Author: Yu-Shun Wang # Description: XBone common utility functions package XB_Common; require Exporter; @ISA = qw(Exporter); @EXPORT = qw(); @EXPORT_OK = qw( ssl_accept ssl_read_cert fh_read_until tcp_ssl_sock udp_sock record_state restore_state api_error_msg ctl_error_msg ctl_msg check_create_dir reset_state get_string update_conf_file ); use strict; use sigtrap; use FileHandle; use Data::Dumper; use Socket; use Socket6; #use IO::Select; #use IO::Socket::SSL 0.92; #use IO::Socket::SSLv6; use IPC::Open3; use Net::IP; use Data::Dumper; use XB_Params; #use XB_Log; my $modname = "XB_Common::"; ############################################################################### # UTILITY FUNCTIONS ############################################################################### # Description: # - # Arguments: # - # Returns: # - # Exceptions: # - # ############################################################################### # EXPORTED API ############################################################################### # =========================================================================== # XBone SSL functions # =========================================================================== # Description: # Parse IO::Socket::SSL::accept. # Arguments: # $ssl socket handle to accept # Returns: # $cliens client socket handle # Exceptions: # "ssl_accept" on error, nothing to clean up by caller # sub ssl_accept ($){ my $ssl = shift; my ($client); my $procname = "ssl_accept"; XB_Log::log "info", "-> $modname$procname $ssl"; eval{ # set alarm because IO::Socket::SSL::accept would block forever waiting # for ssl handshake with a non-SSL client! local $SIG{ALRM} = sub {die "alarm\n"}; alarm 15; # TIMEOUT # unless ($client = $ssl->accept){ XB_Log::log "err", " SSL accept failed" . $ssl->errstr(); alarm 0; # reset alarm die "accept\n"; } alarm 0; # reset alarm }; XB_Log::log "info", "<- $modname$procname"; return $client unless $@; if($@ eq "alarm\n"){ XB_Log::log "err", " ! SSL accept timeout, possibly non-SSL client"; }elsif($@ !~ /^(accept)/){ XB_Log::log "warning", " ! $procname caught unexpected exception $@"; } die "$modname$procname"; } # Description: # Get peer certificate, extract issuer & subject names. # Arguments: # $ssl handle to ssl connection # Returns: # $peer peer canonical name on the cert # $issuer issuer canonical name on the cert # $cipher supported cipher list (not sure if we need it) # Exceptions: # "ssl_read_cert" on error, caller should close the socket sub ssl_read_cert ($){ my $ssl = shift; my ($peer_cert, $peer, $issuer, $cipher); my $procname = "ssl_read_cert"; XB_Log::log "info", "-> $modname$procname $ssl"; eval{ if( ref($ssl) eq "IO::Socket::SSL" or ref($ssl) eq "IO::Socket::SSLv6"){ $peer = $ssl->peer_certificate("subject"); $issuer = $ssl->peer_certificate("issuer"); $cipher = $ssl->get_cipher(); XB_Log::log "debug8", " - peer: $peer"; XB_Log::log "debug8", " - issuer: $issuer"; XB_Log::log "debug8", " - cipher: $cipher"; if ($peer =~ /\/CN=([^\/]*)\/.*/){ $peer = $1; }else{ XB_Log::log "err", " [$procname] error parsing peer CN"; die "cn"; } if ($issuer =~ /\/OU=([^\/]*)(\/.*)?$/){ $issuer = $1; }else{ XB_Log::log "err", " [$procname] error parsing issuer OU"; die "ou"; } }else{ XB_Log::log "err", " [$procname] $ssl not an SSL socket!"; die "sock"; } }; XB_Log::log "info", "<- $modname$procname ($peer, $issuer, $cipher) "; return ($peer, $issuer, $cipher) unless $@; unless ($@ =~ /^(cn|ou|cert|sock)/){ XB_Log::log "warning", " ! $procname caught unexpected exception $@"; } die "$modname$procname"; } # Description: # Read the given file handle until the delimiter # Arguments: # $sock socket handle to read # $eom message delimiter # Returns: # $message message read without the delimiter # Exceptions: # - sub fh_read_until($$){ my ($sock, $eom) = @_; my ($message); my $procname = "fh_read_until"; XB_Log::log "info", "-> $modname$procname $sock, $eom"; eval{ local $SIG{ALRM} = sub {die "alarm\n"}; alarm 100; while( my $line=<$sock> ){ # keep blank lines? #next unless ($line =~ /\S/); # blank line if($line =~ /\b$eom\b/){ my $pending = $sock->pending; if($pending>0){ my $string; $string = $sock->readline; XB_Log::log "debug8", " [$procname] leftover: $string";} else{ XB_Log::log "debug8", " [$procname] nothing pending"; } last; } $message .= $line; } alarm 0; }; XB_Log::log "info", "<- $modname$procname"; XB_Log::log "debug7", " Received message --------------------------\n". $message. "\n=============================================="; return $message unless $@; if($@ eq "alarm\n"){ XB_Log::log "err", " ! procname timeout waiting for \"$eom\""; return ""; }else{ XB_Log::log "warning", " ! $procname caught unexpected exception $@"; } die "$modname$procname"; } # Description: # Create & bind to a TCP/SSL socket on the given local address & port # Arguments: # $ipproto ipv4 or ipv6 # $addr local address or hostname # $port local port # Returns: # sock TCP/SSL socket handle # Exception: # "XB_Common::ssl_listen_sock" on failure, nothing to clean up by caller # sub ssl_listen_sock($$$){ my ($ipproto, $addr, $port) = @_; my $sock; my $procname = "ssl_listen_sock"; XB_Log::log "info", "-> $modname$procname $ipproto, $addr, $port"; eval{ if($ipproto eq 'ipv4'){ $sock = IO::Socket::SSL->new( LocalAddr => $addr, LocalPort => $port, Proto => 'tcp', Reuse => 1, Listen => SOMAXCONN, SSL_server => 1, SSL_verify_mode => 0x03, SSL_cert_file => $XB_Params::node_opts{"node_cert"}, SSL_key_file => $XB_Params::node_opts{"node_key"}, SSL_ca_file => $XB_Params::node_opts{"ca_cert"}, SSL_ca_path => $XB_Params::node_opts{"ca_path"} ); unless($sock){ XB_Log::log "err", " [$procname] create/bind SSL socket ". "$ipproto $addr:$port failed: $!"; die "sock"; }else{ XB_Log::log "notice", " [$procname] open SSL listening socket on ". "$ipproto $addr:$port"; } }elsif($ipproto eq 'ipv6'){ $sock = IO::Socket::SSLv6->new( LocalAddr => $addr, LocalPort => $port, Proto => 'tcp', Reuse => 1, Listen => SOMAXCONN, SSL_server => 1, SSL_verify_mode => 0x03, SSL_cert_file => $XB_Params::node_opts{"node_cert"}, SSL_key_file => $XB_Params::node_opts{"node_key"}, SSL_ca_file => $XB_Params::node_opts{"ca_cert"}, SSL_ca_path => $XB_Params::node_opts{"ca_path"} ); unless($sock){ XB_Log::log "err", " [$procname] create/bind SSL socket ". "$ipproto $addr:$port failed: $!"; die "sock"; }else{ XB_Log::log "notice", " [$procname] open SSL listening socket on ". "$ipproto $addr:$port"; } }else{ XB_Log::log "err", " [$procname] unknown IP protocol: $ipproto"; die "ipproto"; } }; XB_Log::log "info", "<- $modname$procname"; return $sock unless $@; unless($@ =~ /(sock|ipproto)/){ XB_Log::log "warning", " ! $procname caught unknown exception: $@"; } die "$modname$procname"; } # Description: # Create a TCP/SSL socket to given destination address and port # Arguments: # ipproto ipv4 or ipv6 # dest destination hostname # port destination port number # Returns: # sock TCP/SSL socket handle # Exception: # "XB_Common::tcp_ssl_sock" on failure, nothing to clean up by caller sub tcp_ssl_sock ($$$;$){ my ($ipproto, $dest, $port, $addr) = @_; my $procname = "tcp_ssl_sock"; my $argstr = join ", ", @_; XB_Log::log "info", "-> $modname$procname $argstr"; my $sock; if (not defined($ipproto) or $ipproto eq ""){ $ipproto ="ipv4"; } eval{ #=> check if a socket to the dest::port already exist if(defined $XB_Params::persistent_socks{$ipproto}{$dest}{$port}){ # TODO should also verify if the socket is valid, with "ref"? XB_Log::log "info", " [$procname] a socket to $dest:$port exists"; $sock = $XB_Params::persistent_socks{$ipproto}{$dest}{$port}; }else{ # XXX this check should depend on the ip version chosen for the # control. if ($ipproto eq "ipv6"){ if(defined $addr and $addr ne ''){ $sock = IO::Socket::SSLv6->new( LocalAddr => $XB_Params::node_opts{"ctl_addr6"}, PeerAddr => $addr, PeerPort => $port, Proto => "tcp", SSL_use_cert => 1, SSL_verify_mode => 0x03, SSL_cert_file => $XB_Params::node_opts{"node_cert"}, SSL_key_file => $XB_Params::node_opts{"node_key"}, SSL_ca_file => $XB_Params::node_opts{"ca_cert"}, SSL_ca_path => $XB_Params::node_opts{"ca_path"} ); }else{ my $addrs = getaddr($dest, 'ipv6'); foreach my $peer (@{$addrs}){ $sock = IO::Socket::SSLv6->new( LocalAddr => $XB_Params::node_opts{"ctl_addr6"}, PeerAddr => $peer, PeerPort => $port, Proto => "tcp", SSL_use_cert => 1, SSL_verify_mode => 0x03, SSL_cert_file => $XB_Params::node_opts{"node_cert"}, SSL_key_file => $XB_Params::node_opts{"node_key"}, SSL_ca_file => $XB_Params::node_opts{"ca_cert"}, SSL_ca_path => $XB_Params::node_opts{"ca_path"} ); last if $sock; } # foreach } # else } else { my $addrs = getaddr($dest, 'ipv4'); my $peer = ${$addrs}[0]; $sock = IO::Socket::SSL->new( LocalAddr => $XB_Params::node_opts{"ctl_addr"}, PeerAddr => $peer, PeerPort => $port, Proto => "tcp", SSL_use_cert => 1, SSL_verify_mode => 0x03, SSL_cert_file => $XB_Params::node_opts{"node_cert"}, SSL_key_file => $XB_Params::node_opts{"node_key"}, SSL_ca_file => $XB_Params::node_opts{"ca_cert"}, SSL_ca_path => $XB_Params::node_opts{"ca_path"} ); } if(!$sock){ XB_Log::log "err", " [$procname] create ssl socket to $dest:$port ". "failed: $!" and die "socket"; }else{ XB_Log::log "info", " [$procname] open ssl socket to $dest:$port"; if($XB_Params::PERSISTENT_SOCK){ $XB_Params::persistent_socks{$ipproto}{$dest}{$port} = $sock; } } } my $select = IO::Select->new($sock); while (my @w = $select->can_write){ for my $s (@w){ if($s == $sock){ $select->remove($s); last; } } } }; XB_Log::log "info", "<- $modname$procname"; return $sock unless $@; unless($@ =~ /(socket)/){ XB_Log::log "warning", " ! $procname caught unknown exception: $@"; } die "$modname$procname"; } # Description: # Close all opened TCP/SSL sockets inside a forked process # Arguments: # - # Returns: # 1 on success # Exception: # "XB_Common::child_close" on failure, nothing to clean up by caller sub child_close ($){ my ($tag) = @_; my $procname = "child_close"; XB_Log::log "info", "-> $modname$procname $tag"; eval{ if($XB_Params::NO_FORK){ # do nothing if we didn't fork XB_Log::log "info", " [$procname] fork disabled, no need to close"; }else{ while(my ($ip, $hosthash) = each %XB_Params::persistent_socks){ while(my ($host, $porthash) = each %{$hosthash}){ while(my ($port, $sock) = each %{$porthash}){ unless(ref($sock) =~ /IO::Socket::SSL/){ XB_Log::log "warning", " [$procname] wrong socket type: ". ref($sock); } $sock->close('SSL_no_shutdown' => 1); XB_Log::log "debug1", " [$procname:$tag] close $ip:$host:$port"; } } } } }; XB_Log::log "info", "<- $modname$procname"; return 1 unless $@; die "$modname$procname"; } # =========================================================================== # XBone Network & Socket functions # =========================================================================== # Description: # Create a multicast socket bind to given local address and port. # Arguments: # $ipproto ipv4 or ipv6 # $addr local address or hostname # $port local port # Returns: # $sock multicast socket handle # Exceptions: # "mcast_sock" on error, nothing to clean up by caller # sub mcast_sock($$$){ my ($ipproto, $addr, $port) = @_; my $sock; my $procname = "mcast_sock"; XB_Log::log "info", "-> $modname$procname $ipproto, $addr, $port"; eval{ if($ipproto eq 'ipv4'){ $sock = IO::Socket::Multicast->new( LocalAddr => $addr, LocalPort => $port, Proto => "udp" ); unless($sock){ XB_Log::log "err", " [$procname] create multicast/udp socket ". "$ipproto $addr:$port failed: $!"; die "sock"; }else{ XB_Log::log "notice", " [$procname] bind to multicast/udp socket". " on $ipproto $addr:$port"; } }elsif($ipproto eq 'ipv6'){ $sock = IO::Socket::Multicast6->new( LocalAddr => $addr, LocalPort => $port, Proto => "udp" ); unless($sock){ XB_Log::log "err", " [$procname] create multicast/udp socket ". "$ipproto $addr:$port failed: $!"; die "sock"; }else{ XB_Log::log "notice", " [$procname] bind to multicast/udp socket". " on $ipproto $addr:$port"; } }else{ XB_Log::log "err", " [$procname] unknown IP protocol: $ipproto"; die "ipproto"; } }; XB_Log::log "info", "<- $modname$procname"; return $sock unless $@; unless($@ =~ /(sock|ipproto)/){ XB_Log::log "warning", " ! $procname caught unknown exception: $@"; } die "$modname$procname"; } # Description: # Create an UDP socket of given destination & port # Arguments: # $dest destination host # $port destination port # $ip ipv4 or ipv6 # Returns: # $udp udp socket handle # Exceptions: # "udp_sock" on error, nothing to clean up by caller sub udp_sock($$$){ my ($dest, $port, $ip) = @_; my $procname = "udp_sock"; my $udp; XB_Log::log "info", "-> $modname$procname $dest, $port, $ip"; eval{ if($ip ne "ipv6"){ $udp = new IO::Socket::INET( LocalAddr => $XB_Params::node_opts{"ctl_addr"}, PeerAddr => $dest, PeerPort => $port, Proto => "udp" ); }else{ # ipv6. test if the destination is a name or an ip address my $n = new Net::IP($dest); if (defined $n){ $udp = new IO::Socket::INET6( LocalAddr => $XB_Params::node_opts{"ctl_addr6"}, PeerAddr => $dest, PeerPort => $port, Proto => "udp" ); } else { # otherwise resolve the address my $addrs = getaddr($dest, 'ipv6'); my $peer = ${$addrs}[0]; if (defined $peer){ $udp = new IO::Socket::INET6( LocalAddr => $XB_Params::node_opts{"ctl_addr6"}, PeerAddr => $peer, PeerPort => $port, Proto => "udp" ); }; #defined peer } } #else if(!$udp){ XB_Log::log "err", " [$procname] failed to create UDP socket to $dest:$port: $!"; die "sock"; }else{ XB_Log::log "info", " [$procname] UDP socket to $dest:$port"; } }; XB_Log::log "info", "<- $modname$procname"; return $udp unless $@; unless($@ =~ /sock/){ XB_Log::log "warning", " ! $procname caught unknown exception: $@"; } die "$modname$procname"; } # Description: # Front end to call appropriate socket create functions with given # destination and port. # Arguments: # $dest destination host # $port destination port # $ipproto ipv4 or ipv6 # $type TCP/SSL, UDP, or Multicast # Returns: # $sock socket handle # Exceptions: # "create_sock" on error, nothing to clean up by caller # sub create_sock($$$$){ my ($dest, $port, $ipproto, $type) = @_; my $procname = "create_sock"; my $argstr = join ", ", @_; my $sock; XB_Log::log "debug1", "-> $modname$procname $argstr"; eval{ }; return $sock unless $@; unless($@ =~ //){ XB_Log::log "warning", " ! $procname caught unknown exception: $@"; } die "$modname$procname"; } # Description: # Connection Manager: fork a child process to handle all persistent # connections between this node and all its selected RDs & sub-OMs. # It has two modes of operation: direct mode and proxy mode: # - direct mode: open TCP/SSL connection to the given destination, and # return the TCP/SSL socket directly to the caller; # subsequent communications between parent and the given # destination happen directly through the returned socket # - proxy mode: open TCP/SSL connection to the given destination, then # open another UNIX domain socket between main process & # the connection manager process, return the internal UNIX # domain socket to the caller; subsequent communications # between the parent and the given destination are proxied # through the connection manager # Arguments: # command open/close/exit # dest destination hostname # port destination port number # Returns: # sock socket handle for "open", nothing for "close" & "exit" # Exception: # "XB_Common::connection_manager" on failure, nothing to clean up by # caller # sub connection_manager($$$){ my ($cmd, $host, $port) = @_; my $procname = "connection_manager"; XB_Log::log "info", "-> $modname$procname $cmd, $host, $port"; eval{ # main (parent) # check if a cm process already exists # - yes: form the command & send to the cm process through cm_sock # - no: create a socketpair & fork; then form the command & send # to the cm process through cm_sock # cm (chile) # init: create an IO::Select object and add the main socket; then # enter select loop # loop: switch on socket ready to read # [main_sock]: command? # - open $ovlname $host $port: # - open TCP/SSL socket to $host:$port # - direct mode: return the TCP/SSL socket # - proxy mode: create }; XB_Log::log "info", "<- $modname$procname"; return 1 unless $@; unless($@ =~ /\S+/){ XB_Log::log "warning", " ! $procname caught unknown exception: $@"; } die "$modname$procname"; } # Description: # Manipulate file handles in the parent of a fork process. # Arguments: # - # Returns: # 1 on success # Exception: # "XB_Common::fork_parent_close" on failure, nothing to clean up by caller sub fork_parent_close($$$$){ my ($select, $read, $write, $id) = @_; my $procname = "fork_parent_close"; XB_Log::log "debug1", "-> $modname$procname $select, $read, $write, $id"; eval{ # add the read handle to the select object $select->add($read) or die "select"; # close the write handle $write->close or die "close"; }; XB_Log::log "debug1", "<- $modname$procname"; return 1 unless $@; unless ($@ =~ /\b(select|close)\b/){ XB_Log::log "warning", " ! $procname caught unknown exception: $@"; } die "$modname$procname"; } # =========================================================================== # XBone State File Processing # =========================================================================== # - record_state: # calls write_state with XBone-specific parameters to record the XBone # node state # - restore_state: # calls read_state with XBone-specific parameters to restore the XBone # node state, then proceed to re-configure the node accrodingly # - write_state: # generic function to write given variables/names into the given file # - read_state: # generic function to read and eval the given file # Description: # Writes the given data structures with specified names out to the state # file for crash recovery purpose. The state must be rewritten each time # a change is made to an overlay. # Arguments: # $file filename to write to # $vars (ref) array of variables to be written # $varnames (ref) array of variable names specified in @{$vars} # Returns: # 1 on success # Exception: # "XB_Common::write_state" on failure # Note: # o This is a generic function to write any data structures to the given # file. No XBone-specific assumptions are made. # o This function is called by "record_state" to write XBone node state. # sub write_state ($$$){ my ($file, $vars, $varnames) = @_; my $procname = "write_state"; my $state; my $fh = new FileHandle; XB_Log::log "info", "-> $modname$procname @_"; eval{ # open the file for writing if(!$fh->open ($file, ">")){ XB_Log::log "err", " [$modname] failed to open file $file: $!"; die "open"; } # set permission if(!chmod(0600, $file)){ XB_Log::log "err", " [$modname] failed to set permission 0600 on". " $file: $!"; die "chmod"; } $state = Data::Dumper->Dump($vars, $varnames); $fh->print ("$state") or die "print: $!"; $fh->close or die "close: $!"; }; XB_Log::log "info", "<- $modname$procname"; return 1 unless $@; unless($@ =~ /(open|chmod|print|close)/){ XB_Log::log "warning", " [$procname] caught unkown exception: $@"; } die "$modname$procname"; } # Description: # Read the given state file and evaluate its contents # Arguments: # $state state file (full path) # Returns: # 1 on success, 0 if file doesn't exist # Exception: # "XB_Common::read_state" on failure, nothing to cleanup by caller # Side Effect: # The variables stored in the state file will overwrite those of the same # names in the current process. # Note: # o This is a generic function to read any state files generated by # Data::Dumper->Dump. No XBone-specific assumptions are made about # the contents of the state file. # o This function is called by "restore_state" to restore XBone state file. # sub read_state($){ my $state = shift; my $result = 1; my $procname = "read_state"; XB_Log::log "info", "-> $modname$procname $state"; eval{ my $fh = new FileHandle; my $data; if(-e $state){ if($fh->open($state, "<")){ XB_Log::log "debug1", " [$procname] read from $state"; while(<$fh>){ $data .= $_; XB_Log::log "debug6", "[STATE] $_"; } $data =~ /(.*)/s; # untaint the value XB_Log::log "debug1", " [$procname] evaluate the data"; eval $data; $fh->close or XB_Log::log "err", " [$procname] could not close $state: $!" and die "close"; }else{ XB_Log::log "warning", " [$procname] failed to open $state: $!"; $result = 0; } }else{ XB_Log::log "warning", " [$procname] state file $state doesn't exist"; $result = 0; } }; XB_Log::log "info", "<- $modname$procname"; return $result unless $@; unless($@ =~ /(open|close)/){ XB_Log::log "warning", " [$procname] caught unknown exception: $@"; } die "$modname$procname"; } # Description: # Record XBone node state. # Arguments: # - # Returns: # 1 on success # Exception: # "XB_Common::record_state" on failure, # sub record_state{ my $procname = "record_state"; XB_Log::log "info", "-> $modname$procname"; eval{ my $state = $XB_Params::node_opts{workdir}. "/". $XB_Params::node_opts{state_file}; $XB_Params::state_time = time; my @vars = ($XB_Params::state_time, \%XB_Params::node_state); my @varnames = qw ( *XB_Params::state_time *XB_Params::node_state); write_state $state, \@vars, \@varnames; }; XB_Log::log "info", "<- $modname$procname"; return 1 unless $@; unless($@ =~ /(write_state)/){ XB_Log::log "warning", " [$procname] caught unknown exception: $@"; } die "$modname$procname"; } # Description: # Restore XBone node state. # Arguments: # - # Returns: # - # Exception: # "XB_Common::restore_state" on failure, ??? # sub restore_state{ my $result = 1; my $procname = "restore_state"; XB_Log::log "info", "-> $modname$procname"; eval{ my $state = $XB_Params::node_opts{workdir}. "/". $XB_Params::node_opts{state_file}; my $now = time; #1. read and eval the state file $result = read_state $state; # set %XB_Params::node_state if succeeded if($result){ if($XB_Params::state_time != $now){ if($XB_Params::state_time > $now){ XB_Log::log "warning", " [$procname] Reading state from the ". "future! Check your system time."; } my $stime = localtime $XB_Params::state_time; XB_Log::log "info", " [$procname] restored state from [$stime]"; } #-> restore IP address server state if($XB_Params::node_state{ip_allocator}){ if($XB_Params::node_opts{addrserv}){ my ($diff, $str) = (0, ""); my $ip = $XB_Params::node_state{ip_blocks}; # go through each block to check for consistency if($XB_Params::new_alloc){ if(exists $ip->{ipv4}){ # only care if state has it before unless($ip->{ipv4}{cidr} eq $XB_Params::node_opts{netv4}){ # if no active leases, just ignore the old ones unless(keys(%{$ip->{ipv4}{leases}}) == 0){ $diff = 1; $str .= " o IPv4 netblocks: $ip->{ipv4}{cidr} vs. ". "$XB_Params::node_opts{netv4} (new)\n"; } } } if(exists $ip->{ipv6}){ # only care if state has it before unless($ip->{ipv6}{cidr} eq $XB_Params::node_opts{netv6}){ unless(keys (%{$ip->{ipv6}{leases}}) == 0){ $diff = 1; $str .= " o IPv6 netblocks: $ip->{ipv6}{cidr} vs. ". "$XB_Params::node_opts{netv6} (new)\n"; } } } }else{ unless($ip->{ipv4}{netblock} eq $XB_Params::node_opts{netv4}){ $diff = 1; $str .= " o IPv4 netblocks: $ip->{ipv4}{netblock} vs. ". "$XB_Params::node_opts{netv4} (new)\n"; } unless($ip->{ipv4}{linkblock} eq $XB_Params::node_opts{linkv4}){ $diff = 1; $str .= " o IPv4 linkblocks: $ip->{ipv4}{linkblock} vs. ". "$XB_Params::node_opts{linkv4} (new)\n"; } unless($ip->{ipv6}{netblock} eq $XB_Params::node_opts{netv6}){ $diff = 1; $str .= " o IPv6 netblocks: $ip->{ipv6}{netblock} vs. ". "$XB_Params::node_opts{netv6} (new)\n"; } unless($ip->{ipv6}{linkblock} eq $XB_Params::node_opts{linkv6}){ $diff = 1; $str .= " o IPv6 linkblocks: $ip->{ipv6}{linkblock} vs. ". "$XB_Params::node_opts{linkv6} (new)\n"; } } if($diff){ XB_Log::log "err", " [$procname] Saved state conflicted with new config option:\n". " This node was an IP addr server with different ranges:". "\n$str"; die "addrblks"; }else{ XB_Log::log "info", " [$procname] restored IP addr server state"; } }else{ XB_Log::log "warning", " [$procname] Saved state conflicted with new config option:\n". " This node was an IP addr server, but it's disabled now."; #die "addrserv"; } # else compare the range of IP pools, die if different }else{ # state file has nothing, don't care if it's server this time around } #-> restore active applications (overlay) state # for each overlay # top level om # if last refresh is sent within expiration interval # [om] refresh/recreate # elsif(persistent overlay) # [om] refresh/recreate # else # remove state # sub-om or rds # [om] or [rd] refresh/recreate state # (and let it timeout automatically) # * om should wait for a heartbeat before sending refresh, or # wait until a heartbeat is rejected? #if(exists $XB_Params::node_state{user_stats}){ # # re-count from scratch # delete $XB_Params::node_state{user_stats}; #} for my $a (keys %{$XB_Params::node_state{active_apps}{overlay}}){ my $app = $XB_Params::node_state{active_apps}{overlay}{$a}; if(exists $app->{node}){ # simple node [rd], get app info and restore my $ncmd = $app->{node}{command}; my $cred = $app->{node}{credential}; my $type = $ncmd->{app_type}; my $name = $ncmd->{app_name}; my $level = $ncmd->{level}; XB_Log::log "info", " [$procname] restoring $type $name"; # delete but retain the state my $dummy = XB_CTL::ctl_stop($type, $name, $level, "localhost", 1); # create again $dummy = XB_CTL::ctl_config($app->{node}, 1); #$XB_Params::node_state{user_stats}{$cred->{user_email}}++; }elsif(exists $app->{network}){ # recursive meta node XB_Log::log "warning", " [$procname] Recursive crash recovery ". "is not supported yet."; }elsif(exists $app->{application}){ # top level meta node XB_Log::log "info", " [$procname] Creator of $a, restore state". " only."; #$XB_Params::node_state{user_stats}{$app->{credential}{user_email}}++; }else{ XB_Log::log "warning", " [$procname] Unrecognized overlay hash:". "\n". Dumper($app); } XB_Log::log "debug6", " [$procname] restored state:". "\n". Dumper(\%XB_Params::node_state); } } }; XB_Log::log "info", "<- $modname$procname"; return $result unless $@; unless($@ =~ /(open|close|addrblks|addrserv|ctl_stop|ctl_config)/){ XB_Log::log "warning", " [$procname] caught unknown exception: $@"; } die "$modname$procname"; } #sub XB_read_state ($$) #{ # my ($nodehref, $cfgfile) = @_; # my $fh = new FileHandle; # my ($dsdata, $end_found, $dstime, %newstate); # # XB_Log::log ("info", "->XB_read_state (@_)"); # # XB_Log::log ("debug0", "Initializing node database ..."); # # $end_found = 0; # # if (! -d $XB_Params::DAEMON_STATE_DIR) # { # my @md = ("mkdir", "-m", "0755", "$XB_Params::DAEMON_STATE_DIR"); # my $rc = 0xff & system (@md); # ($rc == 0) or # XB_Log::log "err", "mkdir $XB_Params::DAEMON_STATE_DIR failed: $!"; # } # # if ($fh->open ($XB_Params::DAEMON_STATE_FILE, "<")) # { # ############################################## # # Read in state data and look for STATE_TIME # # written, used to indicate that file is good. ## ############################################## # # XB_Log::log ("debug0", # "Reading daemon state file: $XB_Params::DAEMON_STATE_FILE"); # # $dsdata = $dstime = ""; #READLINE: # while (<$fh>) # { # if ($_ !~ m'\$XB_Params::DAEMON_STATE_TIME\s*=') # { $dsdata .= $_; } # else # { # $end_found = 1; # $dstime = $_; # last READLINE; # }; # }; # # $fh->close; # # if ($end_found) # { # $dsdata =~ /(.*)/s; # Taint fixup. State file is in a root # $dsdata = $1; # privileged directory, so we trust it. # # eval $dsdata; # This EVAL sets $XB_Params::DAEMON_STATE. # # $nodehref = \%XB_Params::DAEMON_STATE; # # XB_runtime_state ($nodehref); # Reassert runtime state # # $XB_Params::NODEOS = $XB_Params::DAEMON_STATE{'OS'}; # }; # }; # # ########################################### # # If we either cannot access the state file # # or did not see it properly terminated the # # state is initialized from the config file. # ########################################### # # if (!$end_found) # { # XB_Log::log ("warning", "State data file damaged or missing."); # XB_Log::log ("warning", "Reinitializing using config file alone."); # # %XB_Params::DAEMON_STATE = (); # # XB_read_config_file ($cfgfile, \%XB_Params::DAEMON_STATE); # # $nodehref = \%XB_Params::DAEMON_STATE; # # XB_runtime_state ($nodehref); # Reassert runtime state # # $XB_Params::NODEOS = $XB_Params::DAEMON_STATE{'OS'}; # #{ # my $state = Dumper ($nodehref); # XB_Log::log ("info", "###################################\n"); # XB_Log::log ("info", "########## INIT STATE ##########\n"); # XB_Log::log ("info", "\n$state\n"); # XB_Log::log ("info", "############### END ###############\n"); # XB_Log::log ("info", "###################################\n"); #} # # } # else # { # XB_Log::log "info", "Using state file: $XB_Params::DAEMON_STATE_FILE"; # }; # # # eval { XB_IPsec::init() }; # if ($@) # { # XB_Log::log ("err", "XB_IPsec::init failed with $@"); # die ""; # }; # # eval { XB_Tunnel::init() }; # if ($@) # { # XB_Log::log ("err", "XB_Tunnel::init failed with $@"); # die ""; # }; # # eval { XB_Route::init() }; # if ($@) # { # XB_Log::log ("err", "XB_Route::init failed with $@"); # die ""; # }; # # ########################################### # # If developing, ensure a clean route, # # tunnel and IPsec state in the host. # # # # NOTE: ERASE_AT_STARTUP will eliminate # # ALL host tunnels and IPsec rules, # # not just Xbone tunnels and rules. # ########################################### # # if ($XB_Params::ERASE_AT_STARTUP) # { # XB_erase_host_state (); # } # # ########################################### # # If we read what we believe is good state # # the overlays are reinitialized to reflect # # that state. # ########################################### # # XB_Log::log ("debug0", "Restoring using daemon state file ..."); # # XB_restore_state ($nodehref); # # XB_Log::log ("debug0", "State has been restored."); # # #################################### # # Always reread current config file. # # This can alter some of the just # # reloaded state data, particularly # # changed access control lists. # #################################### # # XB_Log::log ("debug0", "Reading current host config file."); # # %newstate = (); # XB_read_config_file ( $cfgfile, \%newstate ); # # XB_update_daemon_state ($nodehref, \%newstate); # %$nodehref = %newstate; # # XB_runtime_state ($nodehref); # Reassert runtime state # # # ################################# # # Now that config state is loaded # # perform gross legality checks. # ################################# # # { # my $tmp = XB_node_check ($nodehref); # # if ($tmp) # { # XB_Log::log ("err", "\n****************************\n"); # XB_Log::log ("err", "$tmp\n"); # XB_Log::log ("err", "****************************\n\n"); # # die ""; # } # } # #EXIT: # XB_Log::log ("debug0", "Node database initialized."); # XB_Log::log ("info", "<-XB_read_state ()"); #} # =========================================================================== # Generate common XBone API/CTL Messages # =========================================================================== # Description: # Construct the hashes & lists required to build the XBone API XML # messages and call corresponding functions in XB_XML_GUI modules to # build the messages. # Arguments: # $app_obj (ref) application object # $msg_type message type # Returns: # $msg_ref (ref) message # Exceptions: # - sub api_error_msg ($$$$$){ my ($name, $email, $auth_type, $cmd, $emsg) = @_; my $procname = "api_error_msg"; XB_Log::log "info", "-> $modname$procname $name, $email, $auth_type, $cmd"; # cleanup the error message chomp($emsg); $emsg =~ s/^\s*(\S.*\S)\s*$/$1/; $emsg =~ s//]/g; XB_Log::log "info", " Error Msg:========================================". "\n$emsg\n". " =================================================="; my $msg_ref; eval{ my (%ahref); $ahref{protocol} = $XB_Params::api_ver; $ahref{release} = $XB_Params::rel_ver; $ahref{auth_type} = $auth_type; $ahref{user_email} = $email; $ahref{user_name} = $name; $ahref{command} = $cmd; $msg_ref = XB_XML_GUI::XB_build_api_errmsg (\%ahref, $emsg); XB_Log::log "debug1", " [$procname] message:\n". $$msg_ref; }; XB_Log::log "info", "<- $modname$procname"; return $msg_ref unless $@; XB_Log::log "warning", " ! $procname caught unknown exception $@"; die "$modname$procname"; } # Description: # Construct the XBone CTL error messages from the given parameters. # Arguments: # $cmd error command # $type application type # $name application name # $level application level # $msg (ref) error messages # Returns: # $msg_ref (ref) message # Exceptions: # - sub ctl_error_msg ($$$$$){ my ($cmd, $type, $name, $level, $msg) = @_; my $argstr = join ", ". @_; my $procname = "ctl_error_msg"; XB_Log::log "debug1", "-> $modname$procname $argstr"; $cmd = ((defined $cmd) and ($cmd =~ /\S+/))? $cmd : "unknown"; $type = ((defined $type) and ($type =~ /\S+/))? $type : "unknown"; $name = ((defined $name) and ($name =~ /\S+/))? $name : "unknown"; $level= ((defined $level) and ($level =~ /\S+/))? $level: 0; $msg = $$msg; $msg =~ s/^\s*(\S.*\S)\s*$/$1/; # remove white space from both ends $msg = ($msg =~ /\S+/)? $msg : "empty message"; $msg = "(xbone-ctl $XB_Params::ctl_ver $XB_Params::rel_ver\n". " (error\n". " (command $cmd)\n". " (application $type)\n". " (name $name)\n". " (level $level)\n". " (message \"$msg\")\n". " )\n". ")\n". "$XB_Params::msg_delimiter\n"; XB_Log::log "debug1", "<- $modname$procname"; return \$msg; } # Description: # Generate the credential section with given info. # Arguments: # $name user name # $email user email # $auth auth type # Returns: # \$msg (ref) message sub make_credential($$$){ my ($name, $email, $auth) = @_; my $procname = "make_credential"; XB_Log::log "info", "-> $modname$procname $name, $email, $auth"; my $msg = " (credential (user_name \'$name\')\n". " (user_email \'$email\')\n". " (auth_type \'$auth\'))\n"; return \$msg; } # Description: # Generate simple XBone Control messages of the given types. # Arguments: # $cmd command type # $app application type # $name application name # $level application level # $hostname hostname # $extra %@#$..>&*, (it's extra) # Returns: # \$msg (ref) message # Exceptions: # "XB_Common::ctl_ack" on failure, nothing to cleanup by caller sub ctl_msg($$$$;$$){ my ($cmd, $app, $name, $level, $hostname, $extra) = @_; my $msg; my $procname = "ctl_msg"; my $argstr = join ", ", @_; XB_Log::log "debug1", "-> $modname$procname $argstr"; if(defined $hostname and $hostname =~ /^\S+$/){ $hostname = " (hostname $hostname)\n"; }else{ $hostname = ""; } if(not defined $extra){ $extra = ""; } $msg = "(xbone-ctl $XB_Params::ctl_ver $XB_Params::rel_ver\n". " ($cmd\n". " (application $app)\n". " (name $name)\n". " (level $level)\n". $hostname. $extra. " )\n". ")\n". "$XB_Params::msg_delimiter\n"; XB_Log::log "debug1", "<- $modname$procname"; return \$msg; } # =========================================================================== # User ACL functions # =========================================================================== # Description: # Parse and return the user ACL spec'd in config file (strings) into # a structured user ACL hash. # Arguments: # $acl (ref) user ACL from node config option (rule_no. => acl_str) # $ignore ignore the no user acl message (typical for shared user acls) # Returns: # $new_acl (ref) parsed user ACL # Exception: # "parse_user_acl" on failure, nothing to cleanup by caller # Note: # ACL should work like firewall, order of rules matters. # sub parse_user_acl($;$){ my ($acl,$ignore) = @_; my $procname = "parse_user_acl"; XB_Log::log "info", "-> $modname$procname $acl"; my (@new_acl); eval{ my @rules = keys %{$acl}; unless(@rules > 0){ XB_Log::log "err", " [$procname] NO user ACL entry!" if (not defined $ignore); die "none"; } # sort based on rule numbers because hash is not ordered @rules = sort { $a <=> $b } @rules; for my $n (@rules){ my $acl_str = $acl->{$n}; my %new_acl; if($acl_str =~ /^(\S+)\s+(\S+)\s+(\d+)\s+(\S+)$/){ # format: "$match_uid $level $max_ovl $app_suid" # example: "isi.edu deploy 25 guest" # "john_doe guest 0 nobody" $new_acl{$1}{def} = $acl_str; $new_acl{$1}{no} = $n; $new_acl{$1}{level} = $2; $new_acl{$1}{max} = $3; $new_acl{$1}{suid} = $4; XB_Log::log "debug6", " [$procname] acl entry: [no. $n: $1/$2/$3/$4]"; push @new_acl, \%new_acl; }else{ XB_Log::log "err", " [$procname] error parsing user ACL string:\n". " $n => [$acl_str]"; die "format"; } } XB_Log::log "debug6", " [$procname] User ACL hash:", Dumper(\@new_acl); }; XB_Log::log "info", "<- $modname$procname"; return \@new_acl unless $@; unless($@ =~ /(none|format)/){ XB_Log::log "err", " ! $procname caught unknown exception: $@"; } die "$modname$procname"; } # Description: # Verfiy a user email against the user ACL. # Arguments: # $name user name # $email user email # $auth authentication type # Returns: # $result 1 if ok, 0 if failed # $uid effective uid of the matching entry # Exception: # - sub check_user_acl($$$$){ my ($name, $email, $auth, $cmd) = @_; my $procname = "check_user_acl"; my $result = 0; my $uid = ''; XB_Log::log "info", "-> $modname$procname @_"; eval{ # check auth type unless(defined $auth){ XB_Log::log "err", " [$procname] auth type missing"; die "missing"; }else{ my $auth_pass = 0; for my $a (@XB_Params::auth_type){ if(lc($a) eq lc($auth)){ $auth_pass = 1; last; } } unless($auth_pass){ # die if failed auth type check XB_Log::log "err", " [$procname] auth type $auth not allowed"; die "auth"; } } # go through acl rules foreach my $aclhash ( $XB_Params::node_opts{"user_acl"}, $XB_Params::node_opts{"shared_user_acl"}) { for (my $i = 0; $i < @{$aclhash}; $i++){ for my $u (keys %{$aclhash->[$i]}){ my $h = $aclhash->[$i]{$u}; XB_Log::log "debug2", " [$procname] entry $i: $u"; if($email =~ /$u/i){ # matched! check the rule # check the command against the access level my $cmd_pass = 0; my ($l, $m, $s) = ($h->{level}, $h->{max}, $h->{suid}); $uid = $s; XB_Log::log "debug2", " [$procname] match: $u/$l/$m/$s"; my @action = grep /^$cmd$/, @{$XB_Params::access_level{$l}}; if(@action == 1){ $cmd_pass = 1; }elsif(@action > 1){ $cmd_pass = 1; # probably duplicates in the access level spec XB_Log::log "warning", " [$procname] multiple commands! ". (join ", ", @action); } # if failed, move on to the next rule unless($cmd_pass){ next; } else{ if($cmd =~ /(create_overlay|invite)/){ # check max number of overlay allowed if create if(not defined $XB_Params::node_state{user_stats}{$email}){ $XB_Params::node_state{user_stats}{$email} = 0; } if($XB_Params::node_state{user_stats}{$email} < $m){ $result = 1; last; }else{ XB_Log::log "err", " [$procname] $name reached the max ". "overlay limit ($m)"; die "over"; } }else{ # not create, we passed $result = 1; } } } }; if($result){ last; } }; if ($result) { last; } }; # acl hash - user_acl, shared_user_acl }; XB_Log::log "info", "<- $modname$procname $result"; return ($result, $uid) unless $@; unless($@ =~ /(auth|over)/){ XB_Log::log "warning", " ! $procname caught unknown exception: $@"; } return 0; } # Description: # Verfiy a user email against the user ACL. # Arguments: # $msg_type XBone control or XBone API messages # $msg_name name of the message # $socktype TCP/SSL, UDP, or multicast # $ipproto IPv4 or IPv6 # $node_hash (ref) hash ("$node" => "$msg") # $have_reply 1: have replies, 0: not # Returns: # \%replies (ref) hash ("$node" => "$reply_msg") # \@missing (ref) array of nodes that didn't reply # Exception: # - sub fork_and_send($$$$$$$){ my ($msg_type, $msg_name, $socktype, $ipproto, $node_hash, $have_reply) = @_; my $procname = "fork_and_send"; my $argstr = join ", ", @_; my (%replies, @missing); XB_Log::log "info", "-> $modname$procname $argstr"; eval{ #=> check parameters my @nodelist = keys(%{$node_hash}); my $max_procs = ($XB_Params::NO_FORK)? 0 : @nodelist; my $node_count = @nodelist; my %node_fh; my $pm = new Parallel::ForkManager($max_procs); my $sel = IO::Select->new; #=> define callback functions during forking $pm->run_on_start( sub { my ($pid, $ident) = @_; XB_Log::log "info", " [$procname] fork: $ident (pid: $pid)"; } ); $pm->run_on_finish( sub { my ($pid, $exit_code, $ident) = @_; if($exit_code){ XB_Log::log "info", " [$procname] child: $ident (pid $pid) exits $exit_code"; }else{ XB_Log::log "warning", " [$procname] child: $ident (pid $pid) exits $exit_code"; } $node_count--; } ); $pm->run_on_wait( sub { XB_Log::log "debug1", " [$procname] $node_count processes left"; } ); #=> fork loop for my $node (@nodelist){ #-> create socket #=> create or retrieve tcp/ssl socket my $ssl_sock; if($XB_Params::PERSISTENT_SOCK){ $ssl_sock = tcp_ssl_sock ($ipproto, $node, $XB_Params::node_opts{xbone_ctl_port}); } #=> create a pipe for the child to write back to parent my $rh = IO::Handle->new; my $wh = IO::Handle->new; pipe $rh, $wh or die "pipe"; $node_fh{$rh} = $node; #=> fork my $pid = $pm->start($node) and fork_parent_close($sel, $rh, $wh, $node) and next; #=> begin child process ============================================ # exception handling inside the child process: need to catch all # dies by the child process and exit with different code my $received = 0; eval{ #=> close the read handle $rh->close or die "close"; #=> create or retrieve tcp/ssl socket if not yet created unless(defined $ssl_sock){ $ssl_sock = tcp_ssl_sock ($ipproto, $node, $XB_Params::node_opts{xbone_ctl_port}); } #=> send select XB_Log::log "info", " [$procname] send status to $node"; print $ssl_sock $node_hash->{$node}; #=> wait & receive ack-status my $new_sel; unless ($new_sel = IO::Select->new($ssl_sock)){ XB_Log::log "err", " [$procname:$node] select failed: $!" and die "select"; } while(my @r = $new_sel->can_read()){ # TODO set timeout for my $fh (@r){ if($fh != $ssl_sock){ XB_Log::log "err", " [$procname:$node] wrong socket for $node"; next; }else{ #=> read command & write it back to the parent process my $ctl_msg = fh_read_until ($fh, $XB_Params::msg_delimiter); print $wh $ctl_msg; $received = 1; } } if($received == 1){ last; } } if(not $XB_Params::PERSISTENT_SOCK){ $ssl_sock->close or XB_Log::log "err", " [$procname:$node] socket close failed: $!" and die "close"; } unless($received){ XB_Log::log "err", " [$procname:$node] did not received the ". "whole message" and die "rcv"; } }; if($@ && $@ !~ /(tcp_ssl_sock|select|fh_read_until|close|rcv)/){ XB_Log::log "err", " [$procname:$node] caught unknown exception: $@"; } unless($XB_Params::NO_FORK){ child_close($node); } $pm->finish($received); #=> end child process ============================================== } #=> collect responses from all the nodes while (my @handles = $sel->can_read){ # TODO set timeout for my $h (@handles){ my $n = $node_fh{$h}; XB_Log::log "debug1", " [$procname] receive from $n"; my @lines = $h->getlines; my $ack_msg = join "", @lines; my $ctl_cmd = $XB_CTL::parser->xb_ctl($ack_msg); unless (defined $ctl_cmd){ XB_Log::log "err", " [$procname] error parsing message ". "from $n =====\n$ack_msg\n=========="; }else{ unless ($ctl_cmd->{command}{command} =~ /(ack-status|error)/){ XB_Log::log "err", " [$procname] wrong command: ". "$ctl_cmd->{command}{command}"; }else{ XB_Log::log "debug6", " [$procname] CTL command: ". Dumper($ctl_cmd); delete $node_fh{$h}; $replies{$n} = $ctl_cmd; } } $sel->remove($h); $h->close or die "close"; } } $pm->wait_all_children; #=> process replies #if($type eq 'overlay'){ # XB_VN_funcs::process_status($app_obj, \%node_reply); #}else{ # add support for other applications here # XB_Log::log "err", " [$procname] application $type not supported" # and die "app"; #} #=> generate the reply message my @missing = values %node_fh; if(@missing > 0){ XB_Log::log "err", " [$procname] select failed on ". (join ", ", @missing) and die "ack"; } }; XB_Log::log "info", "<- $modname$procname"; return 1 unless $@; unless($@ =~ //){ XB_Log::log "warning", " ! $procname caught unkown exception: $@"; } # die or return 0 return 0; } # =========================================================================== # Init checks # =========================================================================== #-> check directory ------------------------------------------------- # Description: # Check if the given directory exists; create it if not. # Arguments: # $dir directory to check # Returns: # 1 on success # Exception: # "XB_Common::check_create_dir" on failure # sub check_create_dir($){ my $dir = shift; my $procname = $modname. "check_create_dir"; eval{ unless(-d $dir){ #mkdir $dir, 0755 or die "mkdir $dir, 0755: $!"; my @cmd = ('mkdir', '-p', "$dir"); my $cmdstr = join ' ', @cmd; my $rc = 0xff & system (@cmd); ($rc == 0) or XB_Log::log "err", " [$procname] $cmdstr failed: $!" and die "mkdir"; } chmod 0755, $dir or XB_Log::log "err", " [$procname] chmod 0755, $dir failed: $!" and die "chmod"; }; return 1 unless $@; unless($@ =~ /(mkdir|chmod)/){ XB_Log::log "warning", " ! $procname caught unknown exception: $@"; } die "$procname"; } #-> node os --------------------------------------------------------- # Description: # Detects and returns a list of OS info for the current system. # Arguments: # Returns: # @os [OS, release version, arch, kernel version] # Exceptions: # "node_os" on failure. sub node_os (){ my $procname = "node_os"; XB_Log::log "info", "-> $modname$procname"; my ($os, $vers, $arch, $kern); eval { # taint-safe backticks equivalent my $pid = open KID, "-|"; unless(defined $pid) { die "open: $!"; } unless($pid) { foreach my $uname ("/usr/bin/uname", "/bin/uname") { if(-x $uname) { exec $uname, "-msr" or die "exec: $!"; } } die "uname"; } ($os, $vers, $arch) = split ' ', lc ; close KID or die "close: $!"; # check the minimum os version supported # - note: must verify the following for each supported platform for # they will be different # (1) how to obtain kernel versions # (2) how to compare kernel versions cause they might not be numbers if($os =~ /FreeBSD/i){ $kern = sysctl_read('kern.osreldate'); unless($kern >= $XB_Params::os_support{freebsd}){ XB_Log::log "err", " [$procname] $os $vers (kernel $kern) not supported.\n". " Must be $XB_Params::os_support{freebsd} or above.)"; die "vers"; } }elsif($os =~ /Linux/i){ ($kern, my $version) = split (/-/, $vers); my @my_kernel = split (/\./, $kern); $my_kernel[2] =~ s/[a-zA-Z].*$//g; my @support_kernel = split (/\./, $XB_Params::os_support{linux}); my $support = 0; if ($my_kernel[0] > $support_kernel[0]){ $support = 1; } elsif (($my_kernel[0] == $support_kernel[0]) && ($my_kernel[1] > $support_kernel[1])){ $support = 1; } elsif (($my_kernel[0] == $support_kernel[0]) && ($my_kernel[1] == $support_kernel[1]) && ($my_kernel[2] >= $support_kernel[2])){ $support = 1; } unless($support){ XB_Log::log "err", " [$procname] $os $vers (kernel $kern) not supported.\n". " Must be $XB_Params::os_support{linux} or above.)"; die "vers"; } }else{ XB_Log::log "err", " [$procname] $os $vers (kernel $kern) not supported."; die "os"; } }; XB_Log::log "info", "<- $modname$procname $os, $vers, $arch, $kern"; return ($os, $vers, $arch, $kern) unless $@; # exception handling if($@ !~ /^(open|uname|close|sysctl_read|vers|os)/) { # unknown exception caught, log and pass up a defined one XB_Log::log "warning", "XB_Common::node_os caught unexpected exception $@"; } # pass defined exceptions up to caller die "$modname$procname"; } #-> check gif nesting ------------------------------------------------ # Description: # Check if gif nesting is enabled # Arguments: # daemon type # automode # Returns: # 1 on succecss # Exceptions: # "check_gifnesting" on error, nothing to clean up by caller # sub check_gifnesting($$){ my ($nodetype,$auto) = @_; my $procname = "check_gifnesting"; XB_Log::log "info", "-> $modname$procname $nodetype $auto"; eval{ unless($nodetype =~ /(meta|om)/i){ if($XB_Params::node_opts{os} =~ /(freebsd|kame|cairn)/i){ my $nesting = sysctl_read('net.link.gif.max_nesting'); if ($nesting < 2) { if ($auto =~ /(yes)/i){ XB_Log::log "notice", "Automode default: setting gifnesting to 256"; XB_Utils::sysctl_write('net.link.gif.max_nesting', 256); } else { XB_Log::log "err", "Please set sysctl net.link.gif.max_nesting to atleast 2. We recommend 256"; die "nesting"; }; } elsif ($nesting < 256){ XB_Log::log "warning", "We recommend setting sysctl net.link.gif.max_nesting to 256"; } } } #unless }; # eval XB_Log::log "info", "<- $modname$procname $@ "; return 1 unless ($@); if ($@ !~ /(nesting)/){ XB_Log::log "warning", "$modname$procname caught unexpected exception $@"; } # pass defined exceptions up to caller die "$modname$procname"; } #-> check ipsec ------------------------------------------------ # Description: # Check if ipsec is enabled # Arguments: # daemon type # Returns: # 1 on succecss # Exceptions: # "check_ipsec" on error, nothing to clean up by caller # sub check_ipsec($$){ my ($nodetype, $ipproto) = @_; my $procname = "check_ipsec"; XB_Log::log "info", "-> $modname$procname $nodetype $ipproto"; eval{ if ($XB_Params::node_opts{IPsec} =~ /yes/i){ unless($nodetype =~ /(meta|om)/i){ if($XB_Params::node_opts{os} =~ /(freebsd|kame|cairn)/i){ if ($ipproto =~ /(ipv4|both)/i){ my $ipsec4 = XB_Utils::sysctl_read('net.inet.ipsec.debug'); if (not defined $ipsec4){ XB_Log::log "err", "This kernel does not support IPv4 IPsec. " . "Please recompile the kernel or disable IPsec by setting IPsec to \"no\"."; die "ipsec"; }; } # ipproto if ($ipproto =~ /(ipv6|both)/i){ my $ipsec6 = XB_Utils::sysctl_read('net.inet6.ipsec6.debug'); if (not defined $ipsec6){ XB_Log::log "err", "This kernel does not support IPv6 IPsec. " . "Please recompile the kernel or disable IPsec by setting IPsec to \"no\"."; die "ipsec"; }; }# ipproto } # freebsd } #unless }; # if }; # eval XB_Log::log "info", "<- $modname$procname $@ "; return 1 unless ($@); if ($@ !~ /(ipsec)/){ XB_Log::log "warning", "$modname$procname caught unexpected exception $@"; } # pass defined exceptions up to caller die "$modname$procname"; } #-> check forwarding ------------------------------------------------ # Description: # Check if the combination of the node type and proto work # Arguments: # $ipproto ipv4/ipv6/both # $nodetype = meta/node/router/host # $auto = yes/no (automatic mode) # Returns: # 1 on success or exception on error # Exceptions: # "check_ipsupport2" on error # nothing to clean up by caller # no errors logged if automatic mode is enabled. # sub check_ipsupport2($$$){ my ($ipproto, $nodetype,$auto) = @_; my $procname = "check_ipsupport2"; my ($forward4, $forward6) = (1, 1); XB_Log::log "info", "-> $modname$procname $ipproto, $nodetype $auto"; my ($var4, $var6); eval{ # Read the sysctls. Dont print debug messages in case of # automode. # check for whether routing is enabled or not. if($XB_Params::node_opts{os} =~ /linux/i){ #-> Linux if($ipproto !~ /ipv4/){ XB_Log::log "err", " [$procname] Linux IPv6 is not supported" if ($auto =~ /no/i); die "linuxv6"; # enable these when the IPv6 support exists #$var6 = 'net.ipv6.conf.all.forwarding'; #$forward6 = sysctl_read($var6); } if($ipproto !~ /ipv6/){ $var4 = 'net.ipv4.ip_forward'; $forward4 = sysctl_read($var4); } }elsif($XB_Params::node_opts{os} =~ /freebsd/i){ #-> FreeBSD if($ipproto !~ /ipv4/){ $var6 = 'net.inet6.ip6.forwarding'; $forward6 = XB_Utils::sysctl_read($var6); } if($ipproto !~ /ipv6/){ $var4 = 'net.inet.ip.forwarding'; $forward4 = XB_Utils::sysctl_read($var4); } }elsif($XB_Params::node_opts{os} =~ /cisco/i){ if ($ipproto !~ /ipv4/) { XB_Log::log "err", " [$procname] Cisco IPv6 is not supported" if ($auto =~ /no/i); die "ciscov6"; } } else{ XB_Log::log "err", " [$procname] OS $XB_Params::node_opts{os} is ". "not supported" if ($auto =~ /no/i); die "os"; } # for a host/meta check, it is sufficient to not have an exception # thrown by now. unless ($XB_Params::node_opts{os} =~ /cisco/i) { # check if the basic support exists which we do by checking # if any of the variables is undefined. the platform (linux/ # freebsd) does not matter. if ($ipproto !~ /ipv6/i and not defined $forward4){ XB_Log::log "err", " [$procname] IPv4 is not supported while the ". "ipproto is set to" . $XB_Params::node_opts{ipproto} . "\n" if ($auto =~ /no/i); die "ipv4"; } # check for ipv6 if ($ipproto !~ /ipv4/i and not defined $forward6){ XB_Log::log "err", " [$procname] IPv6 is not supported while the ". "ipproto is set to " . $XB_Params::node_opts{ipproto} . "\n" if ($auto =~ /no/i ); die "ipv6"; } # check routing if ( $nodetype =~ /(router|node)/){ if ( $XB_Params::node_opts{'force-router'}){ if (!$forward4) { XB_Utils::sysctl_write ($var4) or die "sysctl"; $forward4 = 1; } if (!$forward6) { XB_Utils::sysctl_write ($var6) or die "sysctl"; $forward6 =1 ; } } unless($forward4 and $forward6){ my $msg = ""; $msg .= (!$forward4)? "\n\t(IPv4)\tsysctl -w $var4=1 " : ""; $msg .= (!$forward6)? "\n\t(IPv6)\tsysctl -w $var6=1 " : ""; XB_Log::log "err", " [$procname] XBone node type $nodetype ". "requires IP forwarding.\n You can run following command(s):". $msg . "and restart XBone node daemon.\n Or just restart ". "Xbone node daemon with option --force-router." if ($auto =~ /no/i ); die "forward"; } }; # router/node check } # except cisco }; XB_Log::log "info", "<- $modname$procname $@"; return 1 unless $@; unless($@ =~ /(linuxv6|os|forward|ciscov6|sysctl|ipv6|ipv4)/){ XB_Log::log "warning", " ! $procname caught unkown exception: $@"; } die "$modname$procname"; } # Description: # Check if forwarding is enabled # Arguments: # $ipproto ipv4/ipv6/both # $nodetype meta/node/router/host # Returns: # combination of (ipproto, daemontype) that works... # Exceptions: # "check_forwarding" on error, nothing to clean up by caller # sub check_ipsupport($$){ my ($ipproto, $nodetype) = @_; my $procname = "check_ipsupport"; my ($forward4, $forward6) = (1, 1); XB_Log::log "info", "-> $modname$procname $ipproto, $nodetype"; my ($var4, $var6); eval { # generate the combination that works from the defaults with # "decreasing" level in terms of capabilities in some sense. my @testprotolist = (); if ($ipproto =~ /(both)/i ){ @testprotolist = ("both", "ipv6", "ipv4"); } else { @testprotolist = ( $ipproto ); }; my @testtypelist = ( $nodetype ); $_ = $nodetype; SWITCH: { /node/ and do { @testtypelist = ("node", "router", "host"); last SWITCH; }; /router/ and do { @testtypelist = ("router", "host"); last SWITCH; }; last SWITCH; }; # if the auto is enabled, walk through the list to see # which combination works. If it does not, then bail # out. if ($XB_Params::node_opts{"auto"} =~ /no/i) { check_ipsupport2($ipproto, $nodetype, "no"); } else { my $found = 0; foreach my $testproto (@testprotolist) { foreach my $testtype (@testtypelist){ $@ = undef; eval { check_ipsupport2($testproto, $testtype, "yes"); }; # if exception thrown, try another combo next if ($@); # save the values so that they can be returned. $ipproto = $testproto; $nodetype = $testtype; $found = 1; last; } last if ($found); }; if (! $found){ XB_Log::log "notice", " Automatic mode of operations. " . "Unable to find a combination of node type" . "and ip version that works "; die ("auto"); } }; }; XB_Log::log "info", "<- $modname$procname"; return ($ipproto, $nodetype) unless $@; unless($@ =~ /(check_forwarding|auto)/){ XB_Log::log "warning", " ! $procname caught unkown exception: $@"; } die "$modname$procname"; }; #-> get addresses from a hostname lookup ---------------------------- # Description: # Return an array of addresses for a given hostname of specified type. # Arguments: # $hostname hostname to lookup # $ipproto ipv4 or ipv6 # Returns: # \@addrs IP addresses of the given hostnames # Exception: # "XB_Common::getaddrinfo" on failure, nothing to cleanup by caller # Notes - The recommended way to lookup IPv4 & IPv6 addresses from hostnames # is getipnodebyname in dual stack implementations. Perl Socket6 # module (0.11) has bugs in processing this call, so we use # gethostbyname2 until it's upgraded. # - Bug on gethostbyname2 of Socket6 0.11: $hostent[4] should be an # an array of all IP addresses, but they are actually pushed in to # the main array (@hostent) instead of @{hostent[4]}; sub getaddr($$){ my ($hostname, $ipproto) = @_; my $procname = "getaddr"; my @addrs; XB_Log::log "debug1", "-> $modname$procname $hostname, $ipproto"; eval{ unless($hostname =~ /\S+/){ XB_Log::log "err", " [$procname] empty hostname"; die "hostname"; } unless($ipproto =~ /(ipv6|ipv4)/){ XB_Log::log "err", " [$procname] unknown IP protocol: $ipproto"; die "ipproto"; } my ($family, $socktype, $proto, $saddr, $canonname); my @res; if($ipproto eq 'ipv4'){ @res = getaddrinfo($hostname, 'daytime', # dummy service AF_INET); unless(scalar(@res) >= 5){ XB_Log::log "err", " [$procname] getaddrinfo failed to return ". "IPv4 addresses for $hostname"; die "getaddrinfo"; }; } else { @res = getaddrinfo($hostname, 'daytime', # dummy service AF_INET6); unless(scalar(@res) >= 5){ XB_Log::log "err", " [$procname] getaddrinfo failed to return ". "IPv6 addresses for $hostname"; die "getaddrinfo"; }; } # give getaddrinfo call while (scalar(@res) >= 5) { $family = -1; # for safety ($family, $socktype, $proto, $saddr, $canonname, @res) = @res; my ($addr, $dummyport) = getnameinfo($saddr, NI_NUMERICHOST | NI_NUMERICSERV); push @addrs, $addr; } unless(@addrs > 0){ XB_Log::log "err", " [$procname] host $hostname has no IP addresses!"; die "noaddr"; } # Bring the 2001 addresses to the beginning. It seems to matter # since the first address is picked. if($ipproto ne 'ipv4'){ my @new = (); foreach my $addr (@addrs){ if ($addr =~ /2001/){ @new = ($addr, @new); } else { @new = (@new, $addr); }; }; @addrs = @new; }; }; #eval XB_Log::log "debug1", "<- $modname$procname"; return \@addrs unless $@; unless($@ =~ /(hostname|ipproto|getaddrinfo|noaddr)/){ XB_Log::log "warning", " ! $procname caught unknown exception: $@"; } die "$modname$procname"; } # Description: # Check if the peer IP address of the given socket handle matches the # the given hostname. # Arguments: # $sock socket handle # $hostname hostname # $ipproto ipv4 or ipv6 # Returns: # (peername, peerport) on succeed # Exceptions: # "get_sock_host" on error, nothing to clean up by caller # Notes: # Ideally, should use reverse DNS lookup on the IP address of the socket # with function like gethostbyaddr for IPv4 or getipnodebyaddr for IPv6. # But given that sysadmins don't always enter reverse DNS entries for # hostnames, use the given hostname (from certificates or in the cmd) to # get the IP addresses and check if the socket IP matches any of them. # sub chk_sockaddr($$$){ my ($sock, $hostname, $ipproto) = @_; my ($peername, $peerport, $hostinfo, $peeraddr); my $procname = "chk_sockaddr"; XB_Log::log "info", "-> $modname$procname @_"; eval{ my $matched = 0; $peeraddr = $sock->peerhost; #returns the ip address in text $peerport = $sock->peerport; my $addrs = getaddr($hostname, $ipproto); XB_Log::log "debug1", " [$procname] peeraddr: $peeraddr"; XB_Log::log "debug1", " [$procname] $hostname: ". (join ", ", @{$addrs}); for my $a (@{$addrs}){ if($peeraddr eq $a){ $matched = 1; last; } } unless($matched){ XB_Log::log "err", " [$procname] $peeraddr isn't an address of ". "$hostname"; die "match"; } }; XB_Log::log "info", "<- $modname$procname $peeraddr, $peerport"; return ($peeraddr, $peerport) unless $@; unless($@ =~ /(getaddr|match)/){ XB_Log::log "warning", " ! [$procname] caught unkown exception: $@"; } die "$modname$procname"; } # =========================================================================== # Misc. Utilities # =========================================================================== # Description: # Return value of given sysctl variable $var. # Arguments: # $var name of the sysctl variable to read # Returns: # $val value of $var if found # undef if $var not found # Exceptions: # "XB_Common::sysctl_read" on failure sub sysctl_read ($) { my $var = shift; my $val; my $procname = "sysctl_read"; XB_Log::log "info", "-> $modname$procname $var"; eval { # get the value by reading from a pipe to sysctl my $pipe = "/sbin/sysctl -n $var 2> /dev/null |"; open PIPE, $pipe or XB_Log::log "err", " [$procname] cannot open pipe $pipe: $!" and die "open"; # read the output $val = ; # done with pipe close PIPE or not $! or XB_Log::log "err", " [$procname] cannot close pipe $pipe: $!" and die "close"; # post-process if(defined $val) { chomp $val; } }; XB_Log::log "info", "<- $modname$procname"; return $val unless $@; # success if no exception # exception handling if($@ =~ /^(open|close)/) { # known exception, nothing to handle, pass up } else { # unknown exception caught, log and pass up a defined one XB_Log::log "warning", "XB_Utils::sysctl_read: caught unexpected " . "exception $@"; } # pass defined exceptions up to caller die "$modname$procname"; } # Description: # Clean up the application object hash if it exists; also cleanup the # application deployment scripts if any. # Arguments: # $type application type # $name application name # Returns: # 1 on success # Exception: # - sub cleanup_app($$){ my ($type, $name) = @_; my $procname = $modname. "cleanup_app"; XB_Log::log "info", "-> $procname $type, $name"; if(exists $XB_Params::node_state{active_apps}{$type}{$name}){ my $app = $XB_Params::node_state{active_apps}{$type}{$name}; if(exists $app->{app_deploy}){ for my $appname (keys %{$app->{app_deploy}}){ if(-f $app->{app_deploy}{$appname}{script}){ unlink $app->{app_deploy}{$appname}{script}; } } } delete $XB_Params::node_state{active_apps}{$type}{$name}; }else{ XB_Log::log "warning", " [$procname] $type $name does not exist"; } return 1; } # Description: # Reset the node state to idle. # Returns: # 1 sub reset_state{ $XB_Params::node_state{state} = "idle"; $XB_Params::node_state{creator} = ""; $XB_Params::node_state{application} = ""; $XB_Params::node_state{name} = ""; $XB_Params::node_state{start} = 0; $XB_Params::node_state{level} = 0; XB_Log::log "debug1", " -> Rreset node state"; return 1; } # Description: # Check IP version support # Arguments: # $ipproto requested # Returns: # 1 supported # 0 not supported # Exceptions: # - sub check_ip($){ my $ipproto = shift; my $procname = "check_ip"; XB_Log::log "info", "-> $modname$procname $ipproto"; if(lc $ipproto eq $XB_Params::node_opts{ipproto} or $XB_Params::node_opts{ipproto} eq 'both'){ #XB_Log::log "info", "$str supported"; #return 1; }else{ XB_Log::log "err", "$ipproto not supported"; die "$modname$procname"; } XB_Log::log "info", "<- $modname$procname $ipproto"; return 1; } # Description: # Check if a given entity is in the list. # Arguments: # $it entity to check # $list (ref) list to be checked against # Returns: # 0 no match # 1 match # 2 empty list # Exceptions: # - sub check_list ($$){ my ($it, $list) = @_; my $procname = $modname. "check_list"; XB_Log::log "info", "-> $procname $it, $list"; if (scalar(@{$list}) > 0){ for my $i (@{$list}){ if($it eq $i){ XB_Log::log "info", "<- $procname - match"; return 1; } } XB_Log::log "info", "<- $procname - no match"; return 0; }else{ XB_Log::log "info", "<- $procname - empty list"; return -1; } } # Description: # Check if current conf satisfies request under "yes" & "no" comparison. # Arguments: # $name name of the resource or question # $req request value # $conf config (available) value # Returns: # 1 if satisfied # 0 if not # Note: # satisfied if (req == no) or (req == conf == yes) # sub check_resource($$$){ my ($name, $req, $conf) = @_; my $ok=1; XB_Log::log "debug1", "-> check [$name] request=$req, configured=$conf"; if ((lc($req) eq 'yes') and (lc($conf) eq 'no')){ $ok = 0; } XB_Log::log "debug1", "<- check_resource $ok"; return $ok; } # Description: # Check given versions for compatibility. # Arguments: # $rver client version # $lver local version # $type version for what # Returns: # 1 (=) matched # 0 (>) client > local # -1 (<) client < local # Exception: # - sub check_vers($$$){ my ($rver, $lver, $type) = @_; my $result = 1; XB_Log::log "debug1", "-> check $type version: client=$rver, local=$lver"; # TODO Should decompose versions into sections separated by dot (.) and # TODO compare each pair until one is greater than the other or reach # TODO the end of the field and the two are equal. # TODO Right now, just see if they are the same. unless($rver eq $lver){ $result = 0; } XB_Log::log "debug1", "<- check_version $result"; return $result; } # # Description: # Get a string input from user # Arguments: # text for prompt # optional default value # Returns: # the string # Exceptions: # sub get_string ($;$) { my ($prompt, $default) = @_; my ($str, $pat); while (1) { if (defined ($default)) { print "$prompt: ($default) "; } else { print "$prompt: "; } $str = ; chomp $str; if (!$str) { $str = $default; }; next if (!$str); last; } return ($str); } # Description: # Add/replace a variable in a configuration file. # Notes: The idea here is that the user should be # able to specify any variables that should # Arguments: # conffile = configuration file (path) # var = variable that needs to be updated # value = new value to be assigned # multiple = could there be multiple # instances of this variable # (only append in this case) # Returns: # # Exceptions: # sub update_conf_file($$$;$) { my ($conffile, $var, $value, $multiple) = @_; my @arr = (); my $done = 0; if (not defined $multiple) { $multiple = 0; }; # read the existing configuration if (-f $conffile){ open(CONF, "<$conffile") or die("file"); while(){ push @arr, $_ ; }; close(CONF); }; # open and truncate the file. open(CONF, "+>$conffile") or XB_Log::log "err", "Cannot open configuration file $conffile for updating." and die("file"); # append/replace the configuration line foreach my $row (@arr){ if (($row =~ /$var/) and ($multiple == 0)){ if ($done == 0){ print CONF "$var = $value\n"; $done = 1; } } else { print CONF $row; }; }; if ($done == 0){ print CONF "$var = $value\n"; } close(CONF); }; # Description: # Execute the system call and return the results # Arguments: # \@cmd : reference of a list # Returns: # $msg: output of the command # Exceptions: # Cant execute the command sub execcmd($){ my ($cmd) = @_; my $cmdline = join (" ", @{$cmd}); my ($cpid, $msg, $status) = (0,"",0); my $procname = "execcmd"; #XB_Log::log "info", "-> $modname$procname "; eval { if ( ($cmd->[0] =~ /\//) and (! -e $cmd->[0] or ! -x $cmd->[0] )) { XB_Log::log "err", " [$procname] Script/Executable " . $cmd->[0] . " does not exist or" . " does not have the right permissions"; die ("cmd"); } my @prefix = (\*WTR, \*RDR, \*ERR); $cpid = open3(@prefix, @{$cmd}) or XB_Log::log "err", "Unable to execute command. $!: Command failed" and die "cmd"; if (defined $cpid) { waitpid $cpid, 0 == $cpid or XB_Log::log "err", "Operating system resource error. ". "No child $cpid" and die "wait"; $status = $? >> 8; }; # Read all the error messages... while () { $msg .= $_; } while () { $msg .= $_; } #close(WTR); #close(RDR); #close(ERR); }; #XB_Log::log "info", "<- $modname$procname "; return ($status, $msg) unless $@; unless($@ =~ /(cmd|wait)/){ XB_Log::log "warning", " ! [$procname] caught unkown exception: $@"; } die "$modname$procname"; }; 1;