From: Michael Wiebusch <m.wiebusch@gsi.de>
Date: Fri, 9 Jan 2015 17:13:06 +0000 (+0100)
Subject: Introduced CGI_dispatch perl module, more functionality to table_control.pm
X-Git-Url: https://jspc29.x-matter.uni-frankfurt.de/git/?a=commitdiff_plain;h=2ce66ab51552d5129264c9f0661e951abc1e8c61;p=coral.git

Introduced CGI_dispatch perl module, more functionality to table_control.pm
---

diff --git a/user_interface/CGI_dispatch.pm b/user_interface/CGI_dispatch.pm
new file mode 100644
index 0000000..4f7bec9
--- /dev/null
+++ b/user_interface/CGI_dispatch.pm
@@ -0,0 +1,77 @@
+package CGI_dispatch;
+
+use strict;
+use warnings;
+use Data::Dumper;
+use CGI ':standard';
+use CGI::Carp qw(fatalsToBrowser);
+
+my $query;
+
+
+sub dispatch_sub {
+
+
+  my $self = shift;
+  my $dispatch_table = shift;
+  
+  $query = CGI->new();
+
+  my $sub = $query->param('sub') || "help";
+
+  # if method exists in dispatch table, execute it, if not complain and show help message
+  # if there is no dispatch table, allow execution of every sub
+  if ( not(defined ($dispatch_table)) or $dispatch_table->{$sub}) {
+    my $args = CGI_parameters();
+    
+    # do not pass the "sub=..." parameters to the called sub
+    delete $args->{"sub"};
+    
+    # here the corresponding method is called
+    my $return = $self->$sub(%$args);
+    # does it return anything?
+    if(defined($return)){ # we get a return value
+      if(ref(\$return) eq "SCALAR"){ # just print it if it is a scalar
+        print "$return\n";
+      } else { # use Data::Dumper to display a hash
+        print "sub returns a hash:\n";
+        print Dumper $return;
+      }
+    }
+  } else {
+    print "$sub is not a valid sub!\n\n";
+    $self->help(1);
+  }
+
+}
+
+sub CGI_parameters {
+  # for each item on the list, get the
+  # designated parameter from the CGI query and
+  # store it in the target hash IF the parameter is
+  # defined in the query!
+  
+  my %options = @_;
+  my $items   = $options{items};
+  # target can be left undefined, then a new hash is created
+  # and returned
+  my $target;
+  $target = $options{target} if defined($options{target});
+  
+  
+  if(defined($items)){ # if there is a list of parameters
+    for my $item (@{$items}){
+      if(defined($query->param($item))){
+        $target->{$item} = $query->param($item);
+      } 
+    }
+  } else { # if there is no list of parameters
+    # extract all parameters
+    for my $item($query->param) {
+      $target->{$item} = $query->param($item);
+    }
+  }
+  return $target;
+}
+
+1;
diff --git a/user_interface/pmt_ro.pl b/user_interface/pmt_ro.pl
index 524c793..b536b09 100755
--- a/user_interface/pmt_ro.pl
+++ b/user_interface/pmt_ro.pl
@@ -1,28 +1,19 @@
 #!/usr/bin/perl
 
-use strict;
-use warnings;
-use CGI ':standard';
-use CGI::Carp qw(fatalsToBrowser);
-use Data::Dumper;
-use pmt_ro;
-
-
 ####################################################################################
 ##  This is a simple script to dispatch a perl module's subs from a CGI request   ##
 ####################################################################################
 
+use strict;
+use warnings;
+use CGI_dispatch;
 
-
-my $query = CGI->new();
+use pmt_ro;
 my $self = pmt_ro->new();
 
-
-my $sub = $query->param('sub') || "help";
-
 # go only to methods that are in the following dispatch table:
 # if associated value is one, sub can be called via CGI
-my $dispatch = {
+my $dispatch_table = {
   help => 1,
   test => 1,
   read_register => 1,
@@ -42,59 +33,4 @@ my $dispatch = {
   apply_device_settings => 1
 };
 
-# if method exists, execute it, if not complain and show help message
-if ($dispatch->{$sub} ) {
-  my $args = CGI_parameters();
-  
-  # do not pass the "sub=..." parameters to the called sub
-  delete $args->{"sub"};
-
-  # here the corresponding method is called
-  my $return = $self->$sub(%$args);
-  # does it return anything?
-  if(defined($return)){ # we get a return value
-    if(ref(\$return) eq "SCALAR"){ # just print it if it is a scalar
-      print "$return\n";
-    } else { # use Data::Dumper to display a hash
-      print "sub returns a hash:\n";
-      print Dumper $return;
-    }
-  }
-} else {
-  print "$sub is not a valid sub!\n\n";
-  $self->help(1);
-}
-
-
-
-sub CGI_parameters {
-  # for each item on the list, get the
-  # designated parameter from the CGI query and
-  # store it in the target hash IF the parameter is
-  # defined in the query!
-  
-  my %options = @_;
-  my $items   = $options{items};
-  # target can be left undefined, then a new hash is created
-  # and returned
-  my $target;
-  $target = $options{target} if defined($options{target});
-  
-  
-  if(defined($items)){ # if there is a list of parameters
-    for my $item (@{$items}){
-      if(defined($query->param($item))){
-        $target->{$item} = $query->param($item);
-      } 
-    }
-  } else { # if there is no list of parameters
-    # extract all parameters
-    for my $item($query->param) {
-      $target->{$item} = $query->param($item);
-    }
-  }
-  return $target;
-}
-
-
-
+CGI_dispatch::dispatch_sub($self,$dispatch_table);
\ No newline at end of file
diff --git a/user_interface/pmt_ro.pm b/user_interface/pmt_ro.pm
index a993473..2b0af14 100644
--- a/user_interface/pmt_ro.pm
+++ b/user_interface/pmt_ro.pm
@@ -6,23 +6,12 @@ use warnings;
 use Time::HiRes;
 use POSIX qw/strftime/;
 use POSIX;
-# use CGI ':standard';
-# use CGI::Carp qw(fatalsToBrowser);
-use Data::Dumper;
-# use Pod::Usage;
 use FileHandle;
 use regio;
-# use manage_settings;
-# use Switch;
 
 use Storable qw(lock_store lock_retrieve);
 
 
-
-# my $self = this->new();
-# $self->main();
-
-
 ## methods
 
 sub new {
@@ -86,75 +75,7 @@ sub require_run {
   }
 }
 
-# sub main {
-#   # go to other methods from here
-#   my $self = shift;
-#   
-#   $self->setup();
-#   
-#   my $action = $self->{query}->param('action') || "help";
-# 
-#   # go only to methods that are in the following dispatch table:
-#   # if associated value is one, sub can be called via CGI
-#   $self->{dispatch} = {
-#     help => 1,
-#     test => 1,
-#     read_register => 1,
-#     write_register => 1,
-#     find_baseline => 1,
-#     signal_range => 1,
-#     count => 1,
-#     load_settings => 1,
-#     save_settings => 1,
-#     reset_settings => 1,
-#     zero_calib => 1,
-#     signal_thresh => 1,
-#     veto_thresh => 1,
-#     spectral_scan => 1,
-#     spectral_scan_onesided => 1,
-#     dead_time => 1,
-#     apply_device_settings => 1
-#   };
-#   
-#   # if method exists, execute it, if not complain and show help message
-#   if ($self->{dispatch}->{$action} ) {
-#     my $args = $self->CGI_parameters();
-#     
-#     # here the corresponding method is called
-#     my $return = $self->$action(%$args);
-#     # does it return anything?
-#     if(defined($return)){ # we get a return value
-#       if(ref(\$return) eq "SCALAR"){ # just print it if it is a scalar
-#         print "$return\n";
-#       } else { # use Data::Dumper to display a hash
-#         print "method returns a hash:\n";
-#         print Dumper $return;
-#       }
-#     }
-#   } else {
-#     print "$action is not a valid action!\n\n";
-#     $self->help(1);
-#   }
-# }
-
-# sub setup {
-#   my $self = shift;
-#   # initialization stuff
-#   
-#   # receive CGI query
-#   #$self->{query} = CGI->new();
-#   
-#   # load settings from settings file 
-#   $self->load_settings();
-#   
-#   my $regio_options = {
-#     tty => $self->{settings}->{tty},
-#     baudrate => $self->{settings}->{baudrate}
-#   };
-#   # create new register IO object, with CGI parameters "tty" and "baudrate"
-#   my $regio_options_CGI = $self->CGI_parameters(items => ["tty","baudrate"]);
-#   # CGI entered values always overwrite settings
-# }
+
 
 sub setup_regio {
   my $self = shift;
@@ -734,37 +655,5 @@ sub test {
   
 }
 
-# 
-# sub CGI_parameters {
-#   # for each item on the list, get the
-#   # designated parameter from the CGI query and
-#   # store it in the target hash IF the parameter is
-#   # defined in the query!
-#   
-#   my $self = shift;
-#   my %options = @_;
-#   my $query  = $self->{query};
-#   my $items   = $options{items};
-#   # target can be left undefined, then a new hash is created
-#   # and returned
-#   my $target;
-#   $target = $options{target} if defined($options{target});
-#   
-#   
-#   if(defined($items)){ # if there is a list of parameters
-#     for my $item (@{$items}){
-#       if(defined($query->param($item))){
-#         $target->{$item} = $query->param($item);
-#       } 
-#     }
-#   } else { # if there is no list of parameters
-#     # extract all parameters
-#     for my $item($query->param) {
-#       $target->{$item} = $query->param($item);
-#     }
-#   }
-#   return $target;
-# }
-# 
 
 1;
diff --git a/user_interface/table_control.pl b/user_interface/table_control.pl
index acceecb..df99afb 100755
--- a/user_interface/table_control.pl
+++ b/user_interface/table_control.pl
@@ -1,90 +1,30 @@
 #!/usr/bin/perl
 
-use strict;
-use warnings;
-use CGI ':standard';
-use CGI::Carp qw(fatalsToBrowser);
-use Data::Dumper;
-use table_control;
-
-
 ####################################################################################
 ##  This is a simple script to dispatch a perl module's subs from a CGI request   ##
 ####################################################################################
 
+use strict;
+use warnings;
+use CGI_dispatch;
 
-
-my $query = CGI->new();
+use table_control;
 my $self = table_control->new();
 
-
-my $sub = $query->param('sub') || "help";
-
 # go only to methods that are in the following dispatch table:
 # if associated value is one, sub can be called via CGI
-my $dispatch = {
+my $dispatch_table = {
   help => 1,
   test => 1,
   load_settings => 1,
   save_settings => 1,
   reset_settings => 1,
   init_port => 1,
-  communicate => 1
+  status => 1,
+  communicate => 1,
+  set_zero => 1,
+  go_xy    => 1,
+  home   => 1
 };
 
-# if method exists, execute it, if not complain and show help message
-if ($dispatch->{$sub} ) {
-  my $args = CGI_parameters();
-  
-  # do not pass the "sub=..." parameters to the called sub
-  delete $args->{"sub"};
-  
-  # here the corresponding method is called
-  my $return = $self->$sub(%$args);
-  # does it return anything?
-  if(defined($return)){ # we get a return value
-    if(ref(\$return) eq "SCALAR"){ # just print it if it is a scalar
-      print "$return\n";
-    } else { # use Data::Dumper to display a hash
-      print "sub returns a hash:\n";
-      print Dumper $return;
-    }
-  }
-} else {
-  print "$sub is not a valid sub!\n\n";
-  $self->help(1);
-}
-
-
-
-sub CGI_parameters {
-  # for each item on the list, get the
-  # designated parameter from the CGI query and
-  # store it in the target hash IF the parameter is
-  # defined in the query!
-  
-  my %options = @_;
-  my $items   = $options{items};
-  # target can be left undefined, then a new hash is created
-  # and returned
-  my $target;
-  $target = $options{target} if defined($options{target});
-  
-  
-  if(defined($items)){ # if there is a list of parameters
-    for my $item (@{$items}){
-      if(defined($query->param($item))){
-        $target->{$item} = $query->param($item);
-      } 
-    }
-  } else { # if there is no list of parameters
-    # extract all parameters
-    for my $item($query->param) {
-      $target->{$item} = $query->param($item);
-    }
-  }
-  return $target;
-}
-
-
-
+CGI_dispatch::dispatch_sub($self,$dispatch_table);
diff --git a/user_interface/table_control.pm b/user_interface/table_control.pm
index 1752558..ab09c1b 100644
--- a/user_interface/table_control.pm
+++ b/user_interface/table_control.pm
@@ -6,24 +6,12 @@ use warnings;
 use Time::HiRes;
 use POSIX qw/strftime/;
 use POSIX;
-# use CGI ':standard';
-# use CGI::Carp qw(fatalsToBrowser);
-use Data::Dumper;
-# use Pod::Usage;
-# use FileHandle;
-# use regio;
-# use manage_settings;
-# use Switch;
 use Device::SerialPort;
 
 use Storable qw(lock_store lock_retrieve);
 
 
 
-# my $self = this->new();
-# $self->main();
-
-
 ## methods
 
 sub new {
@@ -32,6 +20,9 @@ sub new {
   
   my $self = {}; # put tons of default values here (if you wish);
   
+  $self->{setpos} = { x => 0, y => 0};
+  $self->{realpos} = { x => 0, y => 0};
+  
   $self->{constants} = {
   };
   
@@ -42,6 +33,10 @@ sub new {
   $self->{default_settings} = { # hard default settings
     tty => "/dev/ttyACM0",
     baudrate => 115200,
+    approx_speed => 10, #mm per second,
+    size_x => 300,
+    size_y => 150,
+    table_precision => 0.015*2 #mm ... 3mm per round, 200 steps per round
   };
 
   $self->{has_run} = {}; # remember which subs already have run
@@ -159,27 +154,56 @@ sub init_port {
 
 }
 
-sub communicate {
+sub send {
   my $self = shift;
   my %options = @_;
   my $command = $options{command} || "";
   
-  
   $self->require_run("init_port");
 
   my $port = $self->{port};
 
-  $port->are_match("\n");
   $port->lookclear; 
   $port->write("$command\n");
 
+}
+
+sub receive {
+  my $self = shift;
+  my %options = @_;
+  
+  my $wait = $options{wait} || 1;
+  my $output  = $options{output} || "hash"; 
+  
+  $self->require_run("init_port");
+
+  my $port = $self->{port};
+
+  $port->are_match("\n");
+
   # read what has accumulated in the serial buffer
   # do 1 seconds of polling
-  for (my $i = 0; ($i<100) ;$i++) {
+  for (my $i = 0; ($i<100*$wait) ;$i++) {
     while(my $a = $port->lookfor) {
       $a =~ s/[\r\n]//g;
       if( $a =~ m/x_pos.+y_pos/) { ## discard the standard error string
-        return $a;
+        
+        if ($output eq "plain"){
+          return $a;
+        } else {
+          $a =~ m/x_pos: ([\+\-][ 0-9]{3}\.[0-9]{3})  y_pos: ([\+\-][ 0-9]{3}\.[0-9]{3})  end_sw: (\d)(\d)(\d)(\d)/;
+          my $data = {
+            x_pos => $1,
+            y_pos => $2,
+            xend2_sw => $3,
+            xend1_sw => $4,
+            yend2_sw => $5,
+            yend1_sw => $6
+          };
+          $data->{x_pos} =~ s/[\+\s]//g;
+          $data->{y_pos} =~ s/[\+\s]//g;
+          return $data;
+        }
       }
 
     } 
@@ -189,4 +213,114 @@ sub communicate {
   die "no answer";
 }
 
+sub communicate {
+
+  my $self = shift;
+  my %options = @_;
+  my $command = $options{command};
+  my $wait    = $options{wait};
+  #  with parameter output=plain, print plain resonse from board
+  #  else split information in a hash
+  my $output  = $options{output} || "hash"; 
+  
+  $self->send(command => $command);
+  return $self->receive(wait => $wait, output => $output);
+}
+
+
+sub status {
+  my $self = shift;
+  $self->communicate();
+  
+}
+
+sub go_xy {
+  my $self = shift;
+  my %options = @_;
+  
+  my $new_x = (defined $options{x}) ? $options{x} : $self->{setpos}->{x};
+  my $old_x = $self->{setpos}->{x};
+  my $new_y = (defined $options{y}) ? $options{y} : $self->{setpos}->{y};
+  my $old_y = $self->{setpos}->{y};
+  
+  my $dx = $new_x - $old_x;
+  my $dy = $new_y - $old_y;
+  
+  my $longest_movement = max(abs($dx),abs($dy));
+  my $travel_time = $longest_movement / $self->{settings}->{approx_speed};
+  my $travel_timeout = $travel_time * 1.1 + 1;
+  
+  echo("go to x=$new_x, y=$new_y");
+  $self->send(command => "gx$new_x");
+  $self->send(command => "gy$new_y");
+  # hier musst du noch weiterarbeiten!
+ 
+  my $answer = $self->receive(wait => $travel_timeout);
+  
+  
+  if(abs($answer->{x_pos} - $new_x) <= $self->{settings}->{table_precision} ){
+    $self->{setpos}->{x}  = $new_x;
+    $self->{realpos}->{x} = $answer->{x_pos};
+  } else {
+    print "did not move to correct x position!\n";
+  }
+  
+  if(abs($answer->{y_pos} - $new_y) <= $self->{settings}->{table_precision} ){
+    $self->{setpos}->{y}  = $new_y;
+    $self->{realpos}->{y} = $answer->{y_pos};
+  } else {
+    print "did not move to correct y position!\n";
+  }
+  
+  return $answer;
+  
+}
+
+sub set_zero {
+  my $self = shift;
+  $self->communicate(command => "z");
+}
+
+sub home {
+  my $self = shift;
+  
+  # check if already at the stops, if yes, move away and return again
+  my $answer = $self->status();
+  if (($answer->{xend2_sw} == 1) && ($answer->{xend2_sw} == 1)) { ## did you hit the stop switch?
+    $self->set_zero();
+    $answer = $self->go_xy(
+      x => 10,
+      y => 10
+    );
+  }
+ 
+  # not homed ... go home
+  $answer = $self->go_xy(
+    x => -1.2*$self->{settings}->{size_x},
+    y => -1.2*$self->{settings}->{size_y}
+  );
+  
+  if (($answer->{xend2_sw} == 1) && ($answer->{xend2_sw} == 1)) { ## did you hit the stop switch?
+    return $self->set_zero();
+  } else {
+    die "homing the axes failed!\n";
+  }
+}
+
+# simple subs
+
+sub echo {
+  print shift."\n";
+}
+
+sub max {
+  my ($x,$y) = @_;
+  return $x >= $y ? $x : $y;
+}
+sub min {
+  my ($x,$y) = @_;
+  return $x <= $y ? $x : $y;
+}
+
+
 1;