eval '(exit $?0)' && eval 'PERLDB_OPTS="N f=26";export PERLDB_OPTS;PERL=`which perl5`; exec $PERL -wS $0 ${1+"$@"}' & eval 'setenv PERLDB_OPTS "N f=26"; setenv PERL `which perl5`; exec $PERL -wS $0 $argv:q' if 0; ### 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-node-control.pl,v $ # # $Revision: 1.22 $ # $Author: pingali $ # $Date: 2005/04/21 00:58:26 $ # $State: Exp $ # ---------------------------------------------------------------------------- # ############################################################ # # The first lines start PERL on any system where perl is in the path. # This is a modified version of the "start perl" script # provided in the PERL man pages, which starts perl # on the remainder of the file regardless of whether it # is run under sh, csh, or perl. # # This version is modified to dynamically locate the # perl path, rather than requiring it be hard-coded. # # setenv PERLDB_OPTS "N f=26" # # Must be set before perl starts! # # N : Nonstop (noninteractive) # f=26 : frame=26 = 16 + 8 + 2, # 2 = entry and exit, # !4 = don't print args to functions # 8= enabled overloaded stringify and tied FETCH # 16= print return values from subroutines # # note - '-T' (TAINT) switch is not included, because 'which' often # returns a version of perl that isn't secure. don't worry about it. # ############################################################ # PERL CODE STARTS HERE ############################################################ # XBONE code to set libraries BEGIN { use strict; use sigtrap; use FindBin; use Config; delete $ENV{PATH}; #my $version = $Config{'version'}; #my $arch = $Config{'archname'}; my $ldir = $FindBin::RealBin; foreach my $p ( "/usr/local/xbone", "/usr/local/xbone/programs", "$ldir/../programs", "$ldir/../programs/modules", ){ if(-d $p) { unshift @INC, $p; } } # untaint the resulting include path so "use" works foreach my $i (@INC) { if($i =~ /(.*)/) { $i = $1;} } }; ############################################################################## # END OF XBONE PREFIX CODE - PUT YOUR PERL CODE BELOW # ############################################################################## use Tk; use Tk::Getopt; use Tk::BrowseEntry; use Tk::TableMatrix; use Tk::Font; use Tk::LabFrame; use Tk::Labelframe; use IPC::Open3; use Getopt::Long; use Data::Dumper; use Cwd; use File::Basename; # For xbgetaddrinfo use Socket; use Socket6; use AppConfig; use XB_Params; ######################################################################## # Global Variables ######################################################################## my $debug = 0; my $os = `uname -s`; chomp($os); my $font; my %options = (); my %defaults = (); my @conftypes = (["Config Files", '.conf', 'TEXT'], ["All Files", "*"] ); my @ldaptypes = (["LDIF Files", '.ldif', 'TEXT'], ["All Files", "*"] ); ######################################################################## # Read Configuration ######################################################################## # Description: # The options structure has been copied from the xb-node-daemon. # That is the place to correct if any. # Arguments: # # Returns: # # Exceptions: # %options = ( "auto" => $XB_Params::auto, # basic configuration options "conf" => $XB_Params::conf, "workdir" => $XB_Params::workdir, "state_file" => $XB_Params::state_file, "pidfile" => $XB_Params::pidfile, "daemon_type" => $XB_Params::daemon_type, "background" => 0 , # node IP config options "hostname" => `hostname`, "ctl_addr" => $XB_Params::ctl_addr, "ctl_addr6" => $XB_Params::ctl_addr6, "app_addr" => $XB_Params::app_addr, "app_addr6" => $XB_Params::app_addr6, # XBone network parameters "ipproto" => $XB_Params::ipproto, "xbone_mcast_addr" => $XB_Params::xbone_mcast_addr, "xbone_mcast_addrv6" => $XB_Params::xbone_mcast_addrv6, "xbone_api_port" => $XB_Params::xbone_api_port, "xbone_ctl_port" => $XB_Params::xbone_ctl_port, # logging options "log_dest" => $XB_Params::log_dest, "log_mask" => $XB_Params::log_mask, "log_file" => $XB_Params::log_file, # X.509 certificate & key info "node_cert" => $XB_Params::node_cert, "node_key" => $XB_Params::node_key, "ca_cert" => $XB_Params::ca_cert, "ca_path" => $XB_Params::ca_path, # ACLs: for overlay manager & users "ovl_manager" => \@XB_Params::ovl_manager, "user_acl" => \%XB_Params::user_acl, # features & capabilities # - os [should only set these for buddy host; i.e., Cisco] #"os" => $XB_Params::os, "os" => $os, "os_version" => $XB_Params::os_version, "kern_version" => $XB_Params::kern_version, "node_arch" => $XB_Params::node_arch, # - routing (static vs. dynamic) "routing" => $XB_Params::routing, # - ipsec "IPsec" => $XB_Params::IPsec, # - qos "qos" => $XB_Params::qos, # - [optional] address server options "addrserv" => $XB_Params::addrserv, "netv4" => $XB_Params::netv4, "netv6" => $XB_Params::netv6, "addr_server" => $XB_Params::addr_server, # legacy options "address_type" => $XB_Params::address_type, "control_protocol" => $XB_Params::control_protocol, "linkv4" => $XB_Params::linkv4, "linkv6" => $XB_Params::linkv6, # - [optional] DDNS (Dynamic DNS update) server/zone/key info "xbone_net" => $XB_Params::XBONE_NET, "dns" => $XB_Params::dns, "name_server" => $XB_Params::name_server, "forward_zone" => $XB_Params::forward_zone, "reverse_zone" => $XB_Params::reverse_zone, "reverse_zone6" => $XB_Params::reverse_zone6, "dns_key_file" => $XB_Params::dns_key_file, # - [optional] Dynamic routing options "zebra_dir" => $XB_Params::zebra_dir, # - [optional] Force router options "force-router" => 0, # - [optional] Cisco platform options "cisco_buddy_username" => $XB_Params::CISCO_BUDDY_USERNAME, "cisco_buddy_password" => $XB_Params::CISCO_BUDDY_PASSWORD, "cisco_buddy_enable_password"=> $XB_Params::CISCO_BUDDY_ENABLE_PASSWORD, # - [optional] register attributes "register" => \%XB_Params::register, # - [optional] Ldap options "ldap" => \%XB_Params::ldap, ); my @opts_spec = ( "auto=s", # automatic or not - default on # basic configuration options "conf|c=s", # config file "workdir|w=s", # working dir "state_file|s=s", # state file "pidfile|pid=s", # state file "daemon_type|t=s", # daemon type "background|bg", # run in the background # node IP config options "hostname|h=s", # hostname "ctl_addr|caddr=s", # addr for control connection IPv4 "ctl_addr6|caddr6=s", # addr for control connection IPv6 "app_addr|aaddr=s", # addr for app/data connection IPv4 "app_addr6|aaddr6=s", # addr for app/data connection IPv6 # XBone network parameters "ipproto|ip=s", "xbone_mcast_addr|mcast=s", "xbone_mcast_addrv6|mcastv6=s", "xbone_ctl_port|ctl=i", "xbone_api_port|api=i", # logging options "log_dest|d=i", "log_mask|m=s", "log_file|l=s", # X.509 certificate & key info "node_cert|cert=s", "node_key|key=s", "ca_cert|ca=s", "ca_path|cp=s", # ACLs: for overlay manager & users "ovl_manager|om=s@", "user_acl|acl=s%", # node features & capabilities # - os [should only set these for buddy host; i.e., Cisco] "os=s", "os_version|over=s", "kern_version|kver=s", "node_arch|arch=s", # - routing/IPsec/QoS "routing|rt=s", "IPsec|sec=s", "qos|q=s", # address server options [optional] "addrserv|a", # address server / IP allocator "netv4|n4=s", # - Overlay net v4 block "netv6|n6=s", # - Overlay net v6 block "addr_server|as=s", # remote address server # legacy options "address_type|atype=s", "control_protocol|cc=s", "linkv4|l4=s", # - Overlay link v4 block "linkv6|l6=s", # - Overlay link v6 block # DNS related options "xbone_net|xb=s", "dns=s", "name_server|ns=s", "forward_zone|fzone=s", "reverse_zone|rzone=s", "reverse_zone6|rzone6=s", "dns_key_file|dnskey=s", # Dynamic routing related options "zebra_dir|zd=s", # Force router option "force-router|fr", # Cisco platform option "cisco_buddy_username|ciscouname=s", "cisco_buddy_password|ciscopw=s", "cisco_buddy_enable_password|ciscoenpw=s", # variables to be registered with the main xbone daemon "register|reg=s%", # variables to be registered with the main xbone daemon "ldap=s%", ); # Description: # Parse the commandline, conf file and if necessary # conf from an LDAP server. # Arguments: # (Implicit) %options # Returns: # stored in the options structure # Exceptions: # # Notes: This code is a little bit (?) ugly. This has # copied and used almost unmodified from xb-node-daemon. # # sub get_opts { my %cmdl_opts; # hash of args from command line my $file_opts; # obj of args from config file my $ldap_opts; # obj of args from ldap server #=> get command line options if (GetOptions(\%cmdl_opts, @opts_spec)==0) { print "Usage: xb-node-control [-h hostname] \n"; exit; } #=> get conf file options my $have_conf = 1; $options{conf} = defined $cmdl_opts{conf} ? $cmdl_opts{conf} : $options{conf}; unless (-f $options{conf}){ #warn "! Could not find XBone config file: $options{conf}"; $have_conf = 0; }else{ $file_opts = AppConfig->new(@opts_spec); $file_opts->file($options{conf}) or warn "! Error parsing XBone conf file: $options{conf}" and die "parse"; } for my $n (keys %options){ # The following are sets and they have to be treated # slightly differently. next if ($n =~ /(ldap|user_acl|ovl_manager|register)/); if (defined $cmdl_opts{$n}){ # command line $options{$n} = $cmdl_opts{$n}; } elsif ((defined $file_opts) and (defined $file_opts->get($n))){ # conf file $options{$n} = $file_opts->get($n); } elsif ((defined $ldap_opts) and (defined $ldap_opts->get($n))){ # ldap $options{$n} = $ldap_opts->get($n); }; }; # copy the ldap information from the conf files. if (defined $file_opts){ my $ldaphash = $file_opts->get('ldap'); if (defined $ldaphash) { foreach my $attr (keys %{$ldaphash}){ $options{ldap}->{$attr} = $ldaphash->{$attr}; }; } }; # cleanup the result from `hostname` chomp($options{hostname}); #=> Handle Overlay Manager List. Let command line override # conf file, and conf file transitively override ldap. my (@mgrarr) = (); @mgrarr = @{$cmdl_opts{'ovl_manager'}} if (defined $cmdl_opts{'ovl_manager'}); if ($#mgrarr == -1){ @mgrarr = @{$file_opts->get('ovl_manager')} if ((defined $file_opts) and (defined $file_opts->get('ovl_manager'))); } if ($#mgrarr == -1){ @mgrarr = @{$ldap_opts->get('ovl_manager')} if ((defined $ldap_opts) and (defined $ldap_opts->get('ovl_manager'))); } $options{'ovl_manager'} = \@mgrarr; #=> Handle ACL Rules compute the acl union. conflicts between acl #rules of the different sites is handled through offline control. my (@aclarr) = (); push @aclarr, $ldap_opts->get('user_acl') if ((defined $ldap_opts) and (defined $ldap_opts->get('user_acl'))); push @aclarr, $file_opts->get('user_acl') if ((defined $file_opts) and (defined $file_opts->get('user_acl'))); push @aclarr, $cmdl_opts{'user_acl'} if (defined $cmdl_opts{'user_acl'}); # process ACLs. the order is important foreach my $map (@aclarr){ # process each map separately foreach my $key (keys %{$map}){ $options{user_acl}->{$key} = $map->{$key}; } }; #=> Handle the register commands if ((keys %{$cmdl_opts{'register'}}) > 0){ $options{register} = $cmdl_opts{'register'}; } elsif ((defined $file_opts) and ((keys %{$file_opts->get('register')}) > 0)){ $options{register} = $file_opts->get('register'); } elsif ((defined $ldap_opts) and ((keys %{$ldap_opts->get('register')}) > 0)){ $options{register} = $ldap_opts->get('register'); }; # debugging outputs #print ">>> ", Dumper(\%cmdl_opts), "\n"; #print ">>> ", Dumper(\%options), "\n"; #print ">>> ", Dumper($ldap_opts), "\n"; #print ">>> ", Dumper($file_opts), "\n"; #print ">>> ACL: ", Dumper($options{user_acl}); } ######################################################################## # Misc Functions ######################################################################## # Description: # Show error message # Arguments: # $top: parent window to popup a message # $msg: text message # Returns: # # Exceptions: # sub showmsg ($$){ my ($top, $msg) = @_; $top->messageBox(-icon => 'error', -message => $msg, -title => 'Error!', -type => 'Ok', ); }; # Description: # Write a printf style message to the xblogs, if $level matches the mask # Arguments: # $level level of the message, must be a string consisting of one out # of err, debug # @args a printf-style array containing the message to be xblogged # Returns: # 1 on success # Exceptions: # "xblog" on failure sub xblog ($@) { my ($level, @args) = @_; unless($level =~ /^(err|warning|debug)$/) { warn "xblog: unknown xblog level \"$level\"" and die "xblog"; } my $msg = ($#args ? sprintf shift @args, @args : $args[0]); chomp $msg; if ($level eq "err"){ print STDERR "$msg\n"; } elsif ($level eq "warning") { print STDOUT "$msg\n"; } else { print STDOUT "$msg\n" if ($debug); } return 1; }; # 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: # "xbgetaddrinfo" on failure, nothing to cleanup by caller sub xbgetaddr($$){ my ($hostname, $ipproto) = @_; my $procname = "xbgetaddr"; my @addrs = (); my %addrhash = (); xblog "debug", "-> $procname $hostname, $ipproto"; eval{ unless($hostname =~ /\S+/){ xblog "err", " [$procname] empty hostname"; die "hostname"; } unless($ipproto =~ /(ipv6|ipv4)/){ xblog "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){ xblog "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){ xblog "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); # for some reason there are duplicates. This is a way to # avoid the duplicates. $addrhash{$addr} = 1; } @addrs = keys %addrhash; unless(@addrs > 0){ xblog "err", " [$procname] host $hostname has no IP addresses!"; die "noaddr"; } }; #eval xblog "debug", "<- $procname"; return \@addrs unless $@; unless($@ =~ /(hostname|ipproto|getaddrinfo|noaddr)/){ xblog "warning", " ! $procname caught unknown exception: $@"; } die "$procname"; }; # 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 $msg = ""; my $status = 0; eval { die ("Script/Executable " . $cmd->[0] . " does not exist or" . " does not have the right permissions") if (! -e $cmd->[0] or ! -x $cmd->[0] ) ; my @prefix = (\*WTR, \*RDR, \*ERR); $cpid = open3(@prefix, @{$cmd}) or xblog "err" => "Unable to execute command. $!: Route command failed" and die "cmd"; if (defined $cpid) { waitpid $cpid, 0 == $cpid or xblog "err" => "Operating system resource error. ". "No child $cpid" and die "wait"; $status = $? >> 8; } # Read all the error messages... while () { unless (/DB_KEYEXIST/) { $msg .= $_; } } while () { unless (/DB_KEYEXIST/) { $msg .= $_; } } close(WTR); close(RDR); close(ERR); }; if ($@ or $status ) { $msg .= $@ if ($@); die "Command \"" . $cmdline . "\" failed. ". "The following error was reported:\n\n $msg"; } else { return $msg; } }; ########################################################################### # Base Configuration ########################################################################### # Description: # Option setting callback. Called when the user presses # apply/update for LDAP # Arguments: # $top: parent window to popup a message # $what: what should be checked # Returns: # # Exceptions: # sub opt_callback_ldap ($$) { my ($top, $what) = @_; #print "Callback : LDAP, $what\n"; # add a series of checks. my $ldapconf = $options{ldap}; if ($$ldapconf{enable} !~ /(yes|no)/){ $$ldapconf{enable} = "no"; } return if ( $$ldapconf{enable} !~ /(yes)/ ); # basically if we came here, then enable is yes. the variable # updated could be enable or any of the other variable on the # window. So, check all of them if enable has been modified. my @whatall = (); if ( $what eq "enable" ){ @whatall = ( "server", "password", "instance", "port" ); } elsif ( $what eq "all" ){ @whatall = ( "server", "password", "instance", "port" ); } else { @whatall = ( $what ); } foreach (@whatall) { SWITCH: { /(server)/ and do { if ((not defined $$ldapconf{'server'}) or ( $$ldapconf{'server'} eq "")){ showmsg($top, "LDAP server is undefined."); return 0; }; }; /(password)/ and do { if ((not defined $$ldapconf{'password'}) or ( $$ldapconf{'password'} eq "")){ showmsg($top, "LDAP user password is undefined"); return 0; }; }; /(instance)/ and do { if ((not defined $$ldapconf{'instance'}) or ( $$ldapconf{'instance'} eq "")){ showmsg($top, "The instance is undefined"); return 0; }; }; /(port)/ and do { if ((not defined $$ldapconf{'port'}) or ( $$ldapconf{'port'} eq "")){ showmsg($top, "Server port number is undefined"); return 0; }; }; }; # SWITCH }; # foreach return 1; }; # Description: # Option setting callback. Called when the user presses # apply/update for DNS # Arguments: # $top: parent window to popup a message # $what: what should be checked # Returns: # # Exceptions: # sub opt_callback_dns ($$) { my ($top, $what) = @_; #print "Callback : DNS, $what\n"; # add a series of checks. return if ($options{"dns"} !~ /(yes)/); my %map = ( "name_server" => "DNS Server", "dns_key_file" => "TSIG key file", "reverse_zone" => "Reverse zone", "forward_zone" => "Forward zone", "reverse_zone6" => "IPv6 Reverse zone", ); if ( $what ne "dns" and $what ne "all" ) { if ((not defined $options{$what}) or ($options{$what} eq "")) { showmsg($top, $map{$what} . " undefined "); return 0; }; } else { # if DNS is enabled, then look at all the specified # entries. foreach $what (keys %map) { if ((not defined $options{$what}) or ($options{$what} eq "")) { showmsg($top, $map{$what} . " undefined "); return 0; }; }; }; return 1; }; # Description: # Show the base configuration window # Arguments: # $top: parent window to popup a message # Returns: # Updates the %options hash # Blocks until ok is pressed on the popup window # Exceptions: # sub config ($) { my ($top,) = @_; my ($opt); my ($v4addrs, $v6addrs) = (); my @nonexist = (); my ($v4noshow, $v6noshow) = (0, 0); my @ipver = (); my $ovl_mgr_list = ""; my $ldapconf = $options{ldap}; my $hostname = $options{hostname}; eval { $v4addrs = xbgetaddr($hostname, 'ipv4'); push @ipver, "ipv4"; }; if ($@) { $v4addrs = \@nonexist; $v4noshow = 1; } eval { $v6addrs = xbgetaddr($hostname, 'ipv6'); push @ipver, "ipv6"; }; if ($@) { $v6addrs = \@nonexist; $v6noshow = 1; } if (! $v6noshow and ! $v4noshow ){ push @ipver, "both"; }; # Initialization of variables $ovl_mgr_list = join (',', @{$options{ovl_manager}}); if ( not defined $$ldapconf{server} or $$ldapconf{server} eq ""){ $$ldapconf{server} = $options{hostname}; } if ( not defined $$ldapconf{port} or $$ldapconf{port} eq ""){ $$ldapconf{port} = 636; } # Options my @opttable = ( 'Main', [ 'ipproto', '=s', $options{ipproto}, label => 'IP Protocol:', longhelp => 'IP version(s) that the Node Daemon should enable.', choices => \@ipver, var => \$options{ipproto}, strict => 1, ], [ 'daemon_type', '=s', $options{daemon_type}, label => 'Daemon Type', longehelp => 'Select type of node. Options include: meta = overlay manager, node = router + host, router, host', choices => [ "meta", "node", "router", "host"], strict => 1, var => \$options{daemon_type}, ], [ 'os', '=s', $options{os}, label => 'Node OS:', longhelp => 'Node operating system. This is by default the host operating system but if this node is configured as a buddy for another os (we support only cisco), then the node should be set to the other os (cisco). ', choices => [ $options{os}, "cisco" ], var => \$options{os}, strict => 1, ], [ 'ovl_mgr_list', '=s', $ovl_mgr_list, label => 'Overlay Manager List:', longhelp => 'List of overlay manager (host names) that this daemon should accept overlay management requests from.', var => \$ovl_mgr_list, ], 'Addressing', ['', '', "$hostname" ], ['', '', ' Select the appropriate IP version(s) and address(es). The final addresses used will depend on chosen IP protocol.' ], [ 'ctl_addr', '=s', $v4addrs->[0], label => 'IPv4 Address:', longhelp => 'IPv4 address on which the Node Daemon will listen.', choices => $v4addrs, nogui => $v4noshow, var => \$options{ctl_addr}, ], [ 'app_addr', '=s', $v4addrs->[0], label => 'IPv4 Address of Buddy Host:', longhelp => 'Applicable only in case this node is used as a buddy for a Cisco router', nogui => $v4noshow, var => \$options{app_addr}, ], [ 'ctl_addr6', '=s', $v6addrs->[0], label => 'IPv6 Address:', longhelp => 'IPv6 address on which the Node Daemon will listen.', choices => $v6addrs, nogui => $v6noshow, var => \$options{ctl_addr6}, ], [ 'app_addr6', '=s', $v6addrs->[0], label => 'IPv6 Address of Buddy Host:', longhelp => 'Applicable only in case this node is used as a buddy for a Cisco router', nogui => $v6noshow, var => \$options{app_addr6}, ], 'LDAP', ['', '', "LDAP Server Configuration"], [ 'LDAP', '=s', $$ldapconf{enable}, label => 'Enable LDAP', longehelp => 'use LDAP Server', choices => [ "yes", "no" ], var => \$$ldapconf{enable}, callback => sub { opt_callback_ldap($top, "enable"); }, strict => 1, ], [ 'ldapserver', '=s', $$ldapconf{server}, label => 'LDAP Server:', #longhelp => 'LDAP server', var => \$$ldapconf{server}, callback => sub { opt_callback_ldap($top, "server"); } ], [ 'ldapport', '=i', $$ldapconf{port}, label => 'Port', longhelp => 'Port on which LDAP server runs', var => \$$ldapconf{port}, callback => sub { opt_callback_ldap($top, "port"); } ], [ 'ldappasswd', '=s', $$ldapconf{password}, label => 'User Password:', longhelp => 'Password for OID "cn=XBoneUser,ou=Users,ou=xbone" ', var => \$$ldapconf{password}, callback => sub { opt_callback_ldap($top, "password"); } ], [ 'ldapinstance', '=s', $os, label => 'Instance', longhelp => 'Choose the instance name '. '"ou=xbone,ou=local,ou=config,cn=,cn="' . 'See /usr/local/www/xbone/doc/xbone-ldap.txt', var => \$$ldapconf{instance}, callback => sub { opt_callback_ldap($top, "instance"); } ], [ 'ldapscope', '=i', $$ldapconf{scope}, label => 'Scope', choices => [ "local", "global" ], longhelp => 'Is this deployment of X-Bone part of the Global X-Bone Testbed?', var => \$$ldapconf{scope}, ], 'DNS', ['', '', "DNS Configuration"], [ 'dns', '=s', $options{dns}, label => 'Enable DNS', choices => [ "yes", "no" ], var => \$options{dns}, strict => 1, callback => sub { opt_callback_dns($top, "dns"); } ], [ 'name_server', '=s', "", label => 'Name of the DNS Server', longhelp => 'DNS Server', var => \$options{name_server}, callback => sub { opt_callback_dns($top, "name_server"); } ], [ 'forward_zone', '=s', $options{forward_zone}, label => 'DNS Forward Zone', longhelp => 'DNS Forward Zone', var => \$options{forward_zone}, callback => sub { opt_callback_dns($top, "forward_zone"); } ], [ 'reverse_zone', '=s', $options{reverse_zone}, label => 'DNS Reverse Zone', longhelp => 'DNS Reverse Zone', var => \$options{reverse_zone}, callback => sub { opt_callback_dns($top, "reverse_zone"); } ], [ 'reverse_zone6', '=s', $options{reverse_zone6}, label => 'DNS IPv6 Reverse Zone', longhelp => 'DNS IPv6 Reverse Zone', var => \$options{reverse_zone6}, callback => sub { opt_callback_dns($top, "reverse_zone6"); }, nogui => $v6noshow, ], ['dns_key_file', "=s", $options{dns_key_file}, label => "DNS Key", subtype => 'file', var => \$options{dns_key_file}, callback => sub { opt_callback_dns($top, "dns_key_file"); } ], 'Certificates', ['', '', "X-Bone Host/CA Certificates/Path"], ['ca_cert', "=s", $options{ca_cert}, label => "CA Certificate", subtype => 'file', var => \$options{ca_cert}, ], ['ca_path', "=s", $options{ca_path}, label => "Certificate Path", subtype => 'dir', var => \$options{ca_path}, ], ['node_cert', "=s", $options{node_cert}, label => "Host Certificate", subtype => 'file', var => \$options{node_cert}, ], ['node_key', "=s", $options{node_key}, label => "Host Key", subtype => 'file', var => \$options{node_key}, ], 'Miscellaneous', ['', '', "Miscellaneous Settings"], [ 'IPSec', "=s", $options{IPsec}, label => 'Enable IPSec', var => \$options{IPsec}, choices => [ "yes", "no" ], strict => 1, ], [ 'routing', '=s', $options{routing}, label => 'Routing', choices => [ "static", "dynamic"], var => \$options{routing}, strict => 1, ], [ 'qos', '=s', $options{qos}, label => 'Enable QoS', choices => [ "yes", "no" ], var => \$options{qos}, longhelp => 'QoS support depends on host support. '. 'X-Bone uses DummyNet on FreeBSD and NISTnet on Linux', strict => 1, ], ); $opt = new Tk::Getopt(-opttable => \@opttable, -options => \%options, ); $opt->set_defaults; $opt->load_options; $opt->get_options; $opt->process_options; $opt->option_editor($top, "-wait" => 1, "-delaypagecreate" => 1, "-buttons" => [qw/ok/], ); $opt->get_options; # fix the overlay manager list my @ovl_manager = split(/[\s,:;]+/, $ovl_mgr_list); $options{ovl_manager} = \@ovl_manager; #print Dumper(\%options); }; # config ############################################################### # Table Manipulation for Registry and ACL ############################################################### # Description: # Check if the cell entry has been entered correctly # Arguments: # $top: parent window to popup a message # $t: table display window # $tableopts: hash containing variables (including data array) # $prev: previous cell # $curr: current cell # Returns: # 1 on successs # 0 on failure # Exceptions: # sub validatecell ($$$$$) { my ($t, $top, $tableopts, $prev, $curr) = @_; my $msg = 'Cells in the row are empty or incorrect.'; eval { if ((defined $prev) and ($prev ne "")){ my ($row,$col)=split(",",$prev); # empty cells if ((not defined $$tableopts{array}->{"$prev"}) or ($$tableopts{array}->{"$prev"} eq "")){ showmsg($top, $msg); $t->activate($prev); die ("cell"); } # Syntax check if (($$tableopts{name} eq "acl") and (($col eq "0") or ($col eq "3")) and (not (($$tableopts{array}->{$prev} =~ /^(\d+)$/) and ($$tableopts{array}->{$prev} ge 0))) ){ my $supmsg = ""; if ($col eq "0") { $supmsg = "Rule number in row $row has to be an integer."; } else { $supmsg = "Tunnel count in row $row has to be an integer."; } showmsg($top, $msg . $supmsg); $t->activate($prev); die ("cell"); } if (($$tableopts{name} eq "acl") and ($col == "2")){ my $access = $$tableopts{array}->{$prev}; if (not defined $XB_Params::access_level{$access}){ my $line = join (", ", (keys %XB_Params::access_level)); my $supmsg = " The access level specified in third column " . " should belong the supported set { $line } "; showmsg($top, $msg . $supmsg); $t->activate($prev); die ("cell"); } } # if row changes, then make sure that the row is filled. my ($crow,$ccol)=split(",",$curr); # check the entire row. if ($crow ne $row) { # go through as many cols as contained in the first row. my $i = 0; while (defined $$tableopts{array}->{"0,$i"}){ if ((not defined $$tableopts{array}->{"$row,$i"}) or ($$tableopts{array}->{"$row,$i"} eq "")){ my $supmsg = " Check cell in row $row column $i "; showmsg($top, $msg . $supmsg); $t->activate("$row,$i"); die ("row"); } $i++; } } } }; # eval return 0 if ($@); return 1; }; # Description: # This calls validate on each and every row # when the user clicks on quit. # Arguments: # $top: parent window to popup a message # $t: table display window # $tableopts: hash containing variables (including data array) # Returns: # 1 on successs # 0 on failure # Exceptions: # sub validateall ($$$) { my ($t, $top, $tableopts) = @_; eval { foreach my $row (1 .. ${$$tableopts{rows}} - 1){ die ("validate") if (!validatecell($t, $top, $tableopts, "$row,0", "0,0")); } }; return 0 if ($@); return 1; } # Description: # Show the table - whatever it may be. All required data is # specified in the table opts. # Arguments: # $tableopts: hash containing variables (including data array) # Returns: # 1 on successs # 0 on failure # Exceptions: # # Notes: This is a common function for both ACL and Registry # and any future tables that need to read from the user. # sub table ($){ my ($tableopts) = @_; my ($main, $top, $frame, $t); # open a new table $top = $$tableopts{main}->Toplevel; $top->Label(-text => $options{hostname} . " - " . $$tableopts{title})->pack; # A menu bar is really a Frame. $menubar = $top->Frame(-relief=>"raised", -borderwidth=>2); # Menubuttons appear on the menu bar. my $filebutton = $menubar->Menubutton(-text=>"Options", -underline => 0); # Menus are children of Menubuttons. my $filemenu = $filebutton->Menu(); # Associate Menubutton with Menu. $filebutton->configure(-menu => $filemenu); $filemenu->command( -label => "Quit", -command => sub { if (validateall($t, $top, $tableopts)){ $top->destroy(); } } ); my $filebutton2 = $menubar->Menubutton(-text=>"Table", -underline => 0); # Menus are children of Menubuttons. my $filemenu2 = $filebutton2->Menu(); $filebutton2->configure(-menu=>$filemenu2); $filemenu2->command ( -label =>"Append New Row", -command=> sub { my $rows = ${$$tableopts{rows}}; # append blank record at end of table $t->insertRows($rows,1); $rows++; $t->see("$rows,0"); $t->activate("$rows,0"); ${$$tableopts{rows}} = $rows; } ); $filemenu2->command ( -label => "Delete Row Containing Active Cell", -command => sub { my $loc = $t->tagCell("active"); my ($row,$col)=split(",",$loc); $t->deleteRows($row,1); ${$$tableopts{rows}}--; } ); $filemenu2->command ( -label =>"Show Active Cell", -command =>sub{ $t->see("active"); } ); # Help menu. $helpbutton = $menubar->Menubutton(-text => "Help", -underline => 0); $helpmenu = $helpbutton->Menu(); $helpmenu->command(-command => $$tableopts{help}, -label => "Table", -underline => 0); $helpbutton->configure(-menu=>$helpmenu); # Pack most Menubuttons from the left. $filebutton->pack(-side=>"left"); $filebutton2->pack(-side=>"left"); # Help menu should appear on the right. #$helpbutton->pack(-side=>"right"); $menubar->pack(-side => "top", -fill => "x"); $t = $top->Scrolled('TableMatrix', -rows => ${$$tableopts{rows}}, -cols => ${$$tableopts{cols}}, -titlerows => 1, -variable => $tableopts->{array}, -colstretchmode => 'all', -rowstretchmode => 'all', -colwidth => 13, -rowheight => 1, -height => 0, -width => 0, #-selectmode => 'extended', -browsecmd => sub { my ($prev, $curr) = @_; validatecell($t, $top, $tableopts, $prev, $curr); }, #-maxheight => 1000, -selecttype => 'row', #-scrollbars => 'se', -sparsearray => 0, #-bd => 1, ); #-width => 6, #-height =>16, #-bg => 'PaleGreen', #-validatecommand => sub { validatecell ($t, $tableopts); }, #-validate => 1, # the next two statements force left justification of everything $t->tagConfigure("just", -anchor=>'w'); foreach my $col ( 0 .. ${$$tableopts{cols}} -1 ) { $t->tagCol("just",$col); } $t->pack(-expand => 1, -fill => 'both'); # bring focus to the table $t->activate("1,0"); $t->focus; $top->deiconify; $top->raise(); # block access to other windows my $wait_var = 1; $top->OnDestroy(sub { undef $wait_var }); $top->waitVisibility unless $top->ismapped; $top->grab; $top->waitVariable(\$wait_var); }; ############################################################### # ACL ############################################################### # Description: # Obtain the ACL entries. Specify the requirements to # table function. # Arguments: # $main: main window # Returns: # # Exceptions: # sub acl ($){ my ($main) = @_; my $rule; my $array = {}; my ($numrows, $numcols) = (1,5); $array->{"0,0"} = "Rule No"; $array->{"0,1"} = "Pattern"; $array->{"0,2"} = "Capability"; $array->{"0,3"} = "Tunnels"; $array->{"0,4"} = "UID"; foreach $rule (keys %{$options{user_acl}}){ my $line = $options{user_acl}{$rule}; my @opts = split (/\s+/, $line); my $pat = $opts[0]; my $cap = $opts[1]; my $tun = $opts[2]; my $uid = $opts[3]; $array->{"$numrows,0"} = $rule; $array->{"$numrows,1"} = $pat; $array->{"$numrows,2"} = $cap; $array->{"$numrows,3"} = $tun; $array->{"$numrows,4"} = $uid; $numrows++; } my %tableopts = ( "main" => $main, "name" => "acl", "title" => "ACL Configuration", "array" => $array, "rows" => \$numrows, "cols" => \$numcols, ); table(\%tableopts); my %newacl = (); foreach my $row (1..$numrows-1){ # take care of undefined entries foreach my $i (0..$numcols){ $array->{"$row,1"} = "" if (not defined $array->{"$row,1"}); } $rule = $array->{"$row,0"}; my $line = $array->{"$row,1"} . " " . $array->{"$row,2"} . " " . $array->{"$row,3"} . " " . $array->{"$row,4"} ; $newacl{$rule} = $line; } $options{user_acl} = \%newacl; }; ############################################################### # Registry ############################################################### # Description: # Obtain the Registry entries. Specify the requirements to # table function. # Arguments: # $main: main window # Returns: # # Exceptions: # sub registry ($){ my ($main) = @_; my $rule; my $array = {}; my ($numrows, $numcols) = (1,2); $array->{"0,0"} = "Attribute"; $array->{"0,1"} = "Value"; foreach $var (keys %{$options{register}}){ my $val = $options{register}{$var}; $array->{"$numrows,0"} = $var; $array->{"$numrows,1"} = $val; $numrows++; }; my %tableopts = ( "main" => $main, "name" => "registry", "title" => "Registry Configuration", "array" => $array, "rows" => \$numrows, "cols" => \$numcols, ); table(\%tableopts); my %register = (); foreach my $row (1..$numrows-1){ # take care of undefined entries foreach my $i (0..$numcols){ $array->{"$row,1"} = "" if (not defined $array->{"$row,1"}); } $var = $array->{"$row,0"}; $val = $array->{"$row,1"}; $register{$var} = $val; } $options{register} = \%register; #print Dumper($options{register}); }; ############################################################### # Save ############################################################### # Description: # Save all parameters specified through the GUI. If LDAP # is enabled, choose accordingly. # Arguments: # $top: main window # Returns: # # Exceptions: # sub save ($) { my ($top) = @_; my (@keys, $key); my $file = ""; my $dir = "."; while (1) { $file = $top->getSaveFile(-filetypes => \@conftypes, -initialdir => "/usr/local/etc/xbone", -initialfile => "xbone.conf", -title => "Save X-Bone Configuration File"); if ((not defined $file) or ($file eq "")) { last; # dont show the message $top->messageBox(-icon => 'error', -message => "Configuration file undefined", -title => 'Error!', -type => 'Ok', ); } $dir = dirname($file); if ((-e $file and ! -w $file) or (! -e $file and ! -w $dir)) { $top->messageBox(-icon => 'error', -message => "Directory not writable", -title => 'Error!', -type => 'Ok', ); next; }; last; }; return if ((not defined $file) or ($file eq "")); open(CONF,">$file"); print CONF "#************ X-Bone Configuration ***************\n"; print CONF "# * This file has been automatically generated *\n"; print CONF "# * Consult the documentation for more *\n"; print CONF "# * information on how to set the variable in *\n"; print CONF "# * file configuration file. *\n"; print CONF "#*************************************************\n"; print CONF "\n"; $options{address_type} = $options{ipproto}; $options{control_protocol} = $options{control_protocol}; my @variables = ( "hostname", "daemon_type","addrserv", "address_type", "control_protocol","ipproto", "dns","name_server", "dns_key_file", "xbone_net", "os", "os_version", "kern_version", "cisco_buddy_username", "cisco_buddy_password", "cisco_buddy_enable_password", "routing", "IPsec", "qos", ); my @v6variables = ( "ctl_addr6", "app_addr6", "xbone_mcast_addrv6" ); my @v4variables = ( "ctl_addr", "app_addr", "xbone_mcast_addr" ); my @certvariables = ( "ca_cert", "ca_path", "node_cert", "node_key" ); my @ldapvariables = ( "enable", "server", "port", "password", "instance", "scope" ); my @addressarray = (); if ( $options{ipproto} eq "ipv4" ){ @addressarray = @v4variables; } elsif ( $options{ipproto} eq "ipv6" ){ @addressarray = @v6variables; } else { @addressarray = (@v4variables, @v6variables); } #print Dumper(\%options); # Should I write both an LDIF file and a .CONF file or # only a .CONF file. if ($options{ldap}->{enable} =~ /(yes)/i){ # First generate the .conf file with enough # information to contact the server. foreach my $key (@ldapvariables){ print CONF "ldap $key = " . $options{ldap}->{$key} . "\n"; } foreach my $key (@certvariables){ print CONF "$key = " . $options{$key} . "\n"; } # Store everything else in the LDIF File. my $file = $top->getSaveFile(-filetypes => \@ldaptypes, -initialdir => "/usr/local/etc/xbone", -initialfile => "xbone.ldif", -title => "Save LDAP Configuration"); if (defined $file) { open(LDIF,">$file"); my $h = $options{'hostname'}; my $ldapconf = $options{'ldap'}; my $instance = $$ldapconf{'instance'}; #=> host configuration print LDIF "dn: cn=$h,ou=config,ou=local,ou=xbone\n"; print LDIF "objectClass: XBoneGroup\n"; print LDIF "cn: $h\n\n"; #=> host configuration print LDIF "dn: cn=$instance,cn=$h,ou=config,ou=local,ou=xbone\n"; print LDIF "objectClass: XBoneInstance\n"; print LDIF "cn: $instance\n"; foreach $key (@variables, @addressarray){ if ((defined $options{$key}) and ($options{$key} ne "") and ($options{$key} ne $defaults{$key})){ print LDIF "xbattr: \'$key = $options{$key}\'\n"; } } foreach my $mgr ( @{$options{'ovl_manager'}}) { print LDIF "xbattr: \'ovl_manager = $mgr\'\n"; }; foreach my $key ( keys %{$options{user_acl}} ){ print LDIF "xbacl: \'$key = " . $options{user_acl}{$key} . "\'\n"; } foreach my $key ( keys %{$options{register}} ){ print LDIF "xbregister: \'$key = " . $options{register}{$key} . "\'\n"; } close(LDIF); my $m = "Load the contents of $file into the LDAP server ". "using xb-ldap-config or any other ldap tool ". "(e.g., phpldapadmin)"; $top->messageBox(-icon => 'info', -message => $m, -title => 'Help', -type => 'Ok', ); }; # defined LDIF file } else { # Write out the node config in a non-ldap fashion foreach $key (@variables, @addressarray){ if ((defined $options{$key}) and ($options{$key} ne "") and ($options{$key} ne $defaults{$key})){ print CONF "$key = $options{$key}\n"; } } foreach my $key (@certvariables){ print CONF "$key = " . $options{$key} . "\n"; } print CONF "\n\n"; foreach my $mgr (@{$options{'ovl_manager'}}) { print CONF "ovl_manager = $mgr\n"; } print CONF "\n\n"; foreach my $key ( keys %{$options{register}} ){ print CONF "register $key = " . $options{register}{$key} . "\n"; } print CONF "\n\n"; foreach my $key ( keys %{$options{user_acl}} ){ print CONF "acl $key = " . $options{user_acl}{$key} . "\n"; } }; close(CONF); } ############################################################### # Related ############################################################### # Description: # Show help for the different related softwares # Arguments: # $top = window # $what = help for what? # Returns: # # Exceptions: # sub help_btn_cb ($$$){ my ($top,$what) = @_; my $m = ""; return if ($what !~ /(dns|zebra|openldap)/); my $ldapmsg = "X-Bone requires OpenLDAP version 2.2.18 and above.\n\n" . "To configure LDAP, add the following lines to /etc/rc.conf.local" . "\nslapd_enable=\"YES\"\n". "slapd_flags=\"-h ldaps://\"\n\n". "X-Bone specific LDAP configuration is stored in ". "etc/xbone/openldap/slapd-xbone.conf and one include rule ". "is added the the default LDAP configuration file.\n\n". "bin/xb-ldap-config is a useful script that install/uninstall, ". " X-Bone-specific LDAP configuration, show the content of the " . "LDAP server and ". "upload contents of LDIF files generated the control panel.\n\n". "More information can be found in xbone/doc/xbone-ldap.txt\n"; my $dnsmsg = "X-Bone requires Bind 9 or above.\n\n" . "X-Bone Overlay Manager uses Dynamic DNS with DNSSEC to " . "add records to the DNS server. The DNS server must be " . "appropriately configured along with the Overlay Manager\n\n". "Sample X-Bone specific DNS configuration is stored in ". "etc/xbone/named and detailed step by step instructions can ". "be found in xbone/doc/dynamic_dns.txt\n\n"; my $zebramsg = "X-Bone requires Quagga 0.96 or above.\n\n" . "X-Bone Node Daemons manipulate the Quagga routing daemon". " configuration during the overlay creation process.\n\n". "There is little in terms of X-Bone specific Quagga ". "configuration. Example quagga configuration files are stored ". " in etc/xbone/routing and step by step instructions can be " . "found in xbone/doc/xbone-dynamic_routing.txt\n\n"; if ($what =~ /(dns)/i){ $m = $dnsmsg; } elsif ($what =~ /(zebra)/i){ $m = $zebramsg; } elsif ($what =~ /(openldap)/i){ $m = $ldapmsg; } $m .= "Unless specified all paths are relative to /usr/local"; $top->messageBox(-icon => 'info', -message => $m, -title => 'Help', -type => 'Ok', ); } # Description: # Process the clicks on related software button. # This is place where we go ahead and install/uninstall/ # check related software. # Arguments: # $type: process what? (openldap/apache?) # $op: how? (install/uninstall) # Returns: # # Exceptions: # sub related_btn_cb ($$$){ my ($top,$type, $op) = @_; my ($script) = (); #print "related_btn_cb : $type $op \n"; return if ($type !~ /^(openldap)$/); return if ($op !~ /^(install|uninstall)$/); if ($type =~ /^(openldap)$/) { $script = "xb-ldap-config"; } else { $script = "xb-config.pl"; } my @cmd = ("/usr/local/bin/$script", $op); if ($type =~ /^(openldap)$/) { # add other options for OpenLDAP my $scope = "local"; if (defined $options{ldap} and defined $options{ldap}->{scope} and $options{ldap}->{scope} =~ /(global)/){ $scope = "global"; } @cmd = (@cmd, $scope); } eval { $msg = execcmd(\@cmd); }; if ($@) { showmsg($top, "Error! $@."); } else { my $m = "Operation successful!"; if ($msg) { $m .= "\n\nAdditional information: " . $msg; } $top->messageBox(-icon => 'info', -message => $m, -title => 'Status', -type => 'Ok', ); }; }; # Description: # Show the related software window # Arguments: # $main: Main window # Returns: # # Exceptions: # sub related ($){ my ($main) = @_; my ($b, $l); $top = $main->Toplevel; $top->title("Related Software Management"); $top -> minsize(qw(300 375)); $top -> geometry('+0+0'); $l = $top->Label (-text=>'(Un)Install X-Bone Specific Components.'); #$l->place(-x=>10, -y => 10); $l->pack(-pady => 5); my $f = $top->LabFrame(-label => "OpenLDAP"); $f->place(-x => 0, -y => 30, -width => 300, -height => 100); $l = $f->Label(-text=>'(Only if the LDAP is installed on this host)'); $l->pack(-pady => 5, -padx => 5, -side => "top"); $b = $f->Button( -text => 'Install', -command => sub{ &related_btn_cb($top, "openldap", "install"); } ); $b->place(-x=>20, -y => 25); $b = $f->Button( -text => 'Uninstall', -command => sub{ &related_btn_cb($top, "openldap", "uninstall"); } ); $b->place(-x=>100, -y => 25); $b = $f->Button( -text => 'Help', -command => sub{&help_btn_cb($top, "openldap");} ); $b->place(-x=>210, -y => 25); $f = $top->LabFrame(-label => "BIND/DNS"); $f->place(-x => 0, -y => 130, -width => 300, -height => 100); $l = $f->Label(-text=>'(To be supported in future. See help.)'); $l->pack(-pady => 5, -padx => 5, -side => "top"); $b = $f->Button( -text => 'Install', -command => sub{ &related_btn_cb($top, "dns", "install"); }, -state => 'disabled', ); $b->place(-x=>20, -y => 25); $b = $f->Button( -text => 'Uninstall', -command => sub{ &related_btn_cb($top, "dns", "uninstall"); }, -state => 'disabled', ); $b->place(-x=>100, -y => 25); $b = $f->Button( -text => 'Help', -command => sub{&help_btn_cb($top, "dns");} ); $b->place(-x=>210, -y => 25); $f = $top->LabFrame(-label => "Zebra/Quagga"); $f->place(-x => 0, -y => 230, -width => 300, -height => 100); $l = $f->Label(-text=>'(To be supported in future. See help.)'); $l->pack(-pady => 5, -padx => 5, -side => "top"); $b = $f->Button( -text => 'Install', -command => sub{ &related_btn_cb($top, "zebra", "install"); }, -state => 'disabled', ); $b->place(-x=>20, -y => 25); $b = $f->Button( -text => 'Uninstall', -command => sub{ &related_btn_cb($top, "zebra", "uninstall"); }, -state => 'disabled', ); $b->place(-x=>100, -y => 25); $b = $f->Button( -text => 'Help', -command => sub{&help_btn_cb($top, "zebra");} ); $b->place(-x=>210, -y => 25); $b = $top->Button( -text => 'Quit', -command => [$top => 'destroy'] ); $b->place(-x=>115, -y => 335); my $wait_var = 1; $top->OnDestroy(sub { undef $wait_var }); $top->waitVisibility unless $top->ismapped; $top->grab; $top->waitVariable(\$wait_var); }; ############################################################### # Start/Stop X-Bone ############################################################### sub xbonectl ($$) { my ($top, $op) = @_; my $msg = ""; #=> Check to make sure that the user has uploaded the # the LDIF my $ldapconf = $options{'ldap'}; if ( defined $ldapconf and $$ldapconf{'enable'} =~ /(yes)/i) { my $msg .= "If LDAP database is used to store host configuration " . "then the content of the LDIF file generated by the ". "control panel must be uploaded to server. Click Yes ". "if already done. Else run xb-ldap-config with " . "appropriate options."; my $response = $top->messageBox(-icon => 'question', -message => $msg, -title => 'Warning!', -type => 'YesNo', ); return if ($response =~ /(no)/i); }; my @cmd = ("/usr/local/bin/xbonectl", "$op"); eval { # execcmd blocks until all children and their children # finish. #$msg = execcmd(\@cmd); system(@cmd) == 0 || die ("could not $op the node daemon"); }; if ($@) { showmsg($top, "Error! $@."); } else { my $m = "Operation successful! "; # "(See terminal output for additional information.)"; # NOT to put $msg into messageBox because it tends to clog if ($msg) { $m .= "\n\nAdditional information: " . $msg; } $top->messageBox(-icon => 'question', -message => $m, -title => 'Status', -type => 'Ok', ); }; } ############################################################### # Main ############################################################### sub main_btn_cb ($$){ my ($top, $type) = @_; my %funcmap = ( "save" => \&save, "config" => \&config, "registry" => \®istry, "acl" => \&acl, "related" => \&related, ); $funcmap{$type}($top); }; sub main { # create a window my $top = MainWindow->new; $top->title("X-Bone Control Panel"); # make a copy of the defaults foreach my $key (keys %options) { next if ($key =~ /(register|user_acl|ldap)/ ); $defaults{$key} = $options{$key}; } # load existing configuration file my $file = $top->getOpenFile(-filetypes => \@conftypes, -initialdir => "/usr/local/etc/xbone", -initialfile => "xbone.conf", -title => "Load An Existing Configuration File (If Any)"); if (defined $file and -f $file){ $options{conf} = $file; } else { $options{conf} = ""; } # load the options get_opts; $font = $top->Font(family => 'courier', point => 140, weight => 'bold', slant => 'r'); $top -> minsize(qw(300 330)); $top -> geometry('+0+0'); my $f = $top->LabFrame(-label => "Configure X-Bone"); $f->place(-x => 0, -y => 0, -width => 300, -height => 120); $b = $f->Button( -text => 'Base', -command => sub{&main_btn_cb($top,"config");} ); $b->place(-x=>20, -y => 10); $b = $f->Button( -text => 'Registry', -command => sub{&main_btn_cb($top,"registry");} ); $b->place(-x=>100, -y => 10); $b = $f->Button( -text => 'ACL', -command => sub{&main_btn_cb($top,"acl");} ); $b->place(-x=>200, -y => 10); $b = $f->Button( -text => 'Save', -command => sub{&main_btn_cb($top,"save");} ); $b->place(-x=>110, -y => 50); $f = $top->LabFrame(-label => "Configure Related Software"); $f->place(-x => 0, -y => 120, -width => 300, -height => 80); my $msg .= "Automatic configuration of dependent services such as " . "OpenLDAP requires saved X-Bone configuration in the standard " . "location\n/usr/local/etc/xbone/xbone.conf.\nProceed?"; $b = $f->Button( -text => 'Related Software', -command => sub{ my $response = $top->messageBox(-icon => 'question', -message => $msg, -title => 'Warning!', -type => 'YesNo', ); if ($response =~ /(yes)/i){ &main_btn_cb($top,"related"); } } ); $b->place(-x=>80, -y => 10); $f = $top->LabFrame(-label => "X-Bone Runtime"); $f->place(-x => 0, -y => 200, -width => 300, -height => 80); $b = $f->Button( -text => 'Start', -command => sub{&xbonectl($top,"start");} ); $b->place(-x=>50, -y => 10); $b = $f->Button( -text => 'Stop', -command => sub{&xbonectl($top,"stop");} ); $b->place(-x=>150, -y => 10); $b = $top->Button( -text => 'Quit', -command => [$top => 'destroy'] ); $b->place(-x=>105, -y => 280); } ############################################################### # Main Loop ############################################################### main; MainLoop;