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-gui-control.pl,v $
#
# $Revision: 1.10 $
# $Author: pingali $
# $Date: 2005/04/21 00:30:39 $
# $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/www/xbone",
"/usr/local/www/xbone/lib",
"/usr/local/www/xbone/cpan",
){
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 $hostname = `hostname`;
chomp($hostname);
my $font;
my %options = ();
my %defaults = ();
my @conftypes = (["Config Files", '.conf', 'TEXT'],
["All Files", "*"] );
########################################################################
# 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 (<RDR>) { $msg .= $_; }
while (<ERR>) { $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;
}
};
###############################################################
# 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-gui.conf",
-title => "Save X-Bone GUI Configuration File");
if ((not defined $file) or ($file eq "")) {
last; # dont show the message below
$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',
);
last;
};
last;
};
return if (not defined $file or $file eq "");
open(CONF,">$file");
print CONF "#************ X-Bone GUI 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";
my @variables = ("hostname", "ipproto", "timeout");
my @v6variables = ( "ctl_addr6" );
my @v4variables = ( "ctl_addr" );
my @certvariables = ( "ca_cert", "ca_path",
"node_cert", "node_key" );
my @addressarray = ();
if ( $options{ipproto} eq "ipv4" ){
@addressarray = @v4variables;
} elsif ( $options{ipproto} eq "ipv6" ){
@addressarray = @v6variables;
} else {
@addressarray = (@v4variables, @v6variables);
}
#print Dumper(\%options);
# Write out the node config in a non-ldap fashion
foreach $key (@variables, @addressarray, @certvariables){
if ((defined $options{$key}) and
($options{$key} ne "")) {
print CONF "$key = $options{$key}\n";
}
}
print CONF "\n\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 !~ /(apache)/);
my $apachemsg =
"X-Bone requires Apache version 2.0.42 and above.\n\n" .
"To configure Apache, add the following lines to " .
"/etc/rc.conf.local:\n" .
"apache2_enable=\"YES\"\n".
"apache2ssl_enable=\"YES\"\n\n".
"X-Bone specific Apache configuration is stored in ".
"etc/xbone/apache/xbone-apache.conf and symbolically linked ".
"from etc/apache2/Includes. \n\n".
"bin/xb-apache-config is used to install/uninstall X-Bone, " .
"in the background. The installed X-Bone is available at ".
"http://<hostname>/xbone. To run X-Bone GUI on non-standard ".
"ports, edit the above mentioned the configuration file. By ".
"default the X-Bone GUI will be available on port 443 (https).".
"\n\n";
$m = $apachemsg;
$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 !~ /^(apache)$/);
return if ($op !~ /^(install|uninstall)$/);
if ($type =~ /^(apache)$/) {
$script = "xb-apache-config";
} else {
$script = "xb-config";
}
my @cmd = ("/usr/local/bin/$script", $op);
eval {
$msg = execcmd(\@cmd);
};
if ($@) {
showmsg($top, "Error! $@.");
} else {
my $m = "Operation successful!";
if ($msg) {
$m .= "\n\nAdditional information: " . $msg;
}
$top->messageBox(-icon => 'question',
-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 150));
$top -> geometry('+0+0');
$l = $top->Label (-text=>'(Un)Install X-Bone Specific Components.');
#$l->place(-x=>10, -y => 10);
$l->pack(-pady => 5);
$f = $top->LabFrame(-label => "Apache");
$f->place(-x => 0, -y => 20, -width => 300, -height => 80);
$b = $f->Button(
-text => 'Install',
-command => sub{&related_btn_cb($top, "apache", "install");}
);
$b->place(-x=>20, -y => 10);
$b = $f->Button(
-text => 'Uninstall',
-command => sub{&related_btn_cb($top, "apache", "uninstall");}
);
$b->place(-x=>100, -y => 10);
$b = $f->Button(
-text => 'Help',
-command => sub{&help_btn_cb($top, "apache");}
);
$b->place(-x=>210, -y => 10);
$b = $top->Button(
-text => 'Quit',
-command => [$top => 'destroy']
);
$b->place(-x=>110, -y => 110);
my $wait_var = 1;
$top->OnDestroy(sub { undef $wait_var });
$top->waitVisibility unless $top->ismapped;
$top->grab;
$top->waitVariable(\$wait_var);
};
# 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 $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 ( $os =~ /(linux)/i) { $v6noshow = 1; }
if (! $v6noshow and ! $v4noshow ){ push @ipver, "both"; };
my @opttable = (
'Addressing',
[
'ipproto', '=s', $options{ipproto},
label => 'IP Protocol:',
longhelp => 'IPv4 address on which the Node Daemon will listen.',
choices => \@ipver,
var => \$options{ipproto},
strict => 1,
],
['', '',
'
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 to be used as a source address',
choices => $v4addrs,
nogui => $v4noshow,
var => \$options{ctl_addr},
],
[
'ctl_addr6', '=s', $v6addrs->[0],
label => 'IPv6 Address:',
longhelp => 'IPv6 address to be used as a source address',
choices => $v6addrs,
nogui => $v6noshow,
var => \$options{ctl_addr6},
],
'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',
['', '', "Connection Properties"],
['timeout', "=i", $options{timeout},
label => "Timeout",
longhelp => 'Timeout for the connection to the backend',
var => \$options{timeout},
],
);
$opt = new Tk::Getopt(-opttable => \@opttable,
-options => \%options,
);
$opt->set_defaults;
$opt->load_options;
$opt->get_options;
$opt->process_options;
my @packopts = ( -fill => "both",
-expand => 1
);
$opt->option_editor($top,
#-toplevel => "Frame",
"-wait" => 1,
"-delaypagecreate" => 1,
"-buttons" => [qw/ok/],
#-pack => \@packopts,
);
$opt->get_options;
}; # config
###############################################################
# Main
###############################################################
%options = (
ipproto => "both",
hostname => $hostname,
ca_cert => "/usr/local/etc/xbone/cert/CAcert.pem",
ca_path => "/usr/local/etc/xbone/cert",
node_cert => "/usr/local/etc/xbone/cert/node_cert.pem",
node_key => "/usr/local/etc/xbone/cert/node_key.pem",
timeout => "25",
"ctl_addr" => "",
"ctl_addr6" => "",
);
sub main_btn_cb ($$){
my ($top, $type) = @_;
my %funcmap = (
"save" => \&save,
"config" => \&config,
"related" => \&related,
);
$funcmap{$type}($top);
};
sub main {
# create a window
my $top = MainWindow->new;
$top->title("X-Bone GUI Control Panel");
$top -> minsize(qw(300 200));
$top -> geometry('+0+0');
my $f = $top->LabFrame(-label => "Configure X-Bone GUI");
$f->place(-x => 0, -y => 0, -width => 300, -height => 80);
$b = $f->Button(
-text => 'Configure',
-command => sub{&main_btn_cb($top,"config");}
);
$b->place(-x=>50, -y => 10);
$b = $f->Button(
-text => 'Save',
-command => sub{&main_btn_cb($top,"save");}
);
$b->place(-x=>160, -y => 10);
$f = $top->LabFrame(-label => "Configure Related Software");
$f->place(-x => 0, -y => 80, -width => 300, -height => 80);
my $msg = "Automatic configuration of dependent services such as " .
"Apache requires saved X-Bone configuration in the standard " .
"location\n/usr/local/etc/xbone/xbone-gui.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=>70, -y => 10);
$b = $top->Button(
-text => 'Quit',
-command => [$top => 'destroy']
);
$b->place(-x=>105, -y => 160);
}
###############################################################
# Main Loop
###############################################################
main;
MainLoop;
syntax highlighted by Code2HTML, v. 0.9.1