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