#!/usr/bin/perl

# Script to
# + test a Tcl/Tk unix installation
# + call Vitess at HZB
# M.Fromme HMI Jan 2008

use strict;

##################################################################################
### To be configured if used outside Helmholtz-Zentrum Berlin
my @VHOSTS = qw(dinux4 dinux fisi01 fisi02 dixi4);
my $alternative = "call Vitess on any of @VHOSTS";

my $installdir = '/net/pub/vitess';
### End configuration
##################################################################################

my ($wish, $tarfile, $isLinux, $check_sanity, $ldd, $patchfile, $copyexamples);


sub usage {
  print <<EOS;
usage:
callVitess [-w wish] [-i installdir] [-e] [-c] [-p patchfile]
  -w wish           absolute wish path, default is to search bltwish in your PATH
  -i installdir     installation directory, must exist, default $installdir
  -e                copy examples directory FILES from $installdir to ./
  -c                check sanity of Vitess installation
  -p patchfile      generates a replacement file for tkfbox.tcl to be used
                    when Tcl/Tk fails on browsing + storing files
EOS
  exit 0;
}

while ($_ = shift) {
  next unless /^-(.)/;
  $_ = $1;
  if (/c/) {
    $check_sanity = 1;
  } elsif (/e/) {
    $copyexamples = 1;
  } elsif (/w/) {
    $wish = shift;
  } elsif (/i/) {
    $installdir = shift;
  } elsif (/p/) {
    $patchfile = shift;
  } else {
    usage();
  }
}

myexit('please specify a valid installation directory!')
  unless $installdir && -d $installdir;

my $sysapp = mySystem();

if ($wish eq '') {
  $wish = findImage('bltwish');
  $wish = findImage('wish') unless -x $wish;
}

myexit ("Cannot find a Tcl/Tk wish executable. Please install Tcl/Tk first, or $alternative.")
  unless $wish ne '' && -x $wish;

#check version of wish
$_ = `echo 'puts \$tk_version; exit' | $wish 2>&1`;
if (/couldn't connect to display/) {
  myexit("Please set a valid display environment variable!\n");
} else {
  chomp;
  myexit("Version $_ of $wish too old (elder than 8.2) here!\nMaybe you may $alternative")
    if $_ ne '' && $_ < 8.2;
}

$_ = `find $installdir -name Vitess`;
chomp;
unless (-s $_) {
  $_ = `find -L $installdir -name Vitess`;
  chomp;
}
myexit("unable to read file Vitess under $installdir !") unless -s $_;
my $ofile = $_;
$_ = $ENV{PWD};
$ofile = "$_/$1" if $_ && $ofile =~ /^\.\/(.+)/;

if ($copyexamples && $ofile =~ /^(.+)\/Vitess$/) {
  my $d = "$1/FILES/";
  my $td = "$ENV{PWD}/FILES";
  if (-d $d) {
    myexit("will not copy $d to existing $td") if -d $td;
    system "cp -r $d $td";
  }
}

if ($check_sanity || $patchfile ne '') {
  checkSanity() if $check_sanity;
  generatePatchfile() if $patchfile;
} else {
  exec "$wish $ofile";
}



sub checkSanity {
  $_  = `find $installdir -name source$sysapp`;
  chomp;
  myexit ("dubious installation, source$sysapp missing!")
    unless $_ ne '' && -s $_ && -x $_;

  /^(.+)\/[^\/]+$/;
  my $tdir = $1;

  my $anyErr;
  if (($ldd = findImage('ldd'))) {
    # test for missing shared libraries
    foreach my $source (qw(bender)) {
      my $exe = "$source$sysapp";
      my $any;
      open F, "$ldd $tdir/$exe|";
      while (<F>) {
	next unless /([^ ]+)[\s]+=>[\s]+(.+)$/;
	$any = 1;
	my $lib = $1;
	my $rest = $2;
	next unless $lib =~ /^lib/;
	if ($isLinux) {
	  $rest =~ /\((0x[0-9a-fA-F]+)\)/;
	  $rest = $1;
	  my $ok = $rest ne '';
	  eval '$ok = 0 + ' . $ok if $ok;
	  $anyErr .= "problems with library $lib needed for $exe!\n"
	    unless $ok;
	} else {
	  $rest =~ /^(\/[^\s]+)/;
	  $rest = $1;
	  $anyErr .= "problems with library $lib needed for $exe!\n"
	    unless $rest &&  -r $rest;
	}
      }
      close F;
      print "wrong architecture of $exe?\n" unless $any;
    }
  }
  print $anyErr ne '' ? $anyErr : "o.k.\n";
}


sub generatePatchfile {
  # search for tk library and check version

  $_ = `echo 'puts \$tk_library; exit' | $wish 2>&1`;
  if (/couldn't connect to display/) {
    print "set a valid display environment variable to test tkfbox.tcl!\n";
  } else {
    chomp;
    my $tkfbox = "$_/tkfbox.tcl";
    print "can't read and test $tkfbox\n" unless -s $tkfbox;
    my $version;
    open F, $tkfbox;
    if ($patchfile) {
      $patchfile = '' unless open OF, ">$patchfile";
    }
    while (<F>) {
      if (/^([\s]+)(\$data\(.+\)\s+config[a-z]*\s+-state\s+.+)/) {
	print OF "$1catch \{ $2 \}\n" if $patchfile;
      } else {
	$version = $1 if /\$Id:[\s]+tkfbox\.tcl.+v[\s]+([0-9.]+)/;
	print OF $_ if $patchfile;
      }
    }
    close F;
    if ($version ne '') {
      print "$tkfbox\n\t found version $version\n";
    } else {
      print "can't extract version of $tkfbox\n";
    }
    if ($patchfile) {
      close OF;
      print "Replacement patch file written to $patchfile\n";
    }
  }
}

sub myexit {
  print "Error: $_[0]\n";
  exit(2);
}

sub findImage {
  my $p = $_[0];
  foreach (split ':',$ENV{PATH}) {
    foreach (<$_/$p>) {
      return $_ if -x $_;
    }
  }
  '';
}

sub mySystem {
  $_ = `uname`;
  chomp;
  return "_$_" if $_ ne 'Linux';
  $isLinux = 1;
  $_ = `uname -i`;
  return '_Linux_x86_64' if /x86_64/;
  '_Linux';
}
