From 1b165cdcf00bc5fd36dde9aeb96e168820f03dc9 Mon Sep 17 00:00:00 2001 From: Andreas Neiser Date: Wed, 17 Jun 2015 16:31:06 +0200 Subject: [PATCH] xml-db: get.pl: Reformat --- xml-db/get.pl | 396 ++++++++++++++++++++++++-------------------------- 1 file changed, 192 insertions(+), 204 deletions(-) diff --git a/xml-db/get.pl b/xml-db/get.pl index 6dd2d2c..8ceaf34 100755 --- a/xml-db/get.pl +++ b/xml-db/get.pl @@ -34,47 +34,43 @@ if (defined $ENV{'QUERY_STRING'}) { @request = split("&",$ENV{'QUERY_STRING'}); unless ($server =~ /HTTPi/i) { print "Content-type: text/html\n\n"; - } - else { + } else { &htsponse(200, "OK"); print "Content-type: text/html; charset=utf-8\r\n\r\n"; - } - } -else { - $request[0] = ""; #Dummy entry to run foreach } +} else { + $request[0] = ""; #Dummy entry to run foreach +} + - foreach my $req (@request) { -############################### -#### Check if browser or command line -############################### + ############################### + #### Check if browser or command line + ############################### - - if(defined $ENV{'QUERY_STRING'}) { - if($server =~ /HTTPi/i) { + + if (defined $ENV{'QUERY_STRING'}) { + if ($server =~ /HTTPi/i) { $isbrowser = 1; ($entity,$netaddr,$name,$style) = split("-",$req); $file = "htdocs/xml-db/cache/$entity.entity"; - } - else { - # use FindBin qw($RealBin); + } else { + # use FindBin qw($RealBin); my $RealBin = "."; $isbrowser = 1; ($entity,$netaddr,$name,$style) = split("-",$req); $file = "$RealBin/cache/$entity.entity"; - } - $storefile = "/dev/shm/xmldb-".$req.".store"; } - else { - # use FindBin qw($RealBin); + $storefile = "/dev/shm/xmldb-".$req.".store"; + } else { + # use FindBin qw($RealBin); my $RealBin = "."; Getopt::Long::Configure(qw(gnu_getopt)); GetOptions( - 'help|h' => \$help, - 'verbose|v+' => \$verbose, + 'help|h' => \$help, + 'verbose|v+' => \$verbose, ) or pod2usage(2); pod2usage(1) if $help; $entity = $ARGV[0] || ""; @@ -82,20 +78,20 @@ foreach my $req (@request) { $netaddr = $ARGV[1] || ""; $name = $ARGV[2] || ""; $style = $ARGV[3] || ""; - } + } - $style = "" unless $style; - my $isInline = $style =~ /inline/i; - my $isColor = $style =~ /color/i; + $style = "" unless $style; + my $isInline = $style =~ /inline/i; + my $isColor = $style =~ /color/i; my $sortAddr = $style =~ /sortaddr/i; - $verbose = ($style =~ /verbose/i) ||$verbose; - $rates = $style =~ /rate/i; - $cache = $style =~ /cache/i; - - -############################### -#### Check arguments for validity -############################### + $verbose = ($style =~ /verbose/i) ||$verbose; + $rates = $style =~ /rate/i; + $cache = $style =~ /cache/i; + + + ############################### + #### Check arguments for validity + ############################### die "Entity $file not found.\n" unless(-e $file) ; @@ -106,27 +102,35 @@ foreach my $req (@request) { # split off some spi chain, if any, after reading the $db, it is parsed ($netaddr, $spi_chains[0]) = split(':',$netaddr); - 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 ($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"; + } $slice = undef; - if ($name =~ m/^([a-zA-Z0-9]+)\.(\d+)$/) {$name = $1; $slice = $2;} - elsif ($name =~ m/^([a-zA-Z0-9]+)$/) {$name = $1; $slice = undef;} - else {die "Could not parse name $name \n";} + if ($name =~ m/^([a-zA-Z0-9]+)\.(\d+)$/) { + $name = $1; $slice = $2; + } elsif ($name =~ m/^([a-zA-Z0-9]+)$/) { + $name = $1; $slice = undef; + } else { + die "Could not parse name $name \n"; + } $db = lock_retrieve($file); die "Unable to read cache file\n" unless defined $db; die "Your cached database is outdated. Update by running xml-db.pl" unless exists $db->{'§EntityType'}; - - if($rates || $cache) { - if(-e $storefile) { + + if ($rates || $cache) { + if (-e $storefile) { $olddata = lock_retrieve($storefile); - } } + } die "Name $name not found in entity file\n" unless(exists $db->{$name}); @@ -141,126 +145,123 @@ foreach my $req (@request) { if $@; die "Empty SPI range supplied" if @spi_chains==0; - } - elsif($db->{'§EntityType'} eq 'SpiEntity') { + } elsif ($db->{'§EntityType'} eq 'SpiEntity') { # no spi range supplied, just use chain 0 by default @spi_chains = (0); } -############################### -#### Main "do the job" -############################### + ############################### + #### Main "do the job" + ############################### $once = (defined $slice)?1:0; if ($isbrowser) { $data->{time0}=time(); - if($rates || !$cache || !(defined $olddata->{time0}) || $olddata->{time0}{time0}) || $olddata->{time0}{$name},$name,$slice); $data->{time1}=time(); - } - else { + } else { $data = $olddata; - } + } generateoutput($db->{$name},$name,$slice,$once); - if($rates || $cache) { + if ($rates || $cache) { $data->{time2}=time(); lock_store($data,$storefile); - } } - else { + } else { runandprint($db->{$name},$name,$slice,$once); - } + } } - + ############################### #### Formatting of values ############################### sub FormatPretty { my ($value,$obj,$name,$cont,$class,$cstr,$addr,$b) = @_; $class = "" unless $class; - + my $rawvalue = 0; my $readable = $obj->{mode} =~ /r/; - if($readable) { + if ($readable) { $value = $value >> ($obj->{start}); $value &= ((1<<$obj->{bits})-1); $rawvalue = $value; - - if ($rates && $obj->{rate}){ + + if ($rates && $obj->{rate}) { $value = makerate($obj,$value,$addr,$b); $class.=" rate"; - } - - $value = $value * ($obj->{scale}||1) + ($obj->{scaleoffset}||0); } - + + $value = $value * ($obj->{scale}||1) + ($obj->{scaleoffset}||0); + } + $cstr = "" unless $cstr; my $ret, my $cl; if (defined $cont) { - my $isflag = 1; - $isflag = 0 if $obj->{noflag}; - my $single = ""; - $single = " bit=\"1\"" if (($obj->{format} eq 'bitmask' && $obj->{bits} == 1) || $obj->{format} eq 'boolean'); + my $isflag = 1; + $isflag = 0 if $obj->{noflag}; + my $single = ""; + $single = " bit=\"1\"" if (($obj->{format} eq 'bitmask' && $obj->{bits} == 1) || $obj->{format} eq 'boolean'); $cl = "class=\"".($value?"bad":"good")."\"" if ( $obj->{errorflag} && !$obj->{invertflag} && $isflag && $readable); $cl = "class=\"".($value?"good":"bad")."\"" if ( $obj->{errorflag} && $obj->{invertflag} && $isflag && $readable); $cl = "class=\"".($value?"high":"low")."\"" if (!$obj->{errorflag} && !$obj->{invertflag} && $isflag && $readable); $cl = "class=\"".($value?"low":"high")."\"" if (!$obj->{errorflag} && $obj->{invertflag} && $isflag && $readable); $cl .= sprintf(" cstr=\"$cstr\"%s raw=\"0x%x\">
",$single,$rawvalue); - + my $t = ""; $ret = "<$cont "; - if($readable){ - for($obj->{format}) { + if ($readable) { + for ($obj->{format}) { when ("boolean") { - if($obj->{errorflag}) { $ret .= "$cl".($value?"true":"false");} - else { $ret .= "$cl".($value?"true":"false");} - } + if ($obj->{errorflag}) { + $ret .= "$cl".($value?"true":"false"); + } else { + $ret .= "$cl".($value?"true":"false"); + } + } when ("float") { $ret .= sprintf("$cl%.2f",$value);} - when ("integer") { $t = sprintf("%i",$value); - $t =~ s/(?<=\d)(?=(?:\d\d\d)+\b)/ /g; + when ("integer") { $t = sprintf("%i",$value); + $t =~ s/(?<=\d)(?=(?:\d\d\d)+\b)/ /g; $ret .= $cl.$t; - } - when ("unsigned") { $t = sprintf("%u",$value); - $t =~ s/(?<=\d)(?=(?:\d\d\d)+\b)/ /g; + } + when ("unsigned") { $t = sprintf("%u",$value); + $t =~ s/(?<=\d)(?=(?:\d\d\d)+\b)/ /g; $ret .= $cl.$t; - } + } when ("signed") { $ret .= sprintf("$cl%d",$value);} - when ("binary") { $t = sprintf("%0".$obj->{bits}."b",$value); - $t =~ s/(?<=\d)(?=(?:\d\d\d\d)+\b)/ /g; + when ("binary") { $t = sprintf("%0".$obj->{bits}."b",$value); + $t =~ s/(?<=\d)(?=(?:\d\d\d\d)+\b)/ /g; $ret .= $cl.$t; - } + } when ("bitmask") { my $tmp = sprintf("%0".$obj->{bits}."b",$value); $tmp =~ s/(?<=\d)(?=(?:\d\d\d\d)+\b)/ /g; $tmp =~ s/0/\□\;/g; $tmp =~ s/1/\■\;/g; $tmp =~ s/\s/\ \;/g; - + $ret .= $cl.$tmp; - } + } when ("time") {require Date::Format; $ret .= Date::Format::time2str('>%Y-%m-%d %H:%M',$value);} when ("hex") {$ret .= sprintf($cl."0x%0".(int(($obj->{bits}+3)/4))."x",$value);} when ("enum") { my $t = sprintf("%x",$value); if (exists $obj->{enumItems}->{$t}) { - $ret .= $cl.$obj->{enumItems}->{$t} - } - else { + $ret .= $cl.$obj->{enumItems}->{$t} + } else { $ret .= $cl."0x".$t; - } } + } default {$ret .= sprintf(">%08x",$value);} - } } - else { + } else { $ret .= $cl." "; - } + } my $range = $obj->{start}+$obj->{bits}-1; $range .= "..".$obj->{start} if ($obj->{bits}>1); $ret .= " ".$obj->{unit} if exists $obj->{unit}; $ret .= sprintf("$name (Bit $range)
raw: 0x%x
$cstr
",$rawvalue); - } - else { - for($obj->{format}) { + } else { + for ($obj->{format}) { when ("boolean") {$ret = $value?"true":"false";} when ("float") {$ret = sprintf("%.2f",$value);} when ("integer") {$ret = sprintf("%i",$value);} @@ -272,20 +273,19 @@ sub FormatPretty { when ("hex") {$ret = sprintf("0x%0".int(($obj->{bits}+3)/4)."x",$value);} when ("enum") { my $t = sprintf("%x",$value); if (exists $obj->{enumItems}->{$t}) { - $ret = $obj->{enumItems}->{$t} - } - else { + $ret = $obj->{enumItems}->{$t} + } else { $ret = "0x".$t; - } } + } default {$ret = sprintf("0x%08x",$value);} - } - $ret .= " ".$obj->{unit} if exists $obj->{unit}; } - return $ret; + $ret .= " ".$obj->{unit} if exists $obj->{unit}; } + return $ret; +} + - ############################### #### Intelligent data reader ############################### @@ -296,13 +296,13 @@ sub requestdata { if (defined $slice && defined $obj->{repeat} && $slice >= $obj->{repeat}) { print "Slice number out of range.\n"; return -1; - } + } # only read "readable" objects (matches 'r' and 'rw') return unless $obj->{mode} =~ /r/; - - if($obj->{type} eq "group") { - if(defined $obj->{continuous} && $obj->{continuous} eq "true") { + + if ($obj->{type} eq "group") { + if (defined $obj->{continuous} && $obj->{continuous} eq "true") { my $stepsize = $obj->{stepsize} || 1; my $size = $obj->{size}; $slice = $slice || 0; @@ -310,19 +310,17 @@ sub requestdata { $o = register_read_mem($netaddr,$obj->{address}+$slice*$stepsize,0,$size); next unless defined $o; foreach my $k (keys %$o) { - for(my $i = 0; $i < $size; $i++) { + for (my $i = 0; $i < $size; $i++) { $data->{$obj->{address}+$slice*$stepsize+$i}->{$k} = $o->{$k}->[$i]; - } } - } while(!$once && defined $obj->{repeat} && ++$slice < $obj->{repeat}); - } - else { + } + } while (!$once && defined $obj->{repeat} && ++$slice < $obj->{repeat}); + } else { foreach my $c (@{$obj->{children}}) { requestdata($db->{$c},$c,$slice); - } } } - elsif($obj->{type} =~ /^(register|field|registerfield)$/) { # matches register, registerfield, field + } elsif ($obj->{type} =~ /^(register|field|registerfield)$/) { # matches register, registerfield, field my $stepsize = $obj->{stepsize} || 1; $slice = 0 unless defined $slice; do { @@ -330,14 +328,14 @@ sub requestdata { next unless defined $o; foreach my $k (keys %$o) { $data->{$obj->{address}+$slice*$stepsize}->{$k} = $o->{$k}; - } - } while(!$once && defined $obj->{repeat} && ++$slice < $obj->{repeat}); - } + } + } while (!$once && defined $obj->{repeat} && ++$slice < $obj->{repeat}); } +} sub register_read { my ($netaddr, $regaddr) = @_; - for($db->{'§EntityType'}) { + for ($db->{'§EntityType'}) { when ("TrbNetEntity") { return convert_keys_to_hex(trb_register_read($netaddr, $regaddr)); } @@ -350,7 +348,7 @@ sub register_read { sub register_read_mem { my ($netaddr, $regaddr, $start, $size) = @_; - for($db->{'§EntityType'}) { + for ($db->{'§EntityType'}) { when ("TrbNetEntity") { $o = convert_keys_to_hex(trb_register_read_mem($netaddr, $regaddr, $start, $size)); } @@ -368,7 +366,7 @@ sub convert_keys_to_hex { # this makes the keys more flexible, especially for providing chains... my %h = %{$_[0]}; my @keys = keys %h; - for($i=0;$i<@keys;$i++) { + for ($i=0;$i<@keys;$i++) { $keys[$i]=sprintf('%04x',$keys[$i]); } @h{@keys} = delete @h{keys %h}; # this is pure Perl magic :) @@ -407,156 +405,149 @@ sub spi_register_read { return $o; } - + sub generateoutput { my ($obj,$name,$slice,$once) = @_; my $t = ""; - if($obj->{type} eq "group") { + if ($obj->{type} eq "group") { foreach my $c (@{$obj->{children}}) { generateoutput($db->{$c},$c,$slice,$once); - } } - elsif(($obj->{type} eq "register" || $obj->{type} eq "registerfield" || $obj->{type} eq "field")) { + } elsif (($obj->{type} eq "register" || $obj->{type} eq "registerfield" || $obj->{type} eq "field")) { $t = "
"; my $stepsize = $obj->{stepsize} || 1; - $slice = 0 unless defined $slice; + $slice = 0 unless defined $slice; - my $addr = $obj->{address}; + my $addr = $obj->{address}; $t .= sprintf(""; my %tarr; - do { + do { $addr = $obj->{address}+$slice*$stepsize; #### Prepare table header line - if($obj->{mode} =~ /r/) { + if ($obj->{mode} =~ /r/) { $lastboards = $data->{$addr}; #Store list of responding boards as guess for write-only registers. - } + } foreach my $b (sort keys %{$lastboards}) { my $ttmp = ""; my $sl; next unless defined $data->{$addr}->{$b} || !($obj->{mode} =~ /r/); $sl = sprintf("
$name$name (0x%04x)
$obj->{description}
",$addr); - if($once != 1 && defined $obj->{repeat}) { + if ($once != 1 && defined $obj->{repeat}) { $t .= "		Slice"; - } - if($obj->{type} eq "registerfield" || $obj->{type} eq "field"){ + } + if ($obj->{type} eq "registerfield" || $obj->{type} eq "field") { my $range = $obj->{start}+$obj->{bits}-1; $range .= "..".$obj->{start} if ($obj->{bits}>1); $t .= "
$name$name (Bit $range)
$obj->{description}
"; - } - elsif($obj->{type} eq "register"){ - foreach my $c (@{$obj->{children}}){ + } elsif ($obj->{type} eq "register") { + foreach my $c (@{$obj->{children}}) { $oc = $db->{$c}; my $range = $oc->{start}+$oc->{bits}-1; $range .= "..".$oc->{start} if ($oc->{bits}>1); $t .= "
$c$c (Bit $range)
$oc->{description}
"; - } - } + } + } $t .= "
%i$name.$slice (0x%04x)
",$slice,$addr) if ($once != 1 && defined $obj->{repeat}); - + $ttmp .= sprintf("
%s$name on 0x%s
raw: 0x%x
%s",$b,$b,$data->{$addr}->{$b},$sl); - if($obj->{type} eq "register") { + if ($obj->{type} eq "register") { foreach my $c (@{$obj->{children}}) { my $fullc = $c; $fullc .= ".$slice" if ($once != 1 && defined $obj->{repeat}); my $cstr = sprintf("%s-0x%s-%s", $entity,$b,$fullc ); my $wr = 1 if $db->{$c}->{mode} =~ /w/; $ttmp .= FormatPretty($data->{$addr}->{$b},$db->{$c},$c,"td",($wr?"editable":""),$cstr,$addr,$b); - } } - elsif($obj->{type} eq "field" || $obj->{type} eq "registerfield") { + } elsif ($obj->{type} eq "field" || $obj->{type} eq "registerfield") { my $fullc = $name; $fullc .= ".$slice" if ($once != 1 && defined $obj->{repeat}); my $cstr = sprintf("%s-0x%s-%s", $entity,$b,$fullc ); my $wr = 1 if $obj->{mode} =~ /w/; $ttmp .= FormatPretty($data->{$addr}->{$b},$obj,$fullc,"td",($wr?"editable":""),$cstr,$addr,$b); - } - $tarr{sprintf("0x%s%04i",$b,$slice)}=$ttmp; } - - } while($once != 1 && defined $obj->{repeat} && ++$slice < $obj->{repeat}); + $tarr{sprintf("0x%s%04i",$b,$slice)}=$ttmp; + } + + } while ($once != 1 && defined $obj->{repeat} && ++$slice < $obj->{repeat}); $t .= $tarr{$_} for sort keys %tarr; $t .= "
"; - } - print $t; } + print $t; +} sub makerate { my ($obj,$val,$addr,$b) = @_; - if(defined $olddata->{$addr}->{$b}) { + if (defined $olddata->{$addr}->{$b}) { my $ovalue = $olddata->{$addr}->{$b}; $ovalue = $ovalue >> ($obj->{start}); $ovalue &= ((1<<$obj->{bits})-1); $val -= $ovalue; - } + } my $delay = $data->{time0} - $olddata->{time0}; while ($val < 0) { - $val += 1<<$obj->{bits}; - } + $val += 1<<$obj->{bits}; + } $val /= $delay; return $val; - } - +} + ############################### #### Analyze Object & print contents (the simple minded way) ############################### sub runandprint { my ($obj,$name,$slice,$once) = @_; my $o; - print DumpTree($obj) if $verbose; + print DumpTree($obj) if $verbose; #### Iterate if group - if($obj->{type} eq "group") { + if ($obj->{type} eq "group") { foreach my $c (@{$obj->{children}}) { runandprint($db->{$c},$c,$slice,$once); - } } - + } + #### print if entry is a register or field - elsif($obj->{type} eq "register" || $obj->{type} eq "registerfield" || $obj->{type} eq "field") { + elsif ($obj->{type} eq "register" || $obj->{type} eq "registerfield" || $obj->{type} eq "field") { print DumpTree($o) if $verbose>1; - + my $stepsize = $obj->{stepsize} || 1; - $slice = 0 unless defined $slice; + $slice = 0 unless defined $slice; + - do { if (defined $obj->{repeat} && $slice >= $obj->{repeat}) { print "Slice number out of range.\n"; return -1; - } + } $o = register_read($netaddr,$obj->{address}+$slice*$stepsize); next unless defined $o; - + #### Prepare table header line my $t; my @fieldlist; push(@fieldlist,("Board","Reg.")); push(@fieldlist,"raw"); - if($obj->{type} eq "registerfield"){ + if ($obj->{type} eq "registerfield") { push(@fieldlist,$name); - } - elsif($obj->{type} eq "field"){ + } elsif ($obj->{type} eq "field") { push(@fieldlist,$name) ; - } - elsif($obj->{type} eq "register"){ - foreach my $c (@{$obj->{children}}){ + } elsif ($obj->{type} eq "register") { + foreach my $c (@{$obj->{children}}) { push(@fieldlist,$c); - } } - - if($isbrowser == 0) { + } + + if ($isbrowser == 0) { $t = Text::TabularDisplay->new(@fieldlist); - } - else { - if($once == 1 || $slice == 0) { + } else { + if ($once == 1 || $slice == 0) { $t = "
"; $t .= join("",@fieldlist); - } - else{ + } else { $t = ""; - } } + } #### Fill table with information foreach my $b (sort keys %$o) { @@ -564,45 +555,42 @@ sub runandprint { push(@l,sprintf("0x%s",$b)); push(@l,sprintf("%04x",$obj->{address}+$slice*$stepsize)); push(@l,sprintf("%08x",$o->{$b})); - if($obj->{type} eq "register") { + if ($obj->{type} eq "register") { foreach my $c (@{$obj->{children}}) { push(@l,FormatPretty($o->{$b},$db->{$c})); - } } - elsif($obj->{type} eq "field" || $obj->{type} eq "registerfield") { + } elsif ($obj->{type} eq "field" || $obj->{type} eq "registerfield") { push(@l,FormatPretty($o->{$b},$obj)); - } - if($isbrowser == 0) { + } + if ($isbrowser == 0) { $t->add(@l); - } - else { + } else { $t .= "
"; $t .= join("",@l); - } } - + } + #### Show the beautiful result... - if($isbrowser == 0) { + if ($isbrowser == 0) { print $t->render; - } - else { + } else { print $t; - } - print "\n"; - } while($once != 1 && defined $obj->{repeat} && ++$slice < $obj->{repeat}); + } + print "\n"; + } while ($once != 1 && defined $obj->{repeat} && ++$slice < $obj->{repeat}); print "
" if $isbrowser; - } - } - -print "\n"; - -1; - - + +} + +print "\n"; + +1; + + ############################### #### Feierabend! -############################### +############################### __END__ =head1 NAME -- 2.43.0