From fbdccb0be80d99fbafaa3916bb8738bf84dc224c Mon Sep 17 00:00:00 2001 From: Jan Michel Date: Thu, 17 Oct 2013 14:39:44 +0200 Subject: [PATCH] added new put function to xml GUI --- web/htdocs/commands/xmlpage.pm | 19 +++- xml-db/database/TDC.xml | 8 +- xml-db/get.pl | 54 +++++++----- xml-db/put.pl | 155 +++++++++++++++++++++++++++++++++ 4 files changed, 207 insertions(+), 29 deletions(-) create mode 100755 xml-db/put.pl diff --git a/web/htdocs/commands/xmlpage.pm b/web/htdocs/commands/xmlpage.pm index 72b3120..9bec500 100644 --- a/web/htdocs/commands/xmlpage.pm +++ b/web/htdocs/commands/xmlpage.pm @@ -13,8 +13,11 @@ sub getView { if($setup[$n]->{refresh}) { print qq||; } - print qq||; print qq|
|; + print qq||; } @@ -63,7 +66,8 @@ print <
Debug Output
-debug text + +
@@ -75,6 +79,7 @@ EOF + sub printJavaScripts { ####### javascript function land ################ @@ -84,6 +89,16 @@ sub printJavaScripts { EOF } diff --git a/xml-db/database/TDC.xml b/xml-db/database/TDC.xml index ee0f59c..6101970 100644 --- a/xml-db/database/TDC.xml +++ b/xml-db/database/TDC.xml @@ -189,7 +189,7 @@ Resets the internal counters - + Select the trigger mode: With trigger mode or trigger-less mode TRIGGERED @@ -212,11 +212,11 @@ - + Enable signals/hits of the specific channel. LSB is channel 1. - - + + Configuration of the data transfer limit feature diff --git a/xml-db/get.pl b/xml-db/get.pl index 7d335e8..02cd1da 100755 --- a/xml-db/get.pl +++ b/xml-db/get.pl @@ -1,19 +1,16 @@ #!/usr/bin/perl -w -use warnings; -use FileHandle; -use Time::HiRes qw( usleep ); -use Data::Dumper; -use Data::TreeDumper; use HADES::TrbNet; -use Date::Format; -use Pod::Usage; -use Getopt::Long; -use File::chdir; use Storable qw(lock_retrieve); -use Text::TabularDisplay; use feature "switch"; use CGI::Carp qw(fatalsToBrowser); +use if (!defined $ENV{'QUERY_STRING'}), warnings; +use if (!defined $ENV{'QUERY_STRING'}), Pod::Usage; +use if (!defined $ENV{'QUERY_STRING'}), Text::TabularDisplay; +use if (!defined $ENV{'QUERY_STRING'}), Data::Dumper; +use if (!defined $ENV{'QUERY_STRING'}), Data::TreeDumper; +use if (!defined $ENV{'QUERY_STRING'}), Getopt::Long; + my ($db,$data,$once,$slice); my $help = 0; @@ -21,7 +18,7 @@ my $verbose = 0; my $isbrowser = 0; my $server = $ENV{'SERVER_SOFTWARE'} || ""; my @request; -my ($file,$netaddr,$name, $style); +my ($file,$entity,$netaddr,$name, $style); $ENV{'DAQOPSERVER'}="localhost:7" unless (defined $ENV{'DAQOPSERVER'}); @@ -50,15 +47,15 @@ foreach my $req (@request) { if(defined $ENV{'QUERY_STRING'}) { if($server =~ /HTTPi/i) { $isbrowser = 1; - ($file,$netaddr,$name,$style) = split("-",$req); - $file = "htdocs/xml-db/cache/$file.entity"; + ($entity,$netaddr,$name,$style) = split("-",$req); + $file = "htdocs/xml-db/cache/$entity.entity"; } else { # use FindBin qw($RealBin); my $RealBin = "."; $isbrowser = 1; - ($file,$netaddr,$name,$style) = split("-",$req); - $file = "$RealBin/cache/$file.entity"; + ($entity,$netaddr,$name,$style) = split("-",$req); + $file = "$RealBin/cache/$entity.entity"; } } else { @@ -70,7 +67,7 @@ foreach my $req (@request) { 'verbose|v+' => \$verbose, ) or pod2usage(2); pod2usage(1) if $help; - + $entity = $ARGV[0] || ""; $file = "$RealBin/cache/$ARGV[0].entity"; $netaddr = $ARGV[1] || ""; $name = $ARGV[2] || ""; @@ -83,6 +80,8 @@ foreach my $req (@request) { my $sortAddr = $style =~ /sortaddr/i; $verbose = ($style =~ /verbose/i) ||$verbose; + + ############################### #### Check arguments for validity ############################### @@ -116,25 +115,28 @@ foreach my $req (@request) { else { runandprint($db->{$name},$name,$slice,$once); } - } ############################### #### Formatting of values ############################### sub FormatPretty { - my ($value,$obj,$cont,$class) = @_; + my ($value,$obj,$cont,$class,$cstr) = @_; $value = $value >> ($obj->{start}); $value &= ((1<<$obj->{bits})-1); $value = $value * ($obj->{scale}||1) + ($obj->{scaleoffset}||0); $class = "" unless $class; + $cstr = "" unless $cstr; my $ret, my $cl; if (defined $cont) { $cl = "class=\"$class ".($value?"bad":"good")."\"" if ( $obj->{errorflag} && !$obj->{invertflag}); $cl = "class=\"$class ".($value?"good":"bad")."\"" if ( $obj->{errorflag} && $obj->{invertflag}); $cl = "class=\"$class ".($value?"high":"low")."\"" if (!$obj->{errorflag} && !$obj->{invertflag}); $cl = "class=\"$class ".($value?"low":"high")."\"" if (!$obj->{errorflag} && $obj->{invertflag}); + $cl .= sprintf(" title=\"raw: 0x%x\n$cstr\"",$value); + $cl .= sprintf(" cstr=\"$cstr\" raw=\"0x%x\"",$value); + $ret = "<$cont "; for($obj->{format}) { when ("boolean") { @@ -147,7 +149,7 @@ sub FormatPretty { when ("signed") {$ret .= sprintf("$cl>%d",$value);} when ("binary") {$ret .= sprintf("$cl>%0".$obj->{bits}."b",$value);} when ("bitmask") {$ret .= sprintf("$cl>%0".$obj->{bits}."b",$value);} - when ("time") {$ret .= time2str('>%Y-%m-%d %H:%M',$value);} + when ("time") {require Date::Format; $ret .= Date::Format::time2str('>%Y-%m-%d %H:%M',$value);} when ("hex") {$ret .= sprintf("$cl>%8x",$value);} when ("enum") { my $t = sprintf("%x",$value); if (exists $obj->{enumItems}->{$t}) { @@ -169,7 +171,7 @@ sub FormatPretty { when ("signed") {$ret = sprintf("%d",$value);} when ("binary") {$ret = sprintf("%b",$value);} when ("bitmask") {$ret = sprintf("%0".$obj->{bits}."b",$value);} - when ("time") {$ret = time2str('%Y-%m-%d %H:%M',$value);} + when ("time") {require Date::Format; $ret = Date::Format::time2str('%Y-%m-%d %H:%M',$value);} when ("hex") {$ret = sprintf("%8x",$value);} when ("enum") { my $t = sprintf("%x",$value); if (exists $obj->{enumItems}->{$t}) { @@ -229,7 +231,7 @@ sub requestdata { foreach my $k (keys $o) { $data->{$obj->{address}+$slice*$stepsize}->{$k} = $o->{$k}; } - } while(defined $obj->{repeat} && ++$slice < $obj->{repeat}); + } while(!$once && defined $obj->{repeat} && ++$slice < $obj->{repeat}); } } @@ -275,11 +277,17 @@ sub generateoutput { $t .= sprintf("%04x",$data->{$addr}->{$b},$b); if($obj->{type} eq "register") { foreach my $c (@{$obj->{children}}) { - $t .= FormatPretty($data->{$addr}->{$b},$db->{$c},"td",($wr?"editable":"")); + my $fullc = $c; + $fullc .= ".$slice" if ($once != 1 && defined $obj->{repeat}); + my $cstr = sprintf("%s-0x%04x-%s", $entity,$b,$fullc ); + $t .= FormatPretty($data->{$addr}->{$b},$db->{$c},"td",($wr?"editable":""),$cstr); } } elsif($obj->{type} eq "field" || $obj->{type} eq "registerfield") { - $t .= FormatPretty($data->{$addr}->{$b},$obj,"td"); + my $fullc = $name; + $fullc .= ".$slice" if ($once != 1 && defined $obj->{repeat}); + my $cstr = sprintf("%s-0x%04x-%s", $entity,$b,$fullc ); + $t .= FormatPretty($data->{$addr}->{$b},$obj,"td",($wr?"editable":""),$cstr); } } diff --git a/xml-db/put.pl b/xml-db/put.pl new file mode 100755 index 0000000..ad325c8 --- /dev/null +++ b/xml-db/put.pl @@ -0,0 +1,155 @@ +#!/usr/bin/perl -w + +use HADES::TrbNet; +use Storable qw(lock_retrieve); +use feature "switch"; +use CGI::Carp qw(fatalsToBrowser); + +use if (!defined $ENV{'QUERY_STRING'}), warnings; +use if (!defined $ENV{'QUERY_STRING'}), Pod::Usage; +use if (!defined $ENV{'QUERY_STRING'}), Text::TabularDisplay; +use if (!defined $ENV{'QUERY_STRING'}), Data::Dumper; +use if (!defined $ENV{'QUERY_STRING'}), Data::TreeDumper; +use if (!defined $ENV{'QUERY_STRING'}), Getopt::Long; + +my ($db,$data,$once,$slice); +my $help = 0; +my $verbose = 0; +my $isbrowser = 0; +my $server = $ENV{'SERVER_SOFTWARE'} || ""; +my @request; +my ($file,$entity,$netaddr,$fullname, $value); + + +$ENV{'DAQOPSERVER'}="localhost:7" unless (defined $ENV{'DAQOPSERVER'}); +die "can not connect to trbnet-daemon on $ENV{'DAQOPSERVER'}: ".trb_strerror() unless (defined &trb_init_ports()); + + + +if (defined $ENV{'QUERY_STRING'}) { + @request = split("&",$ENV{'QUERY_STRING'}); + unless ($server =~ /HTTPi/i) { + print "Content-type: text/html\n\n"; + } + } +else { + $request[0] = ""; #Dummy entry to run foreach + } + + + + +foreach my $req (@request) { +############################### +#### Check if browser or command line +############################### + + if(defined $ENV{'QUERY_STRING'}) { + if($server =~ /HTTPi/i) { + $isbrowser = 1; + ($entity,$netaddr,$name,$value) = split("-",$req); + $file = "htdocs/xml-db/cache/$entity.entity"; + } + else { + # use FindBin qw($RealBin); + my $RealBin = "."; + $isbrowser = 1; + ($entity,$netaddr,$name,$value) = split("-",$req); + $file = "$RealBin/cache/$entity.entity"; + } + } + else { + # use FindBin qw($RealBin); + my $RealBin = "."; + Getopt::Long::Configure(qw(gnu_getopt)); + GetOptions( + 'help|h' => \$help, + 'verbose|v+' => \$verbose, + ) or pod2usage(2); + pod2usage(1) if $help; + $entity = $ARGV[0] || ""; + $file = "$RealBin/cache/$ARGV[0].entity"; + $netaddr = $ARGV[1] || ""; + $name = $ARGV[2] || ""; + $value = $ARGV[3] || ""; + } + + + +############################### +#### Check arguments for validity +############################### + + die "Entity $file not found.\n" unless(-e $file) ; + + if ($netaddr=~ m/0x([0-9a-fA-F]{4})/) {$netaddr = hex($1);} + elsif ($netaddr=~ m/([0-9]{1,5})/) {$netaddr = $1;} + else {die "Could not parse address $netaddr\n";} + + + if ($name =~ m/^([a-zA-Z0-9]+)\.(\d+)$/) {$name = $1; $slice = $2;} + elsif ($name =~ m/^([a-zA-Z0-9]+)$/) {$name = $1; $slice = 0;} + else {die "Could not parse name $name \n";} + + $db = lock_retrieve($file); + die "Unable to read cache file\n" unless defined $db; + + die "Name not found in entity file\n" unless(exists $db->{$name}); + + die "Object can not be written\n" unless ($db->{$name}->{mode} =~ /w/); + + $value = any2dec($value); + +############################### +#### Main "do the job" +############################### + + writedata($db->{$name},$entity,$name,$slice,$netaddr,$value); + } + + +sub writedata { + my ($obj,$entity,$name,$slice,$netaddr,$value) = @_; + my $stepsize = $obj->{stepsize} || 1; + + unless ($obj->{type} eq "field" || $obj->{type} eq "registerfield") { + print "No valid object name.\n"; + return -1; + } + + my $o = trb_register_read($netaddr,$obj->{address}+$slice*$stepsize); + unless (defined $o) { + print "No valid answer.\n"; + return -2; + } + + foreach my $b (keys $o) { + $old = $o->{$b}; + my $mask = ~(((1<<$obj->{bits})-1) << $obj->{start}); + $old = $old & $mask; + + my $new = $value & ((1<<$obj->{bits})-1); + $new = $new << $obj->{start}; + $new = $new | $old; + trb_register_write($b,$obj->{address}+$slice*$stepsize,$new); + } + } + + +sub any2dec { # converts numeric expressions 0x, 0b or decimal to decimal + + my $argument = $_[0]; + #print "any2dec input argument $argument\n"; + + if ( $argument =~ m/0[bxBX]/) { + return oct $argument; + } else { + return $argument; + } +} + +print "Done\n"; +1; + + + -- 2.43.0