view release on metacpan or  search on metacpan

lib/Device/WS2500PC.pm  view on Meta::CPAN

	my $data = shift;
	my $result = '';

	return "<no data>" if $data eq '';

	for (my $x=0;$x<length($data);$x++) { 
		my $char = substr($data,$x,1);
		my $printed = 0;

		foreach (keys %{$data{'markers'}}) {
			if ($char eq $data{'markers'}->{$_} and !$printed) {
				$result.=sprintf("<%s> ",$_);
				$printed=1;
			}
		}
		$result.=sprintf("%02X ",ord($char)) unless $printed;
	}

	return $result;
}

# Sends a command to the interface
# This subroutine only encodes and sends a message, it does not care wether
# the sent message has been received/acknowledged or not
# Params: token  A command from $data{'commands'}
#         param  An optional parameter containing additional data
# Return: 1      Always true
sub send_Command {
	my $token = shift;
	my ($checksum,$message,$command,$param);
	
	# Is this a valid command, when not die as this is an internal error
	die "Unknown command '$token'" unless exists $data{'commands'}->{$token};
	$param='';
	$param = shift if scalar @_;
	$command = $data{'commands'}->{$token}.$param;

	# Checksum is negative sum of command value, Bit 7 always set
	foreach (split //, $command) { $checksum+=ord($_); }
	$checksum = (0x100-($checksum & 0xFF)) | 0x80;
	
	# Build message and write to port
	$message = $data{'markers'}->{'SOH'}.$command.chr($checksum).$data{'markers'}->{'EOT'};
	print "Sending '$token': ".(printhex($message))."\n" if $data{'debug'};
	$data{'port'}->write ($message);
	# Bad hack, we have to wait until the command is processed
	# Otherwise we will read only partial data
	sleep (0.03);

	return 1;
}

# Reads a response from the interface
# This routine reads a message from the interface, decodes it and does all integrity checking
# Params: bytes_expected  The number of *message* bytes expected, -1 if not known
#         response        A hash-reference which will be filled with the reponse
# Return: 1               Always true
# The filled in hash reference has the following keys:
# {ok}          1 if the response has been valid and passed all checks, 0 upon failure
# {raw}         Actual data received from the interface
# {message}     The actual message, already decoded without any headers
# {datalength}  The lenght in bytes of the message
# {checksum}    The checksum of the message
sub read_Response ($;$) {
	my $bytes_expected = shift;
	my $response	   = shift;
	
	print "Reading Response ... \n" if $data{'debug'};
	
	# Read data
	# As we do not know how many bytes we expect (due to special char encoding)
	# we poll as long we receive any data in a reasonable interval -> again a bad hack
	$$response{'raw'}='';
	while (my $received=$data{'port'}->read (100)) {
		$$response{'raw'}.=$received;
		sleep (0.01);
	}

	# Did we receive a message with a least 5 bytes (shortest possible message)
	if (length($$response{'raw'})>=5) {
		$$response{'ok'}  = 1;
		# First decode any message sequences for STX/ETX/ENQ
		$$response{'message'} = '';
		for (my $x=1;$x<=length($$response{'raw'})-2;$x++) {
			my $char1 = substr($$response{'raw'},$x,1);
			my $char2 = substr($$response{'raw'},$x+1,1);
			if ($char1 eq $data{'markers'}->{'ENQ'}) {
				if    ($char2 eq $data{'markers'}->{'DC2'}) { $char1 = $data{'markers'}->{'STX'} }
				elsif ($char2 eq $data{'markers'}->{'DC3'}) { $char1 = $data{'markers'}->{'ETX'} }
				elsif ($char2 eq $data{'markers'}->{'NAK'}) { $char1 = $data{'markers'}->{'ENQ'} }
				else  { 
					$$response{'ok'} = 0;
					print "ERROR: Unknown encoding char ".(ord($char2))."\n" if $data{'debug'};
				};
				$x++;
			};
			# WTF ? This isn't documented anywhere ? 
			if (ord($char1)==0xff and ord($char2)==0xff) {
				$x++;
			}
			$$response{'message_all'}.= $char1;
		}
		$$response{'message'} = substr($$response{'message_all'},1,ord(substr($$response{'message_all'},0,1)));
		# Check if the received frame is consistent
		$$response{'datalength'} = ord(substr($$response{'message_all'},0,1));
		$$response{'checksum'}   = ord(substr($$response{'message_all'},length($$response{'message_all'})-1,1));
		# Did we receive enough data
		if ($bytes_expected!=-1 and $$response{'datalength'}!=$bytes_expected and $$response{'ok'}) {
			$$response{'ok'} = 0; 
			print "ERROR: Expected datalength is not correct\n" if $data{'debug'};
		};
		# Are the start and end markers ok ?
		if (substr($$response{'raw'},0,1) ne $data{'markers'}->{'STX'} and $$response{'ok'}) {
			$$response{'ok'} = 0;
			print "ERROR: Start marker not found\n" if $data{'debug'};
		}
		if (substr($$response{'raw'},length($$response{'raw'})-1,1) ne $data{'markers'}->{'ETX'} and $$response{'ok'}) {
			$$response{'ok'} = 0;
			print "ERROR: End marker not found\n" if $data{'debug'};
		}
		# Check for a error message from the interface