--- /dev/null
+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;
#!/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,
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
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 {
}
}
-# 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;
}
-#
-# 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;
#!/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);
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 $self = {}; # put tons of default values here (if you wish);
+ $self->{setpos} = { x => 0, y => 0};
+ $self->{realpos} = { x => 0, y => 0};
+
$self->{constants} = {
};
$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
}
-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;
+ }
}
}
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;
jspc29 / coral.git / commitdiff