+++ /dev/null
-#!/usr/bin/perl -w
-
-use English;
-use strict;
-use Getopt::Long;
-use FileHandle;
-use File::Path;
-use File::Basename;
-use Data::Dumper;
-use Time::HiRes;
-
-use IO::Socket;
-use Net::Ping;
-
-use Config::Std;
-use Carp qw( croak );
-use Scalar::Util qw(reftype);
-use List::Util;
-use List::MoreUtils qw(any apply);
-
-use IO::Socket;
-use IO::Select;
-
-use threads;
-use threads::shared;
-
-#use Clone qw(clone);
-
-#- the command line option flags
-my $opt_help = 0;
-my $opt_eb = "on";
-my $opt_check = 1;
-my $opt_rdo = 0;
-my $opt_test = 0;
-my $opt_file = "../main/startup.script";
-my $opt_etrax = "etraxp022";
-my $opt_verb = 0;
-my $opt_ora = "file";
-my @opt_macro;
-my @dead_cservers;
-
-GetOptions ('h|help' => \$opt_help,
- 'b|eb=s' => \$opt_eb,
- 'c|check=i' => \$opt_check,
- 'r|rdo' => \$opt_rdo,
- 'f|file=s' => \$opt_file,
- 'e|etrax=s' => \$opt_etrax,
- 'm|macro=s' => \@opt_macro,
- 'v|verb' => \$opt_verb,
- 'o|oracle=s' => \$opt_ora,
- 't|test' => \$opt_test);
-
-if( $opt_help ) {
- &help();
- exit(0);
-}
-
-my $parent_pid = $$;
-
-my @subsys_array = ('mdc','rich','rpc','start','tof','wall','hub');
-
-my $expect_script = "/tmp/remote_exec.exp";
-my $var_dir = "/var/diskless/etrax_fs";
-my $log_dir = "/tmp/log";
-
-my $cmd_server = "./bin/command_server";
-my $cmd_server_port = 4712;
-my $cmd_server_prtcl = 'tcp';
-my $cmd_server_answer = "";
-
-my %addr_db_conf; # Hash with all addresses, serials, uids from DBs
-my $addr_db_conf_href = \%addr_db_conf;
-my @startup; # Array with all startup configuration
-my $startup_aref = \@startup;
-my %trb_hash; # Hash with TRBs for different subsystems
-my $trb_href = \%trb_hash;
-my %EB_Args; # Hash with EB args
-my $EB_Args_href = \%EB_Args;
-my @rdo; # Array with etrax names which run readout
-my $rdo_aref = \@rdo;
-
-my @usedMacros = (); # Array of used macro names to identify names with typos
-
-my %data2ora_hash; # Hash with data to be stored in Oracle
-my $data2ora_href = \%data2ora_hash;
-
-my @subEvtIds; # Array with subevent Ids
-my $subEvtIds_aref = \@subEvtIds;
-
-my %addressRange; # Hash with ranges of TRBNet addresses for each type of board
-my $addressRange_href = \%addressRange;
-
-if( 0 != &checkArgs() ){
- print "Exit.\n";
- exit(1);
-}
-
-#- Get local time in seconds since Epoch
-my $seconds1 = time;
-
-my $child_pid = &forkStatusServer();
-
-&prepareForStartup(); #0.05s
-&cleanup(); #0.02s
-&readScript($opt_file, 'local'); #1.3s
-&checkUnusedMacros(); #0s
-
-#print Dumper $startup_aref;
-#print Dumper $trb_href;
-#print Dumper $addr_db_conf_href->{'0x3230_3'};
-&checkConnection() if($opt_check); #2.6s
-
-&closeEBs() if($opt_eb eq "on");
-&execViaCmdServer();
-&startEBs() if($opt_eb eq "on");
-
-exit(0);
-
-################### END OF MAIN ####################
-
-sub help()
-{
- print "\n";
- print << 'EOF';
-startup.pl
-
- This script starts readout via Command_Server running
- on etrax boards. The script also starts Event Builder
- to collect the data.
-
-Usage:
-
- Command line: startup.pl
- [-h|--help] : Show this help.
- [-f|--file <path/name>] : Path to main config file.
- [-b|--eb <on>|<off>] : Automatic restart of EBs (default: on).
- [-r|--rdo] : Start readout.
- [-e|--etrax <name>] : Etrax name.
- [-m|--macro <name>] : Macro names for preprocessing startup.script files.
- Only !ifdef, !ifndef, !endif directives are defined.
- !ifdef - by default exclude following cmds,
- !ifndef - by default include following cmds.
- [-o|--oracle <null|
- file>] : Write ascii files with info for Oracle (default: file).
- [-t|--test] : Test without execution.
- [-v|--verb] : Verbose.
-
-Examples:
-
- Start MDC script with macros CALIB and INIT:
- startup.pl -f ../mdc/startup.script -m CALIB -m INIT
-
-EOF
-}
-
-sub checkArgs()
-{
- my $retval = 0;
-
- if($opt_rdo){
- print "Option -r is not implemented yet.\n";
- $retval = 1;
- }
- if( ! (-e $opt_file) ){
- print "File $opt_file does not exist.\n";
- $retval = 1;
- }
-
- return $retval;
-}
-
-sub prepareForStartup()
-{
-
- my $var_log_dir = $var_dir . "/tmp/log";
- &makeDir($var_log_dir);
-
- my $mode_dir = $log_dir . "/mode";
- &makeDir($mode_dir);
-
- #- Write expect script
- &writeExpect();
-}
-
-sub makeDir()
-{
- my ($dir) = @_;
-
- #- Make all needed dirs/subdirs
- my @log_dir_list = split('/', $dir);
-
- my $dir2mk = "";
- foreach my $subdir (@log_dir_list){
- next unless( $subdir );
-
- $dir2mk = $dir2mk . "/" . $subdir;
- mkdir($dir2mk) or die $! unless( -d $dir2mk);
- }
-}
-
-sub cleanup()
-{
- system("rm $log_dir/log*.txt 2>/dev/null 2>/dev/null") unless($opt_test);
- system("rm $log_dir/board_ids_for_oracle*.txt 2>/dev/null 2>/dev/null") unless($opt_test);
- system("rm $log_dir/mode/* 2>/dev/null 2>/dev/null") unless($opt_test);
-}
-
-sub writeExpect()
-{
- # If command_server is not started on Etrax at boot time
- # this expect script can be executed to start command_server.
-
- #! Look if /tmp dir exists
- my $tmp_dir = dirname("/tmp");
- if ( !(-d $tmp_dir) ){
- print "\nCannot access /tmp directory!\nExit.\n";
- exit(1);
- }
-
- my $expect_script_my = <<EOF;
-#!/usr/bin/expect -f
-
-# This script is automatically generated by startup.pl
-# Do not edit, the changes will be lost.
-
-# Print args
-send_user "\$argv0 [lrange \$argv 0 \$argc]\\n"
-
-# Get args
-#
-# host : etrax name
-# path : path to executable
-# bin : executable name
-# opt : args for executable
-#
-if {\$argc>0} {
- set host [lindex \$argv 0]
- set path [lindex \$argv 1]
- set bin [lindex \$argv 2]
- set opt [lindex \$argv 3]
-} else {
- send_user "Usage: \$argv0 host path binary options\\n"
-}
-
-spawn telnet \$host
-expect {
- "error" { exit; }
- "login:" { send "root\\r"; exp_continue; }
- "Password:" { send "pass\\r" }
-}
-
-set timeout 240
-
-expect "# "
-send "killall -9 \$bin\\r"
-expect "# "
-send "cd /home/hadaq/\\r"
-expect "# "
-send "\$path\$bin \$opt\\r"
-expect "# "
-
-EOF
-
- my $fh = new FileHandle(">$expect_script");
-
- if(!$fh) {
- my $txt = "\nError! Could not open file \"$expect_script\" for output. Exit.\n";
- print STDERR $txt;
- print $txt;
- exit(128);
- }
-
- print $fh $expect_script_my;
- $fh->close();
-
- #- open permissions
- system("chmod 755 $expect_script") unless($opt_test);
-}
-
-sub getSubsysName()
-{
- my ($script) = @_;
-
- my $subsys;
-
- if( $script =~ /..\/(\w+)\/(\w+).script/ ){
- $subsys = $1;
-
- die "getSubsysName(): Undefined subsystem: \'$script\'! Exit.\n" unless( defined $subsys );
- }
- else{
- $subsys = 'main';
- }
-
- return $subsys;
-}
-
-sub preprocess()
-{
- my ($preproc, $line) = @_;
-
- my ($directive, $macro) = split(" ", $line);
-
- &preprocessCheck( $preproc, $directive );
-
- if( $directive eq "!ifdef" and (any {lc($_) eq lc($macro)} @opt_macro) ){
- $preproc->{'ifdef'} = 'on';
- $preproc->{'skeepLine'} = 0;
-
- #- Save found macro names
- push(@usedMacros, $macro) unless(any {lc($_) eq lc($macro)} @usedMacros);
-
- return 1;
- }
- elsif( $directive eq "!ifdef" ){
- #- No ifdef macros defined in cmd line => skeep next lines
- $preproc->{'ifdef'} = 'on';
- $preproc->{'skeepLine'} = 1;
-
- return 1;
- }
- elsif( $directive eq "!ifndef" && (any {lc($_) eq lc($macro)} @opt_macro) ){
- $preproc->{'ifndef'} = 'on';
- $preproc->{'skeepLine'} = 1;
-
- #- Save found macro names
- push(@usedMacros, $macro) unless(any {lc($_) eq lc($macro)} @usedMacros);
-
- return 1;
- }
- elsif( $directive eq "!ifndef" ){
- #- No ifndef macros defined in cmd line => include next lines
- $preproc->{'ifndef'} = 'on';
- $preproc->{'skeepLine'} = 0;
-
- return 1;
- }
- elsif( $directive eq "!endif" ){
- $preproc->{'ifndef'} = 'off';
- $preproc->{'ifdef'} = 'off';
- $preproc->{'skeepLine'} = 0;
-
- return 1;
- }
-
- return $preproc->{'skeepLine'};
-}
-
-sub checkUnusedMacros()
-{
- my @unusedMacros = ();
- my $foundUnused = 0;
-
- foreach my $macro (@opt_macro){
- unless((any {lc($_) eq lc($macro)} @usedMacros)){
- push(@unusedMacros, $macro);
- $foundUnused = 1;
- }
- }
-
- if($foundUnused){
- print "\nUnused macro names:";
-
- foreach my $macro (@unusedMacros){
- print " $macro";
- }
-
- print "\n";
-
- &askUser();
- }
-}
-
-sub preprocessInit()
-{
- my %preproc = (
- 'ifdef' => 'off',
- 'ifndef' => 'off',
- 'skeepLine' => 0
- );
-
- return \%preproc;
-}
-
-sub preprocessCheck()
-{
- my ($preproc, $directive) = @_;
-
- if( $directive eq "!ifdef" || $directive eq "!ifndef" ){
- unless( ($preproc->{'ifdef'} eq 'off') &&
- ($preproc->{'ifndef'} eq 'off') ){
- print "Encapsulated \'ifdef\'/\'ifndef\' are not supported. Each \'ifdef\'/\'ifndef\' must be closed with \'endif\' before next \'ifdef\'/\'ifndef\' can be opened.\n";
- exit(1);
- }
- }
- elsif( $directive eq "!endif" ){
- if( ($preproc->{'ifdef'} eq 'on' && $preproc->{'ifndef'} eq 'on') ||
- ($preproc->{'ifdef'} eq 'off' && $preproc->{'ifndef'} eq 'off') ){
- print "The sequence of directives looks fishy. Each \'ifdef\'/\'ifndef\' must be closed with \'endif\' before next \'ifdef\'/\'ifndef\' can be opened.\n";
- exit(1);
- }
- }
- elsif( $directive =~ /!(\w+)/ ){
- print "Unknown directive $directive. Exit.\n";
- exit(1);
- }
-}
-
-sub readTRBSetup()
-{
- my ($trb_db) = @_;
-
- my $fh = new FileHandle("$trb_db", "r");
-
- &isItDefined($fh, $trb_db);
-
- #- Init preprocessor hash
- my $preproc = &preprocessInit();
-
- my $SPACE = "";
-
- while(<$fh>){
-
- #- Remove all comments
- $_ =~ s{ # Substitue...
- \# # ...a literal octothorpe
- [^\n]* # ...followed by any number of non-newlines
- }
- {$SPACE}gxms; # Raplace it with a single space
-
- #- Skip line if it contains only whitespaces
- next unless(/\S/);
-
- #- Check for preprocessor directives
- next if( &preprocess($preproc, $_) );
-
- #- Extract command and parameters
- my ($sys, $etrax, $rdo) = split(" ", $_);
-
- unless( defined $etrax ){
- print "Etrax is not defined in $trb_db for $sys! Exit\n";
- $fh->close;
- exit(1);
- }
-
- #- Add to a main configuration hash
- push( @{$trb_href->{$sys}}, $etrax );
-
- #- Add to a readout array for EB
- if( defined $rdo && $rdo =~ /rdo/ ){
- push( @$rdo_aref, $etrax );
- }
- }
-
- $fh->close;
-}
-
-sub readAddressRangeSetup()
-{
- my ($addressRange_db) = @_;
-
- my $fh = new FileHandle("$addressRange_db", "r");
-
- &isItDefined($fh, $addressRange_db);
-
- #- Init preprocessor hash
- my $preproc = &preprocessInit();
-
- my $SPACE = "";
-
- while(<$fh>){
-
- #- Remove all comments
- $_ =~ s{ # Substitue...
- \# # ...a literal octothorpe
- [^\n]* # ...followed by any number of non-newlines
- }
- {$SPACE}gxms; # Raplace it with a single space
-
- #- Skip line if it contains only whitespaces
- next unless(/\S/);
-
- #- Check for preprocessor directives
- next if( &preprocess($preproc, $_) );
-
- #- Extract command and parameters
- my ($sys, $min, $max, $type) = split(" ", $_);
-
- $min =~ s{ # Substitue...
- 0x # ...hex zero
- }{}gxms; # ...with nothing
-
- $max =~ s{ # Substitue...
- 0x # ...hex zero
- }{}gxms; # ...with nothing
-
-
- unless( defined $sys && defined $min &&
- defined $max && defined $type){
- print "Something wrong with a format of $addressRange_db! Exit.\n";
- $fh->close;
- exit(1);
- }
-
- $addressRange_href->{$sys}->{'MIN'} = $min;
- $addressRange_href->{$sys}->{'MAX'} = $max;
- $addressRange_href->{$sys}->{'TYPE'} = $type;
- }
-
- $fh->close;
-}
-
-sub readSubevtIdsSetup()
-{
- my ($subevt_db) = @_;
-
- my $fh = new FileHandle("$subevt_db", "r");
-
- &isItDefined($fh, $subevt_db);
-
- #- Init preprocessor hash
- my $preproc = &preprocessInit();
-
- my $SPACE = "";
-
- while(<$fh>){
-
- #- Remove all comments
- $_ =~ s{ # Substitue...
- \# # ...a literal octothorpe
- [^\n]* # ...followed by any number of non-newlines
- }
- {$SPACE}gxms; # Raplace it with a single space
-
- #- Skip line if it contains only whitespaces
- next unless(/\S/);
-
- #- Check for preprocessor directives
- next if( &preprocess($preproc, $_) );
-
- #- Extract command and parameters
- my $subevt;
-
- if( $_ =~ /0x(\w+)/ ){
- $subevt = $1;
- }
- else{
- print "Something wrong with a format of $subevt_db! Exit\n";
- $fh->close;
- exit(1);
- }
-
- #- Add to a config array
- push( @$subEvtIds_aref, $subevt );
- }
-
- $fh->close;
-}
-
-sub readScript()
-{
- my ($script, $exec_sys) = @_;
-
- #- Extract subsystem name
- my $subsys = &getSubsysName($script);
- #print "script: $script, subsys: $subsys\n";
-
- my $fh = new FileHandle("$script", "r");
- &isItDefined($fh, $script);
-
- #- Init preprocessor hash
- my $preproc = &preprocessInit();
-
- my $SPACE = "";
-
- while(<$fh>){
-
- #- Remove all comments
- $_ =~ s{ # Substitue...
- \# # ...a literal octothorpe
- [^\n]* # ...followed by any number of non-newlines
- }
- {$SPACE}gxms; # Raplace it with a single space
-
- #- Skip line if it contains only whitespaces
- next unless(/\S/);
-
- #- Check for preprocessor directives
- next if( &preprocess($preproc, $_) );
-
- #- Extract command and parameters
- my ($cmd, @param) = split(" ", $_);
-
- &add2startup( $subsys, $exec_sys, $cmd, \@param );
- }
-
- $fh->close;
-}
-
-sub add2startup(){
-
- my ($subsys, $exec_sys, $cmd, $aref) = @_;
-
- die "add2startup(): one or more arguments are not defined! Exit.\n"
- unless( defined $subsys && defined $exec_sys && defined $cmd && defined $aref);
-
- if( $cmd =~ /exec_script{(\w+)}/ ){
- my $exec_sys = $1;
-
- #- exec_script is followed only by one parameter [0]: script name
- &readScript( $aref->[0], $exec_sys );
- }
- elsif( $cmd =~ /exec_cmd{(\w+)}/){
- my $exec_sys = $1;
-
- my $args = &getArgs4cmd($aref, $subsys);
- &push2array( \@startup, $exec_sys, $args );
- }
- elsif( $cmd eq 'exec_cmd'){
-
- my $args = &getArgs4cmd($aref, $subsys);
-
- &push2array( \@startup, $exec_sys, $args );
- }
- elsif( $cmd eq 'wait'){
-
- #- At this point we will wait for the forked children
- push( @startup, {$cmd => ['-']} );
- }
- elsif( $cmd eq 'trbcmd'){
- my $args = &getArgs4cmd($aref, $subsys);
- my $cmd_line = "$cmd $args";
-
- &push2array( \@startup, $exec_sys, $cmd_line );
- }
- elsif( $cmd eq 'set_addresses' ){
- my $serials = $aref->[0];
- my $addresses = $aref->[1];
-
- my $conf = $subsys . "-" . $cmd . "-" . $serials . ".conf";
- my $args = &makeAddressesConf( $subsys, $serials, $addresses, $conf );
- my $bash_script = "trbdhcp -f $args";
-
- &push2array( \@startup, $exec_sys, $bash_script );
- }
- elsif( $cmd eq 'load_register' ){
- my $register = $aref->[0];
-
- my $conf = $subsys . "-" . $cmd . "-" . $register . ".conf";
- my $args = &makeRegisterConf( $subsys, $register, $conf );
- my $bash_script = "trbcmd -f $args";
-
- &push2array( \@startup, $exec_sys, $bash_script );
- }
- elsif( $cmd eq 'daqop' ){
- my $args = &getArgs4cmd($aref, $subsys);
- my $bash_script = "$cmd $args";
-
- &push2array( \@startup, $exec_sys, $bash_script );
- }
- elsif( $cmd eq 'read_trb_db' ){
- #- Read database file with TRB setup
- my $trb_db = $aref->[0];
-
- &readTRBSetup( $trb_db );
- }
- elsif( $cmd eq 'read_addrange_db' ){
- #- Read database file with TRBNet address ranges
- my $addrRanges_db = $aref->[0];
-
- &readAddressRangeSetup($addrRanges_db);
- }
- elsif( $cmd eq 'read_subevtids_db' ){
- #- Read database file with subevent Ids
- my $subevt_db = $aref->[0];
-
- &readSubevtIdsSetup( $subevt_db );
- }
- elsif( $cmd eq 'read_eb_conf' ){
- #- Read config file with EB settings
- my $eb_conf = $aref->[0];
-
- read_config $eb_conf => %$EB_Args_href;
- }
- else{
- die "add2startup(): do not know what to do with command \'$cmd\' for subsystem \'$subsys\'! Exit.\n";
- }
-}
-
-sub checkScript()
-{
-}
-
-sub getArgs4cmd()
-{
- my ($aref, $subsys) = @_;
-
- my $args = "";
-
- if( $aref->[0] eq '-f' && defined $subsys ){
- my $conf = $aref->[1];
- system("cp ../$subsys/$conf $var_dir/tmp/.") unless($opt_test);
- $args = "-f /home/hadaq/tmp/" . $conf;
- }
- else{
- for( my $i=0; $i < scalar (@{$aref}); $i++){
- $args = $args . " " . $aref->[$i];
- }
- }
-
- return $args;
-}
-
-sub isItDefined()
-{
- my ($fh, $name) = @_;
-
- if(!$fh) {
- my $txt = "\nError! Could not open file \'$name\'. Exit.\n";
- print STDERR $txt;
- print $txt;
- exit(128);
- }
-
- return 0;
-}
-
-sub isVarDefined()
-{
- my ($var, $name) = @_;
-
- unless( defined $var ){
- print "$name is not defined! Exit.\n";
- exit(1);
- }
-}
-
-sub push2array()
-{
- my ($aref, $exec_sys, $cmd) = @_;
-
- if( defined $aref->[-1] && defined $aref->[-1]->{$exec_sys} ){
- #- If last exec_sys equals current exec_sys
- #- push current cmd to the same exec_sys
- push( @{$aref->[-1]->{$exec_sys}}, $cmd );
- }
- else{
- #- Unless create new entry in the main array
- push( @$aref, {$exec_sys => [$cmd]} );
- }
-}
-
-sub execViaCmdServer()
-{
- my (@process_list);
-
- my $i = 1;
-
- #- Loop over subsystems
- foreach my $href ( @$startup_aref ){
-# print Time::HiRes::time()."\n" ;
-
- my ($exec_sys, $cmd_aref) = each ( %$href );
-
- if($exec_sys eq 'con') {
- foreach my $cmd ( @{$cmd_aref} ){
- system($cmd);
- }
- }
-
- if( $exec_sys eq 'wait' ){
- $| = 1; # turn off stdout buffering
- print "wait...\r";
- #- Wait for the forked children
- foreach my $cur_child_pid (@process_list) {
- waitpid($cur_child_pid,0);
- }
- &scanLogs();
-# print Time::HiRes::time()."\n";
- next;
- }
-
- print "exec: $exec_sys\n" unless( $exec_sys eq "local" || $exec_sys eq "con");
-
- #system("logger -p local1.info -t DAQ $exec_sys");
-
- #- Loop over TRBs for given exec_sys
- if( $exec_sys =~ /etrax/ ){
- #- Name of etrax is explicitly written in exec_cmd{}
- # in main startup script.
- if($opt_etrax){
- my $log = $log_dir . "/" . "log" . $i . "_" . $exec_sys . "_" . $opt_etrax . ".txt";
- &forkMe( $cmd_aref, \@process_list, $opt_etrax, $log);
- }
- else{
- my $log = $log_dir . "/" . "log" . $i . "_" . $exec_sys . ".txt";
- &forkMe( $cmd_aref, \@process_list, $exec_sys, $log);
- }
- }
- elsif( $exec_sys eq 'local' ){
- my $log = $log_dir . "/" . "log" . $i . "_" . $exec_sys . ".txt";
- &forkMe( $cmd_aref, \@process_list, $exec_sys, $log);
- }
- elsif( $exec_sys eq 'nofork'){
- &execLocal($cmd_aref,$exec_sys);
- }
- else{
- #- Loop over TRBs for a given subsys
- foreach my $trb ( @{$trb_href->{$exec_sys}} ){
- my $log = $log_dir . "/" . "log" . $i . "_" . $exec_sys . "_" . $trb . ".txt";
- &forkMe( $cmd_aref, \@process_list, $trb, $log);
- }
- }
-
- $i++; #increment log file index
- }
-
- #- Wait for children
- foreach my $cur_child_pid (@process_list) {
- waitpid($cur_child_pid,0);
- }
-}
-
-sub execLocal()
-{
- my ($cmd_aref) = @_;
-
- #- Loop over cmds to be executed on the local system
- # without forking
- foreach my $cmd ( @{$cmd_aref} ){
- $| = 1; # turn off stdout buffering
-
- if($cmd =~ /check_compile_time/){
- &checkCompileTime($cmd) unless($opt_test);
- }
- }
-}
-
-sub forkMe()
-{
- my ($cmd_aref, $proc_list, $etrax, $log) = @_;
-
- my $child = fork();
-
- if( $child ){ # parent
- push( @$proc_list, $child );
-# print "$child: ".$cmd_aref->[0]."\n";
- }
- elsif( $child == 0 ) { # child
- exit(0) if($opt_test);
-
- if( $etrax eq "local" ){
-
- #- Loop over cmds to be executed on the local system
- foreach my $cmd ( @{$cmd_aref} ){
- $| = 1; # turn off stdout buffering
- print "sleep...\r" if( $cmd =~ /sleep/ );
-
- if($cmd =~ /daq2oracle/){
- &data2ora() unless($opt_test);
- }
- else{
-
- #- Redirect STDOUT but not for 'echo'
- unless($cmd =~ /echo/){
- open(STDOUT, ">>$log") || die "Cannot redirect STDOUT";
- open(STDERR, ">>&STDOUT") || die "Cannot dup STDERR";
- select STDERR; $| = 1; # make unbuffered
- select STDOUT; $| = 1; # make unbuffered
- }
-
- unless($opt_test){
- print "===> $cmd\n" unless($cmd =~ /echo/);
- system("$cmd");
- print "> returned value of command $?\n" unless($cmd =~ /echo/);
- }
-
- unless($cmd =~ /echo/){
- close(STDOUT);
- close(STDERR);
- }
- }
- }
- }
- else{
- #- Connect to commandServer to exec commands on the remote systems
- if( &connectCmdServer($cmd_aref, $etrax, $cmd_server_port, $cmd_server_prtcl, $log) ){
- #print "Something went wrong on commandServer side.\n";
- }
- }
-
- exit(0); # exit child
- }
- else{
- print "Could not fork: $!\n";
- exit(1);
- }
-}
-
-sub connectCmdServer()
-{
- my ($cmd, $remote_host, $remote_port, $protocol, $log) = @_;
-
- # '$cmd' can be a reference to an array of commands
- # or just single command. In the first case, the commands
- # from the array will be executed one after another.
-
- &isVarDefined( $cmd, "connectCmdServer(): cmd" );
- &isVarDefined( $remote_host, "connectCmdServer(): remote_host" );
-
- my $fh = new FileHandle(">$log");
-
- if(!$fh) {
- my $txt = "\nError! Could not open file \"$log\" for output. Exit.\n";
- print STDERR $txt;
- print $txt;
- exit(128);
- }
-
- my $answer;
- my $retval = 1;
-
- my $socket = IO::Socket::INET->new(PeerAddr => $remote_host,
- PeerPort => $remote_port,
- Proto => $protocol,
- Type => SOCK_STREAM)
- or $answer = "ERROR: No response from Cmd Server at $remote_host:$remote_port\n";
-
- unless( defined $answer ){
- $socket->autoflush(1);
- print $socket "iamfromhadesdaq\n";
- $answer = <$socket>;
-
- &print2file($fh, $answer);
-
- my $reftype = reftype \$cmd;
-
- if( $reftype =~ /REF/ ){
- #- Loop over commands to be executed on etrax
- foreach my $command ( @{$cmd} ){
-
- $command = &cmdParam( $command, $remote_host );
-
- print $socket "$command\n";
- &print2file( $fh, "===> $command\n" );
-
- while ( <$socket> ) {
- &print2file( $fh, $_ );
-
- if( $_ =~ /- END OF OUTPUT -/ ){
- last;
- }
- }
- }
- }
- else{
- print $socket "$cmd\n";
- &print2file( $fh, "===> $cmd\n" );
-
- while ( <$socket> ) {
- &print2file( $fh, $_ );
-
- if( $_ =~ /- END OF OUTPUT -/ ){
- last;
- }
- }
- }
-
- close($socket);
- }
-
- if( $answer =~ /Connection accepted/ ){
- $retval = 0;
- }
- else{
- &print2file( $fh, $answer );
- }
-
- $fh->close();
-
- return $retval;
-}
-
-sub cpThresholds()
-{
- my ($timestamp) = @_;
-
- my $thresh_dir = "/data/lxhadesdaq/daq/thresh";
- my %ora_thresh;
- my $ora_thresh_href = \%ora_thresh;
-
- foreach my $my_href ( @{$startup_aref} ){
-
- my %my_hash = %$my_href;
-
- my ($exec_sys, $cmd_aref) = each ( %my_hash );
-
- next unless( defined $exec_sys );
-
- next if( $exec_sys eq 'wait' );
-
- foreach my $cmd ( @{$cmd_aref} ){
- if( $cmd =~ /spi_trb/ ){
- $cmd =~ s/^\s+//; # remove leading whitespace
-
- my ($spi, $thresh) = split(" ", $cmd);
- my $thresh_name_new = $thresh_dir . "/thresh_" . $timestamp . "_" . $exec_sys;
-
- $ora_thresh_href->{$exec_sys} = $thresh_name_new;
-
- my $THRPATH = "/var/diskless/etrax_fs";
-
- $thresh =~ s{ # Substitue...
- \/home\/hadaq # ...an Etrax path
- }
- {$THRPATH}gxms; # ...with lxhadesdaq path
-
- if( $thresh =~ /\${TRBNUM}/ ){
- foreach my $trb ( @{$trb_href->{$exec_sys}} ){
- my $trbnum = 0; #default
- if( $trb =~ /etraxp?(\d{3})/ || $trb =~ /trb?\d(\d{2})/){
- $trbnum = $1;
- }
- else{
- croak "cmdParam: unexpected etrax name: $trb. Exit.\n";
- }
-
- #- replace TRBNUM
- $thresh =~ s{ # Substitue ...
- \${TRBNUM} # ... a parameter
- }
- {$trbnum}gxms; # ... with a TRB number
-
- my $thresh_name_trb = $thresh_name_new . "_" . $trbnum;
-
- system("cp $thresh $thresh_name_trb");
- }
- }
- else{
- system("cp $thresh $thresh_name_new");
- }
- }
- }
- }
-
- #- Build a line for Oracle DB
- my $line = "";
-
- foreach my $exec_sys (sort keys %{$ora_thresh_href}){
- my $thresh_name = $ora_thresh_href->{$exec_sys};
- $line = $line . " " . $exec_sys . " lxhadesdaq:" . $thresh_name . "%";
- }
-
- unless( $line eq "" ){
- $line = "loaded_thresholds " . $timestamp . " Loaded thresholds:% " . $line . "\n";
- }
- else{
- print "WARNING: could not identify file names for loaded thresholds!\n"
- }
-
- return $line;
-}
-
-sub print2file()
-{
- my ($fh, $toprint) = @_;
-
- if( defined $toprint ){
- print $fh $toprint;
-
- if( $opt_verb || $toprint =~ /ERROR/){
- print "$toprint\n";
- }
- }
-}
-
-sub cmdParam(){
- my ($cmd, $etrax) = @_;
-
- croak "cmdParam: undefined etrax name. Exit.\n" unless( defined $etrax );
-
- my $trbnum = 0; #default
- if( $etrax =~ /etraxp?(\d{3})/ || $etrax =~ /trb?\d(\d{2})/ || $etrax =~ /hades?\w(\d{2})/){
- $trbnum = $1;
- }
- else{
- croak "cmdParam: unexpected etrax name: $etrax. Exit.\n";
- }
-
- my $eb_port = $EB_Args_href->{'Main'}->{'PORT_BASE'} + $trbnum;
- my $eb_ip = $EB_Args_href->{'Main'}->{'EB_IP'};
-
- #- replace TRBNUM
- $cmd =~ s{ # Substitue...
- \${TRBNUM} # ...a parameter
- }
- {$trbnum}gxms; # Raplace it with a TRB number
-
- #- replace EBIP
- $cmd =~ s{ # Substitue...
- \${EBIP} # ...a parameter
- }
- {$eb_ip}gxms; # Raplace it with a EB IP
-
- #- replace EBPORT
- $cmd =~ s{ # Substitue...
- \${EBPORT} # ...a parameter
- }
- {$eb_port}gxms; # Raplace it with a EB PORT
-
- $cmd = "source /home/hadaq/.bashrc; " . $cmd if($etrax =~ /hades?\w(\d{2})/);
-
- return $cmd;
-}
-
-sub makeRegisterConf()
-{
- my ($subsys, $register, $outConf) = @_;
-
- $register = "../" . $subsys . "/" . $register;
-
- my %reg_hash;
- my $reg_href = \%reg_hash;
-
- my $fh = new FileHandle("$register", "r");
- &isItDefined($fh, $register);
-
- my $reg_table = 0;
- my $val_table = 0;
- my $ver_table = 0;
- my $ver_tdcmask = 0;
- my %mb_type; #Motherboard type
- my $mb_type = \%mb_type;
-
- my $SPACE = "";
-
- while(<$fh>){
-
- #- Remove all comments
- $_ =~ s{ # Substitue...
- \# # ...a literal octothorpe
- [^\n]* # ...followed by any number of non-newlines
- }
- {$SPACE}gxms; # Raplace it with a single space
-
- #- Skip line if it contains only whitespaces
- next unless(/\S/);
-
- #- Find which table we will read now
- if(/^(\s+)?!Register\stable/){
- $reg_table = 1;
- $val_table = 0;
- $ver_table = 0;
- $ver_tdcmask = 0;
- next;
- }
- elsif(/^(\s+)?!Value\stable/){
- $reg_table = 0;
- $val_table = 1;
- $ver_table = 0;
- $ver_tdcmask = 0;
- next;
- }
- elsif(/^(\s+)?!Version\stable/){
- $reg_table = 0;
- $val_table = 0;
- $ver_table = 1;
- $ver_tdcmask = 0;
- next;
- }
- elsif(/^(\s+)?!Version\stdcmask/){
- $reg_table = 0;
- $val_table = 0;
- $ver_table = 0;
- $ver_tdcmask = 1;
- next;
- }
-
- if($reg_table){
- my ($type, @reg) = split(" ", $_);
- my $reg = \@reg;
- $mb_type->{$type} = $reg;
- }
- elsif($val_table){
- # We assume here that reg_table was before val_table
- # thus mb_type hash is already filled at this point.
-
- my ($addr, $type, @val) = split(" ", $_);
-
- if( ! defined $mb_type->{$type} ){
- print "Error: Board type '$type' specified in 'Value table' in $register\n";
- print "is most likely not defined in 'Register table'! Exit.\n";
- $fh->close;
- exit(1);
- }
-
- my $arr_size = scalar @{ $mb_type->{$type} };
-
- for(my $i=0; $i<$arr_size; $i++){
- my $reg = @{$mb_type->{$type}}[$i];
- my $val = $val[$i];
-
- push(@{$reg_hash{$addr}}, {$reg => $val});
- }
- }
- elsif($ver_table){
- $data2ora_href->{"MDC"}->{"THRESH_VERS"} = $_ if( $subsys eq "mdc");
- $data2ora_href->{"RICH"}->{"THRESH_VERS"} = $_ if( $subsys eq "rich");
- }
- elsif($ver_tdcmask){
- $data2ora_href->{"MDC"}->{"TDCMASK_VERS"} = $_ if( $subsys eq "mdc");
- }
- }
-
- $fh->close;
-
- #--------------- Write config file
- my $outConf_register = $var_dir . "/tmp/" . $outConf;
- my $ret_register = "/home/hadaq/tmp/" . $outConf;
-
- $fh = new FileHandle(">$outConf_register");
-
- foreach my $addr ( sort keys %{$reg_href} ){
- foreach my $ref (@{$reg_href->{$addr}}){
- my ($reg, $thr) = each( %{$ref} );
-
- print $fh "w $addr $reg $thr\n";
- }
- }
-
- $fh->close;
-
- return $ret_register;
-}
-
-sub makeAddressesConf()
-{
- my ($subsys, $serials, $addresses, $outConf) = @_;
-
- $serials = "../" . $subsys . "/" . $serials;
- $addresses = "../" . $subsys . "/" . $addresses;
-
- my %trbdhcp_hash;
- my $trbdhcp_href = \%trbdhcp_hash;
-
- #------------ Read addresses into trbdhcp hash
- my $fh = new FileHandle("$addresses", "r");
- &isItDefined($fh, $addresses);
-
- my $SPACE = "";
-
- while(<$fh>){
-
- #- Remove all comments
- $_ =~ s{ # Substitue...
- \# # ...a literal octothorpe
- [^\n]* # ...followed by any number of non-newlines
- }
- {$SPACE}gxms; # Raplace it with a single space
-
- #- Skip line if it contains only whitespaces
- next unless(/\S/);
-
- my ($addr, $serial, $endpoint, $design, $trbNr) = split(" ", $_);
-
- #- All fields must be defined
- next unless( defined $design && defined $addr &&
- defined $serial && defined $endpoint);
-
- #- Skip all lines with serial number zero
- next if( $serial eq '0' );
-
- #- Define uniqueu key
- my $key = $addr . "_" . $endpoint;
-
- $trbdhcp_href->{$key}->{'addr'} = lc($addr);
- $trbdhcp_href->{$key}->{'design'} = $design;
- $trbdhcp_href->{$key}->{'endpoint'} = $endpoint;
- $trbdhcp_href->{$key}->{'serial'} = $serial;
- $trbdhcp_href->{$key}->{'trb'} = $trbNr;
-
- }
-
- $fh->close;
-
- #------------ Read serials into trbdhcp hash
- $fh = new FileHandle("$serials", "r");
- &isItDefined($fh, $serials);
-
- while(<$fh>){
-
- #- Remove all comments
- $_ =~ s{ # Substitue...
- \# # ...a literal octothorpe
- [^\n]* # ...followed by any number of non-newlines
- }
- {$SPACE}gxms; # Raplace it with a single space
-
- #- Skip line if it contains only whitespaces
- next unless(/\S/);
-
- my ($serial, $uid) = split(" ", $_);
-
- next unless( defined $serial && defined $uid );
-
- #- Skip all lines with serial number zero
- next if( $serial eq '0' );
-
- foreach my $key ( keys %{$trbdhcp_href} ){
-
- next unless( $serial eq $trbdhcp_href->{$key}->{'serial'} );
- $trbdhcp_href->{$key}->{'uid'} = lc($uid);
- }
- }
-
- $fh->close;
-
- #------------ Write config file for 'trbdhcp'
- my $outConf_trbdhcp = $var_dir . "/tmp/" . $outConf;
- my $ret_trbdhcp = "/home/hadaq/tmp/" . $outConf;
-
- $fh = new FileHandle(">$outConf_trbdhcp");
-
- foreach my $key (sort keys %$trbdhcp_href) {
- my $addr = $trbdhcp_href->{$key}->{'addr'};
- my $uid = $trbdhcp_href->{$key}->{'uid'};
- my $endpoint = $trbdhcp_href->{$key}->{'endpoint'};
-
- next if( ! defined $addr || ! defined $uid || ! defined $endpoint);
-
- print $fh "$addr $uid $endpoint\n";
- }
-
- $fh->close;
-
- #--- Add this hash to a global hash
- %addr_db_conf = (%addr_db_conf, %$trbdhcp_href);
-
- return $ret_trbdhcp;
-}
-
-sub checkCompileTime()
-{
- my ($cmd) = @_;
-
- my $sys;
- my $compile_time;
-
- if($cmd =~ /check_compile_time\s+(\w+)\s+0x(\w+)/){
- $sys = lc($1);
- $compile_time = hex($2);
- }
-
- unless( defined $sys || defined $compile_time ){
- die "check_compile_time command must contain system and compile time as arguments! Exit.\n";
- }
-
- my $read_cmd = "";
- if(lc($sys) eq "oep"){
- $read_cmd = "trbcmd r 0xfffd 0x40";
- }
- else{
- print "Reading compile times failed: unsupported sys type $sys\n";
- return 0;
- }
-
- my @out = `$read_cmd`;
-
- my $oldCompileTime = 0;
-
- foreach my $line (@out){
-
- next if($line =~ /Read compile time/ );
-
- if( $line =~ /failed/ ){
- print "ERROR: when reading compile times of $sys: $line\n";
- &askUser();
- }
-
- my $local_time;
- my $local_addr;
-
- if( $line =~ /0x(\w+)\s+0x(\w+)/ ){
- $local_addr = lc($1);
- $local_time = hex($2);
- }
-
- unless( defined $local_addr || defined $local_time ){
- print "ERROR: unexpected output: $line\n from command: $read_cmd\n";
- &askUser();
- }
-
- if( defined $local_time && defined $local_addr){
- if( $local_time < $compile_time ){
- $oldCompileTime = 1;
- print "Compile time for $sys $local_addr is too old!\n";
- }
- }
- }
-
- &askUser() if($oldCompileTime);
-}
-
-sub askUser()
-{
- my $answer = &promptUser("Continue?", "Enter to continue, Ctrl+C to stop");
- if( $answer eq "no" || $answer eq "n" ){
- print "Exit.\n";
- exit(0);
- }
- else{
- print "Continue...\n";
- }
-}
-
-sub checkConnection()
-{
-
- #----------- Check connection to hosts -------------
- print "Check connection to hosts...\n";
-
- my @dead_hosts = ();
- my @alive_hosts = ();
- &pingHosts(\@alive_hosts, \@dead_hosts);
-
- if( @dead_hosts ){
- print "Cannot connect to the following hosts:\n";
-
- foreach my $host (@dead_hosts){
-
- my $msg = "undef";
- if($host =~ /etraxp?(\d{3})/){
- my $serial = $1;
-
- if(&checkShowerNORPC($host)){
- $msg = "addr: - type: -";
- }
- else{
- $msg = &serial2addrAndSysType($serial, "TRB");
- }
- }
-
- print "$host $msg\n";
- system("logger -p local1.info -t DAQ STARTUP \\<E\\> Cannot connect to $host $msg");
- }
-
- &askUser();
- }
- else{
- print "Connection to hosts is OK.\n";
- }
-
- #---------- Check connection to command servers -------------
-# print "Check connection to command servers...\n";
-
-# my @dead_cservers = ();
-
-# &checkCmdServers(\@alive_hosts, \@dead_cservers);
-
- if( @dead_cservers ){
- print "Cannot connect to command servers for the hosts:\n";
-
- foreach my $host (@dead_cservers){
- print "$host\n";
- system("logger -p local1.info -t DAQ STARTUP \\<E\\> Cannot connect to command server at $host");
- }
-
- print "I will try to restart the command servers\n";
-
- &restartCmdServers(\@dead_cservers);
-
- @dead_cservers = ();
-
- &pingHosts(\@alive_hosts, \@dead_cservers);
-
- if( @dead_cservers ){
- print "Still cannot connect to command servers for the hosts:\n";
-
- foreach my $host (@dead_cservers){
- print "$host\n";
- }
-
- print "Try to start \'command_server -p 4712 &\' on these hosts by hand.\n";
- print "Exit.\n";
- exit(0);
- }
- else{
- print "Missing command_servers have been started! Continue...\n";
- sleep(2);
- }
-
- }
- else{
- print "Connection to command servers is OK.\n";
- }
- if( @dead_hosts ){
- &rmDeadHosts(\@dead_hosts);
- }
-}
-
-sub rmDeadHosts()
-{
- my ($dead_hosts_aref) = @_;
-
- #my $copy = clone($some_ref);
-
- foreach my $sys (%$trb_href){
-
- next unless( defined @{$trb_href->{$sys}} && $#{$trb_href->{$sys}} > 0 );
-
- foreach my $host (@$dead_hosts_aref){
- @{$trb_href->{$sys}} = grep { !($_ eq $host) } @{$trb_href->{$sys}};
- }
- }
-}
-
-
-
-sub promptUser {
-#----------------------------( promptUser )-----------------------------
-#
-# FUNCTION: promptUser
-#
-# PURPOSE: Prompt the user for some type of input, and return the
-# input back to the calling program.
-#
-# ARGS: $promptString - what you want to prompt the user with
-# $defaultValue - (optional) a default value for the prompt
-#
-# EXAMPLES:
-# $username = &promptUser("Enter the username ");
-# $password = &promptUser("Enter the password ");
-# $homeDir = &promptUser("Enter the home directory ", "/home/$username");
-# print "$username, $password, $homeDir\n";
-#
-#-------------------------------------------------------------------------
- # two possible input arguments - $promptString, and $defaultValue
- # make the input arguments local variables.
-
- my ($promptString,$defaultValue) = @_;
-
- # if there is a default value, use the first print statement; if
- # no default is provided, print the second string.
-
- if ($defaultValue) {
- print $promptString, "[", $defaultValue, "]: ";
- } else {
- print $promptString, ": ";
- }
-
- $| = 1; # force a flush after our print
- my $input = <STDIN>; # get the input from STDIN (presumably the keyboard)
-
- # remove the newline character from the end of the input the user gave us
-
- chomp($input);
-
- # if we had a $default value, and the user gave us input, then
- # return the input; if we had a default, and they gave us no
- # no input, return the $defaultValue.
- #
- # if we did not have a default value, then just return whatever
- # the user gave us. if they just hit the <enter> key,
- # the calling routine will have to deal with that.
-
- if ("$defaultValue") {
- return $input ? $input : $defaultValue; # return $input if it has a value
- } else {
- return $input;
- }
-}
-
-sub pingHosts()
-{
- my ($alive_hosts_aref, $dead_hosts_aref) = @_;
- my @thread_list = ();
- my @host_tmp_list = ();
-
- foreach my $sys (%$trb_href){
- foreach my $host ( @{$trb_href->{$sys}} ){
-
- next if(any {$host eq $_} @host_tmp_list); # Exclude hosts which were already checked
- push(@thread_list, threads->new( \&pingHost, $host));
- push(@host_tmp_list, $host);
- }
- }
-
- #- Join threads
- my $retcode;
-
- foreach my $t (@thread_list){
- $retcode = $t->join();
-
- next if($retcode eq -1);
-
- my ($host, $hstat) = split(/:/, $retcode);
-
- if( $hstat eq "alive" ){
- push( @$alive_hosts_aref, $host );
- }
- elsif( $hstat eq "dead" ){
- push( @$dead_hosts_aref, $host );
- }
- elsif( $hstat eq "cmdserverdead" ){
- push( @$alive_hosts_aref, $host );
- push( @dead_cservers, $host );
- }
- else{
- print "ping $host returned unknown status: $hstat. Exit.\n";
- exit(0);
- }
- }
-}
-
-sub pingHost()
-{
- my ($host) = @_;
-
- my $retval = "undef";
-# print $host." ".Time::HiRes::time()."\n" ;
- my $p = Net::Ping->new();
-
- if( $p->ping($host,1) ){
- $retval = "$host:alive";
- }
- else{
- $retval = "$host:dead";
- return $retval;
- }
- $p->close();
-# print $host." ".Time::HiRes::time()."\n" ;
- #Jan 06.01.12
- my $sock = new IO::Socket::INET (
- PeerAddr => $host,
- PeerPort => $cmd_server_port,
- Proto => 'tcp');
- $retval = "$host:cmdserverdead" unless $sock;
- close($sock) if( defined $sock );
- #Jan 06.01.12
-#print $host." ".Time::HiRes::time()."\n" ;
- return $retval;
-}
-
-# sub checkCmdServers()
-# {
-# my ($alive_hosts_aref, $dead_cservers_aref) = @_;
-#
-# foreach my $host (@$alive_hosts_aref){
-# my $sock = new IO::Socket::INET (
-# PeerAddr => $host,
-# PeerPort => $cmd_server_port,
-# Proto => 'tcp');
-# push( @$dead_cservers_aref, $host ) unless $sock;
-# close($sock) if( defined $sock );
-# }
-# }
-
-sub execViaExpect()
-{
- my ($etrax, $path, $cmd, $args, $log) = @_;
-
- my $exe = "$expect_script $etrax $path $cmd $args > $log 2>&1";
- print "exe: $exe\n" if($opt_verb);
- system($exe) unless($opt_test);
-}
-
-sub restartCmdServers()
-{
- my ($dead_cservers_aref) = @_;
-
- my $path = "/home/hadaq/bin/";
-
- foreach my $host (@$dead_cservers_aref){
- my $log = $log_dir . "/expect_" . $host . ".log";
- &execViaExpect( $host, $path, "command_server", "\'-p 4712 &\'", $log);
- }
-}
-
-sub data2ora()
-{
-
- #- Read unique IDs
- my @id_list = `trbcmd i 0xffff`;
-
- foreach my $id_line (@id_list){
-
- if( $id_line =~ /failed/ ){
- print "ERROR: data2ora(): 'daqop read ids' failed! Exit.\n";
- exit(1);
- }
-
- if( $id_line =~ /0x(\w+)\s+0x(\w+)\s+0x(\w+)/ ){
- my $addr = lc($1);
- my $uid = lc($2);
- my $fpga = $3;
-
- #- There are boards with several FPGAs
- # These boards have identical Ids but several different
- # trbnet addresses (three addresses for the board with three FPGAs)
- # The smallest address is of importance for us because it is an address
- # of FPGA which sends the data out (uplink). Thus the smallest
- # address is the address of the data source.
- if( defined $data2ora_href->{"BOARDID"}->{$uid} ){
- if( hex($addr) < hex($data2ora_href->{"BOARDID"}->{$uid}->{'ADDR'}) ){
- $data2ora_href->{"BOARDID"}->{$uid}->{'ADDR'} = $addr;
- }
- }
- else{
- $data2ora_href->{"BOARDID"}->{$uid}->{'ADDR'} = $addr;
- }
- }
- }
-
- #-------- Write data to a file to be passed to Oracle
-
- my $timestamp = &timeStamp();
- my $ora_file = "/home/hadaq/oper/daq2ora/daq2ora_" . $timestamp . ".txt";
- my $current_file = "/home/hadaq/oper/daq2ora/daq2ora_current.txt";
-
- #- Read settings with resolution mode of TRBs
- my $TDCsettings_href = &readTRBTDCsettings();
-
- open( FILE, '>', $ora_file ) or die "Could not open $ora_file: $!" if($opt_ora eq "file");
-
- #- Write threshold file names
- my $line_thresh = &cpThresholds($timestamp);
- if( $line_thresh =~ /loaded_thresholds/){
- #print FILE $line_thresh;
- }
-
- foreach my $uid ( sort keys %{$data2ora_href->{"BOARDID"}} ){
- my $addr = $data2ora_href->{"BOARDID"}->{$uid}->{'ADDR'};
- my $subevtid;
-
- if( any {lc($_) eq lc($addr)} @subEvtIds ){
- $subevtid = lc($addr);
- }
- else{
- $subevtid = "NULL";
- }
-
- #- Get TRB resolution mode (returns 0 if the board is not TRB)
- my $mode = &getTRBResolutionMode($TDCsettings_href, lc($addr));
-
- my $outdata = sprintf("%19s %6s %6s %4s", $uid, $addr, $subevtid, $mode);
-
- print "data2ora: $outdata\n" if($opt_ora eq "file" && $opt_verb);
- print FILE "$outdata\n" if($opt_ora eq "file");
-
- #- If mode == 0x00 it not necessary to write these zeros to the register
- # because '00' is the default value of the register.
- unless( $mode eq "NULL" || $mode == 0 ){
- my $cmd = "/home/hadaq/scripts/set_modrc.sh 0x$mode 0x$addr 0xa0c2";
- #my $host = @{$trb_href->{"scs"}}[0]; # CTS Etrax name;
- my $host = "localhost"; # pexor slow control interface;
- my $log = $log_dir . "/mode/modrc_" . $host . ".log";
- &connectCmdServer($cmd, $host, $cmd_server_port, $cmd_server_prtcl, $log);
- }
- }
-
- if( defined $data2ora_href->{"MDC"}->{"THRESH_VERS"} ){
- my $var = $data2ora_href->{"MDC"}->{"THRESH_VERS"};
- print FILE "mdc_thresh_version $var\n" if($opt_ora eq "file");
- }
-
- if( defined $data2ora_href->{"MDC"}->{"TDCMASK_VERS"} ){
- my $var = $data2ora_href->{"MDC"}->{"TDCMASK_VERS"};
- print FILE "mdc_tdcmask_version $var\n" if($opt_ora eq "file");
- }
-
- if( defined $data2ora_href->{"RICH"}->{"THRESH_VERS"} ){
- my $var = $data2ora_href->{"RICH"}->{"THRESH_VERS"};
- print FILE "rich_thresh_version $var\n" if($opt_ora eq "file");
- }
-
- close( FILE ) or die "Could not close $ora_file: $!" if($opt_ora eq "file");
-
- system("cp $ora_file $current_file") if($opt_ora eq "file");
-}
-
-sub readTRBTDCsettings()
-{
- #-------- Read TRB TDC settings
- my $config_file = "/var/diskless/etrax_fs/trbtdctools/config/TRB_TDC_settings.conf";
-
- my $TDCsettings_href;
-
- unless( $TDCsettings_href = do $config_file ){
- die "Couldn't parse $config_file: $@, stopped" if $@;
- die "Couldn't do $config_file: $!, stopped" unless defined $TDCsettings_href;
- die "Couldn't run $config_file, stopped" unless $TDCsettings_href;
- }
-
- return $TDCsettings_href;
-}
-
-sub getTRBResolutionMode()
-{
- my ($TDCsettings_href, $addr) = @_;
-
- my $mode;
-
- my $board_type;
- my $board_sysType;
- &boardSysType(lc($addr), \$board_type, \$board_sysType);
-
- if( $board_type eq "TRB" && $board_sysType ne "CTS" && (&excludeBoards($addr)) ){
- my $serial = &addr2serial(lc($addr));
- $mode = &resMode($TDCsettings_href, $serial);
- }
- else{
- $mode = "NULL";
- }
-
- return $mode;
-}
-
-sub resMode()
-{
- my ($TDCsettings_href, $serial) = @_;
-
- my $trbname = sprintf("TRB_%03d", $serial);
-
- my $mrcc_a = $TDCsettings_href->{$trbname}->{'TDC'}->{'TDC_A'}->{'mode_rc_compression'};
- my $mrc_a = $TDCsettings_href->{$trbname}->{'TDC'}->{'TDC_A'}->{'mode_rc'};
- my $mrcc_b = $TDCsettings_href->{$trbname}->{'TDC'}->{'TDC_B'}->{'mode_rc_compression'};
- my $mrc_b = $TDCsettings_href->{$trbname}->{'TDC'}->{'TDC_B'}->{'mode_rc'};
- my $mrcc_c = $TDCsettings_href->{$trbname}->{'TDC'}->{'TDC_C'}->{'mode_rc_compression'};
- my $mrc_c = $TDCsettings_href->{$trbname}->{'TDC'}->{'TDC_C'}->{'mode_rc'};
- my $mrcc_d = $TDCsettings_href->{$trbname}->{'TDC'}->{'TDC_D'}->{'mode_rc_compression'};
- my $mrc_d = $TDCsettings_href->{$trbname}->{'TDC'}->{'TDC_D'}->{'mode_rc'};
-
- my $mode_undefined = 0;
-
- unless( defined $mrcc_a ){
- $mode_undefined = 1;
- print "ERROR: $trbname, TDC_A: mode_rc_compression is not defined! Exit.\n";
- }
- unless( defined $mrc_a ){
- $mode_undefined = 1;
- print "ERROR: $trbname, TDC_A: mode_rc is not defined! Exit.\n";
- }
- unless( defined $mrcc_b ){
- $mode_undefined = 1;
- print "ERROR: $trbname, TDC_B: mode_rc_compression is not defined! Exit.\n";
- }
- unless( defined $mrc_b ){
- $mode_undefined = 1;
- print "ERROR: $trbname, TDC_B: mode_rc is not defined! Exit.\n";
- }
- unless( defined $mrcc_c ){
- $mode_undefined = 1;
- print "ERROR: $trbname, TDC_C: mode_rc_compression is not defined! Exit.\n";
- }
- unless( defined $mrc_c ){
- $mode_undefined = 1;
- print "ERROR: $trbname, TDC_C: mode_rc is not defined! Exit.\n";
- }
- unless( defined $mrcc_d ){
- $mode_undefined = 1;
- print "ERROR: $trbname, TDC_D: mode_rc_compression is not defined! Exit.\n";
- }
- unless( defined $mrc_d ){
- $mode_undefined = 1;
- print "ERROR: $trbname, TDC_D: mode_rc is not defined! Exit.\n";
- }
-
- #- All four TDCs must have identical modes
- unless( $mode_undefined ){
- unless( $mrcc_a == $mrcc_b && $mrcc_a == $mrcc_c && $mrcc_a == $mrcc_d &&
- $mrc_a == $mrc_b && $mrc_a == $mrc_c && $mrc_a == $mrc_d ){
- print "ERROR: $trbname, resolution modes must be identical for all four TDCs! Exit.\n";
- }
- }
-
- if( $mode_undefined ){
- exit(1);
- }
-
- # Description of the resolution modes:
- #
- # mrcc = mode_rc_compression
- # mrc = mode_rc
- #
- # mrcc mrc mode
- # 0 0 00 - high resolution mode (100ps binning)
- # 1 1 01 - very high resolution mode (25ps binning)
- # 0 1 02 - very high resolution mode calibration data
- # (one hit produces 4 data words like in high resolution mode)
-
- my $mode;
-
- if( $mrcc_a eq "0" && $mrc_a eq "0" ){
- $mode = "00";
- }
- elsif( $mrcc_a eq "1" && $mrc_a eq "1" ){
- $mode = "01";
- }
- elsif( $mrcc_a eq "0" && $mrc_a eq "1" ){
- $mode = "02";
- }
- else{
- print "ERROR: $trbname, resolution modes have wrong values! Exit.\n";
- }
-
- return $mode;
-}
-
-sub addr2serial()
-{
- my ($addr) = @_;
-
- my $serial;
-
- my $addr_hex = "0x" . lc($addr);
-
- foreach my $key ( keys %$addr_db_conf_href ){
- if( $addr_db_conf_href->{$key}->{'addr'} eq $addr_hex ){
- unless( defined $addr_db_conf_href->{$key}->{'serial'} ){
- next;
- }
-
- $serial = $addr_db_conf_href->{$key}->{'serial'};
- last;
- }
- }
-
- unless( defined $serial ){
- print "ERROR: addr2serial(): unknown serial number for address $addr. Exit.\n";
- exit(1);
- }
-
- return $serial;
-}
-
-sub checkShowerNORPC()
-{
- my ($trb) = @_;
-
- my $retVal = 0;
-
- unless(defined $trb_href->{'rpc'}){
- if(any {$trb eq $_} @{$trb_href->{'shower'}}){
- $retVal = 1;
- }
- }
-
- return $retVal;
-}
-
-sub serial2addrAndSysType()
-{
- my ($serial, $board_type) = @_;
-
- # There is no direct connection between serial number
- # and TRB-Net address. One should provide board type
- # in addition to serial number.
-
- my $addr;
- my $bType;
- my $bSysType;
-
- foreach my $key ( keys %$addr_db_conf_href ){
- next unless( defined $addr_db_conf_href->{$key}->{'serial'} );
- next unless( defined $addr_db_conf_href->{$key}->{'trb'} );
-
- if( $addr_db_conf_href->{$key}->{'serial'} == $serial &&
- $addr_db_conf_href->{$key}->{'serial'} == $addr_db_conf_href->{$key}->{'trb'} ){
- unless( defined $addr_db_conf_href->{$key}->{'addr'} ){
- next;
- }
-
- $addr = $addr_db_conf_href->{$key}->{'addr'};
-
- &boardSysType($addr, \$bType, \$bSysType);
-
- next unless($bType eq $board_type);
-
- last;
- }
- }
-
- unless( defined $addr ){
- print "ERROR: serial2addr(): unknown address for serial number $serial.\n";
- #exit(1);
- }
-
- unless( defined $bSysType ){
- print "ERROR: serial2addr(): unknown board system type for serial number $serial.\n";
- #exit(1);
- }
-
- my $retval = "";
- if( defined $addr && defined $bSysType ){
- $retval = "addr: $addr type: $bSysType";
- }
-
- return $retval;
-}
-
-sub excludeBoards()
-{
- my ($addr) = @_;
-
- # This subroutine excludes boards which have unused TDCs
- # and those TDCs must not be configured. Moreover the corresponding
- # register should not be overwritten with TDC resoltuion mode value.
-
- # Exclude all CTS and SCS boards
- my $board_sys;
- my $retval = 1;
-
- foreach my $sys ( keys %$addressRange_href ){
- my $addr_min = lc($addressRange_href->{$sys}->{'MIN'});
- my $addr_max = lc($addressRange_href->{$sys}->{'MAX'});
-
- if( hex(lc($addr)) >= hex($addr_min) && hex(lc($addr)) <= hex($addr_max) ){
- $board_sys = $addressRange_href->{$sys};
- last;
- }
- }
-
- unless( defined $board_sys ){
- print "TRB-Net address $addr is outside of the known address ranges! Exit.\n";
- exit(0);
- }
-
- if( $board_sys eq "CTS" || $board_sys eq "SCS" ){
- $retval = 0;
- }
-
- return $retval;
-}
-
-sub boardSysType()
-{
- my ($addr, $bType_ref, $bSysType_ref) = @_;
-
- foreach my $sys ( keys %$addressRange_href ){
- my $addr_min = lc($addressRange_href->{$sys}->{'MIN'});
- my $addr_max = lc($addressRange_href->{$sys}->{'MAX'});
-
- if( hex(lc($addr)) >= hex($addr_min) && hex(lc($addr)) <= hex($addr_max) ){
- $$bType_ref = $addressRange_href->{$sys}->{'TYPE'};
- $$bSysType_ref = $sys;
- last;
- }
- }
-
- unless( defined $$bType_ref ){
- print "ERROR: boardSysType(): unknown board type for address $addr.\n";
- $$bType_ref = "undef";
- }
-
- unless( defined $$bSysType_ref ){
- print "ERROR: boardSysType(): unknown board system type for address $addr.\n";
- $$bSysType_ref = "undef";
- }
-}
-
-sub boardType()
-{
- my ($addr) = @_;
-
- my $board_type;
-
- foreach my $sys ( keys %$addressRange_href ){
- my $addr_min = lc($addressRange_href->{$sys}->{'MIN'});
- my $addr_max = lc($addressRange_href->{$sys}->{'MAX'});
-
- if( hex(lc($addr)) >= hex($addr_min) && hex(lc($addr)) <= hex($addr_max) ){
- $board_type = $addressRange_href->{$sys}->{'TYPE'};
- last;
- }
- }
-
- unless( defined $board_type ){
- print "ERROR: boardType(): unknown board type for address $addr. Exit.\n";
- exit(1);
- }
-
- return $board_type;
-}
-
-sub timeStamp()
-{
- my ($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) = localtime($seconds1);
- my $timestamp = sprintf("%4d-%02d-%02d_%02d.%02d.%02d",
- $year+1900, $mon+1, $mday, $hour, $min, $sec);
-
- return $timestamp;
-}
-
-sub scanLogs()
-{
- #- Check the log files which were created
- # after DAQ restart (after $seconds)
-
- opendir(DIR, $log_dir) or die "Could not open $log_dir: $!";;
- my @logfile_list = grep(/^log/, readdir(DIR));
- closedir(DIR);
-
- #- Sort files by modification date
- @logfile_list = sort { -M "$log_dir/$a" <=> -M "$log_dir/$b" } (@logfile_list);
-
- my $errorFound = 0;
-
- foreach my $file (@logfile_list){
-
- #- Modification date in seconds since EPOCH
- my $seconds2 = (stat "$log_dir/$file")[9];
-
- if( $seconds2 > $seconds1 ){
- if(&scanLogFile("$log_dir/$file")){
- $errorFound = 1;
- }
- }
- }
-
- if($errorFound){
- &askUser();
- }
-
- #- Update time.
- # We want to look only at the log files
- # which were not checked before.
- $seconds1 = time;
-}
-
-sub scanLogFile()
-{
- my ($logFile) = @_;
-
- my $retval = 0;
-
- open(DAT, $logFile) || die("Could not open $logFile!");
- my @log_data = <DAT>;
- close(DAT);
-
- if( any {$_ =~ /TX Busy/} @log_data ){
- print "Found \'TX Busy\' in $logFile. Press Ctrl-C and try again!\n";
- system("logger -p local1.info -t DAQ STARTUP \\<E\\> Found \'TX Busy\' in $logFile");
- $retval = 1;
- }
-
- if( any {$_ =~ /Verification Failure/} @log_data ){
- print "Found \'Verification Failure\' in $logFile. Problem with jam-programming?\n";
- system("logger -p local1.info -t DAQ STARTUP \\<E\\> Found \'Verification Failure\' in $logFile");
- $retval = 1;
- }
-
- if( any {$_ =~ /Fifo not empty/} @log_data ){
- print "Found \'Fifo not empty\' in $logFile. Problem with TRB-Net?\n";
- system("logger -p local1.info -t DAQ STARTUP \\<E\\> \'Fifo not empty\' in $logFile");
- $retval = 1;
- }
-
- if( any {$_ =~ /command not found/} @log_data ){
- print "Found \'command not found\' in $logFile. Problem with environment settings?\n";
- system("logger -p local1.info -t DAQ STARTUP \\<E\\> \'command not found\' in $logFile");
- $retval = 1;
- }
-
- if( any {$_ =~ /file not found/} @log_data ){
- print "Found \'file not found\' in $logFile. Problem with environment settings?\n";
- system("logger -p local1.info -t DAQ STARTUP \\<E\\> \'file not found\' in $logFile");
- $retval = 1;
- }
-
- if( any {$_ =~ /No such file or directory/} @log_data ){
- print "Found \'No such file or directory\' in $logFile. Problem with missing file?\n";
- system("logger -p local1.info -t DAQ STARTUP \\<E\\> \'No such file or directory\' in $logFile");
- $retval = 1;
- }
-
- if( any {$_ =~ /Permission denied/} @log_data ){
- print "Found \'Permission denied\' in $logFile. Problem with permission settings?\n";
- system("logger -p local1.info -t DAQ STARTUP \\<E\\> \'Permission denied\' in $logFile");
- $retval = 1;
- }
- if( any {$_ =~ /RPC/} @log_data ){
- print "Found \'Remote Procedure Call (RPC) Error\' in $logFile. Problem with trbnet deamon?\n";
- system("logger -p local1.info -t DAQ STARTUP \\<E\\> \'Remote Procedure Call (RPC) Error\' in $logFile");
- $retval = 1;
- }
- if( any {$_ =~ /(DMA|SEMAPHORE|PEXOR)/i} @log_data ){
- print "Found \'DMA/Semaphore/Pexor Error\' in $logFile. Problem with PEXOR?\n";
- system("logger -p local1.info -t DAQ STARTUP \\<E\\> \'Logfile shows DMA/Semaphore/Pexor Error\' in $logFile");
- $retval = 1;
- }
-
- return $retval;
-}
-
-sub forkStatusServer()
-{
- my $child = fork();
-
- if( $child ){ # parent
- }
- elsif( $child == 0 ) { # child
- &statusServer();
- exit(0); # exit child
- }
- else{
- print "Could not fork statusServer: $!\n";
- exit(1);
- }
-
- return $child;
-}
-
-sub statusServer()
-{
-
- #- socket for broadcast
- my $sock_udp = IO::Socket::INET->new(PeerPort => 1960,
- PeerAddr => "192.168.103.255",
- Proto => 'udp',
- LocalAddr => "192.168.100.50",
- Broadcast => 1,
- Reuse => 1)
- or die "Can't bind : $@\n";
-
- #- Inform all clients that DAQ is being restarted
- $sock_udp->send("STARTING") or die("Socket send error $!");
- close($sock_udp);
-
- #- Start TCP server
- my $sock = new IO::Socket::INET( LocalAddr => "192.168.100.50",
- LocalPort => 1972,
- Proto => 'tcp',
- Listen => SOMAXCONN,
- Reuse => 1);
-
- $sock or die "Cannot bind socket :$!";
-
- STDOUT->autoflush(1);
-
- my($new_sock, $buf);
-
- my $selector = new IO::Select( $sock );
-
- while(1) {
-
- # wait 3 seconds for connections
- while (my @file_handles = $selector->can_read( 3 )) {
-
- foreach my $file_handle (@file_handles) {
-
- if($file_handle == $sock) {
-
- # create a new socket for this transaction
- unless (defined( $new_sock = $sock->accept() ))
- {
- print "statusServer: ERROR - Cannot open socket to send status!\n";
- return;
- }
-
- while (defined($buf = <$new_sock>)) {
- #print "client asked: $buf";
- if($buf =~ /MON_HUB: STILL STARTING\?/){
- $new_sock->send("STARTING\n") or die("Socket send error $!");
- }
-
- unless( kill(0, $parent_pid) ){
- print "Exit status server thread.\n";
- close( $new_sock );
- close( $sock );
- exit(0);
- }
- }
-
- close( $new_sock );
- }
- }
-
- unless( kill(0, $parent_pid) ){
- print "Exit status server thread.\n";
- close( $sock );
- exit(0);
- }
- }
-
- unless( kill(0, $parent_pid) ){
- print "Exit status server thread.\n";
- close( $sock );
- exit(0);
- }
- }
-}
-
-sub closeEBs()
-{
- print "Kill EBs...";
-# system("cd ../evtbuild/; ./start_eb_gbe.pl -e stop -n 1-16");
- print "\n";
-}
-
-sub startEBs()
-{
- print "Start EBs...\n";
-# system("cd ../evtbuild/; ./start_eb_gbe.sh");
- print "\n";
-}
jspc29 / daqtools.git / commitdiff