1# Library of McStas/McXtrace runtime perl functions
2#
3#   This file is part of the McStas/McXtrace neutron/xray ray-trace simulation package
4#   Copyright (C) 1997-2008, All rights reserved
5#   Risoe National Laborartory, Roskilde, Denmark
6#   Institut Laue Langevin, Grenoble, France
7#
8#   This program is free software; you can redistribute it and/or modify
9#   it under the terms of the GNU General Public License as published by
10#   the Free Software Foundation; version 2 of the License.
11#
12#   This program is distributed in the hope that it will be useful,
13#   but WITHOUT ANY WARRANTY; without even the implied warranty of
14#   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15#   GNU General Public License for more details.
16#
17#   You should have received a copy of the GNU General Public License
18#   along with this program; if not, write to the Free Software
19#   Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
20#
21use Config;
22use File::Path;
23use File::Basename;
24use File::Copy;
25use File::stat;
26use Cwd;
27require "mccode_config.perl";
28
29# Overload with user's personal config
30if ($ENV{"HOME"} && -e $ENV{"HOME"}."/.".$MCSTAS::mcstas_config{'MCCODE'}."/mccode_config.perl") {
31  print "$0: reading local $MCSTAS::mcstas_config{'MCCODE'} configuration from " . $ENV{"HOME"}."/.".$MCSTAS::mcstas_config{'MCCODE'}."/mccode_config.perl\n";
32  require $ENV{"HOME"}."/.".$MCSTAS::mcstas_config{'MCCODE'}."/mccode_config.perl";
33}
34
35require "mcfrontlib.pl";
36
37# get MCSTAS::mcstas_config{'PLOTTER'}
38my $plotter=$MCSTAS::mcstas_config{'PLOTTER'};
39
40# Strip any single quotes around argument.
41sub strip_quote {
42    my ($str) = @_;
43    $str = $1 if($str =~ /^'(.*)'$/); # Remove quotes if present.
44    return $str;
45}
46
47# Get a yes/no argument.
48sub get_yes_no {
49    my ($str) = @_;
50    return ($str =~ /yes/i) ? 1 : 0;
51}
52
53# Read output from "sim --info" or "begin instrument" section in mcstas.sim
54# from file handle.
55# Reads lines from handle until the "end instrument" line is encountered,
56# skips that line and returns the information read in a hash reference.
57# Also terminates upon end-of-file.
58sub read_instrument_info {
59    my ($h) = @_;
60    my $inf = {};
61    $inf->{'RAW'} = [];                # List of lines from output of sim.out --info
62    while(<$h>) {
63        push @{$inf->{'RAW'}}, $_;
64        if(/^\s*Name:\s*([a-zA-Z_0-9]+)\s*$/i) {
65            $inf->{'Name'} = $1;
66        } elsif(/^\s*Parameters:\s*([a-zA-Z_0-9 \t()]*?)\s*$/i) {
67            my $full = $1;
68            my $parms = [ ];
69            my $parmtypes = { };
70            my $p;
71            for $p (split ' ', $full) {
72                if($p =~ /^([a-zA-Z_0-9+]+)\(([a-z]+)\)$/) {
73                    push @$parms, $1;
74                    $parmtypes->{$1} = $2;
75                } elsif($p =~ /^([a-zA-Z_0-9+]+)$/) {
76                    # Backward compatibility: no type specifier.
77                    push @$parms, $1;
78                    $parmtypes->{$1} = 'double'; # Default is double
79                } else {
80                    die "$MCSTAS::mcstas_config{'RUNCMD'}: Invalid parameter specification:\n'$p'";
81                }
82            }
83            $inf->{'Parameters'} = $parms;
84            $inf->{'Parameter-types'} = $parmtypes;
85        } elsif(/^\s*Instrument-source:\s*(.*?)\s*$/i) {
86            $inf->{'Instrument-source'} = strip_quote($1);
87        } elsif(/^\s*Instrument_source:\s*(.*?)\s*$/i) {
88            $inf->{'Instrument-source'} = strip_quote($1);
89        } elsif(/^\s*Source:\s*(.*?)\s*$/i) {
90            $inf->{'Instrument-source'} = strip_quote($1);
91        } elsif(/^\s*Instrument:\s*(.*?)\s*$/i) {
92            $inf->{'Instrument-source'} = strip_quote($1);
93        } elsif(/^\s*Trace-enabled:\s*(no|yes)\s*$/i) {
94            $inf->{'Trace-enabled'} = get_yes_no($1);
95        } elsif(/^\s*Trace_enabled:\s*(no|yes)\s*$/i) {
96            $inf->{'Trace-enabled'} = get_yes_no($1);
97        } elsif(/^\s*Default-main:\s*(no|yes)\s*$/i) {
98            $inf->{'Default-main'} = get_yes_no($1);
99        } elsif(/^\s*Default_main:\s*(no|yes)\s*$/i) {
100            $inf->{'Default-main'} = get_yes_no($1);
101        } elsif(/^\s*Embedded-runtime:\s*(no|yes)\s*$/i) {
102            $inf->{'Embedded-runtime'} = get_yes_no($1);
103        } elsif(/^\s*Embedded_runtime:\s*(no|yes)\s*$/i) {
104            $inf->{'Embedded-runtime'} = get_yes_no($1);
105        } elsif(/^\s*end\s+instrument\s*$/i) {
106            last;
107        } else {
108            # print "\# $_";
109        }
110    }
111    return $inf;
112}
113
114sub get_sim_info {
115    my ($simprog) = @_;
116    # Needs quoting if this is Win32...
117    my $cmdstring="$simprog -i";
118    if ($Config{'osname'} eq 'MSWin32') {
119      $cmdstring="\"$cmdstring\" ";
120    }
121    use FileHandle;
122    my $h = new FileHandle;
123    open $h, "$cmdstring |" or die "$MCSTAS::mcstas_config{'RUNCMD'}: Could not run simulation.";
124    my $inf = read_instrument_info($h);
125    my $sinf= read_simulation_info($h);
126    close $h;
127    $inf->{'Params'} = $sinf->{'Params'};
128    return $inf;
129}
130
131
132# Supporting function for get_out_file() below, suitable for use in a
133# call-back style GUI application.
134#
135# Returns two results. The first is a data structure to pass to
136# subsequence get_out_file_next() calls; if undefined, the second
137# results is an error message.
138#
139sub get_out_file_init {
140    my ($inname, $force, $mpi, $cflags, @ccopts) = @_;
141    return (undef, "$MCSTAS::mcstas_config{'RUNCMD'}: No simulation filename given") unless $inname;
142    # Add a default extension of ".instr" if given name does not exist
143    # as file.
144    my $sim_def = $inname;
145    $sim_def .= ".instr" if(! (-e $sim_def) && (-e "$sim_def.instr"));
146    return(undef, "$MCSTAS::mcstas_config{'RUNCMD'}: Simulation '$sim_def' not found") unless -e $sim_def;
147    my $file_type = MCSTAS;
148    my $base_name = $sim_def;
149    # Different executable suffixes on Win32 vs. unix
150    # PW 20030314
151    my $ext;
152    $ext=$MCSTAS::mcstas_config{'EXE'};
153
154    if($sim_def =~ /(.*)\.instr$/) {
155        $base_name = $1;
156    } elsif($sim_def =~ /(.*)\.c$/) {
157        $base_name = $1;
158        $file_type = C;
159    } elsif($sim_def =~ /(.*)\.$ext$/) {
160        $base_name = $1;
161        $file_type = OUT;
162    }
163    my $dir;
164    if($base_name =~ m'^(.*)/[^/]*$') { # quote hack -> ') {
165        $dir = $1;
166    }
167    my $c_name = "$base_name.c";
168    my $out_name = "$base_name.$ext";
169    $sim_def = "$base_name.instr" unless $file_type eq MCSTAS;
170    my $v = { };
171    $v->{'force'} = $force;
172    $v->{'mpi'} = $mpi;
173    $v->{'cflags'} = $cflags;
174    $v->{'ccopts'} = join(" ",@ccopts);
175    $v->{'file_type'} = $file_type;
176    $v->{'dir'} = $dir;
177    $v->{'sim_def'} = $sim_def;
178    $v->{'c_name'} = $c_name;
179    $v->{'out_name'} = $out_name;
180    $v->{'sim_age'} = -e $sim_def ? -M $sim_def : undef;
181    $v->{'c_age'} = -e $c_name ? -M $c_name : undef;
182    $v->{'out_age'} = -e $out_name ? -M $out_name : undef;
183    $v->{'stage'} = PRE_MCSTAS;
184    $v->{'cc_cmd'} = "";
185    return ($v, "");
186}
187
188# Supporting function for get_out_file() below, suitable for use in a
189# call-back style GUI application.
190#
191# Takes two args. The first is the data structure returned by
192# get_out_file_init(). The second is a function to call to print
193# messages.
194#
195# Returns two results. The first is a status value, describing the
196# meaning of the second result value:
197#    status    value
198#    CONTINUE  undefined   Ok, call again for next stage
199#    RUN_CMD   command     Ok, run the command and call again for next stage
200#    ERROR     message     An error occured, stop
201#    FINISHED  out_name    Compilation has finished, here is .exe name
202#
203# In RUN_CMD, the "command" is a ref to a list for execvl(). The other
204# values are strings. This function should be called repeatedly until
205# either ERROR or FINISHED is returned.
206#
207sub get_out_file_next {
208  my ($v, $printer, $mpi, $mcrunflag) = @_;
209  # The mcrunflag allows mcgui to request a compilation
210  # using mcrun -c (Win32 specific).
211  my ($cmd, $exit_val);
212  my $force = $v->{'force'};
213  my $file_type = $v->{'file_type'};
214  my $sim_def = $v->{'sim_def'};
215  my $c_name = $v->{'c_name'};
216  my $out_name = $v->{'out_name'};
217  my $sim_age = $v->{'sim_age'};
218  my $c_age = $v->{'c_age'};
219  my $out_age = $v->{'out_age'};
220  my $stage = $v->{'stage'};
221  $mpi   = $v->{'mpi'};
222  my $cflags   = $v->{'cflags'};
223  my $ccopts = $v->{'ccopts'};
224  my $cccmd  = $v->{'cc_cmd'};
225  if($stage eq PRE_MCSTAS) {
226    # Translate simulation definition into C if newer than existing C
227    # version.
228    if($file_type eq C && (defined($sim_age) && $sim_age < $c_age)) {
229        &$printer("Warning: simulation definition '$sim_def'" .
230                  " is newer than '$c_name'");
231    }
232    if($file_type eq OUT && (defined($sim_age) && $sim_age < $out_age)) {
233        &$printer("Warning: simulation definition '$sim_def'" .
234                  " is newer than '$out_name'");
235    }
236    if($file_type eq OUT && (defined($c_age) && $c_age < $out_age)) {
237        &$printer("Warning: C source '$c_name'" .
238                  " is newer than '$out_name'");
239    }
240    if($file_type eq MCSTAS &&
241       ($force || !defined($c_age) || $c_age > $sim_age)) {
242        &$printer("Translating instrument definition '$sim_def'" .
243                  " into C ...");
244      # On Win32, quote the filenames if containing spaces...
245      my $dir=$v->{'dir'};
246      if (($Config{'osname'} eq 'MSWin32') && (($c_name =~ /\ /) || ($dir =~ /\ /))) {
247        $c_name="\"$c_name\"";
248        $sim_def="\"$sim_def\"";
249        if (defined($dir)) { $dir="\"$dir\""; }
250      }
251      my @inc = $v->{'dir'} ? ("-I", $dir) : ();
252      if (defined($mcrunflag) && $mcrunflag eq 1) {
253	 my $mpistr;
254	 if ($mpi) {$mpistr="--mpi=1";}
255	 else {$mpistr="";}
256         my $cmd = ["$MCSTAS::mcstas_config{'RUNCMD'} -c $mpistr -n0 ", $sim_def];
257      &$printer(join(" ", @$cmd));
258	$v->{'stage'} = POST_MCSTAS;
259      return (RUN_CMD, $cmd);
260      } else {
261      my $cmd = [$MCSTAS::mcstas_config{'MCCODE'}, @inc, "-t", "-o", $c_name, $sim_def];
262      &$printer(join(" ", @$cmd));
263      $v->{'stage'} = POST_MCSTAS;
264      return (RUN_CMD, $cmd);
265      }
266    } else {
267      $v->{'stage'} = PRE_CC;
268      return (CONTINUE, undef);
269    }
270  } elsif($stage eq POST_MCSTAS) {
271    $v->{'c_age'} = -M $c_name;
272    $v->{'out_age'} = undef; # Force recompilation.
273    $v->{'stage'} = PRE_CC;
274    return (CONTINUE, undef);
275  } elsif($stage eq PRE_CC) {
276    unless(-e $c_name) {
277        return (ERROR, "Could not translate simulation '$sim_def' into C");
278    }
279    # Compile C source if newer than existing out file.
280    # ToDo: splitting CFLAGS should handle shell quoting as well ...
281    my $cc     = $MCSTAS::mcstas_config{CC};
282    my $mcstas_cflags = "";
283    if ($cflags) { $mcstas_cflags = $MCSTAS::mcstas_config{CFLAGS}; }
284    # Check for existing c-dependencies in the generated C-file
285    open(my $fh, "<", $c_name);
286    while (<$fh>) {
287      if (/CFLAGS=(.*)/) {
288	$mcstas_cflags .= " ".$1;
289      }
290      # Replace any @MCCODE_LIB@ by the McStas system path
291      $mcstas_cflags =~ s/\@MCCODE_LIB\@/${MCSTAS::sys_dir}/g;
292    }
293    my $libs = "-lm ";
294    if ($v->{'mpi'} && $MCSTAS::mcstas_config{MPICC} ne "no") {
295      $libs .= " -DUSE_MPI ";
296      $cc      = $MCSTAS::mcstas_config{'MPICC'};
297    }
298    if ($MCSTAS::mcstas_config{'PLOTTER'} =~ /NeXus|HDF/i && $MCSTAS::mcstas_config{'NEXUS'} ne "") {
299      $libs .= $MCSTAS::mcstas_config{'NEXUS'};
300    }
301    # Needs quoting on MSWin32 if containing spaces...
302    if (($Config{'osname'} eq 'MSWin32') && ($out_name =~ /\ /)) {
303      $out_name="\"$out_name\"";
304      $c_name="\"$c_name\"";
305    }
306    if ($ccopts) { $libs .= $ccopts; }
307
308    # assemble compile cmd
309    my $cmd = [];
310    if ($MCSTAS::mcstas_config{'CFLAGS_PLACEMENT'} ne "1") {
311        $cmd = [$cc, split(' ', $mcstas_cflags), "-o",
312                $out_name, $c_name, split(' ', $libs)];
313    } else {
314        $cmd = [$cc, "-o",
315                $out_name, $c_name, split(' ', $libs), split(' ', $mcstas_cflags)];
316    }
317
318    $v->{'cc_cmd'} = join(" ", @$cmd);
319    if(($file_type eq MCSTAS || $file_type eq C) &&
320       ($force || !defined($out_age) || $out_age > $c_age)) {
321      &$printer("Compiling C source '$c_name' ...");
322      &$printer(join(" ", @$cmd));
323      $v->{'stage'} = POST_CC;
324      return (RUN_CMD, $cmd);
325    } else {
326      $v->{'stage'} = FINISHED;
327      return (FINISHED, $out_name);
328    }
329  } elsif($stage eq POST_CC) {
330    unless(-e $out_name) {
331        return (ERROR, "Could not compile C source file '$c_name'");
332    }
333    $v->{'stage'} = FINISHED;
334    return (FINISHED, $out_name);
335  } else {
336    die "$MCSTAS::mcstas_config{'RUNCMD'}: Internal: get_out_file_next: $stage";
337  }
338}
339
340#
341# Get the name of the executable file for the simulation, translating
342# and compiling the instrument definition if necessary.
343#
344# The optional $force option, if true, forces unconditional recompilation.
345#
346sub get_out_file {
347    my ($inname, $force, $mpi, $cflags, @ccopts) = @_;
348    my ($v, $msg, $status, $value);
349    ($v, $msg) = get_out_file_init($inname, $force, $mpi, $cflags, @ccopts);
350    unless($v) {
351        print STDERR "$msg\n";
352        return undef;
353    }
354    for(;;) {
355        ($status, $value) = get_out_file_next($v, sub { print "$_[0]\n"; });
356        if($status eq FINISHED) {
357            return ($value,$v);
358        } elsif($status eq RUN_CMD) {
359            my $exit_val = system(@$value);
360            if($exit_val) {
361                print STDERR "** Error exit **\n";
362                return (undef,$v);
363            }
364            next;
365        } elsif($status eq ERROR) {
366            print STDERR "$value\n";
367            return (undef,$v);
368        } elsif(!($status eq CONTINUE)) {
369            die "$MCSTAS::mcstas_config{'RUNCMD'}: Internal: get_out_file";
370        }
371    }
372}
373
374# McStas/McXtrace selftest procedure: copy LIB/examples and execute
375sub do_test {
376  my ($printer,$force, $plotter, $exec_test, $cflags, $mpi, $ncount, $sim_def) = @_;
377  my $pwd=getcwd;
378
379  &$printer( "# $MCSTAS::mcstas_config{'MCCODE'} self-test ($MCSTAS::mcstas_config{'RUNCMD'} --test)");
380  if ($mpi) {
381      &$printer("# MPI enabled, spawning $mpi compute nodes");
382  }
383  &$printer(`$MCSTAS::mcstas_config{'MCCODE'} --version`);
384  # create selftest direcory
385  require File::Temp; # for tempdir
386  $tmpdir = File::Temp::tempdir( 'selftest_XXXX' ) || return "$MCSTAS::mcstas_config{'RUNCMD'}: Couldn't create 'selftest': $@\n";
387  &$printer("# Installing '$tmpdir' directory in $pwd");
388  # copy all instruments
389  my @paths=();
390  if ($sim_def && $sim_def !~ m'\.[^/]*$') { $sim_def .= ".instr"; }
391  if ($sim_def && -e $sim_def) {    # local instrument to test
392    &$printer("# Using instrument $sim_def");
393    push @paths, "$sim_def";
394    copy("$sim_def","$tmpdir/$sim_def");
395  } else {
396    &$printer("# Copying instruments from $MCSTAS::sys_dir/examples/");
397    if (opendir(DIR,"$MCSTAS::sys_dir/examples/")) {
398      my @instruments = readdir(DIR);
399      closedir(DIR);
400      next unless @instruments;
401      my @paths_loc = ();
402      @paths_loc = map("$MCSTAS::sys_dir/examples/$_", grep(/\.(instr)$/, @instruments));
403      for ($j=0 ; $j<@paths_loc; $j++) {
404        my ($base, $dirname, $ext) = fileparse($paths_loc[$j],".instr");
405        next if ($sim_def && $sim_def !~ $base);
406        if (! copy("$paths_loc[$j]","$tmpdir/$base$ext")) {
407          return "Could not copy $paths_loc[$j] to '$tmpdir' directory: $!\n";
408        } else {
409          push @paths, $paths_loc[$j];
410        }
411      }
412    }
413  }
414  if (!@paths) { return "$MCSTAS::mcstas_config{'RUNCMD'}: no test instruments found. Aborting.\n"; }
415  # go into the selftest directory
416  chdir($tmpdir) or return "$MCSTAS::mcstas_config{'RUNCMD'}: Can not go into $tmpdir: $!\n";
417
418  # Initialize test
419  my $now = localtime;
420  my $start_sec = time();
421  my $n_single;
422  if (!$ncount) {$n_single=1000000;}
423  else {$n_single=int($ncount);}
424  &$printer("# Counts:        $n_single");
425  &$printer("# Output format: $plotter");
426  &$printer("# Start Date:    $now");
427  my $suffix=$MCSTAS::mcstas_config{'SUFFIX'};
428  my $prefix=$MCSTAS::mcstas_config{'PREFIX'};
429  $ENV{'MCSTAS_FORMAT'} = $plotter;
430  if ($mpi) { $mpi=" --mpi=$mpi"; }
431
432  # now execute each simulation and look for errors
433  my $error_flag    = 0;
434  my $accuracy_flag = 0;
435  my $j;
436  my $index=0;
437  my $test_abstract="Test Abstract for $tmpdir\n";
438  for ($j=0 ; $j<@paths ; $j++) {  # loop on instruments
439    my $data=component_information($paths[$j]);     # read instrument header and extract info
440    my @val_par=@{$data->{'validation_par'}};
441    my @val_det=@{$data->{'validation_det'}};
442    my @val_val=@{$data->{'validation_val'}};
443    my ($base, $dirname, $ext) = fileparse($paths[$j],".instr");
444    my $k;
445    if (!@val_par) {
446    	&$printer("Instrument without test: $base");
447	# No reason to use cflags on instruments without test condition
448    	my $this_cmd = "$MCSTAS::mcstas_config{'RUNCMD'} -c -n0 --no-cflags $base";
449    	&$printer("Executing: $this_cmd");
450    	my $res = qx/$this_cmd/;
451    	if ($child_error_code) {
452    	  &$printer("[FAILED] $base: ($child_error_code): $child_error_text");
453        $test_abstract .= "[FAILED] $base". "_$index (compilation/execution)\n";
454        $error_flag++;
455      } else {
456    		$test_abstract .= "[notest] $base (no test procedure)\n";
457    	}
458    }
459    for ($k=0; $k<@val_par; $k++) { # loop on tests
460      if ($k == 0) { &$printer("INSTRUMENT $base:\n  $data->{'identification'}{'short'}"); }
461      my $this_cmd =$val_par[$k];
462      $index++;
463      # check command
464      if ($this_cmd !~ m/$base/) { $this_cmd = "$base $this_cmd"; } # only parameters ?
465      if ($this_cmd !~ m/$MCSTAS::mcstas_config{'RUNCMD'}/ && $this_cmd !~ m/$MCSTAS::mcstas_config{'PLOTCMD'}/ && $this_cmd !~ m/$MCSTAS::mcstas_config{'TRACECMD'}/)
466                                 { $this_cmd = "$MCSTAS::mcstas_config{'RUNCMD'} $this_cmd"; } # omitted $MCSTAS::mcstas_config{'RUNCMD'} ?
467      if ($this_cmd !~ m/mpi/ && $mpi) { $this_cmd .= $mpi; }              # add mpi
468      if ($this_cmd !~ m/-n/ && $this_cmd !~ m/--ncount/) { $this_cmd.= " -n $n_single"; }
469      if ($this_cmd !~ m/--format/) { $this_cmd.= " --format=$plotter"; }
470      if ($this_cmd !~ m/-d/ && $this_cmd !~ m/--dir/) { $this_cmd.= " -d $base" . "_$index"; }
471
472
473      if ($cflags==0) { $this_cmd .= " --no-cflags"; }
474
475      &$printer("Executing: $this_cmd");
476      my $res = qx/$this_cmd/;
477      my $child_error_text = $!;
478      my $child_error_code = $?;
479      if ($child_error_code) {
480        &$printer("[FAILED] $base: ($child_error_code): $child_error_text");
481        $test_abstract .= "[FAILED] $base". "_$index (compilation/execution)\n";
482        $error_flag++;
483        last; # go to next instrument (exit for $k)
484      } else {
485        #Analyse test output if reference value is available
486        if ($val_val[$k] ne 0) { # there is a reference value...
487          # split the output in lines
488          my $line;
489          my $sim_I= 0;
490          my $sim_E= 0;
491          for $line (split "\n", $res) {
492            # search reference monitor in these lines
493            if($line =~ m/Detector: ([^ =]+_I) *= *([^ =]+) ([^ =]+_ERR) *= *([^ =]+) ([^ =]+_N) *= *([^ =]+) *(?:"[^"]+" *)?$/) {
494              my $sim_I_name = $1;
495              if ($val_det[$k] eq $sim_I_name) {
496                $sim_I = $2;
497                $sim_E = abs($4);
498              }
499            }
500          } # end for $line
501          if ($sim_E) { # found monitor for this test, either below 1 % or within Error bar
502            my $diff = int(abs($sim_I/$val_val[$k]-1)*100+0.99);
503            if (abs($sim_I/$sim_E) < 2) { # error is higher than half signal: stats too low
504              &$printer("[OK] $base: $val_det[$k] = $sim_I +/- $sim_E (statistics too low for testing, increase ncount)");
505              $test_abstract .= "[OK]     $base". "_$index (statistics too low for testing, increase ncount)\n";
506            } elsif (abs($val_val[$k]-$sim_I) < abs($val_val[$k]*0.05) || abs($val_val[$k]-$sim_I) < 3*$sim_E)  {
507              &$printer("[OK] $base: $val_det[$k] = $sim_I +/- $sim_E, equals $val_val[$k] within $diff \%");
508              $test_abstract .= "[OK]     $base". "_$index (accuracy, $diff \%)\n";
509            } elsif (abs($val_val[$k]-$sim_I) < abs($val_val[$k]*0.2))  {
510              &$printer("[OK] $base: $val_det[$k] = $sim_I +/- $sim_E, equals $val_val[$k] within $diff \%");
511              $test_abstract .= "[OK]     $base". "_$index (accuracy, fair $diff \%)\n";
512            } else {
513              $accuracy_flag++;
514              &$printer("[FAILED] $base: $val_det[$k] = $sim_I +/- $sim_E, should be $val_val[$k] ");
515              $test_abstract .= "[FAILED] $base". "_$index (accuracy off by $diff \%)\n";
516            }
517          } else {
518            &$printer("[???] $base: $val_det[$k] = $sim_I (may have failed, reference not found)");
519            $test_abstract .= "[??????] $base". "_$index (reference not found)\n";
520          }
521        }  else {   # no reference value
522          &$printer("[OK] $base: $val_det[$k] = $sim_I (accuracy not checked)");
523          $test_abstract .= "[OK]     $base". "_$index (accuracy not checked)\n";
524        }
525      } # end else $child_error_code (execution)
526    } # end for $k (examples in instrument)
527  } # end for $j (instruments)
528  my $elapsed_sec = time() - $start_sec;
529  $test_abstract .= "\n";
530  $now = localtime();
531  &$printer($test_abstract);
532  if ($error_flag) {
533    &$printer("# Execution check:    FAILED. $error_flag instrument(s) did not compile/execute.");
534    &$printer("# >> Check instruments and $MCSTAS::mcstas_config{'MCCODE'} installation.");
535  } else {
536    &$printer("# Execution check:    OK.     Computing time: $elapsed_sec [sec] for $index tests.");
537    if ($accuracy_flag > 2) {
538      &$printer("# Accuracy check:     FAILED. $accuracy_flag test(s) with inaccurate results.");
539    } elsif ($accuracy_flag==0) {
540      &$printer("# Accuracy check:     OK.");
541    } else {
542    	&$printer("# Accuracy check:     FAIR. $accuracy_flag test(s) with inaccurate results.");
543    }
544  }
545
546  &$printer("# End Date: $now");
547  chdir($pwd) or return "$MCSTAS::mcstas_config{'RUNCMD'}: Can not come back to $pwd: $!\n";; # come back to initial directory
548  return undef;
549}
550
551# return the component name given the file name for the definition.
552sub compname {
553    my ($path) = @_;
554    my $name = $path;
555    my $i;
556    if($i = rindex($name, "/")) {
557        $name = substr($name, $i + 1);
558    }
559    if($name =~ /^(.+)\.(comp|cmp|com)$/) {
560        $name = $1;
561    }
562    return $name;
563}
564
565# Parse comment header in McDoc format in component definition.
566# Return a data structure containing the gathered information.
567sub parse_header {
568    my ($f) = @_;
569    my $d;
570    my ($i,$where, $thisparm);
571
572    $where = "";
573    $d->{'identification'} = { 'author' => "(Unknown)",
574                               'origin' => "(Unknown)",
575                               'date' => "(Unknown)",
576                               'version' => "(Unknown)",
577                               'history' => [ ],
578                               'short'  => ""
579                           };
580    $d->{'description'} = undef;
581    $d->{'parhelp'} = { };
582    $d->{'links'} = [ ];
583    $d->{'site'}="";
584    my @val_det=();
585    my @val_val=();
586    my @val_par=();
587    while(<$f>) {
588        if(/\%INSTRUMENT_SITE:(.*)$/i) {
589            $d->{'site'}=$1;
590        } elsif(/\%I[a-z]*/i && not /\%include/i) {
591            $where = "identification";
592        } elsif(/\%D[a-z]*/i) {
593            $where = "description";
594        } elsif(/\%P[a-z]*/i) {
595            $where = "parameters";
596            undef $thisparm;
597        } elsif(/\%L[a-z]*/i) {
598            $where = "links";
599            push @{$d->{'links'}}, "";
600        } elsif(/\%EXAMPLE: (.*) Detector: *([^ =]+_I|[^ =]+) *= *([^ =]+)/i) {
601                  push @val_det, "$2";
602                  push @val_val,  $3;
603                  push @val_par, "$1";
604        } elsif(/\%EXAMPLE: (.*)/i) {
605                  push @val_det, "";
606                  push @val_val, 0;
607                  push @val_par, "$1";
608        } elsif(/\%E[a-z]*/i) {
609            last;
610        } else {
611            s/^[ ]?\*[ ]?//;
612            if($where eq "identification") {
613                if(/(Written by|Author):(.*)$/i) {
614                    $d->{'identification'}{'author'} = $2;
615                }elsif(/Origin:(.*)$/i) {
616                    $d->{'identification'}{'origin'} = $1;
617                }elsif(/Date:(.*)$/i) {
618                    $d->{'identification'}{'date'} = $1;
619                }elsif(/Release:(.*)$/i) {
620                    $d->{'identification'}{'release'} = $1;
621                }elsif(/Version:(.*)$/i) {
622                    my $verstring = $1;
623                    # Special case for RCS style $[R]evision: 1.2 $ tags.
624                    # Note the need for [R] to avoid RCS keyword expansion
625                    # in the mcdoc source code!
626                    if($verstring =~ /^(.*)\$[R]evision: (.*)\$(.*)$/) {
627                        $d->{'identification'}{'version'} = "$1$2$3";
628                    } else {
629                        $d->{'identification'}{'version'} = $verstring;
630                    }
631                }elsif(/Modified by:(.*)$/i) {
632                    push @{$d->{'identification'}{'history'}}, $1;
633                } else {
634                    $d->{'identification'}{'short'} .= $_
635                        unless /^\s*$/;
636                }
637            } elsif($where eq "description") {
638                $d->{'description'} .= $_;
639            } elsif($where eq "parameters") {
640                if(/^[ \t]*([a-zA-Z0-9_]+)\s*:(.*)/) {
641                    $thisparm = \$d->{'parhelp'}{$1}{'full'};
642                    $$thisparm = "$2\n";
643                } elsif(/^[ \t]*$/) { # Empty line
644                    undef $thisparm;
645                } elsif($thisparm && /^(  | *\t)[ \t]*(.*)/) {
646                    # Continuation line needs at least two additional
647                    # indentations
648                    $$thisparm .= "$2\n";
649                } elsif(/^[ \t]*([a-zA-Z0-9_]+)\s*(.*)/) {
650                    $thisparm = \$d->{'parhelp'}{$1}{'full'};
651                    $$thisparm = "$2\n";
652                } else {
653                    # Skip it
654                }
655            } elsif($where eq "links") {
656                $d->{'links'}[-1] .= $_;
657            } else {
658                # Skip.
659            }
660        }
661    }
662    $d->{'validation_det'} = \@val_det;
663    $d->{'validation_val'} = \@val_val;
664    $d->{'validation_par'} = \@val_par;
665    # Now search for unit specifications in the parameter information.
666    # This is a bit tricky due to various formats used in the old
667    # components. The preferred format is a specification of the unit
668    # in square brackets "[..]", either first or last in the short
669    # description. Specification using parenthesis "(..)" is also
670    # supported for backwards compatibility only, but only one set of
671    # nested parenthesis is supported.
672    for $i (keys %{$d->{'parhelp'}}) {
673        my $s = $d->{'parhelp'}{$i}{'full'};
674        my ($unit, $text);
675        if($s =~ /^\s*\(([^()\n]*(\([^()\n]*\))?[^()\n]*)\)\s*((.|\n)*)\s*$/){
676            $unit = $1;
677            $text = $3;
678        } elsif($s =~ /^\s*((.|\n)*)\s*\(([^()\n]*(\([^()\n]*\))?[^()\n]*)\)\s*$/){
679            $unit = $3;
680            $text = $1;
681        } elsif($s =~ /^\s*\[([^][\n]*)\]\s*((.|\n)*)\s*$/){
682            $unit = $1;
683            $text = $2;
684        } elsif($s =~ /^\s*((.|\n)*)\s*\[([^][\n]*)\]\s*$/){
685            $unit = $3;
686            $text = $1;
687        } else {
688            # No unit. Just strip leading and trailing white space.
689            $unit = "-";
690            if($s =~ /^\s*((.|\n)*\S)\s*$/) {
691                $text = $1;
692            } else {
693                $s =~ /^\s*$/ || die "$MCSTAS::mcstas_config{'RUNCMD'}: Internal: parse_header match 1";
694                $text = "$s";
695            }
696        }
697        $d->{'parhelp'}{$i}{'unit'} = $unit;
698        $d->{'parhelp'}{$i}{'text'} = $text;
699    }
700    return $d;
701}
702
703# This sub gets component information by parsing the McStas/McXtrace
704# metalanguage. For now this is a regexp hack, later the real mcstas/mcxtrace
705# parser will be used.
706sub get_comp_info {
707    my ($name, $d) = @_;
708    my $file = new FileHandle;
709    my ($cname, $decl, $init, $trace, $finally, $disp, $typ);
710    my (@dpar, @spar, @ipar, @opar);
711    open($file, $name)  || die "$MCSTAS::mcstas_config{'RUNCMD'}: Could not open file $name\n";
712    local $/ = undef;                # Read the whole file in one go.
713    my $s = <$file>;
714    close($file);
715    $typ = "Component";
716    @opar = (); @dpar = (); @spar = ();
717    if ($s =~ m!DEFINE\s+INSTRUMENT\s+([a-zA-Z0-9_]*)\s*\(([-+.a-zA-Z0-9_ \t\n\r=,/*{}\"]*)\)!i) {
718        $cname = $1;
719        $typ   = "Instrument";
720        foreach (split(",", $2)) {
721            if(/^\s*([a-zA-Z0-9_ \s\*]+)\s*\=\s*(.*)\s*$/)  {  # [type] name=value
722                my $p = $1;
723                my @p_splitted = split(" ", $p);
724                my $length = scalar @p_splitted;
725                my $p_last_word = $p_splitted[$length-1];
726                push @spar, $p_last_word;
727                $d->{'parhelp'}{$p_last_word}{'default'} = $2;
728            } elsif(/^\s*([a-zA-Z0-9_ \s\*]+)\s*$/) {                # [type] name
729                my $p = $1;
730                my @p_splitted = split(" ", $p);
731                my $length = scalar @p_splitted;
732                my $p_last_word = $p_splitted[$length-1];
733                push @spar, $p_last_word;
734            } else {
735                print STDERR "Warning: Possible syntax error in specification of PARAMETER in instrument $cname: $1 .\n";
736            }
737        }
738        if ($s =~ /DEFINE\s+COMPONENT\s+([a-zA-Z0-9_]+)/i)
739        { push @opar, "$1"; $d->{'parhelp'}{$1}{'default'} = "This instrument contains embedded components"; }
740    } elsif ($s =~ /DEFINE\s+COMPONENT\s+([a-zA-Z0-9_]+)/i) {
741        $cname = $1;
742        if($s =~ m!DEFINITION\s+PARAMETERS\s*\(([-+.a-zA-Z0-9_ \t\n\r=,/*{}\"]+)\)!i && $typ ne "Instrument") {
743            foreach (split(",", $1)) {
744                if(/^\s*([a-zA-Z0-9_ \s\*]+)\s*\=\s*(.*)\s*$/) { # [type] name=define
745                    my $p = $1;
746                    my @p_splitted = split(" ", $p);
747                    my $length = scalar @p_splitted;
748                    my $p_last_word = $p_splitted[$length-1];
749                    my $p_first_word= $p_splitted[0];
750                    push @dpar, $p_last_word;
751                    $d->{'parhelp'}{$p_last_word}{'default'} = $2;
752                    if ($length > 1) {
753                      $d->{'parhelp'}{$p_last_word}{'type'} = $p_first_word;
754                    }
755                } elsif(/^\s*([a-zA-Z0-9_ \s\*]+)\s*$/) {                # [type] name
756                    my $p = $1;
757                    my @p_splitted = split(" ", $p);
758                    my $length = scalar @p_splitted;
759                    my $p_last_word = $p_splitted[$length-1];
760                    my $p_first_word= $p_splitted[0];
761                    push @dpar, $p_last_word;
762                    if ($length > 1) {
763                      $d->{'parhelp'}{$p_last_word}{'type'} = $p_first_word;
764                    }
765                } else {
766                    print STDERR "Warning: Possible syntax error in specification of DEFINITION PARAMETER in component $cname: $1 .\n";
767                }
768            }
769        }
770        if($s =~ m!SETTING\s+PARAMETERS\s*\(([-+.a-zA-Z0-9_ \t\n\r=,/*\"]+)\)!i && $typ ne "Instrument") {
771            foreach (split(",", $1)) {
772                if(/^\s*([a-zA-Z0-9_ \s\*]+)\s*\=\s*([-+.e0-9]+)\s*$/) { # [type] name=numerical value
773                    my $p = $1;
774                    my @p_splitted = split(" ", $p);
775                    my $length = scalar @p_splitted;
776                    my $p_last_word = $p_splitted[$length-1];
777                    push @spar, $p_last_word;
778                    my $p_first_word = $p_splitted[0];
779                    $d->{'parhelp'}{$p_last_word}{'default'} = $2;
780                    if ($length > 1) {
781                      $d->{'parhelp'}{$p_last_word}{'type'} = $p_first_word;
782                    }
783                } elsif(/^\s*([a-zA-Z0-9_ \s\*]+)\s*\=\s*(.*)\s*$/) { # [type] name=other value
784                    my $p = $1;
785		    my $val = $2;
786                    my @p_splitted = split(" ", $p);
787                    my $length = scalar @p_splitted;
788                    my $p_last_word = $p_splitted[$length-1];
789                    push @spar, $p_last_word;
790                    my $p_first_word = $p_splitted[0];
791                    if ($length > 1 && $p_first_word !~ m/char/ && $p_first_word !~ m/string/) {
792                      print STDERR "
793Warning: SETTING parameter $1 with default value $val\n
794         is not of type char/string. Ignoring default value.\n";
795                    } else {
796                      $d->{'parhelp'}{$p_last_word}{'default'} = $val;
797                    }
798                    if ($length > 1) {
799                      $d->{'parhelp'}{$p_last_word}{'type'} = $p_first_word;
800                    }
801                } elsif(/^\s*([a-zA-Z0-9_]+)\s*$/) {                    # [type] name
802                    my $p = $1;
803                    my @p_splitted = split(" ", $p);
804                    my $length = scalar @p_splitted;
805                    my $p_last_word = $p_splitted[$length-1];
806                    my $p_first_word = $p_splitted[0];
807                    push @spar, $p_last_word;
808                    if ($length > 1) {
809                      $d->{'parhelp'}{$p_last_word}{'type'} = $p_first_word;
810                    }
811                } else {
812                    print STDERR "Warning: Possible syntax error in specification of SETTING PARAMETER in component $cname: $1 .\n";
813                }
814            }
815        }
816        if($s =~ /OUTPUT\s+PARAMETERS\s*\(([a-zA-Z0-9_, \t\r\n]+)\)/i && $typ ne "Instrument") {
817            @opar = split (/\s*,\s*/, $1);
818        }
819    } else {
820        $cname = "<Unknown>";
821    }
822
823    @ipar = (@dpar, @spar);
824
825    # DECLARE, INITIALIZE, ... blocks will have to wait for the real parser.
826    $d->{'name'} = $cname;
827    $d->{'type'} = $typ;
828    if ($typ eq "Component") { $d->{'ext'} = "comp"; }
829    else { $d->{'ext'} = "instr"; }
830    $d->{'inputpar'} = \@ipar;
831    $d->{'definitionpar'} = \@dpar;
832    $d->{'settingpar'} = \@spar;
833    $d->{'outputpar'} = \@opar;
834}
835
836
837# Return component information given filename.
838sub component_information {
839    my ($comp) = @_;
840    my $file = new FileHandle;
841    open($file, $comp)  || return undef;
842    my $data = parse_header($file);
843    close($file);
844    return undef unless defined($data);
845    get_comp_info($comp, $data);
846    return $data;
847}
848
849# Open .instr file for component information
850# Needed for implementation of 'inspect' feature
851# in mcgui.pl
852# PW 20030314
853sub instrument_information {
854    my ($instr) = @_;
855    my $file = new FileHandle;
856    open($file, $instr) || return undef;
857    my @data = parse_instrument($file);
858    close($file);
859    return @data;
860}
861
862# Parse .instr file
863sub parse_instrument {
864    my ($f) = @_;
865    my @d;
866    my ($i,$where, $thisparm);
867    while(<$f>) {
868        if(/^\s*COMPONENT \s*([a-zA-Z0-9_]+)\s=*/) {
869      push @d, $1;
870        } else  {
871  }
872    }
873    return @d;
874
875}
876
8771;
878