--- /dev/null
+#!/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;
+}
+
+
+
--- /dev/null
+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;
jspc29 / coral.git / commitdiff