From 5625361d41e751aab7fa9ba4f075169a614e9be9 Mon Sep 17 00:00:00 2001
From: "M.Wiebusch@jspc10" <m.wiebusch@gsi.de>
Date: Fri, 9 Jan 2015 11:52:49 +0100
Subject: [PATCH] added table_control script

---
 user_interface/pmt_ro.pl        |   3 +
 user_interface/pmt_ro.pm        |   2 +-
 user_interface/table_control.pl |  90 +++++++++++++++
 user_interface/table_control.pm | 192 ++++++++++++++++++++++++++++++++
 4 files changed, 286 insertions(+), 1 deletion(-)
 create mode 100755 user_interface/table_control.pl
 create mode 100644 user_interface/table_control.pm

diff --git a/user_interface/pmt_ro.pl b/user_interface/pmt_ro.pl
index 0021638..524c793 100755
--- a/user_interface/pmt_ro.pl
+++ b/user_interface/pmt_ro.pl
@@ -46,6 +46,9 @@ my $dispatch = {
 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?
diff --git a/user_interface/pmt_ro.pm b/user_interface/pmt_ro.pm
index 3fc5826..a993473 100644
--- a/user_interface/pmt_ro.pm
+++ b/user_interface/pmt_ro.pm
@@ -49,7 +49,7 @@ sub new {
   };
   
   $self->{misc} = {
-    settings_file => "./settings.dat"
+    settings_file => "./pmt_ro.settings"
   };
   
   $self->{default_settings} = { # hard default settings
diff --git a/user_interface/table_control.pl b/user_interface/table_control.pl
new file mode 100755
index 0000000..acceecb
--- /dev/null
+++ b/user_interface/table_control.pl
@@ -0,0 +1,90 @@
+#!/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   ##
+####################################################################################
+
+
+
+my $query = CGI->new();
+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 = {
+  help => 1,
+  test => 1,
+  load_settings => 1,
+  save_settings => 1,
+  reset_settings => 1,
+  init_port => 1,
+  communicate => 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;
+}
+
+
+
diff --git a/user_interface/table_control.pm b/user_interface/table_control.pm
new file mode 100644
index 0000000..1752558
--- /dev/null
+++ b/user_interface/table_control.pm
@@ -0,0 +1,192 @@
+package table_control;
+
+
+use strict;
+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 {
+  my $class = shift;
+  my %options = @_;
+  
+  my $self = {}; # put tons of default values here (if you wish);
+  
+  $self->{constants} = {
+  };
+  
+  $self->{misc} = {
+    settings_file => "./table_control.settings"
+  };
+  
+  $self->{default_settings} = { # hard default settings
+    tty => "/dev/ttyACM0",
+    baudrate => 115200,
+  };
+
+  $self->{has_run} = {}; # remember which subs already have run
+  
+  $self->{settings} = {%{$self->{default_settings}}};
+  
+  $self  = {
+    %$self,
+    %options
+  };
+  bless($self, $class);
+  
+  return $self;
+}
+
+sub require_run {
+  my $self    = shift;
+  my $subname = shift;
+  
+  unless($self->{has_run}->{$subname}){
+    $self->$subname();
+    $self->{has_run}->{$subname} = 1;
+  }
+}
+
+
+
+
+
+
+
+sub load_settings {
+  my $self=shift;
+  my $settings_file = $self->{misc}->{settings_file};
+  
+  if ( -e $settings_file ) {
+    $self->{settings} = {%{$self->{settings}}, %{lock_retrieve($settings_file)}};
+  }
+  return $self->{settings};
+}
+
+sub save_settings {
+  my $self=shift;
+  my %options = @_;
+  
+  $self->require_run("load_settings");
+  
+  my $settings_file = $self->{misc}->{settings_file};
+  
+  $self->{settings} = { %{$self->{settings}}, %options};
+  lock_store($self->{settings},$settings_file);
+  return $self->{settings}
+}
+
+sub reset_settings {
+  my $self=shift;
+  my $settings_file = $self->{misc}->{settings_file};
+  lock_store({},$settings_file);
+  $self->{settings} = {%{$self->{default_settings}}};
+  return $self->{settings}
+}
+
+
+sub help {
+  my $self = shift;
+  my $verbose = shift;
+  print "This is the help message!\n";
+#   pod2usage(verbose => $verbose);
+  exit;
+  
+}
+sub test {
+  my $self = shift;
+  my %options = @_;
+  print "This is the test message!\n";
+  print "The test routine has received the following options:\n\n";
+  
+  for my $item ( keys %options ) {
+    print "key: $item\tvalue: ".$options{$item}."\n";
+  }
+  exit;
+  
+}
+
+
+
+
+
+sub init_port {
+  my $self = shift;
+  
+  $self->require_run("load_settings");
+  
+  my $baudrate = $self->{settings}->{baudrate};
+  my $tty = $self->{settings}->{tty};
+    
+  # talk to the serial interface
+
+  $self->{port} = new Device::SerialPort($tty);
+  my $port = $self->{port};
+  
+  unless ($port)
+  {
+    print "can't open serial interface $tty\n";
+    exit;
+  }
+
+  $port->user_msg('ON'); 
+  $port->baudrate($baudrate); 
+  $port->parity("none"); 
+  $port->databits(8); 
+  $port->stopbits(1); 
+  $port->handshake("none"); 
+  $port->write_settings;
+
+}
+
+sub communicate {
+  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");
+
+  # read what has accumulated in the serial buffer
+  # do 1 seconds of polling
+  for (my $i = 0; ($i<100) ;$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;
+      }
+
+    } 
+      Time::HiRes::sleep(.01);
+  }
+
+  die "no answer";
+}
+
+1;
-- 
2.43.0