Adding SPI write support, simple tests showed it worked

diff --git a/xml-db/put.pl b/xml-db/put.pl
index d2beab0a7caa3c398fec7807f8c95c36dc26dc9f..95f2fec39741140b1c9bc32f86c22130bacfd11a 100755 (executable)
--- a/xml-db/put.pl
+++ b/xml-db/put.pl
@@ -2,6 +2,7 @@
 
 use HADES::TrbNet;
 use Storable qw(lock_retrieve);
+use Time::HiRes qw( usleep );
 use feature "switch";
 use CGI::Carp qw(fatalsToBrowser);
 
@@ -18,7 +19,7 @@ my $verbose = 0;
 my $isbrowser = 0;
 my $server = $ENV{'SERVER_SOFTWARE'} || "";
 my @request;
-my ($file,$entity,$netaddr,$fullname, $value);
+my ($file,$entity,$netaddr,@spi_chains,$fullname, $value);
 
 
 $ENV{'DAQOPSERVER'}="localhost:7" unless (defined $ENV{'DAQOPSERVER'});
@@ -81,7 +82,15 @@ foreach my $req (@request) {
 ###############################
 
   die "Entity $file not found.\n" unless(-e $file) ;
-    
+
+  
+  
+  # trim whitespace from netaddr
+  $netaddr =~ s/^\s+|\s+$//g;
+
+  # split off the spi chain, if any, after reading the $db, it is parsed/checked
+  ($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";}
@@ -97,7 +106,25 @@ foreach my $req (@request) {
   die "Name not found in entity file\n" unless(exists $db->{$name});
 
   die "Object can not be written\n" unless ($db->{$name}->{mode} =~ /w/);
-  
+
+
+  # parse the spi chains
+  if (defined $spi_chains[0]) {
+    die "You specified some SPI chains but $entity is not an SpiEntity"
+      if $db->{'§EntityType'} ne 'SpiEntity';
+    die "SPI range '$spi_chains[0]' is invalid"
+      unless $spi_chains[0] =~ m/^[0-9.,]+$/;
+    @spi_chains = eval $spi_chains[0];
+    die "Could not eval SPI range: $@"
+      if $@;
+    die "Empty SPI range supplied"
+      if @spi_chains==0;
+  } elsif ($db->{'§EntityType'} eq 'SpiEntity') {
+    # no spi range supplied, just use chain 0 by default
+    @spi_chains = (0);
+  }
+
+
   $value = any2dec($value);
   
 ###############################
@@ -119,7 +146,7 @@ sub writedata {
     }
   
   if($obj->{mode} =~ /r/) {
-    $o = trb_register_read($netaddr,$obj->{address}+$slice*$stepsize);
+    $o = register_read($netaddr,$obj->{address}+$slice*$stepsize);
     unless (defined $o) {
       print "No valid answer.\n";
       return -2;
@@ -129,22 +156,111 @@ sub writedata {
       my $mask = ~(((1<<$obj->{bits})-1) << $obj->{start});
       $old = $old & $mask;
 
-      my $new = $value & ((1<<$obj->{bits})-1); 
+      my $new = $value & ((1<<$obj->{bits})-1);
       $new = $new << $obj->{start};
       $new = $new | $old;
-      trb_register_write($b,$obj->{address}+$slice*$stepsize,$new);
+      register_write($b,$obj->{address}+$slice*$stepsize,$new);
       }
     }
   else {
+    die "Writing write-only non-TrbNetEntity registers not implemented"
+      if $db->{'§EntityType'} ne 'TrbNetEntity';
+
     my $mask = ~(((1<<$obj->{bits})-1) << $obj->{start});
     my $new = $value & ((1<<$obj->{bits})-1); 
     $new = $new << $obj->{start};
 
     trb_register_loadbit($netaddr,$obj->{address}+$slice*$stepsize,~$mask,$new);
     }
-    
   }
 
+sub register_read {
+  my ($netaddr, $regaddr) = @_;
+  for ($db->{'§EntityType'}) {
+    when ("TrbNetEntity")  {
+      $o =  trb_register_read($netaddr, $regaddr);
+    }
+    when ("SpiEntity") {
+      $o = spi_register_read($netaddr, $regaddr);
+    }
+    default {die "EntityType not recognized";}
+  }
+  return $o;
+}
+
+sub register_write {
+  my ($netaddr, $regaddr, $value) = @_;
+  for ($db->{'§EntityType'}) {
+    when ("TrbNetEntity")  {
+      $o =  trb_register_write($netaddr, $regaddr, $value);
+    }
+    when ("SpiEntity") {
+      $o = spi_register_write($netaddr, $regaddr, $value);
+    }
+    default {die "EntityType not recognized";}
+  }
+  return $o;
+}
+
+sub spi_register_read {
+  # inspired by the simple padiwa.pl
+  my ($netaddr, $regaddr) = @_;
+  $o = {};
+  foreach my $chain (@spi_chains) {
+    # in $cmd, the lower 16 bits are the payload
+    # the upper 16 bits control:
+    # 31..24: select (something like an address)
+    # 23..20: command read=0x0, write=0x8
+    # 19..16: channel/register (something like an address)
+
+    # the lower 4 bits directly map:
+    my $cmd = $regaddr & 0xF;
+    # the next 8 bits need to be shifted
+    $cmd |= (($regaddr >> 4) & 0xFF) << 8;
+    # shift it to the upper 16 bits finally
+    $cmd <<= 16;
+
+    my $c = [$cmd,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1<<$chain,1];
+    trb_register_write_mem($netaddr,0xd400,0,$c,scalar @{$c});
+    usleep(1000);
+    my $res = trb_register_read($netaddr,0xd412);
+    next unless defined $res;
+    foreach my $board (keys %$res) {
+      my $b = sprintf('%d:%d', $board, $chain); # no hex conversion here
+      $o->{$b} = $res->{$board};
+    }
+  }
+
+  return $o;
+}
+
+sub spi_register_write {
+  # inspired by the simple padiwa.pl
+  my ($netaddr, $regaddr, $value) = @_;
+
+  ($netaddr, $spi_chains[0]) = split(':',$netaddr);
+  die "Cannot write to multiple chains, $spi_chains[0] not a number"
+    unless $spi_chains[0]=~/^\d+$/;
+
+  # see spi_register_read
+  # we set additionally the write bit and the $value payload
+  my $cmd = $regaddr & 0xF;
+  $cmd |= (($regaddr >> 4) & 0xFF) << 8;
+  $cmd |= 0x0080;
+  $cmd <<= 16;
+  $cmd |= 0xFFFF & $value;
+
+  #print sprintf('Write cmd %08x, Chain %d, Netaddr %04x', $cmd, $spi_chains[0], $netaddr),"\n";
+
+  my $c = [$cmd,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1<<$spi_chains[0],1];
+  trb_register_write_mem($netaddr,0xd400,0,$c,scalar @{$c});
+  usleep(1000);
+
+  # TODO: some response cheking??
+}
+
+
+
   
 sub any2dec { # converts numeric expressions 0x, 0b or decimal to decimal