# Library of McStas runtime perl functions
#
#   This file is part of the McStas neutron ray-trace simulation package
#   Copyright (C) 1997-2004, All rights reserved
#   Risoe National Laborartory, Roskilde, Denmark
#   Institut Laue Langevin, Grenoble, France
#
#   This program is free software; you can redistribute it and/or modify
#   it under the terms of the GNU General Public License as published by
#   the Free Software Foundation; either version 2 of the License, or
#   (at your option) any later version.
#
#   This program is distributed in the hope that it will be useful,
#   but WITHOUT ANY WARRANTY; without even the implied warranty of
#   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#   GNU General Public License for more details.
#
#   You should have received a copy of the GNU General Public License
#   along with this program; if not, write to the Free Software
#   Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
#
use Config;
use File::Path;
use File::Basename;
use File::Copy;
use File::stat;
use Cwd;
require "mcstas_config.perl";
require "mcfrontlib.pl";

# get MCSTAS::mcstas_config{'PLOTTER'}
my $plotter=$MCSTAS::mcstas_config{'PLOTTER'};

# Strip any single quotes around argument.
sub strip_quote {
    my ($str) = @_;
    $str = $1 if($str =~ /^'(.*)'$/); # Remove quotes if present.
    return $str;
}

# Get a yes/no argument.
sub get_yes_no {
    my ($str) = @_;
    return ($str =~ /yes/i) ? 1 : 0;
}

# Read output from "sim --info" or "begin instrument" section in mcstas.sim
# from file handle.
# Reads lines from handle until the "end instrument" line is encountered,
# skips that line and returns the information read in a hash reference.
# Also terminates upon end-of-file.
sub read_instrument_info {
    my ($h) = @_;
    my $inf = {};
    $inf->{'RAW'} = [];                # List of lines from output of sim.out --info
    while(<$h>) {
        push @{$inf->{'RAW'}}, $_;
        if(/^\s*Name:\s*([a-zA-Z_0-9]+)\s*$/i) {
            $inf->{'Name'} = $1;
        } elsif(/^\s*Parameters:\s*([a-zA-Z_0-9 \t()]*?)\s*$/i) {
            my $full = $1;
            my $parms = [ ];
            my $parmtypes = { };
            my $p;
            for $p (split ' ', $full) {
                if($p =~ /^([a-zA-Z_0-9+]+)\(([a-z]+)\)$/) {
                    push @$parms, $1;
                    $parmtypes->{$1} = $2;
                } elsif($p =~ /^([a-zA-Z_0-9+]+)$/) {
                    # Backward compatibility: no type specifier.
                    push @$parms, $1;
                    $parmtypes->{$1} = 'double'; # Default is double
                } else {
                    die "mcrun: Invalid parameter specification:\n'$p'";
                }
            }
            $inf->{'Parameters'} = $parms;
            $inf->{'Parameter-types'} = $parmtypes;
        } elsif(/^\s*Instrument-source:\s*(.*?)\s*$/i) {
            $inf->{'Instrument-source'} = strip_quote($1);
        } elsif(/^\s*Source:\s*(.*?)\s*$/i) {
            $inf->{'Instrument-source'} = strip_quote($1);
        } elsif(/^\s*Trace-enabled:\s*(no|yes)\s*$/i) {
            $inf->{'Trace-enabled'} = get_yes_no($1);
        } elsif(/^\s*Trace_enabled:\s*(no|yes)\s*$/i) {
            $inf->{'Trace-enabled'} = get_yes_no($1);
        } elsif(/^\s*Default-main:\s*(no|yes)\s*$/i) {
            $inf->{'Default-main'} = get_yes_no($1);
        } elsif(/^\s*Default_main:\s*(no|yes)\s*$/i) {
            $inf->{'Default-main'} = get_yes_no($1);
        } elsif(/^\s*Embedded-runtime:\s*(no|yes)\s*$/i) {
            $inf->{'Embedded-runtime'} = get_yes_no($1);
        } elsif(/^\s*Embedded_runtime:\s*(no|yes)\s*$/i) {
            $inf->{'Embedded-runtime'} = get_yes_no($1);
        } elsif(/^\s*end\s+instrument\s*$/i) {
            last;
        } else {
            # print "\# $_";
        }
    }
    return $inf;
}

sub get_sim_info {
    my ($simprog) = @_;
    # Needs quoting if this is Win32...
    my $cmdstring="$simprog -i";
    if ($Config{'osname'} eq 'MSWin32') {
      $cmdstring="\"$cmdstring\" ";
    }
    use FileHandle;
    my $h = new FileHandle;
    open $h, "$cmdstring |" or die "mcrun: Could not run simulation.";
    my $inf = read_instrument_info($h);
    my $sinf= read_simulation_info($h);
    close $h;
    $inf->{'Params'} = $sinf->{'Params'};
    return $inf;
}


# Supporting function for get_out_file() below, suitable for use in a
# call-back style GUI application.
#
# Returns two results. The first is a data structure to pass to
# subsequence get_out_file_next() calls; if undefined, the second
# results is an error message.
#
sub get_out_file_init {
    my ($inname, $force) = @_;
    return (undef, "mcrun: No simulation filename given") unless $inname;
    # Add a default extension of ".instr" if given name does not exist
    # as file.
    my $sim_def = $inname;
    $sim_def .= ".instr" if(! (-e $sim_def) && (-e "$sim_def.instr"));
    return(undef, "mcrun: Simulation '$sim_def' not found") unless -e $sim_def;
    my $file_type = MCSTAS;
    my $base_name = $sim_def;
    # Different executable suffixes on Win32 vs. unix
    # PW 20030314
    my $ext;
    $ext=$MCSTAS::mcstas_config{'EXE'};

    if($sim_def =~ /(.*)\.instr$/) {
        $base_name = $1;
    } elsif($sim_def =~ /(.*)\.c$/) {
        $base_name = $1;
        $file_type = C;
    } elsif($sim_def =~ /(.*)\.$ext$/) {
        $base_name = $1;
        $file_type = OUT;
    }
    my $dir;
    if($base_name =~ m'^(.*)/[^/]*$') { # quote hack -> ') {
        $dir = $1;
    }
    my $c_name = "$base_name.c";
    my $out_name = "$base_name.$ext";
    $sim_def = "$base_name.instr" unless $file_type eq MCSTAS;
    my $v = { };
    $v->{'force'} = $force;
    $v->{'file_type'} = $file_type;
    $v->{'dir'} = $dir;
    $v->{'sim_def'} = $sim_def;
    $v->{'c_name'} = $c_name;
    $v->{'out_name'} = $out_name;
    $v->{'sim_age'} = -e $sim_def ? -M $sim_def : undef;
    $v->{'c_age'} = -e $c_name ? -M $c_name : undef;
    $v->{'out_age'} = -e $out_name ? -M $out_name : undef;
    $v->{'stage'} = PRE_MCSTAS;
    return ($v, "");
}

# Supporting function for get_out_file() below, suitable for use in a
# call-back style GUI application.
#
# Takes two args. The first is the data structure returned by
# get_out_file_init(). The second is a function to call to print
# messages.
#
# Returns two results. The first is a status value, describing the
# meaning of the second result value:
#    status    value
#    CONTINUE  undefined   Ok, call again for next stage
#    RUN_CMD   command     Ok, run the command and call again for next stage
#    ERROR     message     An error occured, stop
#    FINISHED  out_name    Compilation has finished, here is .exe name
#
# In RUN_CMD, the "command" is a ref to a list for execvl(). The other
# values are strings. This function should be called repeatedly until
# either ERROR or FINISHED is returned.
#
sub get_out_file_next {
  my ($v, $printer) = @_;
  my ($cmd, $exit_val);
  my $force = $v->{'force'};
  my $file_type = $v->{'file_type'};
  my $sim_def = $v->{'sim_def'};
  my $c_name = $v->{'c_name'};
  my $out_name = $v->{'out_name'};
  my $sim_age = $v->{'sim_age'};
  my $c_age = $v->{'c_age'};
  my $out_age = $v->{'out_age'};
  my $stage = $v->{'stage'};
  if($stage eq PRE_MCSTAS) {
    # Translate simulation definition into C if newer than existing C
    # version.
    if($file_type eq C && (defined($sim_age) && $sim_age < $c_age)) {
        &$printer("Warning: simulation definition '$sim_def'" .
                  " is newer than '$c_name'");
    }
    if($file_type eq OUT && (defined($sim_age) && $sim_age < $out_age)) {
        &$printer("Warning: simulation definition '$sim_def'" .
                  " is newer than '$out_name'");
    }
    if($file_type eq OUT && (defined($c_age) && $c_age < $out_age)) {
        &$printer("Warning: C source '$c_name'" .
                  " is newer than '$out_name'");
    }
    if($file_type eq MCSTAS &&
       ($force || !defined($c_age) || $c_age > $sim_age)) {
        &$printer("Translating instrument definition '$sim_def'" .
                  " into C ...");
      # On Win32, quote the filenames...
      my $dir=$v->{'dir'};
      if ($Config{'osname'} eq 'MSWin32') {
        $c_name="\"$c_name\"";
        $sim_def="\"$sim_def\"";
        if (defined($dir)) { $dir="\"$dir\""; }
      }
      my @inc = $v->{'dir'} ? ("-I", $dir) : ();
      my $cmd = ["mcstas", @inc, "-t", "-o", $c_name, $sim_def];
      &$printer(join(" ", @$cmd));
      $v->{'stage'} = POST_MCSTAS;
      return (RUN_CMD, $cmd);
    } else {
      $v->{'stage'} = PRE_CC;
      return (CONTINUE, undef);
    }
  } elsif($stage eq POST_MCSTAS) {
    $v->{'c_age'} = -M $c_name;
    $v->{'out_age'} = undef; # Force recompilation.
    $v->{'stage'} = PRE_CC;
    return (CONTINUE, undef);
  } elsif($stage eq PRE_CC) {
    unless(-e $c_name) {
        return (ERROR, "Could not translate simulation '$sim_def' into C");
    }
    # Compile C source if newer than existing out file.
    if(($file_type eq MCSTAS || $file_type eq C) &&
       ($force || !defined($out_age) || $out_age > $c_age)) {
      &$printer("Compiling C source '$c_name' ...");
      # ToDo: splitting CFLAGS should handle shell quoting as well ...
      my $cc     = $MCSTAS::mcstas_config{CC};
      my $cflags = $MCSTAS::mcstas_config{CFLAGS};
      # Needs quoting on MSWin32:
      if ($Config{'osname'} eq 'MSWin32') {
        $out_name="\"$out_name\"";
        $c_name="\"$c_name\"";
      }
      my $cmd = [$cc, split(' ', $cflags), "-o",
                 $out_name, $c_name, "-lm"];
      &$printer(join(" ", @$cmd));
      $v->{'stage'} = POST_CC;
      return (RUN_CMD, $cmd);
    } else {
      $v->{'stage'} = FINISHED;
      return (FINISHED, $out_name);
    }
  } elsif($stage eq POST_CC) {
    unless(-e $out_name) {
        return (ERROR, "Could not compile C source file '$c_name'");
    }
    $v->{'stage'} = FINISHED;
    return (FINISHED, $out_name);
  } else {
    die "mcrun: Internal: get_out_file_next: $stage";
  }
}

#
# Get the name of the executable file for the simulation, translating
# and compiling the instrument definition if necessary.
#
# The optional $force option, if true, forces unconditional recompilation.
#
sub get_out_file {
    my ($inname, $force) = @_;
    my ($v, $msg, $status, $value);
    ($v, $msg) = get_out_file_init($inname, $force);
    unless($v) {
        print STDERR "$msg\n";
        return undef;
    }
    for(;;) {
        ($status, $value) = get_out_file_next($v, sub { print "$_[0]\n"; });
        if($status eq FINISHED) {
            return $value;
        } elsif($status eq RUN_CMD) {
            my $exit_val = system(@$value);
            if($exit_val) {
                print STDERR "** Error exit **\n";
                return undef;
            }
            next;
        } elsif($status eq ERROR) {
            print STDERR "$value\n";
            return undef;
        } elsif(!($status eq CONTINUE)) {
            die "mcrun: Internal: get_out_file";
        }
    }
}

# McStas selftest procedure: copy LIB/examples and execute
sub do_test {
  my ($printer,$force, $plotter, $exec_test) = @_;
  my $j;
  my $pwd=getcwd;

  &$printer( "# McStas self-test (mcrun --test='$exec_test')");
  &$printer(`mcstas --version`);
  &$printer("# Installing 'selftest' directory in $pwd");
  if (-d "selftest") # directory already exists
  { if ($force) { eval { rmtree('selftest',0,1); } }
    else {
      return "mcrun: Directory 'selftest' already exists.\n       Use '-c' or '--force' option to overwrite.\n";
    }
  }
  # create selftest direcory
  eval { mkpath('selftest') };
  if ($@) {
    return "mcrun: Couldn't create 'selftest': $@\n";
  }
  # copy all instruments
  &$printer("# Copying instruments from $MCSTAS::sys_dir/examples/");
  if (opendir(DIR,"$MCSTAS::sys_dir/examples/")) {
    my @instruments = readdir(DIR);
    closedir(DIR);
    next unless @instruments;
    my @paths = map("$MCSTAS::sys_dir/examples/$_", grep(/\.(instr)$/, @instruments));
    for ($j=0 ; $j<@paths; $j++) {
      my ($base, $dirname, $suffix) = fileparse($paths[$j],".instr");
      if (! copy("$paths[$j]","./selftest/$base$suffix")) {
        return "Could not copy $paths[$j] to 'selftest' directory: $!\n";
      }
    }
  } else { return "mcrun: no test instruments found. Aborting.\n"; }
  # go into the selftest directory
  chdir("selftest") or return "mcrun: Can get into selftest: $!\n";
  # Initialize test
  my $n_single=1e5;
  my $n_scan=1e4;
  my $now = localtime;
  my $start_sec = time();
  &$printer("# Counts: single=$n_single, scans=$n_scan");
  &$printer("# Output format: $plotter");
  &$printer("# Start Date: $now");
  my @test_names;
  my @test_commands;
  my @test_monitor_names;
  my @test_monitor_values;
  my $suffix='';
  $suffix=$MCSTAS::mcstas_config{'SUFFIX'};
  $prefix=$MCSTAS::mcstas_config{'PREFIX'};
  $ENV{'MCSTAS_FORMAT'} = $plotter;

  # compatible test definition
  if ($exec_test =~ /compatible/i) {
  @test_names   = ("ISIS prisma2: in focusing mode",
      "ISIS prisma2: in non-focusing mode",
      "vanadium_example: vanadium scattering anisotropy",
      "Brookhaven H8: Thermal TAS with vanadium sample",
      "Risoe TAS1: monochromator rocking curve (no collimator)",
      "Risoe TAS1: monochromator rocking curve (with 30 minutes collimator)",
      "Risoe TAS1: collimator C1 tilt",
      "Risoe TAS1: monochromator rotation (PHM aka A1) with C1 tilted by OMC1=-2 deg",
      "Risoe TAS1: monochromator rotation (PHM aka A1) with C1 tilted by OMC1=-5 deg",
      "Risoe TAS1: monochromator rotation (PHM aka A1) with C1 tilted by OMC1=-6 deg",
      "Risoe TAS1: monochromator rotation (PHM aka A1) with C1 tilted by OMC1=-10 deg",
      "Risoe TAS1: sample take-off angle (TT aka A4) scan with 3 collimators. Slit sample",
      "Risoe TAS1: analyzer arm alignment (TTA aka A6). No detector collimation C3. Vanadium sample",
      "Risoe TAS1: analyzer arm alignment (TTA aka A6). 30 minutes detector collimation C3. Vanadium sample",
      "Risoe TAS1: sample two-theta (TT aka A4). positive side . Powder sample",
      "Risoe TAS1: sample two-theta (TT aka A4). negative side . Powder sample",
      "Risoe TAS1: Triple axis mode. Analyzer rocking curve (OMA aka A5). Vanadium sample",
      "Risoe TAS1: Triple axis mode. Sample take-off (TT aka A4). Powder sample",);
  @test_commands= ("mcrun$suffix --dir=prisma2a prisma2.instr --ncount=$n_single TT=-30 PHA=22 PHA1=-3 PHA2=-2 PHA3=-1 PHA4=0 PHA5=1 PHA6=2 PHA7=3 TTA=44",
      "mcrun$suffix --dir=prisma2b prisma2.instr --ncount=$n_single TT=-30 PHA=22 PHA1=3 PHA2=2 PHA3=1 PHA4=0 PHA5=-1 PHA6=-2 PHA7=-3 TTA=44",
      "mcrun$suffix --dir=V_test vanadium_example.instr --ncount=$n_single ROT=0",
      "mcrun$suffix -n $n_single --dir=h8_test  h8_test.instr Lambda=2.359",
      "mcrun$suffix --numpoints=41 -n $n_scan --dir=linup_1_45 linup-1.instr PHM=-39,-35 TTM=-74 C1=0",
      "mcrun$suffix --numpoints=41 -n $n_scan --dir=linup_2_45 linup-1.instr PHM=-39,-35 TTM=-74 C1=30",
      "mcrun$suffix --numpoints=41 -n $n_scan --dir=linup_3_45 linup-2.instr PHM=-37.077 TTM=-74 C1=30 OMC1=-50,50",
      "mcrun$suffix --numpoints=41 -n $n_scan --dir=linup_4_45 linup-2.instr PHM=-39,-35 TTM=-74 C1=30 OMC1=-1.81715",
      "mcrun$suffix --numpoints=31 -n $n_scan --dir=linup_5_m5 linup-2.instr PHM=-38.5,-35.5 TTM=-74 C1=30 OMC1=-5",
      "mcrun$suffix --numpoints=31 -n $n_scan --dir=linup_5_m6 linup-2.instr PHM=-38.5,-35.5 TTM=-74 C1=30 OMC1=-6",
      "mcrun$suffix --numpoints=31 -n $n_scan --dir=linup_5_m10 linup-2.instr PHM=-38.5,-35.5 TTM=-74 C1=30 OMC1=-10",
      "mcrun$suffix --numpoints=41 -n $n_scan --dir=linup_6_0 linup-3.instr PHM=-37.077 TTM=-74 TT=-1.5,1.5 C1=30 OMC1=-5.5 C2=0 C3=0",
      "mcrun$suffix --numpoints=41 -n $n_scan --dir=linup_7 linup-4.instr PHM=-37.077 TTM=-74 TT=33.52 TTA=-3,3 C1=30 OMC1=-5.5 C2=28 C3=0",
      "mcrun$suffix --numpoints=41 -n $n_scan --dir=linup_8 linup-4.instr PHM=-37.077 TTM=-74 TT=33.52 TTA=-3,3 C1=30 OMC1=-5.5 C2=28 C3=67",
      "mcrun$suffix --numpoints=41 -n $n_scan --dir=linup_9 linup-5.instr PHM=-37.077 TTM=-74 TT=32,35 TTA=0 C1=30 OMC1=-5.5 C2=28 C3=67",
      "mcrun$suffix --numpoints=41 -n $n_scan --dir=linup_10 linup-5.instr PHM=-37.077 TTM=-74 TT=-32,-35 TTA=0 C1=30 OMC1=-5.5 C2=28 C3=67",
      "mcrun$suffix --numpoints=21 -n $n_scan --dir=linup_11 linup-6.instr PHM=-37.077 TTM=-74 TT=33.57 OMA=-16.44,-18.44 TTA=-34.883 C1=30 OMC1=-5.5 C2=28 C3=67",
      "mcrun$suffix --numpoints=21 -n $n_scan --dir=linup_13 linup-7.instr PHM=-37.077 TTM=-74 TT=32.5,34.5 OMA=-17.45 TTA=-34.9 C1=30 OMC1=-5.5 C2=28 C3=67");
  @test_monitor_names =("mon9_I","mon9_I","PSD_4pi_I","D7_SC3_In_I","","","","","","","","","","","","","","");
  @test_monitor_values=(6.2e-08,4.2e-08,2.1e-06,3.11e-11,0,0,0,0,0,0,0,0,0,0,0,0,0,0);
  } # end of compatible test definition
  # now execute each simulation and look for errors
  my $error_flag    = 0;
  my $accuracy_flag = 0;
  my $plot_flag     = 0;
  my $total_diff    = 0;
  for ($j=0 ; $j<@test_commands ; $j++) {
    my $this_cmd =$test_commands[$j];
    my $this_name=$test_names[$j];
    &$printer("Executing: $this_cmd");
    my $res = qx/$this_cmd/;
    my $child_error_text = $!;
    my $child_error_code = $?;
    if ($child_error_code) {
      &$printer("[FAILED] $this_name: ($child_error_code): $child_error_text");
      $error_flag = 1;
      last;
    } else {
      my $diff = 0;
      my $sim_I= 0;
      my $line;
      #Analyse test output if reference value is available
      if ($test_monitor_values[$j] ne 0) { # there is a reference value...
        # split the output in lines
        for $line (split "\n", $res) {
        # search reference monitor in these lines
          if($line =~ m/Detector: ([^ =]+_I) *= *([^ =]+) ([^ =]+_ERR) *= *([^ =]+) ([^ =]+_N) *= *([^ =]+) *(?:"[^"]+" *)?$/) {
            my $sim_I_name = $1;
            if ($test_monitor_names[$j] eq $sim_I_name) {
              $sim_I = $2;
              $diff = abs($sim_I/$test_monitor_values[$j] -1);
              $total_diff = $total_diff+$diff;
            }
          }
        } # end for
        if ($diff) {
          if ($diff > 0.2) {
            $accuracy_flag = 1;
            $diff = $diff*100;
            &$printer("[FAILED] $this_name ($test_monitor_names[$j] = $sim_I, should be $test_monitor_values[$j])");
          } else { &$printer("[OK] $this_name ($test_monitor_names[$j] accuracy within $diff %)"); }
        }
      } # end if ($test_monitor_values[$j] ne 0)
      if ($diff eq 0) { &$printer("[OK] $this_name (accuracy not checked)"); }
    } # end else
  } # end for
  my $elapsed_sec = time() - $start_sec;

  # now test graphics...
  if ($exec_test =~ /graphics/i) {
    @test_names   = ("Plot of Scan of parameters with Risoe TAS1 monochromator rocking curve (no collimator)",
      "Plot of Single simulation with Brookhaven H8 Termal TAS with vanadium sample");
    @test_commands= ("mcplot$suffix -psc linup_1_45",
      "mcplot$suffix -psc h8_test");
    @test_monitor_names =("linup_1_45","h8_test");
    for ($j=0 ; $j<@test_commands ; $j++) {
      my $this_cmd =$test_commands[$j];
      my $this_name=$test_names[$j];
      &$printer("Executing: $this_cmd");
      my $res = qx/$this_cmd/;
      my $child_error_text = $!;
      my $child_error_code = $?;
      if ($child_error_code) {
        &$printer("[Warning] $this_name: ($child_error_code): $child_error_text");
      }
      my $this_flag = 1;
      if (opendir(DIR, "$test_monitor_names[$j]")) {
        my @files = readdir(DIR);
        closedir(DIR);
        my $k;
        my $filename;
        my @paths = map("$test_monitor_names[$j]/$_", grep(/\.(gif|png|ps|eps|jpg)$/i, @files));
        for ($k=0 ; $k<@paths; $k++) {
          $filename = $paths[$k];
          $this_flag = 1;
          if (-f "$filename") {
            my $sb = stat($filename);
            if ($sb->size) {
              &$printer("[OK] $this_name ($filename)");
              $this_flag = 0;
            } else {
              &$printer("[Warning] $this_name ($filename) exists but is empty");
              $this_flag = 0;
            }
          } # end if (-f "$filename")
        } # end for
      } # end opendir
      if ($this_flag) { &$printer("[FAILED] $this_name"); $plot_flag=1; }
    } # end for
  } # end of graphics test

  $now = localtime();
  if ($error_flag) {
    &$printer("# Installation check: FAILED. McStas has not been properly installed.");
    &$printer("# >> Check that you have a C compiler, perl, and perl-Tk installed.");
  } else {
    &$printer("# Installation check: OK.     Computing time: $elapsed_sec [sec].");
    if ($accuracy_flag) {
      &$printer("# Accuracy     check: FAILED. Results are not reliable.");
      &$printer("# >> This McStas installation does NOT produce accurate results.");
    } else {
      &$printer("# Accuracy     check: OK.");
    }
    if ($exec_test =~ /graphics/i) {
      if ($plot_flag) {
        &$printer("# Plotter      check: FAILED.");
        &$printer("# >> The $plotter plotter may NOT be working properly.");
        &$printer("# >> Check that you have Scilab/Matlab/PGPLOT installed");
        &$printer("# >>    and that your Display is available.");
      } else {
        &$printer("# Plotter      check: OK.     Using Plotter $plotter.");
      }
    } else {
      &$printer("# Plotter NOT  checked ($plotter).");
    }
  }

  &$printer("# End Date: $now");
  chdir($pwd) or return "mcrun: Can not come back to $pwd: $!\n";; # come back to initial directory
  return undef;
}

# return the component name given the file name for the definition.
sub compname {
    my ($path) = @_;
    my $name = $path;
    my $i;
    if($i = rindex($name, "/")) {
        $name = substr($name, $i + 1);
    }
    if($name =~ /^(.+)\.(comp|cmp|com)$/) {
        $name = $1;
    }
    return $name;
}

# Parse comment header in McDoc format in component definition.
# Return a data structure containing the gathered information.
sub parse_header {
    my ($f) = @_;
    my $d;
    my ($i,$where, $thisparm);

    $where = "";
    $d->{'identification'} = { 'author' => "(Unknown)",
                               'origin' => "(Unknown)",
                               'date' => "(Unknown)",
                               'version' => "(Unknown)",
                               'history' => [ ],
                               'short'  => ""
                           };
    $d->{'description'} = undef;
    $d->{'parhelp'} = { };
    $d->{'links'} = [ ];
    $d->{'site'}="";
    while(<$f>) {
        if(/\%INSTRUMENT_SITE:(.*)$/i) {
            $d->{'site'}=$1;
        } elsif(/\%I[a-z]*/i && not /\%include/i) {
            $where = "identification";
        } elsif(/\%D[a-z]*/i) {
            $where = "description";
        } elsif(/\%P[a-z]*/i) {
            $where = "parameters";
            undef $thisparm;
        } elsif(/\%L[a-z]*/i) {
            $where = "links";
            push @{$d->{'links'}}, "";
        } elsif(/\%E[a-z]*/i) {
            last;
        } else {
            s/^[ ]?\*[ ]?//;
            if($where eq "identification") {
                if(/(Written by|Author):(.*)$/i) {
                    $d->{'identification'}{'author'} = $2;
                }elsif(/Origin:(.*)$/i) {
                    $d->{'identification'}{'origin'} = $1;
                }elsif(/Date:(.*)$/i) {
                    $d->{'identification'}{'date'} = $1;
                }elsif(/Release:(.*)$/i) {
                    $d->{'identification'}{'release'} = $1;
                }elsif(/Version:(.*)$/i) {
                    my $verstring = $1;
                    # Special case for RCS style $[R]evision: 1.2 $ tags.
                    # Note the need for [R] to avoid RCS keyword expansion
                    # in the mcdoc source code!
                    if($verstring =~ /^(.*)\$[R]evision: (.*)\$(.*)$/) {
                        $d->{'identification'}{'version'} = "$1$2$3";
                    } else {
                        $d->{'identification'}{'version'} = $verstring;
                    }
                }elsif(/Modified by:(.*)$/i) {
                    push @{$d->{'identification'}{'history'}}, $1;
                } else {
                    $d->{'identification'}{'short'} .= $_
                        unless /^\s*$/;
                }
            } elsif($where eq "description") {
                $d->{'description'} .= $_;
            } elsif($where eq "parameters") {
                if(/^[ \t]*([a-zA-Z0-9_]+)\s*:(.*)/) {
                    $thisparm = \$d->{'parhelp'}{$1}{'full'};
                    $$thisparm = "$2\n";
                } elsif(/^[ \t]*$/) { # Empty line
                    undef $thisparm;
                } elsif($thisparm && /^(  | *\t)[ \t]*(.*)/) {
                    # Continuation line needs at least two additional
                    # indentations
                    $$thisparm .= "$2\n";
                } elsif(/^[ \t]*([a-zA-Z0-9_]+)\s*(.*)/) {
                    $thisparm = \$d->{'parhelp'}{$1}{'full'};
                    $$thisparm = "$2\n";
                } else {
                    # Skip it
                }
            } elsif($where eq "links") {
                $d->{'links'}[-1] .= $_;
            } else {
                # Skip.
            }
        }
    }
    # Now search for unit specifications in the parameter information.
    # This is a bit tricky due to various formats used in the old
    # components. The preferred format is a specification of the unit
    # in square brackets "[..]", either first or last in the short
    # description. Specification using parenthesis "(..)" is also
    # supported for backwards compatibility only, but only one set of
    # nested parenthesis is supported.
    for $i (keys %{$d->{'parhelp'}}) {
        my $s = $d->{'parhelp'}{$i}{'full'};
        my ($unit, $text);
        if($s =~ /^\s*\(([^()\n]*(\([^()\n]*\))?[^()\n]*)\)\s*((.|\n)*)\s*$/){
            $unit = $1;
            $text = $3;
        } elsif($s =~ /^\s*((.|\n)*)\s*\(([^()\n]*(\([^()\n]*\))?[^()\n]*)\)\s*$/){
            $unit = $3;
            $text = $1;
        } elsif($s =~ /^\s*\[([^][\n]*)\]\s*((.|\n)*)\s*$/){
            $unit = $1;
            $text = $2;
        } elsif($s =~ /^\s*((.|\n)*)\s*\[([^][\n]*)\]\s*$/){
            $unit = $3;
            $text = $1;
        } else {
            # No unit. Just strip leading and trailing white space.
            $unit = "-";
            if($s =~ /^\s*((.|\n)*\S)\s*$/) {
                $text = $1;
            } else {
                $s =~ /^\s*$/ || die "mcrun: Internal: parse_header match 1";
                $text = "$s";
            }
        }
        $d->{'parhelp'}{$i}{'unit'} = $unit;
        $d->{'parhelp'}{$i}{'text'} = $text;
    }
    return $d;
}

# This sub gets component information by parsing the McStas
# metalanguage. For now this is a regexp hack, later the real mcstas
# parser will be used.
sub get_comp_info {
    my ($name, $d) = @_;
    my $file = new FileHandle;
    my ($cname, $decl, $init, $trace, $finally, $disp, $typ);
    my (@dpar, @spar, @ipar, @opar);
    open($file, $name)  || die "mcrun: Could not open file $name\n";
    local $/ = undef;                # Read the whole file in one go.
    my $s = <$file>;
    close($file);
    $typ = "Component";
    @opar = (); @dpar = (); @spar = ();
    if ($s =~ m!DEFINE\s+INSTRUMENT\s+([a-zA-Z0-9_]+)\s*\(([-+.a-zA-Z0-9_ \t\n\r=,/*]*)\)!i) {
        $cname = $1;
        $typ   = "Instrument";
        foreach (split(",", $2)) {
            if(/^\s*([a-zA-Z0-9_\s\*]+)\s*\=\s*([-+.e0-9]+)\s*$/) {
                my $p = $1;
                my @p_splitted = split(" ", $p);
                my $length = scalar @p_splitted;
                my $p_last_word = $p_splitted[$length-1];
                push @spar, $p_last_word;
                $d->{'parhelp'}{$p_last_word}{'default'} = $2;
            } elsif(/^\s*([a-zA-Z0-9_]+)\s*$/) {
                my $p = $1;
                my @p_splitted = split(" ", $p);
                my $length = scalar @p_splitted;
                my $p_last_word = $p_splitted[$length-1];
                push @spar, $p_last_word;
            } else {
                print STDERR "Warning: Unrecognized PARAMETER in instrument $cname: $1 from $s\n";
            }
        }
        if ($s =~ /DEFINE\s+COMPONENT\s+([a-zA-Z0-9_]+)/i)
        { push @opar, "$1"; $d->{'parhelp'}{$1}{'default'} = "This instrument contains embedded components"; }
    } elsif ($s =~ /DEFINE\s+COMPONENT\s+([a-zA-Z0-9_]+)/i) {
        $cname = $1;
        if($s =~ m!DEFINITION\s+PARAMETERS\s*\(([-+.a-zA-Z0-9_ \t\n\r=,/*{}\"]+)\)!i && $typ ne "Instrument") {
            foreach (split(",", $1)) {
                if(/^\s*([a-zA-Z0-9_]+)\s*\=\s*([-+.e0-9]+)\s*$/) { # name=numerical_value
                    my $p = $1;
                    my @p_splitted = split(" ", $p);
                    my $length = scalar @p_splitted;
                    my $p_last_word = $p_splitted[$length-1];
                    push @dpar, $p_last_word;
                    $d->{'parhelp'}{$p_last_word}{'default'} = $2;
                } elsif(/^\s*([a-zA-Z0-9_]+)\s*\=\s*(.*)\s*$/) { # name=other define
                    my $p = $1;
                    my @p_splitted = split(" ", $p);
                    my $length = scalar @p_splitted;
                    my $p_last_word = $p_splitted[$length-1];
                    push @dpar, $p_last_word;
                    $d->{'parhelp'}{$p_last_word}{'default'} = $2;
                } elsif(/^\s*([a-zA-Z0-9_]+)\s*$/) {                # name
                    my $p = $1;
                    my @p_splitted = split(" ", $p);
                    my $length = scalar @p_splitted;
                    my $p_last_word = $p_splitted[$length-1];
                    push @dpar, $p_last_word;
                } else {
                    print STDERR "Warning: Unrecognized DEFINITION PARAMETER in component $cname: $1 from $s\n";
                }
            }
        }
        if($s =~ m!SETTING\s+PARAMETERS\s*\(([-+.a-zA-Z0-9_ \t\n\r=,/*]+)\)!i && $typ ne "Instrument") {
            foreach (split(",", $1)) {
                if(/^\s*([a-zA-Z0-9_\s\*]+)\s*\=\s*([-+.e0-9]+)\s*$/) { # name=numerical_value
                    my $p = $1;
                    my @p_splitted = split(" ", $p);
                    my $length = scalar @p_splitted;
                    my $p_last_word = $p_splitted[$length-1];
                    push @spar, $p_last_word;
                    $d->{'parhelp'}{$p_last_word}{'default'} = $2;
                } elsif(/^\s*([a-zA-Z0-9_\s\*]+)\s*\=\s*([-+.e0-9]+)\s*$/) { # name=numerical_value
                    my $p = $1;
                    my @p_splitted = split(" ", $p);
                    my $length = scalar @p_splitted;
                    my $p_last_word = $p_splitted[$length-1];
                    push @spar, $p_last_word;
                    my $p_first_word = $p_splitted[0];
                    if ($p_first_word !~ m/char/ && $p_first_word !~ m/string/) {
                      print STDERR "
Warning: SETTING parameter $1 with default value $2\n
         is not of type char/string. Ignoring default value.\n";
                    } else {
                      $d->{'parhelp'}{$p_last_word}{'default'} = $2;
                    }
                } elsif(/^\s*([a-zA-Z0-9_]+)\s*$/) {                    # name
                    my $p = $1;
                    my @p_splitted = split(" ", $p);
                    my $length = scalar @p_splitted;
                    my $p_last_word = $p_splitted[$length-1];
                    push @spar, $p_last_word;
                } else {
                    print STDERR "Warning: Unrecognized SETTING PARAMETER in component $cname: $1 from $s.\n";
                }
            }
        }
        if($s =~ /OUTPUT\s+PARAMETERS\s*\(([a-zA-Z0-9_, \t\r\n]+)\)/i && $typ ne "Instrument") {
            @opar = split (/\s*,\s*/, $1);
        }
    } else {
        $cname = "<Unknown>";
    }

    @ipar = (@dpar, @spar);

    # DECLARE, INITIALIZE, ... blocks will have to wait for the real parser.
    $d->{'name'} = $cname;
    $d->{'type'} = $typ;
    if ($typ eq "Component") { $d->{'ext'} = "comp"; }
    else { $d->{'ext'} = "instr"; }
    $d->{'inputpar'} = \@ipar;
    $d->{'definitionpar'} = \@dpar;
    $d->{'settingpar'} = \@spar;
    $d->{'outputpar'} = \@opar;
}


# Return component information given filename.
sub component_information {
    my ($comp) = @_;
    my $file = new FileHandle;
    open($file, $comp)  || return undef;
    my $data = parse_header($file);
    close($file);
    return undef unless defined($data);
    get_comp_info($comp, $data);
    return $data;
}

# Open .instr file for component information
# Needed for implementation of 'inspect' feature
# in mcgui.pl
# PW 20030314
sub instrument_information {
    my ($instr) = @_;
    my $file = new FileHandle;
    open($file, $instr) || return undef;
    my @data = parse_instrument($file);
    close($file);
    return @data;
}

# Parse .instr file
sub parse_instrument {
    my ($f) = @_;
    my @d;
    my ($i,$where, $thisparm);
    while(<$f>) {
        if(/^\s*COMPONENT \s*([a-zA-Z0-9_]+)\s=*/) {
      push @d, $1;
        } else  {
  }
    }
    return @d;

}

1;



