#!/usr/bin/perl -w
#
# slharoutines  -  Version 1.1 by Robert Harlander, BU Wuppertal
#                  public version of May 10, 2011 (CERN)
#
# Original version of 2005 by Robert Harlander.
#
# This is a collection of PERL routines to manipulate and read
# in- and output files that are in SUSY Les Houches Type format.
# Comments and bug reports should be sent to
# robert.harlander@uni-wuppertal.de
#
# Include this module into your perl program by putting the lines
# > use lib $ENV{'HOME'}."/perl/modules";
# > use slharoutines;
# at the beginning of your program.
#
package slharoutines;
use Exporter;
use Cwd;
@ISA = ('Exporter');
@EXPORT = ('changeparam','extractslha','extractslhav2','printdataline',
    'mapfile','dataline','readblock','searchline','getvalblock',
    'addline','movefile','changeparam','diff','f2num');

#- {{{ sub extractslhav2:

sub extractslhav2 {
#
# extractslhav2($dir,$dataform,@options)
#
# Collects data from a set of SLHA (SUSY Les Houches Accord) files.
# 
# Usage:
# ------
# 1) put all SLHA files into a directory $dir
# 2) modify the variable @dataform: the format is
#    $dataform = [ [ ( $block1, $entry1, $entry2 ) ],
#                  [ ( $block2, $entry1 ) ], ... ];
#    - $block1, $block2, ... are strings specifying the BLOCKs
#    - $entry1, $entry2, ... are integers specifying which entry of the BLOCK
#                            should be read
# 3) call 
#    > extractslha($dir,$dataform)
# 4) this will print the following to STDOUT:
#    - a comment line starting with '#', containing essentially '@dataform'
#    - a line with data for each file in <dir>, containing the value
#    - the order in which the lines are printed is such that the values
#      in the first column are ascending
#
# Examples:
# --------
# $dataform = [ ["MINPAR",3],["stopmix",1,2],["MASS",25],["MASS",35] ];
# This will print a data file containing
#     tan(beta)  sin(thetat)  M(h0)  M(H0)
# where the first line corresponds to the smallest, the last line to the
# largest value of tan(beta).
#
#
# Options:
# --------
# should be given in the form
# {"<option>" => value, ...}
# as the third argument of extractslhav2.
# Current options are:
# * comments => 1 [0: no comments in data file]
# * printfun => \&printdataline
#   this option allows you to modify the output of extractslha().
#   In this way, one can do some simple calculations with the data.
#
### NOTHING NEEDS TO BE MODIFIED BELOW THIS POINT

    %defaults = ("header" => 1,
		 "output" => "STDOUT",
                 "comments" => 1,
                 "printfun" => \&printdataline);
    $dir = shift;
    $dataform = shift;
    @dataform = @{$dataform};
    $opts = shift;
    %options = %{$opts};
    foreach $key (keys(%defaults)) {
	if (exists($options{$key})) {
	    $defaults{$key} = $options{$key};
	}
    }

    if (!(-d $dir)) {print("$dir does not exist. Stopped.\n");exit}

    $cwd = cwd();

    if ($defaults{"output"} ne "STDOUT") {
	$out = "OUT";
	open($out,">".$cwd."/".$defaults{"output"}) || die;
    } else {$out = "STDOUT"};

    chdir($dir);

    opendir(DIR,".") || die;
    @files = readdir(DIR);
    close(DIR);
    
    @files = diff([@files],["..","."]);

    foreach $file (@files) {
	$fh = "FILE";
	open($fh,"$file")||die;
	@dataline = ($file,dataline($file,@dataform));
	@datafile = (@datafile,[@dataline]);
	close($fh);
    }

    unless ($defaults{"comments"} == 0) {
	print {$out} ("##############################################\n");
	print {$out} ("# directory: $dir\n");
	print {$out} ("##############################################\n");
	open(FILE,$files[0]) || die;
	while (<FILE>) {
	    print {$out} ("## ",$_);
	}
	close(FILE);
        $comments = 1;
    } else { $comments = "nocomments" }
    
    if ($defaults{"header"} == 1) {
	$" = "\-";
	print {$out} ("# ");
	foreach $set (@dataform) {
	    print {$out} ("@{$set}");
	    print {$out} (" --- ");
	}
	print {$out} ("\n");
	$" = " ";
    }

    foreach $line (sort {f2num(${$a}[1]) <=> f2num(${$b}[1])} (@datafile)) {
          &{$defaults{"printfun"}}($line,$comments);
    }
    close($out);
}

#- }}}
#- {{{ sub extractslha:

sub extractslha {
#
# extractslha($dir,$dataform,@options)
#
# Collects data from a set of SLHA (SUSY Les Houches Accord) files.
# 
# Usage:
# ------
# 1) put all SLHA files into a directory $dir
# 2) modify the variable @dataform: the format is
#    $dataform = [ [ ( $block1, $entry1, $entry2 ) ],
#                  [ ( $block2, $entry1 ) ], ... ];
#    - $block1, $block2, ... are strings specifying the BLOCKs
#    - $entry1, $entry2, ... are integers specifying which entry of the BLOCK
#                            should be read
# 3) call 
#    > extractslha($dir,$dataform)
# 4) this will print the following to STDOUT:
#    - a comment line starting with '#', containing essentially '@dataform'
#    - a line with data for each file in <dir>, containing the value
#    - the order in which the lines are printed is such that the values
#      in the first column are ascending
#
# Examples:
# --------
# $dataform = [ ["MINPAR",3],["stopmix",1,2],["MASS",25],["MASS",35] ];
# This will print a data file containing
#     tan(beta)  sin(thetat)  M(h0)  M(H0)
# where the first line corresponds to the smallest, the last line to the
# largest value of tan(beta).
#
#
# Options:
# --------
# "header": prints a header before the data
#
# Note:
# -----
# By defining a suitable subroutine 'printdataline()' after loading 
# slharoutines.pl, one can modify the output of extractslha().
# In this way, one can even do some simple calculations with the data.
#
### NOTHING NEEDS TO BE MODIFIED BELOW THIS POINT

    $dir = shift;
    $dataform = shift;
    @dataform = @{$dataform};
    @options = @_;
    chdir($dir);
    
    opendir(DIR,".") || die;
    @files = readdir(DIR);
    close(DIR);
    
    @files = diff([@files],["..","."]);

    foreach $file (@files) {
	$fh = "FILE";
	open($fh,"$file")||die;
	@dataline = ($file,dataline($file,@dataform));
	@datafile = (@datafile,[@dataline]);
	close($fh);
    }
    
    unless (grep(/^nocomments$/,@options)) {
	print("##############################################\n");
	print("# directory: $dir\n");
	print("##############################################\n");
	open(FILE,$files[0]) || die;
	while (<FILE>) {
	    print("## ",$_);
	}
	close(FILE);
    }
    
    if (grep(/^header$/,@options)) {
	$" = "-";
	print("# ");
	foreach $set (@dataform) {
	    print("@{$set}");
	    print(" --- ");
	}
	print("\n");
	$" = " ";
    }
    

    foreach $line (sort {f2num(${$a}[1]) <=> f2num(${$b}[1])} (@datafile)) {
	if (grep(/^nocomments$/,@options)) {
	    printdataline($line,"nocomments");
	}
	else {
	    printdataline($line);
	}
    }
}

#- }}}
#- {{{ sub f2num:

sub f2num {
    #
    # perl apparently does not know double precision, so just turn
    # "1.D+3" to 1.e+3
    #
    my($num);
    $num = shift;
#    $num =~ s/([0-9\.])D([\+\-])([0-9]+)/$1*10**($2$3)/;
    $num =~ s/D/e/;
    return(eval($num));
}

#- }}}
#- {{{ sub printdataline:

sub printdataline {
    my($input,@output,@options);
    $input = shift;
    @options = @_;
    $file = shift(@{$input});
    @entry = @{$input};
 
    if (grep(/^nocomments$/,@options)) {
	print {$out} ("@entry\n");
    } else {
	print {$out} ("@entry # $file\n");
	}
}

#- }}}
#- {{{ sub mapfile:

sub mapfile {
#
# mapfile($infile,$outfile,([["block1a",entry1a],["block1b",entry1b]],
#                           [["block2a",entry2a],["block2b",entry2b]],
#                           ...));
#
# Searches entry1a of block1a in $infile and puts this entry
# in block1b of $outfile.
# The old entry remains.
#
# Example:
# $infile = "HEINOIN";
# $outfile = "HEINOOUT";
# open($infile,"ggh.out.lo.35");
# open($outfile,"+<heino.out");
# 
# mapfile($infile,$outfile,([["mass",36],["wat",1982]],
# 			  [["crein",7],["watto",2]]));
# 
# close($infile);
# close($outfile);
# 
    my(@dum);
    $infile = shift;
    $outfile = shift;
    @sets = @_;
    %lines = ();
    seek($infile,0,0);
    foreach $set (@sets) {
	($fromset,$toset) = @{$set};
	($fromblock,@fromentries) = @{$fromset};
	($fromline,@dum) = searchline($infile,$fromblock,@fromentries);
	%lines = ( %lines, 
		   "$fromline" => $set );
    }
    seek($infile,0,0);
    seek($outfile,0,2);
  LOOP: while (<$infile>) {
 	$inline = $_;
# 	foreach $line (keys(%lines)) {
# 	    if ($inline eq $line) {
# 		next LOOP;
# 	    }
# 	}

	print {$outfile} ($inline);
    }
    foreach $line (keys(%lines)) {
	seek($outfile,0,0);
	($outline = $line) =~ s/^ *//;
	$outline =~ s/[ \t]+/ /g;
	($fromset,$toset) = @{$lines{$line}};
	($toblock,@toentries) = @{$toset};
	($fromblock,@fromentries) = @{$fromset};
	$pattern = "@fromentries";
	$outline =~ s/^$pattern//;
	$outline = " @toentries".$outline;
	$outline = "#added to Block $toblock by mapfile():\n".$outline.
	    "\n#end of addition";
	addline($outfile,$outline,$toblock);
    }
}

#- }}}
#- {{{ sub dataline:

sub dataline {
#
# dataline($file,@dataform)
# 
# $file: SLHA file name
# @dataform: (["BLOCK1",entry1],["BLOCK2",entry2],...)
#
# Returns the list of values corresponding to 
# Block BLOCK1 and entry1 etc. as given in file $file.
#
    my(@dataline,$filehandle,@sets,$set,$block,@entries,$val);
    $filehandle = shift;
    @sets = @_;
    @dataline = ();
    foreach $set (@sets) {
	($block,@entries) = @{$set};
	$val = getvalblock($filehandle,$block,@entries);
	@dataline = (@dataline,$val);
    }
    return(@dataline);
}

#- }}}
#- {{{ sub readblock:

sub readblock {
    #
    # readblock($file,$block)
    #
    # Read the whole Block $block of $file into a string and return it.
    # Useful to copy blocks from one file to the other.
    #
    my($file,$block,$fullblock,@out,@entries,$val);
    $file = shift;
    $block = shift;
    @entries = @_;
    $blockfound = 0;
    $valfound = 0;
    $fullblock = "";
    if (-f $file) {
	open(FL,$file) || die;
	while (<FL>) {
	    $line = $_;
	    if ($line =~ /^BLOCK +$block([ \#\t]|$)/i) {
		$blockfound = 1;
		while (<FL>) {
		    if (/^(BLOCK|DECAY)/i) {last}
		    ($line = $_) =~ s/\#.*$//;
		    $line =~ s/[ \t]+/ /g;
		    $fullblock .= $line;
		}
	    }}
	    close(FL);
	} 
    else {
	print(" $file is not a regular file.\n Stopped in $0.\n");
	exit;
    }
    if ($blockfound == 0) {
	print(" BLOCK $block not found in file $file.\n Stopped in $0.\n");
	exit;
    }
	return($fullblock);
}

#- }}}
#- {{{ sub searchline:

sub searchline {
    #
    # searchline($filehandle,$block,@entries)
    #
    # returns the line containing the entry @entries in $block
    # in file $file,
    # and the list (@entries,$val)
    #
    # examples:
    # * searchline("$file","MASS",36)
    #   returns 
    #   36  107.3d0  (or similar)
    # * getvalblock("$file","stopmix",1,2)
    #   returns
    #   1 2 0.97 (or similar)
    #
    # see also getvalblock()
    #
    my($tmp,$filehandle,$block,@splitline,@entries,$line);
    $filehandle = shift;
    open($filehandle,"<$filehandle") || die "Died opening $filehandle";
    $block = shift;
    @entries = @_;
    $blockfound = 0;
    $valfound = 0;
    seek($filehandle,0,0);
    while (<$filehandle>) {
	$line = $_;
	if ( ($line =~ /^BLOCK +$block([ \#\t])/i) ||
	     ($line =~ /^BLOCK +$block$/i) ) {
	    $blockfound = 1;
	    while (<$filehandle>) {
		if (/^(BLOCK|DECAY)/i) {last}
		chop($fullline = $_);
		($line = $fullline) =~ s/\#.*$//;
		$line =~ s/[ \t]+/ /g;
		$pattern = "@entries";
		if ($line =~ /^ +$pattern /) {
		    $valfound = 1;
		    @splitline = split(/ +/,$line);
		    if ($#splitline != $#entries+2) {
			print("Specification \"@entries\" not sufficient".
			      " for BLOCK $block.\n",
			      "Stopped in $0.\n");
			exit;
		    }
		    return($fullline,@splitline);
		}
	    }
	}
    }
    if ($blockfound == 0) {
	print(" BLOCK $block not found in file $filehandle.\n Stopped in $0.\n");
	exit;
    }
    if ($valfound == 0) {
	print(" Value @entries not found in BLOCK $block, file $file.\n",
	      " Stopped in $0.\n");
	exit;
    }
}

#- }}}
#- {{{ sub getvalblock:

sub getvalblock {
    #
    # getvalblock($filehandle,$block,@entries)
    #
    # returns the value corresponding to entry @entries of $block
    # in file $file.
    #
    # examples:
    # * getvalblock("sps1a.out","MASS",36)
    #   returns the pseudo-scalar Higgs mass
    # * getvalblock("sps1a.out","stopmix",1,2)
    #   returns the (1,2) entry in the stop mixing matrix
    #
    my($line);
    ($fullline,@splitline) = searchline(@_);
    $val = pop(@splitline);
    return($val);
}

#- }}}
#- {{{ sub addline:

sub addline {
#
#  addline($filehandle,$line,$block)
#
#  Adds $line under $block into $filehandle,
#  except if entry already exists.
#  Entries thus cannot be changed: use changeparam() instead.
#  If $block does not exist, addline() creates it.
#
#  Example:
#  $slhafile = "FILE";
#  open($slhafile,"+<myfile.txt");
#  addline($slhafile," 36  1.07d2  # A0 mass","MASS");
#  close($slhafile);
#
    my($filehandle,$block,$val,@entries);
    my($failed);
    $block = pop(@_);
    ($filehandle,$fullline,@entries) = @_;
    ($line = $fullline) =~ s/\#.*$//;
    $line =~ s/^ *//;
    @entries = split(/ +/,$line);
    $val = pop(@entries);
    $failed = 1;
    $noteof = 0;
    while (<$filehandle>) { 
 	if ((/^Block +$block /i) || (/^Block +$block$/i)) {
 	  $failed = 0;
 	  last;
       }
    }
    $curpos = tell($filehandle);
    while (<$filehandle>) {
	($thisline = $_) =~ s/[ \t]+/ /g;
	$pattern = "@entries";
	if ($thisline =~ /^ +$pattern /) {
	    $exists = 1;
	    print("Error in addline(): ",
		  "entry @entries in BLOCK $block exists.\n");
	    last;
	}
	if ($thisline =~ /^[BD]/i ) {
	    $noteof = 1;
	    $contents = $thisline;
	    while (<$filehandle>) {
		$contents .= $_;
	    }
	    seek($filehandle,$curpos,0); 
	    last;
	}
	$curpos = tell($filehandle);
    }
    if ($failed) {
	print {$filehandle} ("BLOCK $block\n");
    }
    unless ($exists) {
	print {$filehandle} ("$fullline\n");
	if ($noteof) {
	    print {$filehandle} ("$contents");
	}
    }
}

#- }}}
#- {{{ sub movefile:

sub movefile {
    my($fromfile,$tofile,$targetdir);
    ($fromfile,$tofile) = @_;
    if ($tofile =~ /\//) {
	($targetdir = $tofile) =~ s/\/[^\/]*$//;
	unless (-d $targetdir) { system("mkdir -p $targetdir") }
    }
    unless (-f $fromfile) {
	print("Error in movefile: Cannot find file $fromfile.\n");
	exit 1;
    }
    system("/bin/mv -f $fromfile $tofile");
}

#- }}}
#- {{{ sub changeparam:

sub changeparam {
#
#  changeparam($file,$block,$entry,$val)
#
#  In Block $block of an SLHA input file, change the line
#  $entry  <somevalue>
#  to
#  $entry  $val
#
#  Example:   changeparam('slha.in','MASS',25,120)
#  This will set the light Higgs mass to 120 GeV.
#
    my($file,$block,$entry,$val);
    my($failed);
    ($file,$block,$entry,$val) = @_;
    movefile("$file","$file.bak");
    open(FILEIN,"$file.bak") || die;
    open(FILEOUT,">$file") || die "Cannot open file $file.";
    $failed = 1;
  LOOP: while (<FILEIN>) {
      if ((/^Block +$block[ \t\#]/i) || (/^Block +$block$/i)) {
	  print {FILEOUT} ($_);
	  while (<FILEIN>) {
	      if (/^[BD]/i) { 
		  print {FILEOUT} ($_);
		  next LOOP;
	      }
#	      if (/^ +$entry +.*(\#.*)?/) {
	      if (/^ +$entry +\S+ *(\#.*)?/) {
		  if ($1) {$desc = $1} else {$desc = ""}
		  $desc =~ s/\# *//;
		  $failed = 0;
		  s/^ +$entry +\S+ *(\#)?/ $entry $val \#/;
	      }
	      print {FILEOUT} ($_);
	  }
      } 
	else {print {FILEOUT} ($_)}
    }
    if ($failed) {
	print("warning: changeparam(): error entry $entry in ",
	      "Block $block.\n");
	exit 1;
    } else {
	print("info: changeparam(): $desc\n",
	      "      changed entry $entry in Block $block to ",
	      "value $val.\n");
    }
    close(FILEIN);
    close(FILEOUT);
    unlink("$file.bak");
}

#- }}}
#- {{{ sub diff:

sub diff {
#
# diff([@ARRAY1],[@ARRAY2]) returns the difference of @ARRAY1 and @ARRAY2
#
    my(@IN1,@IN2);
    my($i1,$i2,$j1,$j2,$k);
    @IN1 = @{$_[0]};
    @IN2 = @{$_[1]};

    $j1 = 0;
    foreach $i1 (0..$#IN1) {
      LDIFF: foreach $i2 (0..$#IN2) {
          if ("$IN1[$i1-$j1]" eq "$IN2[$i2]") {
              splice(@IN1,$i1-$j1++,1,());
              splice(@IN2,$i2,1,());
              last LDIFF;
          }
      }
    }
    return(@IN1,@IN2);
}

#- }}}







# END OF mapslha.pl