if($setup[$n]->{refresh}) {
print qq|<input type="button" class="stdbutton" onClick="getdataprint('../xml-db/get.pl?|.$setup[$n]->{cmd}.qq|','content',false);" value="Refresh">|;
}
- print qq|<script language="javascript">setTimeout("getdataprint('../xml-db/get.pl?|.$setup[$n]->{cmd}.qq|','content',false,|.$setup[$n]->{period}.qq|)",400);</script>|;
print qq|<div id="content"></div>|;
+ print qq|<script language="javascript">
+ setTimeout("getdataprint('../xml-db/get.pl?|.$setup[$n]->{cmd}.qq|','content',false,|.$setup[$n]->{period}.qq|)",400);
+ document.getElementById("content").addEventListener("click",test,0);
+ </script>|;
}
</div>
<div id="debugpane">
<div class="header">Debug Output</div>
-debug text
+<span id="returntext">
+</span>
</div>
+
sub printJavaScripts {
####### javascript function land ################
<script language="javascript">
+
+ function test(e) {
+ if(e.target.getAttribute("class") && e.target.getAttribute("class").indexOf("editable")!=-1) {
+ var text = e.target.getAttribute("cstr");
+ text += "\\nCurrent Value: "+e.target.innerHTML+" ("+e.target.getAttribute("raw")+")\\n ";
+ var newval = prompt(text,e.target.getAttribute("raw"));
+ getdataprint('../xml-db/put.pl?'+e.target.getAttribute("cstr")+'-'+newval,'returntext',false,0);
+ }
+ }
+
</script>
EOF
}
<field name="ResetCounters" start="8" bits="1" purpose="trigger" mode="w" format="boolean">
<description>Resets the internal counters</description>
</field>
- <field name="TriggerMode" start="0" bits="12" mode="rw" format="enum">
+ <field name="TriggerMode" start="12" bits="1" mode="rw" format="enum">
<description>Select the trigger mode: With trigger mode or
trigger-less mode</description>
<enumItem value="0">TRIGGERED</enumItem>
</field>
</register>
- <memory name="ChannelEnable" address="0002" size="2">
+ <register name="ChannelEnable" address="0002" repeat="2">
<description>Enable signals/hits of the specific channel. LSB is
channel 1.</description>
- <field name="ChannelEnable" start="0" bits="64" format="bitmask" />
- </memory>
+ <field name="ChannelEnable" start="0" bits="32" format="bitmask" />
+ </register>
<register name="DataTransferLimit" address="0004">
<description>Configuration of the data transfer limit feature</description>
#!/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;
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'});
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 {
'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] || "";
my $sortAddr = $style =~ /sortaddr/i;
$verbose = ($style =~ /verbose/i) ||$verbose;
+
+
###############################
#### Check arguments for validity
###############################
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") {
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}) {
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}) {
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});
}
}
$t .= sprintf("<tr><td title=\"raw: 0x%x\">%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);
}
}
--- /dev/null
+#!/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;
+
+
+
jspc29 / daqtools.git / commitdiff